unit credut;
interface
uses routines,map;
const vidseg = $a000;
      chars = 39; { 0..25 =  a..z
                    26..35 = 0..9
                    36..39 = . - ! # }
      space = 13; { space between chars (x) char x len = 18 }
      slowdown = 4; { change y offset every <-- frame }
      tarinaX = 10;
      tarinaY = 10;
      pituus = 160; { <-- frames one text on the screen until fade }
      blurri = 85; { how long to blur (dumm sydeemi but working and fast) }
      texts = 9;
      texti:array[1..texts] of string =
        ('GODSPEED','RELEASED AT ESCAPE2K','CODE','ACCESS','MUSIC.IDEAS.GFX','JOBE',
         '','KILOBITE . 2000','');

      { cube stuff }
      cubecol = 64;
      zf = 256;
      points = 8;
      point : array[1..points,1..3] of integer =
        ((-50,-50,-50),(50,-50,-50),(50,50,-50),(-50,50,-50),
         (-50,-50,50),(50,-50,50),(50,50,50),(-50,50,50));
      lines = 12;
      line : array[1..lines,1..2] of byte =
        ((1,2),(2,3),(3,4),(4,1),
         (5,6),(6,7),(7,8),(8,5),
         (5,1),(6,2),(7,3),(8,4));

var addseg,virseg,fontseg:word; { addseg could be taken off with kikkailu }
    addscr,virscr,fontscr:pointer;
    x,y,realx,realy:word;
    textY,textX:word;
    lenkki:word; { text length in pixels }
    kohta:word;
    loop:word;
    frame:byte;
    inva:byte;
    curText:byte;
    blurframe:word;
    light:integer; { affects the text }
    fontti:array[0..chars,0..18*18-1] of byte; { pretty amateuristic but saves mem }
    loppu:boolean;
    pal:array[0..255,1..3] of byte;
    palOK:boolean;

    { cube stuff }
    stab,ctab:array[0..255] of real;
    phi:byte;
    trans:array[1..points,1..3] of integer;
    cubex,cubey,cubez : integer;
    phi_inc : byte;
    piSini : byte;

procedure do_credut(nosound:boolean);

implementation

procedure do_credut(nosound:boolean);

procedure DrawCube;
var l,p,j : word;
    sx,sy : array[1..4] of integer;
    dx,dy,dz:integer;
    cdz:integer;

procedure dline (x1,y1,x2,y2:word ; col:byte); assembler;
var ddx,ddy : word;
    sx,sy : word;                {  This procedure has not been  }
asm                              {  made by me... It came from   }
        mov     ax,addseg        {  some nameless source.        }
        mov     es,ax
        mov     ax,[y1]
        mov     bx,320
        imul    bx
        mov     di,[x1]
        add     di,ax
        mov     ax,[x2]
        clc
        mov     bx,1
        sub     ax,[x1]
        jnc     @@1
        neg     ax
        mov     bx,0ffffh
@@1:    mov     [ddx],ax
        mov     [sx],bx
        mov     ax,[y2]
        clc
        mov     bx,320
        sub     ax,[y1]
        jnc     @@2
        neg     ax
        mov     bx,-320
@@2:    mov     [ddy],ax
        mov     [sy],bx

        cmp     ax,[ddx]
        ja      @@yGrtr
        mov     cx,[ddx]
        inc     cx
        mov     bx,[ddx]
        shr     bx,1
        mov     al,[col]
@@x1:
        mov     byte ptr [es:di],al
        add     di,[sx]
        clc
        sub     bx,[ddy]
        jnc     @@xg
        add     di,[sy]
        add     bx,[ddx]
@@xg:   loop    @@x1
        jmp     @@ret
@@yGrtr:mov     cx,[ddy]
        inc     cx
        mov     bx,[ddy]
        shr     bx,1
        mov     al,[col]
@@y1:
        mov     byte ptr [es:di],al
        add     di,[sy]
        clc
        sub     bx,[ddx]
        jnc     @@yg
        add     di,[sx]
        add     bx,[ddy]
@@yg:   loop    @@y1
@@ret:
end;

begin
  for l:=1 to lines do begin
    for p:=1 to 2 do begin
      dx:=trans[line[l,p],1];
      dy:=trans[line[l,p],2];
      dz:=trans[line[l,p],3];
      cdz:=cubez-dz;
      if cdz = 0 then cdz:=1;
        sx[p]:=round(zf*dx / cdz + cubex);
        sy[p]:=round(zf*dy / cdz + cubey);
    end;
    dline(sx[1],sy[1],sx[2],sy[2],cubecol);
  end;
end;

procedure rotate;

var x,y,z : integer;
    sini,kosi : real;

begin
  for loop:=1 to points do begin
    x := point[loop,1];
    y := point[loop,2];
    z := point[loop,3];
    sini := stab[phi];
    kosi := ctab[phi];
{
                   Ú                                      ¿
                   ³ cy*cz          cy*sz          -sy    ³
     [X]*[Y]*[Z] = ³ sx*sy*cz-cx*sz sx*sy*sz+cx*cz  sx*cy ³
                   ³ cx*sy*cz+sx*sz cx*sy*sz-sx*cz  cx*cy ³
                   À                                      Ù
               Ú          ¿   Ú          ¿   Ú                  ¿
               ³ 1  0  0  ³   ³ cy 0 -sy ³   ³ cy     0  -sy    ³
     [X]*[Y] = ³ 0  cx sx ³ * ³ 0  1  0  ³ = ³ sx*sy  cx  sx*cy ³
               ³ 0 -sx cx ³   ³ sy 0  cy ³   ³ cx*sy -sx  cx*cy ³
               À          Ù   À          Ù   À                  Ù
}

    trans[loop,1]:=round((kosi*x)+(sini*sini*y)+(kosi*sini*z));
    trans[loop,2]:=round((kosi*y)+(-sini*z));
    trans[loop,3]:=round((-sini*x)+(sini*kosi*y)+(kosi*kosi*z));
{
    trans[loop,1]:=round((kosi*kosi*x)+((sini*sini*kosi*y)-(kosi*sini*y))+
                         ((kosi*sini*kosi*z)+(sini*sini*z)));
    trans[loop,2]:=round((kosi*sini*x)+((sini*sini*sini*y)+(kosi*kosi*y))+
                         ((kosi*sini*sini*z)-(sini*kosi*z)));
    trans[loop,3]:=round((-sini*x)+(sini*kosi*y)+(kosi*kosi*z));
}
  end;
  phi:=phi+phi_inc;
end;

procedure blurTxt; assembler; { k3wl! }
    asm
      mov es,[fontseg]
      mov di,2
      mov si,320*18-5
      @outer:

          xor ax,ax
          xor bx,bx
          mov al,[es:di+1]
          mov bl,[es:di-1]
          add ax,bx
          shr ax,1
          mov [es:di],al
          inc di

      dec si
      jne @outer
      inc blurframe
    end;


{ "strink" must be in CAPITALS }
procedure txtStr(strink:string; segi:word);
var tx,ty : word; { t:texture, s:screen }
    looppi : word;
    charn : byte;
    sx : word;
    theX : word;
    ordi : byte;
    col : byte;

begin
  cls(fontseg); { tyhjennet„„n ekaks }
  lenkki:=length(strink)*space;
  sx:=160-(lenkki shr 1);
  for looppi:=1 to length(strink) do begin
    { ascii
      65 = "A"
      90 = "Z"
      48 = "0"
      57 = "9"
    }
    ordi:=ord(strink[looppi]);
    if ordi<>32 then begin { 32 = space }
    if (ordi>=65)and(ordi<=90)
      then charn:=ordi-65;
    if (ordi>=48)and(ordi<=57)
      then charn:=ordi-48+26;
    if ordi=ord('.') then charn:=36;
    if ordi=ord('-') then charn:=37;
    if ordi=ord('!') then charn:=38;
    if ordi=ord('#') then charn:=39;
    kohta:=0;
    for ty:=0 to 17 do
      for tx:=0 to 17 do begin
        theX:=sx+tx+((looppi-1)*space);
        col:=mem[segi:theX+ty*320];
        if col+fontti[charn,kohta]>255 then col:=255 else inc(col,fontti[charn,kohta]);
        pixel(theX,ty,col,segi);
        inc(kohta);
      end;
    end;
  end;
end;

procedure addfont2vir(source,dest,yOff,xOff,valo:word); assembler;
asm
  push ds          { ds talteen }
  mov ds,[source]
  mov es,[dest]
  mov ax,yOff
  sub ax,9         { menn„„n ihan keskelle }
  shl ax,6
  mov di,ax
  shl ax,2
  add di,ax
  xor si,si
  mov cx,320*18
  sub cx,yOff
@inner:
  xor ax,ax
  xor bx,bx
  mov al,[ds:si]
  cmp ax,0
  jz @over1
  add ax,valo
  cmp ax,0
  jg @over1
  mov ax,0
@over1:
  mov bl,[es:di]
  add ax,bx
  cmp ax,256
  jb @jump
  mov ax,255
@jump:
  mov [es:di],al
  inc di
  inc si
  loop @inner
  pop ds           { palautetaan ds }
end;

procedure getFont;
begin
  for loop:=0 to 16 do begin { 1. rivi a..q (17 chars) }
    kohta:=0;
    for y:=0 to 17 do
      for x:=0 to 17 do begin
        fontti[loop,kohta]:=mem[virseg:(x+loop*18)+(y*320)];
        inc(kohta);
      end;
  end;
  for loop:=0 to 16 do begin { 2. rivi r..z, 0..7 (17 chars) }
    kohta:=0;
    for y:=0 to 17 do
      for x:=0 to 17 do begin
        fontti[17+loop,kohta]:=mem[virseg:(x+loop*18)+((y+18)*320)];
        inc(kohta);
      end;
  end;
  for loop:=0 to 5 do begin { 3. rivi 8..9, . - ! # (6 chars) }
    kohta:=0;
    for y:=0 to 17 do
      for x:=0 to 17 do begin
        fontti[34+loop,kohta]:=mem[virseg:(x+loop*18)+((y+36)*320)];
        inc(kohta);
      end;
  end;
end;

procedure fadein;
var r,g,b:byte;
    cols:byte;
begin
  cols:=0;
  for loop:=0 to 255 do begin
    port[$3c7]:=loop;
    r:=port[$3c9];
    g:=port[$3c9];
    b:=port[$3c9];
    if r>pal[loop,1] then dec(r);
    if g>pal[loop,2] then dec(g);
    if b>pal[loop,3] then dec(b);
    if (r<>pal[loop,1])or(g<>pal[loop,2])or(b<>pal[loop,3]) then inc(cols);
    port[$3c8]:=loop;
    port[$3c9]:=r;
    port[$3c9]:=g;
    port[$3c9]:=b;
  end;
  if cols=0 then palOK:=true;
end;

begin
  randomize;
  getmem(virscr,64000);
  getmem(fontscr,320*18); { = 5760 bytes }
  getmem(addscr,64000);
  virseg:=seg(virscr^);
  fontseg:=seg(fontscr^);
  addseg:=seg(addscr^);
  writeln('ok.');

  loadMAP(virseg,'font.map'); { temppi...unpacked to arrays later on }
  getFont; { from [virseg] }
  loadMAP(virseg,'bg.map');
  for loop:=0 to 255 do ctab[loop]:=cos(loop*pi/128);
  for loop:=0 to 255 do stab[loop]:=sin(loop*pi/128);
  cubex:=160;
  cubey:=100;
  cubez:=256;
  phi_inc:=1;
  piSini:=0;
  loppu:=false;
  cls(vidseg);
  for loop:=0 to 255 do
    begin
      port[$3c7]:=loop;
      pal[loop,1]:=port[$3c9];
      pal[loop,2]:=port[$3c9];
      pal[loop,3]:=port[$3c9];
    end;
  for loop:=0 to 255 do setcol(loop,63,63,63);

  loadPAL('pal2.pal');
  curText:=1;
  txtStr(texti[curText],fontseg);
  x:=0;
  y:=100;
  frame:=0;
  blurframe:=0;
  light:=-128;
  palOK:=false;
  repeat
    cubez:=cubez+round(stab[piSini]*32);
    inc(piSini);
    flip(virseg,addseg);
    rotate;
    drawCube;
    addfont2vir(fontseg,addseg,y,x,light);
    retrace;
    if not palOK then fadein;
    flip(addseg,vidseg);
    inc(frame);
    if light<0 then inc(light,2);
    if frame >= pituus then blurTxt;
    if blurframe=blurri then begin
      blurframe:=0;
      light:=-128;
      frame:=0;
      if curText<texts then inc(curText) else loppu:=true;
      txtStr(texti[curText],fontseg);
    end;
  until (keypressed)or(loppu);

  freemem(virscr,64000);
  freemem(fontscr,320*18);
  freemem(addscr,64000);
end;

end.