/[james]/archive/chess/Chess.opl
ViewVC logotype

Contents of /archive/chess/Chess.opl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 7 - (show annotations) (download)
Tue Jan 28 15:20:48 2003 UTC (21 years, 9 months ago) by james
File size: 11379 byte(s)
Initial import.

1 APP Chess
2 TYPE 0
3 ICON "\OPD\CHESS.PIC"
4 ENDA
5
6 PROC chess:
7 GLOBAL pb$(10),pw$(10),c$(6,1),l$(6,6),p%(64),f%,g%,q%,s%,t%,r%,w%,z%,c,m,sm%,cs%(4),g$(1)
8 ESCAPE OFF
9 vars:
10 window:
11 ONERR error
12 DO
13 players:
14 start:
15 r%=0 :g%=1 :z%=1 :c=1 :t%=20 :q%=0
16 DO
17 cont::
18 IF z% :redraw: :f%=0 :sm%=0 :ELSE :z%=1 :ENDIF
19 input:
20 UNTIL q%
21 IF q%<>1 :new: :ENDIF
22 UNTIL 0
23
24 error::
25 ONERR OFF
26 CLS
27 PRINT "Unexpected error:",ERR$(ERR)
28 PRINT "(C)ontinue or E(x)it?"
29 DO :g$=LOWER$(GET$) :UNTIL g$="c" OR g$="x"
30 IF g$="c" :z%=1 :CLS :ONERR error :GOTO cont :ENDIF
31 ENDP
32
33 PROC vars:
34 c$(1)="P" :l$(1)="Pawn"
35 c$(2)="R" :l$(2)="Rook"
36 c$(3)="N" :l$(3)="Knight"
37 c$(4)="B" :l$(4)="Bishop"
38 c$(5)="Q" :l$(5)="Queen"
39 c$(6)="K" :l$(6)="King"
40 pw$="Player 1"
41 pb$="Player 2"
42 s%=2
43 ENDP
44
45 PROC window:
46 DEFAULTWIN 1
47 STATUSWIN ON,s%
48 FONT 12,0
49 gBORDER $200
50 ENDP
51
52 PROC players:
53 dINIT "Players' names"
54 dEDIT pw$,"White"
55 dEDIT pb$,"Black"
56 LOCK ON
57 DIALOG
58 LOCK OFF
59 ENDP
60
61 PROC start:
62 LOCAL a%
63 p%(1)=2 :p%(2)=3 :p%(3)=4 :p%(4)=6
64 p%(5)=5 :p%(6)=4 :p%(7)=3 :p%(8)=2
65 a%=9
66 DO :p%(a%)=1 :a%=a%+1 :UNTIL a%=17
67 DO :p%(a%)=0 :a%=a%+1 :UNTIL a%=49
68 DO :p%(a%)=11 :a%=a%+1 :UNTIL a%=57
69 p%(57)=12 :p%(58)=13 :p%(59)=14 :p%(60)=16
70 p%(61)=15 :p%(62)=14 :p%(63)=13 :p%(64)=12
71 cs%(1)=1 :cs%(2)=1 :cs%(3)=1 :cs%(4)=1
72 ENDP
73
74 PROC redraw:
75 LOCAL a%,x,y
76 a%=1 :w%=gWIDTH/2-80
77 gUPDATE OFF
78 clear:
79 IF r%=1 :x=7
80 ELSEIF r%=2 :x=7 :y=7
81 ELSEIF r%=3 :y=7
82 ENDIF
83 DO
84 place:(x,y,a%)
85 a%=a%+1
86 IF r%=0 :x=x+1 :IF x=8 :x=0 :y=y+1 :ENDIF
87 ELSEIF r%=1 :y=y+1 :IF y=8 :y=0 :x=x-1 :ENDIF
88 ELSEIF r%=2 :x=x-1 :IF x=-1 :x=7 :y=y-1 :ENDIF
89 ELSEIF r%=3 :y=y-1 :IF y=-1 :y=7 :x=x+1 :ENDIF
90 ENDIF
91 UNTIL a%=65
92 gGREY 0
93 IF g%=1 :gSTYLE 36 :ELSE :gSTYLE 32 :ENDIF
94 gAT 1,20
95 gPRINTB "White",w%-2,3
96 IF g%=2 :gSTYLE 36 :ELSE :gSTYLE 32 :ENDIF
97 gAT w%+161,20
98 gPRINTB "Black",w%-2,3
99 IF g%=1 :gSTYLE 12 :ELSE :gSTYLE 8 :ENDIF
100 gAT 1,50
101 gPRINTB pw$,w%-2,3
102 IF g%=2 :gSTYLE 12 :ELSE :gSTYLE 8 :ENDIF
103 gAT w%+161,50
104 gPRINTB pb$,w%-2,3
105 IF g%>2 :hilite:(m) :ENDIF
106 gUPDATE
107 gSTYLE 0
108 ENDP
109
110 PROC clear:
111 gGREY 2 :gAT w%,0 :gFILL 160,160,1
112 gGREY 0 :gAT w%,0 :gBOX 160,160
113 ENDP
114
115 PROC place:(x,y,a%)
116 gGREY 1
117 IF ((x+y+r%+1)/2)=INT((x+y+r%+1)/2)
118 gAT w%+x*20,y*20
119 gFILL 20,20,0
120 ENDIF
121 IF p%(a%)>0
122 gAT w%+x*20+3,y*20+3
123 gFILL 14,14,1
124 gGREY 0
125 IF p%(a%)>9
126 gAT w%+x*20+4,y*20+4
127 gFILL 12,12,0
128 ELSE
129 gAT w%+x*20+3,y*20+3
130 gBOX 14,14
131 ENDIF
132 gTMODE 2
133 gAT w%+x*20+6,y*20+15
134 gPRINT c$(rem:(FLT(p%(a%)),10))
135 ENDIF
136 ENDP
137
138 PROC input:
139 LOCAL e%(6),k%,m%
140 IF TESTEVENT
141 GETEVENT e%()
142 k%=e%(1)
143 m%=e%(2) AND $00ff
144 IF k%=44
145 r%=r%-1
146 IF r%<0 :r%=3 :ENDIF
147 ELSEIF k%=46
148 r%=r%+1
149 IF r%=4 :r%=0 :ENDIF
150 ELSEIF k%=290 AND (m% AND 4)
151 s%=s%-1
152 IF s%=-1 :s%=2 :ENDIF
153 window:
154 ELSEIF k%=256
155 IF sm% AND g%<3 :moves: :sm%=0 :ENDIF
156 IF r%=0 AND c>8 :u:
157 ELSEIF r%=1 AND (c-1)/8<>INT((c-1)/8) :l:
158 ELSEIF r%=2 AND c<57 :d:
159 ELSEIF r%=3 AND c/8<>INT(c/8) :r:
160 ENDIF
161 z%=0
162 ELSEIF k%=257
163 IF sm% AND g%<3 :moves: :sm%=0 :ENDIF
164 IF r%=0 AND c<57 :d:
165 ELSEIF r%=1 AND c/8<>INT(c/8) :r:
166 ELSEIF r%=2 AND c>8 :u:
167 ELSEIF r%=3 AND (c-1)/8<>INT((c-1)/8) :l:
168 ENDIF
169 z%=0
170 ELSEIF k%=258
171 IF sm% AND g%<3 :moves: :sm%=0 :ENDIF
172 IF r%=0 AND c/8<>INT(c/8) :r:
173 ELSEIF r%=1 AND c>8 :u:
174 ELSEIF r%=2 AND (c-1)/8<>INT((c-1)/8) :l:
175 ELSEIF r%=3 AND c<57 :d:
176 ENDIF
177 z%=0
178 ELSEIF k%=259
179 IF sm% AND g%<3 :moves: :sm%=0 :ENDIF
180 IF r%=0 AND (c-1)/8<>INT((c-1)/8) :l:
181 ELSEIF r%=1 AND c<57 :d:
182 ELSEIF r%=2 AND c/8<>INT(c/8) :r:
183 ELSEIF r%=3 AND c>8 :u:
184 ENDIF
185 z%=0
186 ELSEIF k%=13 OR k%=32
187 IF g%<3
188 choose:
189 ELSE
190 move:
191 ENDIF
192 ELSEIF k%=27
193 IF g%>2
194 IF sm% :moves: :sm%=0 :ENDIF
195 g%=g%-2
196 hilite:(m)
197 ENDIF
198 z%=0
199 ELSEIF k%=290
200 menu:
201 ELSEIF k%=291
202 help:
203 z%=0
204 ELSEIF k%=621 OR k%=109
205 IF sm%=0 :moves: :ENDIF
206 sm%=1
207 z%=0
208 ELSEIF k%=622
209 new2:
210 ELSEIF k%=624
211 players:
212 ELSEIF k%=632
213 exit:
214 z%=0
215 ELSEIF k%=$404
216 IF LEFT$(GETCMD$,1)="X" :STOP :ENDIF
217 ELSE
218 z%=0
219 ENDIF
220 ELSE
221 IF t%=20
222 f%=1-f%
223 t%=0
224 hilite:(c)
225 ENDIF
226 t%=t%+1
227 z%=0
228 ENDIF
229 ENDP
230
231 PROC choose:
232 IF p%(c)=0 :GIPRINT "No piece chosen"
233 ELSEIF g%=1 AND p%(c)>9 :GIPRINT "White's turn!"
234 ELSEIF g%=2 AND p%(c)<9 :GIPRINT "Black's turn!"
235 ELSE
236 gAT (g%-1)*(w%+160)+1,80
237 gPRINTB l$(p%(c)-10*(g%-1)),w%-2,3
238 g%=g%+2
239 m=c
240 hilite:(c)
241 ENDIF
242 z%=0
243 ENDP
244
245 PROC move:
246 LOCAL ok%,t
247 IF (p%(c)=0) OR (g%=3 AND p%(c)>9) OR (g%=4 AND p%(c)<10)
248 IF p%(m)=1 :ok%=pawnw:(1)
249 ELSEIF p%(m)=11 :ok%=pawnb:(1)
250 ELSEIF p%(m)=2 OR p%(m)=12 :ok%=rook:(1)
251 ELSEIF p%(m)=3 OR p%(m)=13 :ok%=knight:
252 ELSEIF p%(m)=4 OR p%(m)=14 :ok%=bishop:
253 ELSEIF p%(m)=5 OR p%(m)=15 :ok%=queen:
254 ELSEIF p%(m)=6 OR p%(m)=16 :ok%=king:(1)
255 ENDIF
256 IF ok%
257 t=p%(c)
258 p%(c)=p%(m)
259 p%(m)=0
260 IF check:(g%-2)
261 GIPRINT "Into check!"
262 p%(m)=p%(c)
263 p%(c)=t
264 z%=0
265 ELSE
266 g%=3-(g%-2)
267 IF t>0 :GIPRINT l$(rem:(t,10))+" taken" :ENDIF
268 IF check:(g%) :GIPRINT "Check" :ENDIF
269 ENDIF
270 ELSE
271 GIPRINT "Bad move"
272 z%=0
273 ENDIF
274 ELSE
275 GIPRINT "Bad move"
276 z%=0
277 ENDIF
278 ENDP
279
280 PROC pawnw:(c%)
281 IF (p%(c)=0 AND (c=m+8 OR (c=m+16 AND m<17 AND p%(m+8)=0))) OR (p%(c)<>0 AND (c=m+7 OR c=m+9))
282 IF c>55 AND c% :p%(m)=5 :ENDIF
283 RETURN 1
284 ENDIF
285 ENDP
286
287 PROC pawnb:(c%)
288 IF (p%(c)=0 AND (c=m-8 OR (c=m-16 AND m>47 AND p%(m-8)=0))) OR (p%(c)<>0 AND (c=m-7 OR c=m-9))
289 IF c<9 AND c% :p%(m)=15 :ENDIF
290 RETURN 1
291 ENDIF
292 ENDP
293
294 PROC rook:(c%)
295 LOCAL t
296 IF c>(INT((m-1)/8)*8) AND c<(INT((m-1)/8)*8)+9
297 IF c<m-1
298 t=m-1
299 DO
300 IF p%(t)>0 :RETURN 0 :ENDIF
301 t=t-1
302 UNTIL t=c
303 ELSEIF c>m+1
304 t=m+1
305 DO
306 IF p%(t)>0 :RETURN 0 :ENDIF
307 t=t+1
308 UNTIL t=c
309 ENDIF
310 IF m=1 AND c% AND cs%(1) :cs%(1)=0 :ENDIF
311 IF m=8 AND c% AND cs%(2) :cs%(2)=0 :ENDIF
312 IF m=64 AND c% AND cs%(3) :cs%(3)=0 :ENDIF
313 IF m=57 AND c% AND cs%(4) :cs%(4)=0 :ENDIF
314 RETURN 1
315 ELSEIF rem:(c,8)=rem:(m,8)
316 IF c<m-8
317 t=m-8
318 DO
319 IF p%(t)>0 :RETURN 0 :ENDIF
320 t=t-8
321 UNTIL t=c
322 ELSEIF c>m+8
323 t=m+8
324 DO
325 IF p%(t)>0 :RETURN 0 :ENDIF
326 t=t+8
327 UNTIL t=c
328 ENDIF
329 IF m=1 AND c% AND cs%(1) :cs%(1)=0 :ENDIF
330 IF m=8 AND c% AND cs%(2) :cs%(2)=0 :ENDIF
331 IF m=64 AND c% AND cs%(3) :cs%(3)=0 :ENDIF
332 IF m=57 AND c% AND cs%(4) :cs%(4)=0 :ENDIF
333 RETURN 1
334 ENDIF
335 ENDP
336
337 PROC knight:
338 LOCAL x%
339 x%=rem:(m,8)
340 IF x%=0 :x%=8 :ENDIF
341 IF ((c=m-17 OR c=m+15) AND x%>1) OR ((c=m-15 OR c=m+17) AND x%<8) OR ((c=m-10 OR c=m+6) AND x%>2) OR ((c=m-6 OR c=m+10) AND x%<7)
342 RETURN 1
343 ENDIF
344 ENDP
345
346 PROC bishop:
347 LOCAL c1%,c2%,r1%,r2%,t
348 c1%=rem:(m,8) :r1%=(m-1)/8
349 c2%=rem:(c,8) :r2%=(c-1)/8
350 IF c1%=0 :c1%=8 :ENDIF
351 IF c2%=0 :c2%=8 :ENDIF
352 IF ABS(c2%-c1%)<>ABS(r2%-r1%) :RETURN 0 :ENDIF
353 IF c=m-9 OR c=m-7 OR c=m+7 OR c=m+9 :RETURN 1 :ENDIF
354 IF c2%<c1% AND r2%<r1%
355 t=m-9
356 DO
357 IF p%(t)>0 :RETURN 0 :ENDIF
358 t=t-9
359 UNTIL t=c
360 ELSEIF c2%>c1% AND r2%<r1%
361 t=m-7
362 DO
363 IF p%(t)>0 :RETURN 0 :ENDIF
364 t=t-7
365 UNTIL t=c
366 ELSEIF c2%<c1% AND r2%>r1%
367 t=m+7
368 DO
369 IF p%(t)>0 :RETURN 0 :ENDIF
370 t=t+7
371 UNTIL t=c
372 ELSEIF c2%>c1% AND r2%>r1%
373 t=m+9
374 DO
375 IF p%(t)>0 :RETURN 0 :ENDIF
376 t=t+9
377 UNTIL t=c
378 ENDIF
379 RETURN 1
380 ENDP
381
382 PROC queen:
383 IF rook:(0) OR bishop: :RETURN 1 :ENDIF
384 ENDP
385
386 PROC king:(c%)
387 LOCAL x%
388 x%=rem:(m,8)
389 IF x%=0 :x%=8 :ENDIF
390 IF ((c=m-9 OR c=m-1 OR c=m+7) AND x%>1) OR ((c=m-7 OR c=m+1 OR c=m+9) AND x%<8) OR c=m-8 OR c=m+8
391 IF m=4 AND c% AND (cs%(1) OR cs%(2)) :cs%(1)=0 :cs%(2)=0 :ENDIF
392 IF m=60 AND c% AND (cs%(3) OR cs%(4)) :cs%(3)=0 :cs%(4)=0 :ENDIF
393 RETURN 1
394 ELSEIF m=4 AND c=2 AND cs%(1) AND p%(2)=0 AND p%(3)=0
395 IF c% :p%(3)=p%(1) :p%(1)=0 :cs%(1)=0 :ENDIF
396 RETURN 1
397 ELSEIF m=4 AND c=6 AND cs%(2) AND p%(5)=0 AND p%(6)=0 AND p%(7)=0
398 IF c% :p%(5)=p%(8) :p%(8)=0 :cs%(2)=0 :ENDIF
399 RETURN 1
400 ELSEIF m=60 AND c=62 AND cs%(3) AND p%(61)=0 AND p%(62)=0 AND p%(63)=0
401 IF c% :p%(61)=p%(64) :p%(64)=0 :cs%(3)=0 :ENDIF
402 RETURN 1
403 ELSEIF m=60 AND c=58 AND cs%(4) AND p%(58)=0 AND p%(59)=0
404 IF c% :p%(59)=p%(57) :p%(57)=0 :cs%(4)=0 :ENDIF
405 RETURN 1
406 ENDIF
407 ENDP
408
409 PROC hilite:(c)
410 LOCAL s%,x%,y%
411 y%=c/8
412 x%=c-y%*8-1
413 IF x%=-1 :x%=7 :y%=y%-1 :ENDIF
414 IF r%=1
415 s%=x%
416 x%=7-y%
417 y%=s%
418 ELSEIF r%=2
419 x%=7-x%
420 y%=7-y%
421 ELSEIF r%=3
422 s%=x%
423 x%=y%
424 y%=7-s%
425 ENDIF
426 gGMODE 2
427 gAT w%+20*x%+1,20*y%+1
428 gBOX 18,18
429 gAT w%+20*x%+2,20*y%+2
430 gBOX 16,16
431 ENDP
432
433 PROC menu:
434 LOCAL k%
435 mINIT
436 mCARD "Chess board","Players",%p,"Possible moves",%m,"New game",-%n,"Exit",%x
437 LOCK ON
438 k%=MENU
439 LOCK OFF
440 IF k%=%x
441 exit:
442 z%=0
443 ELSEIF k%=%p
444 players:
445 ELSEIF k%=%n
446 new2:
447 ELSEIF k%=%m
448 IF sm%=0 :moves: :ENDIF
449 sm%=1
450 z%=0
451 ELSE
452 z%=0
453 ENDIF
454 ENDP
455
456 PROC new:
457 dINIT "New game"
458 dBUTTONS "No",%N,"Yes",%Y
459 LOCK ON
460 IF DIALOG<>%y :STOP :ENDIF
461 LOCK OFF
462 ENDP
463
464 PROC new2:
465 dINIT "New game"
466 dBUTTONS "No",%N,"Yes",%Y
467 LOCK ON
468 IF DIALOG=%y :q%=1 :ENDIF
469 LOCK OFF
470 ENDP
471
472 PROC exit:
473 dINIT "Confirm exit"
474 dBUTTONS "Cancel",27,"Exit",13
475 LOCK ON
476 IF DIALOG=13 :STOP :ENDIF
477 LOCK OFF
478 ENDP
479
480 PROC moves:
481 LOCAL a,ok%
482 IF g%<3 :m=c :ENDIF
483 IF p%(m)=0 :RETURN 0 :ENDIF
484 BUSY "Busy"
485 a=c
486 c=1
487 gGREY 1
488 DO
489 IF (p%(c)=0) OR ((g%=3 OR p%(m)<10) AND p%(c)>9) OR ((g%=4 OR p%(m)>9) AND p%(c)<10)
490 IF p%(m)=1 :ok%=pawnw:(0)
491 ELSEIF p%(m)=11 :ok%=pawnb:(0)
492 ELSEIF p%(m)=2 OR p%(m)=12 :ok%=rook:(0)
493 ELSEIF p%(m)=3 OR p%(m)=13 :ok%=knight:
494 ELSEIF p%(m)=4 OR p%(m)=14 :ok%=bishop:
495 ELSEIF p%(m)=5 OR p%(m)=15 :ok%=queen:
496 ELSEIF p%(m)=6 OR p%(m)=16 :ok%=king:(0)
497 ENDIF
498 IF ok% :hilite:(c) :ENDIF
499 ENDIF
500 c=c+1
501 UNTIL c>64
502 gGREY 0
503 c=a
504 BUSY OFF
505 ENDP
506
507 PROC check:(t%)
508 LOCAL a,b,ok%
509 BUSY "Busy"
510 a=c :b=m
511 c=0
512 DO :c=c+1 :UNTIL (t%=1 AND p%(c)=6) OR (t%=2 AND p%(c)=16)
513 m=1
514 DO
515 IF (t%=1 AND p%(m)>9) OR (t%=2 AND p%(m)<10)
516 IF p%(m)=1 :ok%=pawnw:(0)
517 ELSEIF p%(m)=11 :ok%=pawnb:(0)
518 ELSEIF p%(m)=2 OR p%(m)=12 :ok%=rook:(0)
519 ELSEIF p%(m)=3 OR p%(m)=13 :ok%=knight:
520 ELSEIF p%(m)=4 OR p%(m)=14 :ok%=bishop:
521 ELSEIF p%(m)=5 OR p%(m)=15 :ok%=queen:
522 ELSEIF p%(m)=6 OR p%(m)=16 :ok%=king:(0)
523 ENDIF
524 IF ok%
525 gGREY 0
526 c=a
527 m=b
528 BUSY OFF
529 RETURN 1
530 ENDIF
531 ENDIF
532 m=m+1
533 UNTIL m>64
534 gGREY 0
535 c=a
536 m=b
537 BUSY OFF
538 ENDP
539
540 PROC help:
541 dINIT "Help: Chess board"
542 dTEXT "","Use the arrows and Enter/Space to choose a piece and again"
543 dTEXT "","to move it. Press M to see all the possible moves for the"
544 dTEXT "","current/selected piece. Use <> to rotate the board. Use"
545 dTEXT "","'Players' to edit player names. Use 'New game' to start again."
546 dTEXT "","Castling is implemented (move the king). En-passant is not"
547 dTEXT "","implemented. Check is detected but checkmate is not detected."
548 LOCK ON
549 DIALOG
550 LOCK OFF
551 ENDP
552
553 PROC u:
554 IF f% :hilite:(c) :ENDIF :c=c-8 :f%=0
555 ENDP
556
557 PROC d:
558 IF f% :hilite:(c) :ENDIF :c=c+8 :f%=0
559 ENDP
560
561 PROC r:
562 IF f% :hilite:(c) :ENDIF :c=c+1 :f%=0
563 ENDP
564
565 PROC l:
566 IF f% :hilite:(c) :ENDIF :c=c-1 :f%=0
567 ENDP
568
569 PROC rem:(a,b%)
570 LOCAL c%
571 c%=a/b%
572 RETURN a-c%*b%
573 ENDP

  ViewVC Help
Powered by ViewVC 1.1.26