home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / strscr.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-22  |  3KB  |  96 lines
  1.  
  2. program strectch_scroll;
  3. { Stretching and wobbling scroll, by Bas van Gaalen, Holland, PD }
  4. { REEAAAAALLL slow if you don't have a 486dx2/66 or Pentium }
  5. uses crt;
  6. const
  7.   len:byte=99;
  8.   vidseg:word=$a000;
  9.   diffsin:array[0..63] of byte=(
  10.     0,0,0,1,0,1,1,2,1,2,2,3,2,3,3,4,3,4,4,5,
  11.     4,5,5,4,5,4,4,3,4,3,3,2,3,2,2,1,2,1,1,0,
  12.     1,0,0,0,0,1,2,2,3,3,3,4,4,4,4,3,3,3,2,2,1,0,0,0);
  13. var
  14.   f:text;
  15.   txt:array[0..99] of string[20];
  16.   stab:array[0..255] of shortint;
  17.   bitmap:array[0..40,0..159] of byte;
  18.   virscr:pointer;
  19.   virseg,fofs,fseg:word;
  20.  
  21. procedure getfont; assembler; asm
  22.   mov ax,1130h; mov bh,3; int 10h; mov fseg,es; mov fofs,bp; end;
  23.  
  24. procedure setvideo; assembler; asm
  25.   mov ax,13h; int 10h; mov dx,3d4h; mov al,9; out dx,al; inc dx
  26.   in al,dx; and al,0e0h; add al,3; out dx,al; end;
  27.  
  28. procedure cls(lvseg:word); assembler; asm
  29.   mov es,[lvseg]; xor di,di; xor ax,ax; mov cx,320*200/2; rep stosw; end;
  30.  
  31. procedure flip(src,dst:word); assembler; asm
  32.   push ds; mov ax,[dst]; mov es,ax; mov ax,[src]; mov ds,ax
  33.   xor si,si; xor di,di; mov cx,320*200/2; rep movsw; pop ds; end;
  34.  
  35. procedure retrace; assembler; asm
  36.   mov dx,3dah; @vert1: in al,dx; test al,8; jz @vert1
  37.   @vert2: in al,dx; test al,8; jnz @vert2; end;
  38.  
  39. procedure dosomescrolling;
  40. var x,y,repy,idx1,idx2,offset,add,col,txtidx:word; pos:longint; i:byte;
  41. begin
  42.   fillchar(bitmap,sizeof(bitmap),0);
  43.   offset:=0; idx1:=0; idx2:=40; add:=0; txtidx:=0;
  44.   repeat
  45.     for x:=1 to 20 do for i:=0 to 7 do
  46.       if ((mem[fseg:fofs+ord(txt[txtidx][x])*8+idx1 and 7] shl i) and 128) <> 0 then
  47.         bitmap[40,((x-1)*8)+i]:=32+(x+i+idx1) and $3f else bitmap[40,((x-1)*8)+i]:=0;
  48.     add:=0;
  49.     for y:=0 to 40 do begin
  50.       offset:=diffsin[(y+idx1+idx2) and $3f];
  51.       if offset>0 then begin
  52.         inc(add,offset);
  53.         repy:=0;
  54.         while (repy<=offset) and ((add+repy)<100) do begin
  55.           for x:=0 to 159 do begin
  56.             col:=bitmap[y,x]; col:=col+col*256;
  57.             pos:=(add+repy+stab[(idx2+add+x) and $ff])*320;
  58.             if pos>0 then memw[virseg:pos+x+x]:=col;
  59.           end;
  60.           inc(repy);
  61.         end;
  62.       end;
  63.     end;
  64.     retrace;
  65.     flip(virseg,vidseg);
  66.     cls(virseg);
  67.     inc(idx1); dec(idx2,2);
  68.     if (idx1 mod 8)=0 then begin inc(txtidx); if txtidx>len then txtidx:=0; end;
  69.     move(bitmap[1,0],bitmap[0,0],sizeof(bitmap)-160);
  70.   until keypressed;
  71. end;
  72.  
  73. var i:byte;
  74. begin
  75.   if paramstr(1)='' then begin
  76.     writeln('Enter textfile on commandline.'); halt; end;
  77.   assign(f,paramstr(1));
  78.   reset(f);
  79.   i:=0;
  80.   while (not eof(f)) and (i<99) do begin
  81.     readln(f,txt[i]);
  82.     inc(i);
  83.   end;
  84.   len:=i;
  85.   for i:=0 to 255 do stab[i]:=round(sin(pi*i/128)*20);
  86.   getfont;
  87.   setvideo;
  88.   getmem(virscr,64000);
  89.   virseg:=seg(virscr^);
  90.   cls(virseg);
  91.   dosomescrolling;
  92.   repeat until keypressed;
  93.   freemem(virscr,64000);
  94.   textmode(lastmode);
  95. end.
  96.