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

Annotation of /archive/chess/Chess.opl

Parent Directory Parent Directory | Revision Log Revision Log

Revision 7 - (hide annotations) (download)
Tue Jan 28 15:20:48 2003 UTC (23 years, 4 months ago) by james
File size: 11379 byte(s) 
Initial import.
1 james 7 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