Demo/BlackHole/tunplas.pas

   1 {$E-,F+,G+,I-,N+,O+,Q-,R-,S-,V-}
   2 Unit Tunplas;
   3
   4 INTERFACE
   5
   6 Uses Blue_Cob,Crt;
   7
   8 Procedure CalcPlas( plas : Pointer);
   9 Procedure CalcTunnel( Int : Word);
  10 Procedure Trash_it_256;
  11 Procedure DoTunnel( plas : Pointer; move : Word);
  12 Procedure CalcWorm( seg3 : Pointer);
  13 Procedure CalcRain( plas : Pointer; Intensity : Byte);
  14 Procedure DoWorm( plas, seg3 : Pointer; move : Word);
  15
  16 IMPLEMENTATION
  17
  18 Procedure CalcPlas( plas : Pointer);
  19 Var a, x, x2, x3, y, y2 : Word;
  20   Begin
  21     Randomize;
  22     For x:=0 To $ffff Do
  23       If Random(800)=0 Then Mem[seg(segmen^):x]:=Random(30)*Random(20);
  24     For a:=0 To 14 Do
  25     Begin
  26       For x:=0 To $ffff Do
  27       Begin
  28         x2:=0;
  29         For y:=1 To 5 Do
  30           For y2:=1 To 5 Do
  31             x2:=x2+Mem[seg(segmen^):x+(y-3)*256+y2-3];
  32         x3:=Mem[seg(segmen^):x];
  33         If a>10 Then x2:=x2 div 25
  34           Else x2:=x2 div 25+Random(4)*Random(10*x3)-Random(4)*Random(5*x3);
  35         If a=11 Then x2:=x2+Random(20)*Random(20);
  36         Mem[seg(segmen2^):x]:=x2;
  37       End;
  38       Zeiger:=segmen;
  39       segmen:=segmen2;
  40       segmen2:=Zeiger;
  41       Write('²');
  42     End;
  43     asm
  44       les di,plas
  45       push ds
  46       lds si,segmen
  47       mov cx,4000h
  48     db 66h
  49       rep movsw
  50       pop ds
  51     end;
  52   End;
  53
  54 Procedure CalcTunnel( Int : Word);
  55 Var x, y, col, Winkel : Word;
  56   Begin
  57     For y:=0 To 99 Do
  58       For x:=0 To 159 Do
  59       Begin
  60         Winkel:=Lo(Round(Arctan386(1.5*(99.5-y)/(159.5-x))
  61                                       *(256 Shl (Int-1))/pi));
  62         col:=Round( 12000/Sqrt((159.5-x)*(159.5-x)+1.5*(99.5-y)*(99.5-y)) );
  63         Memw[seg(segmen2^):2*(320*y+x)]:=(col And 255) shl 8 +winkel;
  64      {} Memw[seg(segmen2^):2*(320*y+(319-x))]:=(col and 255) shl 8 -winkel;
  65    {} End;
  66   End;
  67
  68 Procedure DoTunnel( plas : Pointer; move : Word);assembler;
  69   asm
  70     les di, segmen
  71     mov ax, word ptr [segmen2+2]
  72   db 08eh          {mov }
  73   db 0e8h          {gs,ax}
  74     mov ax, move
  75     push ds
  76     lds si, plas
  77     mov dx, si
  78     mov cx, 32000  {z„hler}
  79 @lp1:
  80     mov bx, dx
  81   db 65h
  82     mov si, [bx]   {Addresse holen}
  83     add si, ax     {Bewegung drauf}
  84     movsb          {Byte kopieren}
  85     add dx, 2
  86     push di        {di sichern}
  87     mov bx, 63999  {"von hinten" auch!}
  88     sub bx, di
  89     inc bx         {wegen "inc di" bei "movsb"}
  90     mov di, bx     {neuer Offset}
  91     dec si         {auch wegen "inc si" bei "movsb"}
  92     movsb
  93     pop di         {di holen}
  94     dec cx
  95     jnz @lp1
  96     pop ds
  97   end;
  98
  99 Procedure CalcWorm( seg3 : Pointer);
 100 Var
 101   x, x2, y, y2, mo, col, peri : Word;
 102   r : Double;
 103   Begin
 104     {For x:=0 To 3120 Do Sinus^[x]:=Round( 1024*Sin386((x*pi/180)/3120*360) );}
 105     r:=26.4;
 106     Repeat
 107       r:=r+0.1*Sqrt(Sqrt(Sqrt(r)));
 108       peri:=Round(869*(r/240));
 109       For x:=0 To peri Do
 110       Begin
 111         y2:=Round(0.6*(110.5+4000/r
 112                   +r{Sinus^[Trunc(780+3120/(peri*2)*x)]/1024}
 113                   *Cos386(x*pi/peri) ));
 114         If (y2>=0) And (y2<200) Then
 115         Begin
 116           x2:=Round(159.5+r{*Sinus^[Trunc(3120/(peri*2)*x)]/1024}
 117                            *Sin386(x*pi/peri) );
 118           If (x2>159) And (x2<320) Then
 119           Begin
 120             col:=Round(x/peri*512) And 255;
 121          {} Memw[seg(segmen2^):2*(160*y2+(319-x2))]:=(256*(Round(2*r) and 255))+257-col;
 122          {} Memw[seg(seg3^):2*(160*y2+x2-160)]:=(256*(Round(2*r) and 255))+col;
 123           End;
 124         End;
 125       End;
 126       If (Round(r*1000) mod 114=0)
 127          And (r<240) Then Write('²');
 128     Until (r>=260);
 129   End;
 130
 131 Procedure Trash_It_256;
 132   Begin
 133     Zeiger:=segmen;
 134     segmen:=segmen2;
 135     segmen2:=Zeiger;
 136     asm
 137       push ds
 138       les di,segmen      {Schreib-Speicher" laden}
 139       lds si,segmen2
 140       xor di,di
 141       mov cx,0ffffh
 142     db 66h
 143       inc cx
 144
 145 @lop:
 146       xor ax,ax
 147       xor dx,dx
 148       mov al,[si+1]      {Pixelfarbe rechts neben dem Zielpixel nach al}
 149       mov dl,[si-1]      {Pixelfarbe links neben dem Zielpixel nach bl}
 150       add ax,dx          {Pixelfarben addieren}
 151       mov dl,[si-257]    {...und so weiter...[der Offset der Pixel berechnet
 152                           sich aus 320*Y+X ...min=0...max=63999]}
 153       add ax,dx
 154       mov dl,[si-256]
 155       add ax,dx
 156       mov dl,[si-255]
 157       add ax,dx
 158       mov dl,[si+255]
 159       add ax,dx
 160       mov dl,[si+256]
 161       add ax,dx
 162       mov dl,[si+257]
 163       add ax,dx
 164       add ax,2
 165       shr ax,3           {Summe der Farben per shiften um 3 nach rechts durch
 166                           8 teilen}
 167       stosb              {in den "original-Punkt"}
 168       inc si             {n„chstes Pixel}
 169     db 66h
 170       dec cx             {   "       "  }
 171       jnz @lop           {solange, bis cx=0...dann sind alle, bis auf die
 172                           Pixel in Zeile 1 berechnet worden}
 173       pop ds
 174     end
 175   End;
 176
 177 Procedure Klecks( x, y, farbe : Byte);assembler;
 178   asm
 179     les di,segmen
 180     mov ah,y
 181     mov al,x
 182     mov di,ax
 183     mov al,farbe
 184     mov dx,10
 185 @lp1:
 186     mov cx,10
 187     rep stosb
 188     add di,246
 189     dec dx
 190     jnz @lp1
 191   end;
 192
 193 Procedure CalcRain( plas : Pointer; Intensity : Byte);
 194 Var x, y, i, a : Word;
 195   Begin
 196     Randomize;
 197     For i:=0 To 160 Do              {schon mal vorbereiten, damit dann nicht}
 198     Begin                            {erst langsam der Screen voller wird}
 199       If i mod 16=0 Then Write('²');
 200       For a:=0 To 2 Do
 201         Klecks( Random(246), Random(246), Intensity);
 202       trash_it_256;
 203     End;
 204     trash_it_256;
 205     asm
 206       les di, plas
 207       push ds
 208       lds si, segmen
 209       mov cx, 4000h
 210     db 66h
 211       rep movsw
 212       pop ds
 213     end;
 214   End;
 215
 216 Procedure DoWorm( plas, seg3 : Pointer; move : Word);assembler;
 217   asm
 218     les di, segmen  {}
 219     mov ax, word ptr [segmen2+2]
 220   db 08eh          {mov... }
 221   db 0e8h          {...gs,ax}
 222     mov ax, word ptr [seg3+2]
 223   db 8eh           {mov... }
 224   db 0e0h          {...fs,ax}
 225     mov ax, move
 226     push ds
 227     lds si, plas
 228     mov bx, si
 229     mov dx, si
 230     mov ch, 200    {Z„hler der Zeilen}
 231 @lp1:
 232     mov cl, 160    {Spalten}
 233 @lpl:
 234   db 65h
 235     mov si, [bx]   {Adresse laden}
 236     add si, ax     {Bewegung drauf}
 237     movsb          {Pixel kopieren}
 238     add bx, 2      {n„chste Adresse}
 239     dec cl         {Z„hler senken}
 240     jnz @lpl
 241     push bx        {linken Offset sichern}
 242
 243     mov cl, 160    {Spalten}
 244     mov bx, dx     {rechten laden}
 245 @lpr:
 246   db 64h
 247     mov si, [bx]
 248     add si, ax
 249     movsb
 250     add bx, 2
 251     dec cl
 252     jnz @lpr
 253     mov dx, bx      {rechten sichern}
 254     pop bx          {linken laden}
 255
 256     dec ch
 257     jnz  @lp1
 258     pop ds
 259   end;
 260
 261
 262 End.