( * * 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 * )