16/PCGPE10/WORMIE.PAS

   1 {$R-}\r
   2 {$X+}\r
   3 Program T_holic;\r
   4 \r
   5 USES\r
   6    Crt;\r
   7 \r
   8 CONST\r
   9    Vga : Word = $a000;\r
  10 \r
  11    Block : Array[1..40,1..40] of Byte = (\r
  12 \r
  13        (0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0),\r
  14        (0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0),\r
  15        (0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0),\r
  16        (0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0),\r
  17        (0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0),\r
  18        (0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0),\r
  19        (0,0,0,0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0,0,0,0),\r
  20        (0,0,0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0,0,0),\r
  21        (0,0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0,0),\r
  22        (0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0),\r
  23        (1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1),\r
  24        (1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1),\r
  25        (1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1),\r
  26        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  27        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  28        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  29        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  30        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  31        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  32        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  33        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  34        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  35        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  36        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  37        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  38        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  39        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),\r
  40        (1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1),\r
  41        (1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1),\r
  42        (1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1),\r
  43        (0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0),\r
  44        (0,0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0,0),\r
  45        (0,0,0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0,0,0),\r
  46        (0,0,0,0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0,0,0,0),\r
  47        (0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0),\r
  48        (0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0),\r
  49        (0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0),\r
  50        (0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0),\r
  51        (0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0),\r
  52        (0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0)\r
  53        );\r
  54 \r
  55 \r
  56 VAR\r
  57    WholePal : Array[1..256,1..3] of Byte;\r
  58    CurX,CurY,CurCol : Word;\r
  59    right,down:Boolean;\r
  60 \r
  61 \r
  62 {ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}\r
  63 Procedure SetMCGA;  { This procedure gets you into 320x200x256 mode. }\r
  64 BEGIN\r
  65   asm\r
  66      mov        ax,0013h\r
  67      int        10h\r
  68   end;\r
  69 END;\r
  70 \r
  71 \r
  72 {ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}\r
  73 Procedure SetText;  { This procedure returns you to text mode.  }\r
  74 BEGIN\r
  75   asm\r
  76      mov        ax,0003h\r
  77      int        10h\r
  78   end;\r
  79 END;\r
  80 \r
  81 \r
  82 {ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}\r
  83 procedure WaitRetrace; assembler;\r
  84 label\r
  85   l1, l2;\r
  86 asm\r
  87     mov dx,3DAh\r
  88 l1:\r
  89     in al,dx\r
  90     and al,08h\r
  91     jnz l1\r
  92 l2:\r
  93     in al,dx\r
  94     and al,08h\r
  95     jz  l2\r
  96 end;\r
  97 \r
  98 \r
  99 {ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}\r
 100 Procedure GetPal(ColorNo : Byte; Var R,G,B : Byte);\r
 101   { This reads the values of the Red, Green and Blue values of a certain\r
 102     color and returns them to you. }\r
 103 Begin\r
 104    Port[$3c7] := ColorNo;\r
 105    R := Port[$3c9];\r
 106    G := Port[$3c9];\r
 107    B := Port[$3c9];\r
 108 End;\r
 109 \r
 110 \r
 111 {ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}\r
 112 Procedure Pal(ColorNo : Byte; R,G,B : Byte);\r
 113   { This sets the Red, Green and Blue values of a certain color }\r
 114 Begin\r
 115    Port[$3c8] := ColorNo;\r
 116    Port[$3c9] := R;\r
 117    Port[$3c9] := G;\r
 118    Port[$3c9] := B;\r
 119 End;\r
 120 \r
 121 \r
 122 {ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}\r
 123 Procedure FadeDown;\r
 124   { This procedure fades the screen out to black. }\r
 125 VAR loop1,loop2:integer;\r
 126     Tmp : Array [1..3] of byte;\r
 127       { This is temporary storage for the values of a color }\r
 128 BEGIN\r
 129   For loop1:=1 to 64 do BEGIN\r
 130     WaitRetrace;\r
 131     For loop2:=1 to 255 do BEGIN\r
 132       Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);\r
 133       If Tmp[1]>0 then dec (Tmp[1]);\r
 134       If Tmp[2]>0 then dec (Tmp[2]);\r
 135       If Tmp[3]>0 then dec (Tmp[3]);\r
 136         { If the Red, Green or Blue values of color loop2 are not yet zero,\r
 137           then, decrease them by one. }\r
 138       Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);\r
 139         { Set the new, altered pallette color. }\r
 140     END;\r
 141   END;\r
 142 END;\r
 143 \r
 144 \r
 145 \r
 146 {ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}\r
 147 Procedure Putpixel (X,Y : Integer; Col : Byte);\r
 148   { This puts a pixel on the screen by writing directly to memory. }\r
 149 BEGIN\r
 150   Mem [VGA:X+(Y*320)]:=Col;\r
 151 END;\r
 152 \r
 153 \r
 154 {ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}\r
 155 Procedure CunninglyManipulatePalette;\r
 156    { This moves up the pallette by one so that the color of the block\r
 157      being put down is always the same }\r
 158 Var\r
 159    Tmp : Array[1..3] of byte;\r
 160   loop : Byte;\r
 161 Begin\r
 162    Move(WholePal[210],Tmp[1],3);           { Save Last Colour             }\r
 163    Move(WholePal[1],WholePal[2],209*3);    { Move Rest Up one             }\r
 164    Move(Tmp,WholePal[1],3);                { Put Last Colour to First pos }\r
 165    For Loop := 1 to 210 do\r
 166       Pal(Loop,WholePal[Loop,1],WholePal[Loop,2],WholePal[Loop,3]);\r
 167 End;\r
 168 \r
 169 \r
 170 \r
 171 {ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}\r
 172 Procedure PreparePalette;\r
 173    { This sets up the palette to have pretty gradients in it for our use }\r
 174 Var\r
 175    Loop : Byte;\r
 176 Begin\r
 177    For loop := 1 to 30 do BEGIN\r
 178       Wholepal [loop,1]:=loop*2;\r
 179       Wholepal [loop,2]:=0;\r
 180       Wholepal [loop,3]:=0;\r
 181    END;\r
 182 \r
 183    For loop := 31 to 60 do BEGIN\r
 184       Wholepal [loop,1]:=0;\r
 185       Wholepal [loop,2]:=loop*2-30;\r
 186       Wholepal [loop,3]:=0;\r
 187    END;\r
 188 \r
 189 \r
 190    For loop := 61 to 90 do BEGIN\r
 191       Wholepal [loop,1]:=0;\r
 192       Wholepal [loop,2]:=0;\r
 193       Wholepal [loop,3]:=loop*2-30;\r
 194    END;\r
 195 \r
 196    For loop := 91 to 120 do BEGIN\r
 197       Wholepal [loop,1]:=loop*2-30;\r
 198       Wholepal [loop,2]:=loop*2-30;\r
 199       Wholepal [loop,3]:=loop*2-30;\r
 200    END;\r
 201 \r
 202    For loop := 121 to 150 do BEGIN\r
 203       Wholepal [loop,1]:=loop*2-30;\r
 204       Wholepal [loop,2]:=loop*2-30;\r
 205       Wholepal [loop,3]:=0;\r
 206    END;\r
 207 \r
 208    For loop := 151 to 180 do BEGIN\r
 209       Wholepal [loop,1]:=0;\r
 210       Wholepal [loop,2]:=loop*2-30;\r
 211       Wholepal [loop,3]:=loop*2-30;\r
 212    END;\r
 213 \r
 214    For loop := 181 to 210 do BEGIN\r
 215       Wholepal [loop,1]:=loop*2-30;\r
 216       Wholepal [loop,2]:=0;\r
 217       Wholepal [loop,3]:=loop*2-30;\r
 218    END;\r
 219 End;\r
 220 \r
 221 \r
 222 {ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}\r
 223 Procedure IngeniouslyMoveCurPos;\r
 224    { This moves the position of the block to put down around the screen }\r
 225 Begin\r
 226    CurCol := (CurCol) mod 210 + 1;        { This Does Work                }\r
 227    if right then CurX := CurX + 4 else CurX := CurX - 3;\r
 228    if down then CurY := CurY + 3 else CurY := CurY - 2;\r
 229 \r
 230    If CurX > 250 then right:= FALSE;\r
 231    If CurY > 150 then down := FALSE;\r
 232 \r
 233    If CurX < 10 then right := TRUE;\r
 234    If CurY < 10 then down  := TRUE;\r
 235 \r
 236 End;\r
 237 \r
 238 \r
 239 {ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}\r
 240 Procedure DrawBlock;\r
 241    { This draws the block onto the VGA screen }\r
 242 Var\r
 243    Xloop,Yloop : Integer;\r
 244 Begin\r
 245    For XLoop := 1 to 40 do\r
 246       For Yloop := 1 to 40 do\r
 247          If block[Yloop,Xloop] = 1 then\r
 248             PutPixel(CurX+Xloop,CurY+Yloop,CurCol);\r
 249 End;\r
 250 \r
 251 \r
 252 {ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}\r
 253 Procedure StartSnakiepoo;\r
 254    { This is the proc where we set things up & set em in motion! ;-) }\r
 255 Begin\r
 256    CurX := 100;\r
 257    CurY := 100;\r
 258    CurCol := 1;\r
 259    PreparePalette;\r
 260    Repeat\r
 261       DrawBlock;\r
 262       CunninglyManipulatePalette;\r
 263       IngeniouslyMoveCurPos;\r
 264    Until Keypressed;\r
 265    fadedown;\r
 266    Readkey;\r
 267 End;\r
 268 \r
 269 Begin\r
 270    ClrScr;\r
 271    Writeln ('Hi there!  This is a small little routine that Livewire');\r
 272    Writeln ('and Denthor of ASPHYXIA threw together during lunch break');\r
 273    Writeln ('at varsity. We first saw this routine in the T-Holic demo');\r
 274    Writeln ('by Extreme a few months back, and decided to write it as');\r
 275    Writeln ('a supliment to the ASPHYXIA VGA Demo Trainer Series on the');\r
 276    Writeln ('MailBox BBS here in Durban.                              ');\r
 277    Writeln;\r
 278    Writeln ('The routine consists of a wormy type thing bouncing around');\r
 279    Writeln ('the screen, and looks quite effective. The code is');\r
 280    Writeln ('documented, and the concept behind it is so easy everyone');\r
 281    Writeln ('should be able to understand it.                         ');\r
 282    Writeln;\r
 283    Writeln ('The Pal routines, setmcga, waitretrace etc. are taken');\r
 284    Writeln ('directly from the ASPHYXIA Trainer Series, and you should');\r
 285    Writeln ('read those to understand how they work.');\r
 286    Writeln;\r
 287    Writeln ('See the Trainer Series for how to get into contact with us.');\r
 288    Writeln; Writeln;\r
 289    Writeln ('Hit any key to continue ....                             ');\r
 290    Readkey;\r
 291    SetMCGA;\r
 292    StartSnakiepoo;\r
 293    SetText;\r
 294    Writeln ('All done. This was a sample routine written by ASPHYXIA.');\r
 295    Writeln ('Please read the ASPHYXIA Demo Trainer Series on the MailBox BBS,');\r
 296    Writeln ('written by Denthor. You may reach DENTHOR under the name of GRANT');\r
 297    Writeln ('SMITH on the MailBox BBS, or leave a message to ASPHYXIA on the');\r
 298    Writeln ('ASPHYXIA BBS. Get the numbers from Roblist, or write to :');\r
 299    Writeln ('             Grant Smith');\r
 300    Writeln ('             P.O. Box 270');\r
 301    Writeln ('             Kloof');\r
 302    Writeln ('             3640');\r
 303    Writeln ('We hope to hear from you soon!');\r
 304    Writeln; Writeln;\r
 305    Write   ('Hit any key to exit ...');\r
 306    Readkey;\r
 307 End.