home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / spiral.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-22  |  3KB  |  113 lines
  1.  
  2. {$r-} { <- seems to improve speed A LOT! }
  3. program GraphicScroll;
  4. { Spiral scroll, by Bas van Gaalen, Holland, PD }
  5. uses
  6.   crt,dos;
  7.  
  8. const
  9.   Amp    = 22;
  10.   Bits   : array[0..7] of byte = (128,64,32,16,8,4,2,1);
  11.   Color  : array[0..7] of byte = (blue,lightblue,cyan,lightcyan,lightcyan,cyan,lightblue,blue);
  12.   ScrTxt : string = 'HOWDY FOLKS, THIS SEEMS TO WORK...         ';
  13.  
  14. var
  15.   Font8x8Seg,
  16.   Font8x8Ofs  : word;
  17.   SinTab      : array[0..320] of word;
  18.   ChrTab      : array[0..320] of byte;
  19.   ColTab      : array[0..320] of byte;
  20.  
  21. {----------------------------------------------------------------------------}
  22.  
  23. procedure GetFont8x8(var Segment,Offset : word);
  24.  
  25. var
  26.   Reg : Registers;
  27.  
  28. begin
  29.   Reg.AX := $1130;
  30.   Reg.BH := 3;
  31.   Intr($10,Reg);
  32.   Segment := Reg.ES;
  33.   Offset := Reg.BP;
  34. end;
  35.  
  36. {----------------------------------------------------------------------------}
  37.  
  38. procedure VideoMode(Mode : byte); assembler;
  39.  
  40. asm
  41.   mov AH,00
  42.   mov AL,Mode
  43.   int 10h
  44. end;
  45.  
  46. {----------------------------------------------------------------------------}
  47.  
  48. procedure CalcSin;
  49.  
  50. var
  51.   I    : word;
  52.   X,
  53.   Step : real;
  54.  
  55. begin
  56.   Step := 5*pi/320;
  57.   I := 0;
  58.   while I <= 320 do begin
  59.     SinTab[I] := round(sin(I*Step)*Amp)+amp;
  60.     if cos(I*Step) <= 0 then ColTab[I] := cyan else ColTab[I] := lightcyan;
  61.     inc(I);
  62.   end;
  63. end;
  64.  
  65. {----------------------------------------------------------------------------}
  66.  
  67. procedure Scroll(Segment,Offset : word);
  68.  
  69. var
  70.   J,
  71.   Ofs,
  72.   TxtPos    : word;
  73.   CharPos,
  74.   I,K,
  75.   Character : byte;
  76.  
  77. begin
  78.   TxtPos := 1;
  79.   repeat
  80.     CharPos := 0;
  81.     Character := ord(ScrTxt[TxtPos]);
  82.     I := 0;
  83.     while I < 8 do begin
  84.       for J := 0 to 319 do ChrTab[J] := ChrTab[J+1];
  85.       ChrTab[320] := mem[Font8x8Seg:Font8x8Ofs+(8*Character)+I];
  86.  
  87.       while (port[$3da] and 8) <> 0 do;
  88.       while (port[$3da] and 8) = 0 do;
  89.  
  90.       for J := 1 to 312 do
  91.         for K := 0 to 7 do begin
  92.           Ofs := (190-(2*Amp)+SinTab[J])*320+J+K;
  93.           if ChrTab[J] and Bits[K] <> 0 then
  94.             mem[$A000:Ofs] := ColTab[J]
  95.           else {if SinTab[J] <> SinTab[J-1] then} mem[$A000:Ofs] := black;
  96.         end;
  97.       inc(I);
  98.     end;
  99.  
  100.     inc(TxtPos);
  101.     if TxtPos = length(ScrTxt) then TxtPos := 1;
  102.   until keypressed;
  103. end;
  104.  
  105. {----------------------------------------------------------------------------}
  106.  
  107. begin
  108.   Videomode($13);
  109.   CalcSin;
  110.   GetFont8x8(Font8x8Seg,Font8x8Ofs);
  111.   Scroll(Font8x8Seg,Font8x8Ofs);
  112. end.
  113.