Transportation Administration System
Snoezelen Pillows for Dementia
Begeleiders voor gehandicapten
Laat uw hond het jaarlijkse vuurwerk overwinnen
Betuweroute en Kunst
Hey Vos! Je eigen naam@vos.net emailadres?
Kunst in huis? Nicole Karrèr maakt echt bijzonder mooie dingen
Kunst in huis? Netty Franssen maakt ook bijzonder mooie dingenBackgammon in MacForth
Tweet
| Back in the days when IBM could only use 5 characters to name files, like around 1980's, IBM created a hip modern 4GL language called FORTH. The legend goes that it should have been named FOURTH, but 5 chars was the limit, so the U was left out. In 1984, FORTH came to the first Macintosh as MacForth. I coded some apps with it in 1986/7 on a Macintosh and later on my Macintosh Plus. From all the apps I wrote, I kept just one, as a paper source code listing : Backgammon, which I started coding in 1986 but never really finished. So, for memory's sake, I publish it here so you and I can enjoy reading and looking at it, whilst thinking about the first days we had a fabulous MacPlus to work with. BTW, there's still some activity around FORTH on Github . |  |
( LOAD BLOCK )
APPLE.MENU
FORTH DEFINITIONS SET.FENCE
25000 MINIMUM.OBJECT 17000 MINIMUM.VOCAB
FIND SNAPPY NOT
IFTRUE
OPIONS.MENU
INCLUDE" GRAPHICS"
INCLUDE" CONTROLS"
CREATE ?FIRST 1 ALLOT
1 0 1 ITEM.ENABLE
?FIRST 1 ERASE
2 10 THRU 48 LOAD 11 LOAD
INTRO.SCHERM ADD.WINDOW
OTHERWISE
49 LOAD
IFEND
SYS.WINDOW HIDE.WINDOW
EVENT.LOOP
( INIT VARIABELEN )
HEX
CREATE KEUZE 82401601 , 10820016 , DECIMAL
CREATE WORP 2 ALLOT ( bewaart de worpen uit DOBBEL )
CREATE MIJN 25 ALLOT ( witte velden tabel )
CREATE DIJN 25 ALLOT ( zwarte velden tabel )
CREATE WIE 1 ALLOT ( wit [2] of zwart [1] speelt )
CREATE WIE.S 1 ALLOT ( save-veld ivm deactiv.window )
CREATE SW 2 ALLOT ( bewaart wat na KLIK.EEN gebeurt )
CREATE SW' 1 ALLOT ( algemeen gebruik )
CREATE X.CO 2 ALLOT ( x-coord mouse-click 1 )
CREATE Y.CO 2 ALLOT ( y-coord mouse-click 1 )
CREATE X'.CO 2 ALLOT ( x-coord mouse-click 2 )
CREATE Y'.CO 2 ALLOT ( y-coord mouse-click 2 )
CREATE BEURT 1 ALLOT ( aantal beurten )
CREATE TOMANY 1 ALLOT ( meer op 1 kolom, displayed nummer )
CREATE BAR 3 ALLOT ( zwarte [1], witte [2] op de bar )
CREATE KOL 1 ALLOT ( kolom VAN )
CREATE KOL' 1 ALLOT ( kolom NAAR )
CREATE WIN 1 ALLOT ( wie heeft er gewonnen? )
CREATE WRP 1 ALLOT ( welke worp correct is.0/1 )
CREATE VELD1 1 ALLOT ( hoort bij KLIK.DRIE )
CREATE VELD2 2 ALLOT ( idem )
CREATE AF.VELD 3 ALLOT ( afgespeelde stenen )
CREATE MOVES 3 ALLOT ( aantal zetten zwart [1], wit [2] )
CREATE NOTACT 1 ALLOT ( window wel/niet actief )
CREATE BETS 2 ALLOT ( inzet waarom gespeeld wordt )
CREATE DUBBEL 1 ALLOT ( wel of niet mogen dubbelen )
CREATE PL1$ ," 1234567890" ( naam speler 1 )
CREATE PL2$ ," 1234567890" ( naam speler 2 )
CREATE SNAPPY 1 ALLOT ( snapshot???? )
0 SNAPPY C!
: PR.PL1$
PL1$ C@
PL1$ COUNT TYPE ;
: PR.PL2$
PL2$ C@
PL2$ COUNT TYPE ;
: D.M
1 " New game "
10 SET.ITEM$ ;
: D.I
3 SWAP
10 ITEM.ENABLE ( disable/enable DOUBLE } ;
: INPUT.BETS
BEGIN
250 189 MOVE.TO
4 INPUT.NUMBER
IF
DUP 0=
IF 20 SYSBEEP ELSE BETS W! -1 THEN
ELSE
20 SYSBEEP
0
THEN
UNTIL ;
: ERASE.VARS
0 WORP W! MIJN 25 ERASE DIJN 25 ERASE
0 WIE C! 0 WIE.S C! 0 SW W! 0 BEURT C!
0 KOL C! 0 X.CO W! 0 Y.CO W! 0 TOMANY C!
BAR 3 ERASE 0 X'.CO W! 0 Y'.CO W! 0 SW' C!
0 KOL' C! 0 WIN C! 0 WRP C! 0 VELD1 C!
0 VELD2 C! AF.VELD 3 ERASE MOVES 3 ERASE
0 NOTACT C! 1 DUBBEL C! ;
NEW.WINDOW INTRO.SCHERM
2 INTRO.SCHERM W.TYPE
19 0 370 514 INTRO.SCHERM W.BOUNDS
SYS.WINDOW INTRO.SCHERM W.BEHIND
: V-1
0 0 MOVE.TO
POLY.IS:
0 23 DRAW.TO
97 97 DRAW.TO
17 0 DRAW.TO
POLY.END
DUP
INVERT POLYGON
DISPOSE.POLY ;
: V-2
512 323 MOVE.TO
POLY.IS:
492 323 DRAW.TO
412 223 DRAW.TO
512 301 DRAW.TO
POLY.END
DUP
INVERT POLYGON
DISPOSE.POLY ;
: V-3
0 323 MOVE.TO
POLY.IS:
0 300 DRAW.TO
100 228 DRAW.TO
20 323 DRAW.TO
POLY.END
DUP
LTGRAY PATTERN POLYGON
DISPOSE.POLY ;
: V-4
512 0 MOVE.TO
POLY.IS:
512 20 DRAW.TO
415 97 DRAW.TO
492 0 DRAW.TO
POLY.END
DUP
LTGRAY PATTERN POLYGON
DISPOSE.POLY ;
: ZET.FONT
TEXTSIZE
TEXTFONT
TEXTMODE ;
: TEKST
0 151 18 ZET.FONT
148 30 MOVE.TO
." BACKGAMMON 1.5"
118 60 MOVE.TO
." WRITTEN BY MARC VOS"
210 300 MOVE.TO
." © 1986" ;
: SC-1
OVER OVER
30 WHITE PATTERN CIRCLE
30 FRAME CIRCLE ;
: SC-2
OVER OVER
30 GRAY PATTERN CIRCLE
30 FRAME CIRCLE ;
: INTRO.DB
1 1 PENSIZE
115 277 144 305 15 15 FRAME RRECTANGLE
370 277 398 305 15 15 FRAME RRECTANGLE
1 11 18 ZET.FONT
118 299 MOVE.TO
." 6"
373 299 MOVE.TO
." 1" ;
NEW.CONTROL OK.CT
A.PUSH.BUTTON OK.CT C.TYPE
" OK" OK.CT C.TITLE
10 90 OK.CT C.POSITION
NEW.CONTROL N.OK.CT
A.PUSH.BUTTON N.OK.CT C.TYPE
" BYE" N.OK.CT C.TITLE
100 90 N.OK.CT C.POSITION
NEW.WINDOW BORD
2 BORD W.TYPE
19 0 370 514 BORD W.BOUNDS
INTRO.SCHERM BORD W.BEHIND
NEW.WINDOW N.GAMEW
1 N.GAMEW W.TYPE
140 128 180 384 N.GAMEW W.BOUNDS
BORD N.GAMEW W.BEHIND
NEW.WINDOW DBBL.W
1 DBBL.W W.TYPE
110 118 240 394 DBBL.W W.BOUNDS
N.GAMEW DBBL.W W.BEHIND
: CNTRL.SEL
LAST.CONTROL
DUP
TOGGLE.CONTROL
CASE
OK.CT @ OF
DUBBEL C@
2*
DUBBEL C!
2 200 8000 TONE
ENDOF
N.OK.CT @ OF
PAGE
." Dan is dit het einde"
1000 0 DO LOOP
BYE
ENDOF
ENDCASE
-1 ;
: TEST.CNTRL
DO.EVENTS
MOUSE.DOWN =
IF
IN.CONTROL?
IF
FOLLOW.MOUSE
IF CNTRL.SEL ELSE 0 THEN
ELSE 0 THEN
ELSE 0 THEN ;
: BET.CNTRL
BEGIN
@MOUSE
LOCAL>GLOBAL
FIND.WINDOW
3 =
SWAP
DBBL.W =
AND
IF
EVENTS ON
TEST.CNTRL
ELSE
0
FLUSH.EVENTS
EVENTS OFF
THEN
UNTIL ;
: MIDDEN
2 2 PENSIZE
106 96 408 231 40 40 FRAME RRECTANGLE ;
: SPELERS
125 127 MOVE.TO
1 151 18 ZET.FONT
." PLAYER 1: "
125 158 MOVE.TO
." PLAYER 2: "
125 189 MOVE.TO
." YOUR BET: "
190 220 MOVE.TO
." LOADING ...." ;
: DBBL
IF
EVENTS OFF
GINIT
PAGE
1 0 12 ZET.FONT
CASE WIE C@
1 OF CR PR.PL2$ ." ," CR CR PR.PL1$ ENDOF
2 OF CR PR.PL1$ ." ," CR CR PR PL2$ ENDOF
ENDCASE
." biedt jou een dubbel aan." CR
." Het gaat nu nog om "
BETS W@
DUBBEL C@ * .
." guldens."
FLUSH.EVENTS
BET.CNTRL
EVENTS ON
BORD SELECT.WINDOW
BORD WINDOW
THEN ;
: !SPELERS
1 TEXTMODE
BEGIN
250 127 MOVE.TO
PL1$
10 INPUT.STRING
PL1$
C@ UNTIL
BEGIN
250 158 MOVE.TO
PL2$
10 INPUT.STRING
PL2$
C@ UNTIL
INPUT.BETS ;
: INTRO!
PAGE
V-1
V-2
V-3
V-4
54 200 SC-1
54 125 SC-2
458 125 SC-1
458 200 SC-2
TEKST
MIDDEN
INTRO.DB
SPELERS ;
: CORNERS
IF
?FIRST C@
IF INTRO!
ELSE
INTRO!
SNAPPY C@
0= IF 12 47 THRU ELSE 1 ?FIRST C! THEN
INIT.CURSOR
0 TEXTMODE
190 220 MOVE.TO
." "
!SPELERS
THEN
THEN
-1
SPEL.MENU MENU.ENABLE ;
INTRO.SCHERM ON.ACTIVATE CORNERS
: WIS.RAAM
242 32 270 58 LTGRAY PATTERN RECTANGLE ;
: TABEL
WIE C@
1 = IF DIJN ELSE MIJN THEN ;
: TABEL'
WIE C@
1 = IF MIJN ELSE DIJN THEN ;
: VAN.BORD
AF.VELD
WIE C@ + ;
: VUL
5 DIJN 6+ C!
3 DIJN 8+ C!
5 DIJN 13 + C!
2 DIJN 24 + C!
2 MIJN 1+ C!
5 MTJN 12 + C!
3 MIJN 17 + C!
5 MIJN 19 + C! ;
1 ?FIRST C! ( eerste keer switch )
: V.A
POLY.IS:
3 0 DO
19 123 RDRAW
19 -123 RDRAW
38 0 RDRAW
LOOP
POLY.END
DUP
INVERT POLYGON
DISPOSE.POLY ;
: V.B
POLY.IS:
3 0 DO
19 123 RDRAW
19 -123 RDRAW
38 0 RDRAW
LOOP
POLY.END
DUP
LTGRAY PATTERN POLYGON
DISPOSE.POLY ;
: V.C
POLY.IS:
3 0 DO
19 -123 RDRAW
19 123 RDRAW
38 0 RDRAW
LOOP
POLY.END
DUP
INVERT POLYGON
DISPOSE.POLY ;
: V.D
POLY.IS:
3 0 DO
19 -123 RDRAW
19 123 RDRAW
38 0 RDRAW
LOOP
POLY.END
DUP
LTGRAY PATTERN POLYGON
DISPOSE.POLY ;
: WIS.A
POLY.IS:
0 126 RDRAW
38 0 RDRAW
0 -126 RDRAW
POLY.END
DUP
WHITE PATTERN POLYGON
DISPOSE.POLY ;
: WIS.B
POLY.IS:
0 -126 RDRAW
38 0 RDRAW
0 126 RDRAW
POLY.END
DUP
WHITE PATTERN POLYGON
DISPOSE.POLY ;
: NEWV.A
OVER
OVER
MOVE.TO
WIS.A
MOVE.TO
POLY.IS:
19 123 RDRAW
19 -123 RDRAW
POLY.END
DUP
INVERT POLYGON
DISPOSE.POLY ;
: NEWV.B
OVER
OVER
MOVE.TO
WIS.A
MOVE.TO
POLY.IS:
19 123 RDRAW
19 -123 RDRAW
POLY.END
DUP
LTGRAY PATTERN POLYGON
DISPOSE.POLY ;
: NEWV.C
OVER
OVER
MOVE.TO
WIS.A
MOVE.TO
POLY.IS:
19 -123 RDRAW
19 123 RDRAW
POLY.END
DUP
INVERT POLYGON
DISPOSE.POLY ;
: NEWV.D
OVER
OVER
MOVE.TO
WIS.A
MOVE.TO
POLY.IS:
19 -123 RDRAW
19 123 RDRAW
POLY.END
DUP
LTGRAY PATTERN POLYGON
DISPOSE.POLY ;
: W.SC
OVER
OVER
12 WHITE PATTERN CIRCLE
12 FRAME CIRCLE ;
: Z.SC
OVER
OVER
12 GRAY PATTERN CIRCLE
12 FRAME CIRCLE ;
: K.SC
OVER
OVER
12 KEUZE PATTERN CIRCLE
12 FRAME CIRCLE ;
: S.SC
12 LTGRAY PATTERN CIRCLE ;
: TEK.V
0 17 MOVE.TO
V.A
38 17 MOVE.TO
V.B
283 17 MOVE.TO
V.A
321 17 MOVE.TO
V.B
0 306 MOVE.TO
V.D
38 306 MOVE.TO
V.C
283 306 MOVE.TO
V.D
321 306 MOVE.TO
V.C ;
: BEURTEN
WORP C@ WORP 1+ C@ =
IF 4 BEURT C! ELSE 2 BEURT C! THEN ;
: Z.RAAM
243 33 MOVE.TO
POLY.IS:
269 45 DRAW.TO
243 57 DRAW.TO
243 33 DRAW.TO
POLY.END
DUP
BLACK PATTERN POLYGON
DISPOSE.POLY ;
: W.RAAM
269 33 MOVE.TO
POLY.IS:
243 45 DRAW.TO
269 57 DRAW.TO
269 33 DRAW.TO
POLY.END
DUP
DUP
WHITE PATTERN POLYGON
FRAME POLYGON
DISPOSE.POLY ;
: JIJ
WIS.RAAM
Z.RAAM
1 WIE C! ;
: IK
WIS.RAAM
W.RAAM
2 WIE C! ;
: GRIJS
233 214 279 302 LTGRAY PATTERN RECTANGLE ;
: STENEN
243 237 269 263 15 15 WHITE PATTERN RRECTANGLE
243 275 269 301 15 15 WHITE PATTERN RRECTANGLE
242 236 270 264 15 15 FRAME RRECTANGLE
242 274 270 302 15 15 FRAME RRECTANGLE ;
: STEEN1
243 237 269 263 15 15 WHITE PATTERN RRECTANGLE
242 236 270 264 15 15 FRAME RRECTANGLE ;
: STEEN2
243 275 269 301 15 15 WHITE PATTERN RRECTANGLE
242 274 270 302 15 15 FRAME RRECTANGLE ;
: DOBBEL
1 0 12 ZET.FONT
13 165 MOVE.TO
-1
D.I
." Dubbel-klik om te gooien"
BEGIN
DO.EVENTS
MOUSE.DOWN =
IF
?DOUBLE.CLICK
IF
0
D.I
GRIJS
16 10 DO
TICKCOUNT
1000 /MOD
DROP
100 / 0 DO
RANDOM
DROP
LOOP
1
BEGIN
DROP
RANDOM
ABS
1000 /
1+
DUP
7 < UNTIL
WORP C!
1
BEGIN
DROP
RANDOM
ABS
1000 /
1+
DUP
7 < UNTIL
WORP 1+ C!
STENEN
11 TEXTFONT
18 TEXTSIZE
1 TEXTMODE
245 296 MOVE.TO
WORP 1+ C@
48 +
DRAW.CHAR
245 258 MOVE.TO
WORP C@
48 +
DRAW.CHAR
0 TEXTFONT
1 100 I
700 * TONE
LOOP
BEURTEN
1
ELSE 0 THEN
ELSE 0 THEN
UNTIL
13 165 MOVE.TO
0 0 12 ZET.FONT
." " ;
: RESTORE.STEEN
WORP C@
99 = IF
WORP 1+ C@
99 = IF 99 SW W! THEN
THEN
SW W@
99 < IF
1 11 18 ZET.FONT
WORP 1+ C@
99 < IF
STEEN2
245 296 MOVE.TO
WORP 1+ C@
48 +
DRAW.CHAR
THEN
WORP C@
99 < IF
STEEN1
245 258 MOVE.TO
WORP C@
48 +
DRAW.CHAR
THEN
THEN
0 TEXTFONT ;
: GOOI1
16 10 DO
1
BEGIN
DROP
RANDOM
ABS
1000 /
1+
DUP
7 < UNTIL
WORP C!
STEEN1
1 11 18 ZET.FONT
245 258 MOVE.TO
WORP C@
48 +
DRAW.CHAR
0 TEXTFONT
2000 0 DO LOOP
1 100 I
700 * TONE
LOOP ;
: GOOI2
16 10 DO
1
BEGIN
DROP
RANDOM
ABS
1000 /
1+
DUP
7 < UNTIL
WORP 1+ C!
STEEN2
1 11 18 ZET.FONT
245 296 MOVE.TO
WORP 1+ C@
48 +
DRAW.CHAR
0 TEXTFONT
2000 0 DO LOOP
1 100 I
700 * TONE
LOOP ;
: SELECTION.2
SPEL.MENU
MENU.SELECTION:
CASE
1 OF N.GAMEW SELECT.WINDOW ENDOF
3 OF DBBL.W SELECT.WINDOW ENDOF
4 OF .S ENDOF
5 OF SPEL.MENU DELETE.MENU BYE ENDOF
ENDCASE
0 HILITE.MENU ;
: NIEUW
IF
GINIT
PAGE
ERASE.VARS
1 ?FIRST C!
1 151 18 ZET.FONT
CR
." Jammer van dit spel."
THEN
3 200 4000 TONE
10000 0 DO LOOP
BORD SELECT.WINDOW ;
N.GAMEW ON.ACTIVATE NIEUW
DBBL.W ON.ACTIVATE DBBL
: WEL.ZET
1 0 12 ZET.FONT
30 SYSBEEP
13 165 MOVE.TO
MOVES
WIE C@ + C@
CASE
0 4 RANGE.OF ." Ga alsjeblieft kwartetten!" ENDOF
5 13 RANGE.OF ." Ben je fouten aan het zoeken?" ENDOF
14 24 RANGE.OF ." Lees de spelregels weer eens!" ENDOF
25 40 RANGE.OF 23 TEXTFONT ." Heb je er moeite mee?" ENDOF
41 60 RANGE.OF ." Weet je het nou nog niet!?" ENDOF
60 99 RANGE.OF ." Wat een zooitje moet het zijn!" ENDOF
100 150 RANGE.OF ." Kan je niet winnen!?" ENDOF
." IK WEET HET NIET MEER.SNIK ...."
ENDCASE
100000 0 DO LOOP
0 TEXTMODE
13 165 MOVE.TO
." "
1 TEXTMODE
0 TEXTFONT ;
: FIRST.TIME
?FIRST C@
IF
BEGIN
GRIJS
0 0 12 ZET.FONT
30 SYSBEEP
13 165 MOVE.TO
PR.PL1$
." gooit ....."
1 TEXTMODE
GOOI1
100000 0 DO LOOP
0 0 12 ZET.FONT
13 165 MOVE.TO
PR.PL2$
." gooit ....."
1 TEXTMODE
GOOI2
0 0 12 ZET.FONT
100000 0 DO LOOP
WORP C@
WORP 1+ C@ =
1+ UNTIL
30 SYSBEEP
0 0 12 ZET.FONT
WORP C@
WORP 1+ C@ >
IF
JIJ
13 165 MOVE.TO
PR.PL1$
." begint!"
ELSE
IK
13 165 MOVE.TO
PR.PL2$
." begin!"
THEN
2 BEURT C!
0 TEXTMODE
100000 0 DO LOOP
13 165 MOVE.TO
." "
THEN ;
: TEVEEL
TOMANY C@
CASE
1 99 RANGE.OF
Y.CO W@
DUP
29 = IF 100 + ELSE 92 - THEN
X.CO W@
4 -
SWAP
12 TEXTSIZE
8 TEXTSTYLE
1 TEXTMODE
MOVE.TO
TOMANY C@
48 + DRAW.CHAR
ENDOF
ENDCASE
0 TEXTSTYLE
0 TOMANY C! ;
: GET.XY
KOL C@
DUP
12 > IF 25 - ABS THEN
DUP
SW W!
CASE
1 6 RANGE.OF 530 SW W@ 38 * - X.CO W! ENDOF
7 12 RANGE.OF 475 SW W@ 38 * - X.CO W! ENDOF
ENDCASE
KOL C@
CASE
1 12 RANGE.OF 29 Y.CO W! ENDOF
13 24 RANGE.OF 294 Y.CO W! ENDOF
ENDCASE ;
: SHOW.SC
TABEL
KOL C@ + C@
DUP
0= IF DROP
ELSE
DUP
5 > IF
5- TOMANY C!
5
THEN
24 * SW W!
KOL C@
CASE
1 12 RANGE.OF SW W@ 29 + SW W! ENDOF
13 24 RANGE.OF SW W@ 295 - ABS SW W! ENDOF
ENDCASE
SW W@
Y.CO W@
DO
X.CO W@
I
WIE C@
1 = IF Z.SC ELSE W.SC THEN
Y.CO W@
29 = IF 24 ELSE -24 THEN
+LOOP
TEVEEL
0 TOMANY C!
THEN ;
: ZETOP
1 WIE C!
BEGIN
25 1 DO
WIE C@
CASE
1 OF I KOL C! DIJN ENDOF
2 OF I 25 - ABS KOL C! MIJN ENDOF
ENDCASE
KOL C@ + C@
CASE
1 99 RANGE.OF GET.XY SHOW.SC ENDOF
ENDCASE
LOOP
WIE C@
1+ WIE C!
WIE C@
2 >
ABS
UNTIL
WIE.S C@ WIE C! ;
: KOLOM.NR
SW W@
CASE
2 3 RANGE.OF
X.CO W@
CASE
0 38 RANGE.OF 12 ENDOF
39 77 RANGE.OF 11 ENDOF
78 115 RANGE.OF 10 ENDOF
116 153 RANGE.OF 9 ENDOF
154 191 RANGE.OF 8 ENDOF
192 229 RANGE.OF 7 ENDOF
282 320 RANGE.OF 6 ENDOF
321 360 RANGE.OF 5 ENDOF
361 398 RANGE.OF 4 ENDOF
399 437 RANGE.OF 3 ENDOF
438 475 RANGE.OF 2 ENDOF
476 514 RANGE.OF 1 ENDOF
ENDCASE
KOL C!
Y.CO W@
183 > IF
KOL C@
25 - ABS
KOL C!
THEN
TABEL
KOL C@ + C@
0= IF 0 SW W! THEN
ENDOF
ENDCASE ;
: TEXT.RAAM
2 2 PENSIZE
10 150 220 172 FRAME RECTANGLE
1 1 PENSIZE
11 151 218 170 WHITE PATTERN RECTANGLE ;
: ?OP.BAR
0 VELD1 C!
0 VELD2 C!
WIE C@
CASE
1 OF BAR 1+ C@ IF 1 SW W! 99 KOL C! ELSE 0 SW W! THEN ENDOF
2 OF BAR 2+ C@ IF 1 SW W! 0 KOL C! ELSE 0 SW W! THEN ENDOF
ENDCASE
SW W@
1- ;
: VELD.OK
SW' C@
IF
WIE C@
CASE
1 OF
WORP C@
25 -
ABS
KOL' C@ =
IF 0 WRP C!
ELSE
WORP 1+ C@
25 -
ABS
KOL' C@ =
IF 1 WRP C! ELSE 0 SW' C! THEN
THEN
ENDOF
2 OF
WORP C@
KOL' C@ =
IF 0 WRP C!
ELSE
WORP 1+ C@
KOL' C@ =
IF 1 WRP C! ELSE 0 SW' C! THEN
THEN
ENDOF
ENDCASE
THEN ;
: NAAR.KOLOM
X'.CO W@
CASE
0 38 RANGE.OF 12 ENDOF
39 77 RANGE.OF 11 ENDOF
78 115 RANGE.OF 10 ENDOF
116 153 RANGE.OF 9 ENDOF
154 191 RANGE.OF 8 ENDOF
192 229 RANGE.OF 7 ENDOF
282 320 RANGE.OF 6 ENDOF
321 360 RANGE.OF 5 ENDOF
361 398 RANGE.OF 4 ENDOF
399 437 RANGE.OF 3 ENDOF
438 475 RANGE.OF 2 ENDOF
476 514 RANGE.OF 1 ENDOF
ENDCASE
KOL' C!
Y'.CO W@
183 > IF
KOL' C@
25 -
ABS
KOL' C!
THEN
TABEL'
KOL' C@ + C@
CASE
1 OF 9 SW' C! ENDOF ( op de bar )
2 99 RANGE.OF 0 SW' C! ENDOF
ENDCASE
WIE C@
CASE
1 OF KOL C@ KOL' C@ < ENDOF
2 OF KOL C@ KOL' C@ > ENDOF
ENDCASE
IF 0 SW' C! THEN ;
: TST.VLDZ
25 VELD1 C!
BEGIN
VELD1 C@ 1-
DUP
VELD1 C!
WORP C@ -
CASE
1 24 RANGE.OF
DIJN
VELD1 C@ + C@
IF
VELD1 C@
WORP C@ -
MIJN
SWAP + C@
1 > IF 4 SW W! ELSE 0 SW W! THEN
ELSE
4 SW W!
THEN
ENDOF
5 SW W!
ENDCASE
SW W@
4 = IF 0 ELSE 1 THEN
UNTIL
SW W@
5 = IF
25 VELD1 C!
BEGIN
VELD1 C@ 1-
DUP
VELD1 C!
WORP 1+ C@ -
CASE
1 24 RANGE.OF
DIJN
VELD1 C@ + C@
IF
VELD1 C@
WORP 1+ C@ -
MIJN
SWAP + C@
1 > IF 4 SW W! ELSE 0 SW W! THEN
ELSE
4 SW W!
THEN
ENDOF
5 SW W!
ENDCASE
SW W@
4 = IF 0 ELSE 1 THEN
UNTIL
THEN ;
: TST.VLDW
0 VELD2 C!
BEGIN
VELD2 C@ 1+
DUP
VELD2 C!
WORP C@ +
CASE
1 24 RANGE.OF
MIJN
VELD2 C@ + C@
IF
VELD2 C@
WORP C@ +
DIJN
SWAP + C@
1 > IF 4 SW W! ELSE 0 SW W! THEN
ELSE
4 SW W!
THEN
ENDOF
5 SW W!
ENDCASE
SW W@
4 = IF 0 ELSE 1 THEN
UNTIL
SW W@
5 = IF
0 VELD2 C!
BEGIN
VELD2 C@ 1+
DUP
VELD2 C!
WORP 1+ C@ +
CASE
1 24 RANGE.OF
MIJN
VELD2 C@ + C@
IF
VELD2 C@
WORP 1+ C@ +
DIJN
SWAP + C@
1 > IF 4 SW W! ELSE 0 SW W! THEN
ELSE
4 SW W!
THEN
ENDOF
5 SW W!
ENDCASE
SW W@
4 = IF 0 ELSE 1 THEN
UNTIL
THEN ;
: NO.MOVE?
X.CO W@
CASE
242 270 RANGE.OF Y.CO W@
CASE
32 58 RANGE.OF WIE C@
CASE
1 OF TST.VLDZ ENDOF
2 OF TST.VLDW ENDOF
ENDCASE
ENDOF
ENDCASE
ENDOF
ENDCASE
SW W@
0= IF WEL.ZET THEN ;
: SH.BAR
WIE C@
CASE
1 OF
3 0 DO
256 171 K.SC
10000 0 DO LOOP
256 171 Z.SC
10000 0 DO LOOP
LOOP
256 171 K.SC
ENDOF
2 OF
3 0 DO
256 145 K.SC
10000 0 DO LOOP
256 145 W.SC
10000 0 DO LOOP
LOOP
256 145 K.SC
ENDOF
ENDCASE ;
: DO.MOVES
MOVES
WIE C@ + C@ 1+
MOVES
WIE C@ + C! ;
: KLIK.EEN
0 SW W!
?OP.BAR
IF
BEGIN
DO.EVENTS
MOUSE.DOWN =
IF
?DOUBLE.CLICK
IF
@MOUSEXY
Y.CO W!
X.CO W!
Y.CO W@
CASE
0 17 RANGE.OF 0 SW W! ENDOF
306 400 RANGE.OF 0 SW W! ENDOF
138 182 RANGE.OF 0 SW W! ENDOF
3 SW W!
ENDCASE
X.CO W@
CASE
229 283 RANGE.OF 0 SW W! ENDOF
3 Sw W!
ENDCASE
SW W@
CASE
3 OF
TABEL C@ VAN.BORD C@ +
15 = IF 2 SW W! THEN
ENDOF
ENDCASE
KOLOM.NR
SW W@
0= IF
NO.MOVE?
SW W@
0= IF 4 SYSBEEP THEN
THEN
THEN
THEN
SW W@ UNTIL
THEN ;
( Nu zit in SW de waarde die bepaalt wat er moet gaan gebeuren )
: KLIK.DRIE
0 SW' C!
BEGIN
DO.EVENTS
MOUSE.DOWN =
IF
?DOUBLE.CLICK
IF
@MOUSEXY
Y'.CO W!
X'.CO W!
X'.CO W@
CASE
284 514 RANGE.OF 1 SW' C! ENDOF
ENDCASE
SW' C@
CASE
1 OF Y'.CO W@
CASE
17 132 RANGE.OF
WIE C@ 1 =
IF 0 SW' C! ELSE 2 SW' C! THEN
ENDOF
184 301 RANGE.OF
WIE C@ 2 =
IF 0 SW' C! ELSE 2 SW' C! THEN
ENDOF
ENDCASE
ENDOF
0 SW' C!
ENDCASE
SW' C@
CASE
2 OF NAAR.KOLOM VELD.OK ENDOF
ENDCASE
SW' C@
0= IF 4 SYSBEEP THEN
THEN
THEN
SW' C@ UNTIL ;
: DE.BAR
230 17 282 306 LTGRAY PATTERN RECTANGLE
229 16 283 307 FRAME RECTANGLE
230 158 MOVE.TO
282 158 DRAW.TO ;
: ?GELIJK
KOL C@
KOL' C@ =
IF
SHOW.SC
11 WRP C!
0
ELSE -1 THEN ;
: STAPPEN
?GELIJK
IF
KOL C@
WORP C@
WIE C@
1 = IF - ( zwart ) ELSE + ( wit ) THEN
KOL' C@ -
IF
KOL C@
WORP 1+ C@
WIE C@
1 = IF - ELSE + THEN
KOL' C@ -
IF 0 SW' C! ELSE 1 WRP C! THEN
ELSE
0 WRP C!
THEN
THEN ;
: BORD.RAND
GINIT
PAGE
2 2 PENSIZE
0 15 MOVE.TO
514 15 DRAW.TO
0 306 MOVE.TO
514 306 DRAW.TO
1 1 PENSIZE
0 TEXTFONT
BOLD TEXTSTYLE
0 12 MOVE.TO
." M N 0 P Q R"
243 12 MOVE.TO
" BAR S T U V W X"
0 320 MOVE.TO
." L K J I H G"
243 320 MOVE.TO
." BAR F E D C B A"
PLAIN TEXTSTYLE ;
: DE.SCHYF
GET.XY
TABEL
KOL C@ + C@
DUP
5 > IF DROP 5 THEN
24 * 24 -
Y.CO W@
DUP
29 = IF + ELSE SWAP - THEN
X.CO W@
SWAP
K.SC ;
: NIEUW.VELD
X.CO W@
19 -
Y.CO W@
DUP
29 = IF 12 - ELSE 12 + THEN
KOL C@
CASE
1 12 RANGE.OF
KOL C@ 2/ 2*
KOL C@ = IF NEWV.A ELSE NEWV.B THEN
ENDOF
13 24 RANGE.OF
KOL C@ 2/ 2*
KOL C@ = IF NEWV.C ELSE NEWV.D THEN
ENDOF
ENDCASE ;
: ZET.STEEN
VAN.BORD C@
0> IF
1 0 12 ZET.FONT
WIE C@
1 = IF
371 147 390 173 WHITE PATTERN RECTANGLE
372
ELSE
447 147 466 173 WHITE PATTERN RECTANGLE
448
THEN
164 MOVE.TO
VAN.BORD C@ .
THEN ;
: AF.SCHIJF
TABEL C@
VAN.BORD C@ + 15 =
IF
WIE C@
CASE
1 OF
X'.CO W@
CASE
370 418 RANGE.OF
Y'.CO W@
CASE
146 174 RANGE.OF 3 SW' C! ENDOF
ENDCASE
ENDOF
ENDCASE
ENDOF
2 OF
X'.CO W@
CASE
446 494 RANGE.OF
Y'.CO W@
CASE
146 174 RANGE.OF 3 SW' C! ENDOF
ENDCASE
ENDOF
ENDCASE
ENDOF
ENDCASE
THEN ;
: ZET.VELD
370 146 418 174 FRAME RECTANGLE
404 160 Z.SC
446 146 494 174 FRAME RECTANGLE
480 160 W.SC
390 146 MOVE.TO
390 173 DRAW.TO
466 146 MOVE.TO
466 173 DRAW.TO ;
: BARR
WIE C@
CASE
1 OF
BAR
WIE C@ 1+ + C@ ( van wit )
1+
DUP
BAR
WIE C@ 1+ + C!
1 -
DUP
0> IF
TOMANY C!
256 145 W.SC
12 TEXTSIZE
8 TEXTSTYLE
1 TEXTMODE
252 150 MOVE.TO
TOMANY C@
48 +
DRAW.CHAR
ELSE
DROP
256 145 W.SC
THEN
ENDOF
2 OF
BAR
WIE C@ 1- + C@ ( van zwart )
1+
DUP
BAR
WIE C@ 1- + C!
1-
DUP
0> IF
TOMANY C!
256 171 Z.SC
12 TEXTSIZ
8 TEXTSTYLE
1 TEXTMODE
252 176 MOVE.TO
TOMANY C@
48 +
DRAW.CHAR
ELSE
DROP
256 171 Z.SC
THEN
ENDOF
ENDCASE
0 TEXTSTYLE
0 TABEL'
KOL' C@ + C!
0 TOMANY C! ;
: AF.BAR
WIE C@
CASE
1 OF
BAR 1+ C@
1- DUP
BAR 1+ C!
1- DUP
0> IF
TOMANY C!
256 171 Z.SC
12 TEXTSIZE
8 TEXTSTYLE
1 TEXTMODE
252 176 MOVE.TO
TOMANY C@
48 +
DRAW.CHAR
ELSE
0= IF
256 171 Z.SC
ELSE
0 BAR 1+ C!
256 171 S.SC
THEN
THEN
ENDOF
2 OF
BAR 2+ C@
1- DUP
BAR 2+ C!
1- DUP
0> IF
TOMANY C!
256 145 W.SC
12 TEXTSIZE
8 TEXTSTYLE
1 TEXTMODE
252 150 MOVE.TO
TOMANY C@
48 +
DRAW.CHAR
ELSE
0= IF
256 145 W.SC
ELSE
0 BAR 2+ C!
256 145 S.SC
THEN
THEN
ENDOF
ENDCASE
0 TEXTSTYLE
0 TOM/hNY C! ;
: RSET.WORP
WORP C@
0= IF 99 WORP C! THEN
WORP 1+ C@
0= IF 99 WORP 1+ C! THEN ;
: GEEF'M
WRP 11 -
IF
SW' C@
3 = IF
ELSE
TABEL
KOL' C@ + C@ 1+
TABEL
KOL' C@ + C!
THEN
SW W@
1 > IF
TABEL
KOL C@ + C@ 1-
DUP
0< IF DROP 0 THEN
TABEL
KOL C@ + C!
NIEUW.VELD
SHOW.SC
ELSE
AF.BAR
THEN
KOL' C@
KOL C!
X'.CO W@
X.CO W!
Y'.CO W@
Y.CO W!
SW' C@
3 = IF
ELSE
GET.XY
SHOW.SC
TABEL'
KOL' C@ + C@
1 = IF BARR THEN
THEN
THEN ;
( WRP=11 : herstelling van de keuze. )
( Hierin wordt de schijf in de tabellen verwerkt. )
( SW'=3 : Afvoeren. )
: NEE
1000 0 DO LOOP
30 SYSBEEP
13 165 MOVE.TO
1 0 12 ZET.FONT
." Je kan niet van de bar af!"
0 BEURT C!
100000 0 DO LOOP
13 165 MOVE.TO
0 TEXTMODE
." "
1 TEXTMODE ;
: WISSEL.WORP
WORP C@
99 = IF 0 WORP C! THEN
WORP 1+ C@
99 = IF 0 WORP 1+ C! THEN ;
: REST.LEEG
WIE C@
CASE
1 OF 0 7 1 KOL C@ + DO DIJN I+ C@ + LOOP ENDOF
2 OF 0 KOL C@ 19 DO MIJN I+ C@ + LOOP ENDOF
ENDCASE
IF 0 SW' C! ELSE 3 SW' C! THEN ;
: MAG.HET
WIE C@
CASE
1 OF
WORP C@
CASE
0 7 RANGE.OF
WORP C@
25 -
ABS
MIJN
SWAP
+ C@
1 > IF 0 SW W! ELSE 4 SW W! THEN
ENDOF
0 SW W!
ENDCASE
SW W@
0= IF
WORP 1+ C@
CASE
0 7 RANGE.OF
WORP 1+ C@
25 -
ABS
MIJN
SWAP
+ C@
1 > IF 0 SW W! ELSE 4 SW W! THEN
ENDOF
0 SW W!
ENDCASE
THEN
ENDOF
2 OF
WORP C@
CASE
0 7 RANGE.OF
WORP C@
DIJN
SWAP
+ C@
1 > IF 0 SW W! ELSE 4 SW W! THEN
ENDOF
0 SW W!
ENDCASE
SW W@
0= IF
WORP 1+ C@
CASE
0 7 RANGE.OF
WORP 1+ C@
DIJN
SWAP
+ C@
1 > IF 0 SW W! ELSE 4 SW W! THEN
ENDOF
0 SW W!
ENDCASE
THEN
ENDOF
ENDCASE
SW W@
IF SW W@ ELSE NEE 0 THEN ;
: KOL.OK
WIE C@
CASE
1 OF
WORP C@
KOL C@ =
IF
0 WRP C!
ELSE
WORP 1+ C@
KOL C@ =
IF 1 WRP C! ELSE 9 WRP C! THEN
THEN
ENDOF
2 OF
WORP C@
25 -
ABS
KOL C@ =
IF
0 WRP C!
ELSE
WORP 1+ C@
25 -
ABS
KOL C@ =
IF 1 WRP C! ELSE 9 WRP C! THEN
THEN
ENDOF
ENDCASE
WRP C@
9 = IF
WIE C@
CASE
1 OF
WISSEL.WORP
WORP C@
KOL C@ >
IF
0 WRP C!
REST.LEEG
ELSE
WORP 1+ C@
KOL C@ >
IF
1 WRP C!
REST.LEEG
ELSE
0 SW' C!
THEN
THEN
ENDOF
2 OF
WORP C@
25 -
ABS
KOL C@ <
IF
0 WRP C!
REST.LEEG
ELSE
WORP 1+ C@
25 -
ABS
KOL C@ <
IF
1 WRP C!
REST.LEEG
ELSE
0 SW' C!
THEN
THEN
ENDOF
ENDCASE
RSET.WORP
THEN ;
: KLIK.TWEE
0 SW' C!
BEGIN
DO.EVENTS
MOUSE.DOWN =
IF
?DOUBLE.CLICK
IF
@MOUSEXY
Y'.CO W!
X'.CO W!
Y'.CO W@
CASE
0 17 RANGE.OF 0 SW' C! ENDOF
306 400 RANGE.OF 0 SW' C! ENDOF
137 186 RANGE.OF 0 SW' C! ENDOF
X'.CO W@
CASE
228 283 RANGE.OF 0 SW' C! ENDOF
1 SW' C!
NAAR.KOLOM
ENDCASE
ENDCASE
AF.SCHIJF
SW' C@
3 = IF KOL.OK ELSE STAPPEN THEN
SW' C@
0= IF 4 SYSBEEP THEN
THEN
THEN
SW' C@ UNTIL ;
( Nu weten we dat hij een goede keuze heeft gemaakt. In de )
( volgende woorden wordt de schijf verplaatst. )
: AF.BEURT
BEURT C@
0> IF
WRP C@
11 < IF
BEURT C@
1- BEURT C!
DO.MOVES
BEURT C@
2 < IF
WRP C@
CASE
1 OF
241 273 271 303 LTGRAY PATTERN RECTANGLE
99 WORP 1+ C!
ENDOF
241 235 271 265 LTGRAY PATTERN RECTANGLE
99 WORP C!
ENDCASE
THEN
THEN
ELSE
0 BEURT C!
THEN ;
: VUL.TAB
WIE C@
CASE
1 OF
0 7 1 DO DIJN I+ C@ + LOOP
DIJN C!
0 25 7 DO DIJN I+ C@ + LOOP
DIJN C@ +
BAR 1+ C@
+ 15 -
ABS
AF.VELD 1+ C!
ENDOF
2 OF
0 25 19 DO MIJN I+ C@ + LOOP
MIJN C!
0 19 1 DO MIJN I+ C@ + LOOP
MIJN C@ +
BAR 2+ C@
+ 15 -
ABS
AF.VELD 2+ C!
ENDOF
ENDCASE
VAN.BORD C@
15 = IF
WIE C@
WIN C!
ELSE
0 WIN C!
THEN
ZET.STEEN ;
: SPEEL
FIRST.TIME
BEGIN
NOTACT C@
0= IF
?FIRST C@
1 = IF
0 ?FIRST C!
ELSE
WIE C@
1 = IF IK ELSE JIJ THEN
DOBBEL
THEN
THEN
SW W@
99 = IF DOBBEL THEN
0 NOTACT C!
BEGIN
KLIK.EEN
DROP
0 D.M
SW W@
CASE
1 OF ( bar )
MAG.HET
IF
1 SW W!
SH.BAR
KLIK.DRIE
GEEF'M
THEN
AF.BEURT
ENDOF
2 OF ( uitspelen )
DE.SCHYF
2 SW W!
KLIK.TWEE
GEEF'M
AF.BEURT
ENDOF
3 OF ( normaal )
DE.SCHYF
3 SW W!
KLIK.TWEE
GEEF'M
AF.BEURT
ENDOF
20 SYSBEEP
0 BEURT C!
ENDCASE
VUL.TAB
BEURT C@
0= IF 1 ELSE 0 THEN
WIN C@
IF
DROP
WIN C@
THEN
UNTIL
WIN C@
UNTIL ;
: RESTORE.BORD
WIS.RAAM
WIE C@
CASE
1 OF Z.RAAM ENDOF
2 OF W.RAAM ENDOF
ENDCASE
( restore contents of the bar --> )
BAR 2+ C@
DUP
0> IF
1 -
DUP
0> IF
TOMANY C!
256 145 W.SC
12 TEXTSIZE
8 TEXTSTYLE
1 TEXTMODE
252 150 MOVE.TO
TOMANY C@
48 +
DRAW.CHAR
ELSE
DROP
256 145 W.SC
THEN
ELSE
DROP
THEN
BAR 1+ C@
DUP
0> IF
1-
DUP
0> IF
TOMANY C!
256 171 Z.SC
12 TEXTSIZE
8 TEXTSTYLE
1 TEXTMODE
252 176 MOVE.TO
TOMANY C@
48 +
DRAW.CHAR
ELSE
DROP
256 171 Z.SC
THEN
ELSE
DROP
THEN
0 TEXTSTYLE
RESTORE.STEEN ;
: WERK
IF
PAGE
1 0 1 ITEM.ENABLE
?FIRST C@
IF
ERASE.VARS
D.M
SELECTION.2
THEN
BORD.RAND
DE.BAR
TEK.V
TEXT.RAAM
NOTACT C@
0= IF
VUL
ZETOP
ELSE
ZETOP
RESTORE.BORD
THEN
ZET.VELD
-1 SPEL.MENU MENU.ENABLE
SPEEL
PAGE
BYE
ELSE
1 NOTACT C!
WIE C@
WIE.S C!
0 SPEL.MENU MENU.ENABLE
THEN ;
BORD ON.ACTIVATE WERK
BORD ADD.WINDOW
N.GAMEW ADD.WINDOW
DBBL.W ADD.WINDOW
DBBL.W OK.CT APPEND.CONTROL
DBBL.W N.OK.CT APPEND.CONTROL
1 SNAPPY C!
10 CONSTANT SPEL.MENU
: HET.MENU
0 " Backgammon" SPEL.MENU NEW.MENU
" Start;-(;Double(;-;Quit" SPEL.MENU APPEND.ITEMS
DRAW.MENU.BAR ;
: SELECTION.1
SPEL.MENU
MENU.SELECTION:
CASE
1 OF INTRO.SCHERM HIDE.WINDOW ENDOF
5 OF SPEL.MENU DELETE.MENU BYE ENDOF
ENDCASE
0 HILITE.MENU ;
HET.MENU
SELECTION.1
0 SPEL.MENU MENU.ENABLE
1 0 1 ITEM.ENABLE
0 ?FIRST C! ( eerste keer switch )
HET.MENU SELECTION.1
0 SPEL.MENU MENU.ENABLE
INTRO.SCHERM ADD.WINDOW
BORD ADD.WINDOW
N.GAMEW ADD.WINDOW
DBBL.W ADD.WINDOW
DBBL.W OK.CT APPEND.CONTROL
DBBL.W N.OK.CT APPEND.CONTROL