]> 4ch.mooo.com Git - 16.git/blob - 16/PCGPE10/WORMIE.PAS
reverted my open watcom to 1.9 an recompiled everything~
[16.git] / 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.