home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / pasgraph / worm.pas < prev    next >
Pascal/Delphi Source File  |  1994-08-25  |  3KB  |  216 lines
  1. { Turbo Pascal Version 7.0 Directive Settings }
  2. {$A+,B-,D+,E+,F-,G+,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+}
  3.  
  4. Program Wormhole;
  5.  
  6. Uses
  7.   Crt;
  8.  
  9. Const
  10.   Vidseg:Word = $A000;
  11.   Divd        = 128;
  12.   Astep       = 6;
  13.   Xst         = 4;
  14.   Yst         = 5;
  15.  
  16. Var
  17.   Sintab      : Array[0..449] Of Integer;
  18.   Stab,
  19.   Ctab        : Array[0..255] Of Integer;
  20.   Virscr      : Pointer;
  21.   Virseg      : Word;
  22.   Lstep       : Byte;
  23.  
  24. {$Define Cpu386}
  25.  
  26. {----------------------------------------------------------------------------}
  27.  
  28. Procedure Setpal( Col,R,G,B : Byte ); Assembler;
  29.  
  30. Asm
  31.   Mov Dx,03C8H
  32.   Mov Al,Col
  33.   Out Dx,Al
  34.   Inc Dx
  35.   Mov Al,R
  36.   Out Dx,Al
  37.   Mov Al,G
  38.   Out Dx,Al
  39.   Mov Al,B
  40.   Out Dx,Al
  41. End;
  42.  
  43. {----------------------------------------------------------------------------}
  44.  
  45. Procedure Drawpolar( Xo,Yo,R,A : Word; C : Byte; Lvseg : Word ); Assembler;
  46.  
  47. Asm
  48.   Mov Es,Lvseg
  49.   Mov Bx,A
  50.   Add Bx,A
  51.   Mov Cx,Word Ptr Sintab[Bx]
  52.   Add Bx,2*90
  53.   Mov Ax,Word Ptr Sintab[Bx]
  54.   Mul R
  55.   Mov Bx,Divd
  56.   Xor Dx,Dx
  57.   Cwd
  58.   Idiv Bx
  59.   Add Ax,Xo
  60.   Add Ax,160
  61.   Cmp Ax,320
  62.   Ja @Out
  63.   Mov Si,Ax
  64.  
  65.   Mov Ax,Cx
  66.   Mul R
  67.   Mov Bx,Divd
  68.   Xor Dx,Dx
  69.   Cwd
  70.   Idiv Bx
  71.   Add Ax,Yo
  72.   Add Ax,100
  73.   Cmp Ax,200
  74.   Ja @Out
  75.  
  76.   Shl Ax,6
  77.   Mov Di,Ax
  78.   Shl Ax,2
  79.   Add Di,Ax
  80.   Add Di,Si
  81.   Mov Al,C
  82.   Mov [Es:Di],Al
  83.   @Out:
  84. End;
  85.  
  86. {----------------------------------------------------------------------------}
  87.  
  88. Procedure Cls(Lvseg:Word); Assembler;
  89.  
  90. Asm
  91.   Mov Es,[Lvseg]
  92.   Xor Di,Di
  93.   Xor Ax,Ax
  94.  
  95. {$IFDEF Cpu386}
  96.  
  97.   Mov Cx,320*200/4
  98.   Rep
  99.   Db $66; Stosw
  100.  
  101. {$ELSE}
  102.  
  103.   Mov Cx,320*200/2
  104.   Rep Stosw
  105.  
  106. {$ENDIF}
  107.  
  108. End;
  109.  
  110. {----------------------------------------------------------------------------}
  111.  
  112. Procedure Flip(Src,Dst:Word); Assembler;
  113.  
  114. Asm
  115.   Push Ds
  116.   Mov Ax,[Dst]
  117.   Mov Es,Ax
  118.   Mov Ax,[Src]
  119.   Mov Ds,Ax
  120.   Xor Si,Si
  121.   Xor Di,Di
  122.  
  123. {$IFDEF Cpu386}
  124.  
  125.   Mov Cx,320*200/4
  126.   Rep
  127.   Db $66; Movsw
  128.  
  129. {$ELSE}
  130.  
  131.   Mov Cx,320*200/2
  132.   Rep Movsw
  133.  
  134. {$ENDIF}
  135.  
  136.   Pop Ds
  137. End;
  138.  
  139. {----------------------------------------------------------------------------}
  140.  
  141. Procedure Retrace; Assembler;
  142.  
  143. Asm
  144.   Mov Dx,03Dah
  145.  @Vert1:
  146.   In Al,Dx
  147.   Test Al,8
  148.   Jnz @Vert1
  149.  @Vert2:
  150.   In Al,Dx
  151.   Test Al,8
  152.   Jz @Vert2
  153. End;
  154.  
  155. {----------------------------------------------------------------------------}
  156.  
  157. Var
  158.   C       : Byte;
  159.   X,Y,I,J : Word;
  160.  
  161. Begin
  162.   Asm
  163.     Mov Ax,13H;
  164.     Int 10H;
  165.   End;
  166.  
  167.   For I := 0 To 255 Do
  168.     Begin
  169.       Ctab[I] := Round(Cos(Pi*I/128)*60);
  170.       Stab[I] := Round(Sin(Pi*I/128)*45);
  171.     End;
  172.  
  173.   For I := 0 To 449 Do
  174.     Sintab[I] := Round(Sin(2*Pi*I/360)*Divd);
  175.  
  176.   Getmem(Virscr,64000);
  177.   Virseg := Seg(Virscr^);
  178.   Cls(Virseg);
  179.   X := 30;
  180.   Y := 90;
  181.  
  182.   Repeat
  183.     {Retrace;}
  184.     C     := 22;
  185.     Lstep := 2;
  186.     J     := 10;
  187.     While J < 220 Do
  188.       Begin
  189.         I := 0;
  190.         While I < 360 Do
  191.           Begin
  192.             Drawpolar(Ctab[(X+(200-j)) Mod 255],Stab[(Y+(200-j)) Mod
  193.                 255],J,I,C,Virseg);
  194.             Inc(I,Astep);
  195.           End;
  196.         Inc(J,Lstep);
  197.         If (J Mod 5) = 0 Then
  198.           Begin
  199.             Inc(Lstep);
  200.             Inc(C);
  201.             If C > 31 Then
  202.               C := 22;
  203.           End;
  204.       End;
  205.     X := Xst + X Mod 255;
  206.     Y := Yst + Y Mod 255;
  207.     Flip(Virseg,Vidseg);
  208.     Cls(Virseg);
  209.   Until Keypressed;
  210.  
  211.   While Keypressed Do
  212.     Readkey;
  213.   Freemem(Virscr,64000);
  214.   Textmode(Lastmode);
  215. End.
  216.