\ Message-ID: \ ( * \ * LANGUAGE : ANS Forth \ * PROJECT : Forth Environments \ * DESCRIPTION : Son-of Terry Winograd's SHRDLU \ * CATEGORY : Example AI program \ * AUTHOR : Marcel Hendrix \ * LAST CHANGE : Tuesday, June 04, 2002 8:03 AM, Marcel Hendrix; fixed comments \ * LAST CHANGE : October 15, 1993, Marcel Hendrix; Ansification \ * LAST CHANGE : May 1, 1993, Marcel Hendrix \ * ) \ MARKER -blocks CR .( --- Blockworld Version 1.01 ---) \ ( * \ A [simple] program that ``knows'' about colored blocks placed in its \ two dimensional world. It can tell what its world looks like, it can \ locate any of the blocks by color, and it can manipulate things. \ [Put block1 on top of block2, even if both blocks are obscured by other \ blocks]. \ * ) \ Two-dimensional array : 2D-ARRAY CREATE OVER , * CHARS ALLOT ( xm ym -- ) DOES> DUP CELL+ >R ( x y -- addr ) @ * + CHARS R> + ; 6 CONSTANT #cols 5 CONSTANT #rows #cols #rows 2D-ARRAY world char R CONSTANT 'R' char Y CONSTANT 'Y' char B CONSTANT 'B' char G CONSTANT 'G' char ú CONSTANT 'ú' char a CONSTANT 'a' char z CONSTANT 'z' char A CONSTANT 'A' : INITIALIZE #cols 0 DO #rows 0 DO 'ú' J I world C! LOOP LOOP 0 1 2 3 4 5 6 0 DO \ shuffle 6 CHOOSE ROLL LOOP 'R' ( red) SWAP 0 world C! 'Y' ( yellow) SWAP 0 world C! 'B' ( blue) SWAP 0 world C! 'G' ( green) SWAP 0 world C! 2DROP ; INITIALIZE : .WORLD CR 0 #rows 1- DO CR 8 SPACES #cols 0 DO I J world C@ EMIT LOOP -1 +LOOP CR 1000 MS ; [UNDEFINED] >UPC [IF] : >UPC DUP 'a' 'z' 1+ WITHIN IF [ 'a' 'A' - ] LITERAL - THEN ; [THEN] : .COLOR >UPC CASE ( char -- ) 'R' OF ." the red block" ENDOF 'B' OF ." the blue block" ENDOF 'Y' OF ." the yellow block" ENDOF 'G' OF ." the green block" ENDOF 'ú' OF ." a space" ENDOF ENDCASE ; : ?CR CR ; : TELL-COLUMN LOCALS| column | ( col# -- ) 0 #rows 1- DO column I world C@ DUP 'ú' <> IF ?CR .COLOR I IF ." on top of" THEN ELSE I 0= IF .COLOR ELSE DROP THEN THEN -1 +LOOP ; : TELL CR CR ." Starting from the left, I see: " CR #cols 0 DO I TELL-COLUMN I #cols 1- <> IF ." ," CR ." flanked by" ELSE ." ." THEN LOOP ; : .SINGLE LOCALS| row col | ( col row -- ) col 0 #cols WITHIN row 0 #rows WITHIN AND IF col row world C@ .COLOR ELSE ." nothing" THEN ; : .ALL LOCALS| row col | ( col row -- ) CR ." That block is at column " col 0 .R ." and row " row 0 .R ." ." CR col 1- row .SINGLE ." is to the left," ?CR col 1+ row .SINGLE ." is to the right," ?CR col row 1- .SINGLE ." is beneath it," ?CR col row 1+ .SINGLE ." is on top of it." ; 0 VALUE color1 0 VALUE color2 0 VALUE col#1 \ the column where color1 is 0 VALUE col#2 \ the column where color2 is 0 VALUE row#1 \ the row where color1 is 0 VALUE row#2 \ the row where color2 is : BCOLOR CREATE , ( char -- ) DOES> @ color1 0= IF TO color1 ELSE TO color2 THEN ; : LOCATE? LOCALS| color | ( color -- c r bool ) -1 -1 #cols 0 DO #rows 0 DO J I world C@ color = IF 2DROP J I LEAVE THEN LOOP LOOP 2DUP -1 -1 D= IF 2DROP 0 0 FALSE ELSE TRUE THEN ; : WHERE-IS color1 LOCATE? ( -- ) 0= IF 2DROP CR ." That block isn't there." EXIT THEN .ALL ; : SHUFFLE INITIALIZE .WORLD CR CR ." I enjoyed that." ; \ Find a free column (not corresponding to color1 or color2). : HOLE BEGIN #cols CHOOSE ( -- > One of the colors doesn't exist <<" -88 THROW THEN ; : (UNOBSCURE) LOCALS| column color | ( color column -- ) 0 #rows 1- DO column I world C@ DUP color = IF DROP LEAVE THEN DUP 'ú' = IF DROP ELSE HOLE STORE 'ú' column I world C! FIND'M .WORLD THEN -1 +LOOP ; : UNOBSCURE color1 col#1 (UNOBSCURE) color2 col#2 (UNOBSCURE) ; : TOP color1 col#2 row#2 1+ world C! 'ú' col#1 row#1 world C! .WORLD ; : PUT-BLOCK color1 color2 = IF ." That's easy." EXIT THEN FIND'M UNOBSCURE TOP ; WORDLIST CONSTANT \ Here's where the user commands go. : EVAL-REST BEGIN >IN @ #TIB @ < WHILE BL WORD COUNT SEARCH-WORDLIST 0<> IF EXECUTE THEN REPEAT ; : HELLO-WORLD PAGE 0 12 AT-XY .WORLD ." Ready for service." BEGIN 0 TO color1 0 TO color2 CR ." BW> " QUERY ['] EVAL-REST CATCH IF CR ." >> An error occurred ... <<" THEN AGAIN ; SET-CURRENT 'R' BCOLOR Red 'B' BCOLOR Blue 'G' BCOLOR Green 'Y' BCOLOR Yellow : SHOW PAGE 0 12 AT-XY .WORLD ; : WHERE EVAL-REST WHERE-IS ; : TELL TELL ; : SHUFFLE SHUFFLE ; : PUT EVAL-REST PUT-BLOCK ; : STOP QUIT ; : HELP CR ." Commands: SHOW WHERE TELL SHUFFLE PUT STOP HELP" ; FORTH DEFINITIONS : .ABOUT CR ." Enter HELLO-WORLD to begin (CASESENSITIVE should be off)." CR ." Commands: SHOW WHERE TELL SHUFFLE PUT STOP HELP" CR ." A possible conversation might go as follows:" CR CR ." Tell me what you see." CR ." Where is the blue block?" CR ." Shuffle your blocks around a bit." CR ." Show it to me" CR ." Help me please, I lost my bearings." CR ." Put the red block over the green one." CR ." Stop it, I'm getting bored." ; .ABOUT ( * End of Source * ) -marcel