Fixed various bugs with the current version of SHRDLU.

Also added some descriptive files with info about the various files in the source directory.
2026-05-10 01:20:41 +00:00 · 2024-07-25 15:18:01 -07:00
parent 8794a3e050
commit 1280fce06c
9 changed files with 292 additions and 21 deletions
--- a/src/shrdlu/blockl.6
+++ b/src/shrdlu/blockl.6
@@ -256,7 +256,7 @@
 								     TYPE)))
 						 (LIST (LIST (QUOTE X) X)))
 					  (SETQ XX (PACKORD X (SIZE X) XX)))))
-		   OBJ)
+		   (listify obj))
 	     (RETURN (MAPCAR (QUOTE CADR) XX))))

 (DEFUN PACKON
@@ -285,6 +285,7 @@
 	     ((CONS (LIST SIZE X) LIST))))
 (DEFUN SIZE (X) (COND ((EQ X (QUOTE :BOX)) (QUOTE (400 400 300)))
 		      ((EQ X (QUOTE :TABLE)) (QUOTE (1200 1200 1200)))
+		      ((eq x (quote :hand)) (quote (0 0 0)))
 		      ((ATOM X) (CADDR (ATAB X)))
 		      (X)))

--- a/src/shrdlu/blockp.5
+++ b/src/shrdlu/blockp.5
@@ -493,7 +493,8 @@ THEOREM)
  (X Y BLOCKS PYR (WHY (EV)) EV)
  (!STACKUP $?X)
  (OR (LESSP (APPLY (QUOTE PLUS)
-		    (MAPCAR (QUOTE (LAMBDA (X) (CADDR (SIZE X)))) $?X))
+		    (MAPCAR (QUOTE (LAMBDA (X) (CADDR (SIZE X))))
+			    (listify $?x)))
 	     1201)
      (NOT (DPRINT2 (QUOTE TOO/ HIGH/,))))
  (THCOND
@@ -685,8 +686,13 @@ THEOREM)
 		  (TIMECHK $?EVENT $?TIME)
 		  (THOR (THGOAL (!PUTON $?EVENT $?X ?))
 			(THGOAL (!PICKUP $?EVENT $?X)))
-		  (OR (THVSETQ $_Z (SUB1 (ASSQ (GET $?EVENT (QUOTE END))
-					       (GET $?X (QUOTE HISTORY)))))
+		  ; ejs
+		  ;
+		  ; to fix: "why did you move the blue pyramid?" yielding
+		  ; (31 (700 174 600) :HAND NIL) NON-NUMERIC VALUE
+		  ;
+		  (OR (THVSETQ $_Z (SUB1 (car (ASSQ (GET $?EVENT (QUOTE END))
+					       (GET $?X (QUOTE HISTORY))))))
 		      (ERT TCTE-PUT WRONG))
 		  (THAMONG $?Y (LIST (CADR $?Z)))
 		  (THSETQ $_EV (MAKESYM (QUOTE E)))
--- a/src/shrdlu/dictio.75
+++ b/src/shrdlu/dictio.75
@@ -300,12 +300,14 @@
    SEMANTICS ((VB
 		((TRANS
 		  (RELATION 
-		      (RESTRICTIONS: RESTRICTIONS: 
+		      (
+;		       RESTRICTIONS: RESTRICTIONS:
 		       PROCEDURE: ((((!ANIMATE)) ((!EVENT)))) 
 		       MARKERS: PROCEDURE: 
-		       PLAUSIBILITY: (!EVAL (OR (GET MAP2 'REFER)
-						(ERT DO
-						     DEFINITION)))))))
+;		       PLAUSIBILITY: (!EVAL (OR (GET MAP2 'REFER)
+;						(ERT DO
+;						     DEFINITION)))
+	))))
 ))  FEATURES (TRANS VFS PRESENT VPL VB AUX DO INF))

 (DEFS DOES IRREGULAR (DO (V3PS) (VFS VPL INF)))
@@ -950,7 +952,7 @@

 (DEFUN THANK NIL 
    (COND ((EQ (CADR N) 'YOU)
-            (SAY YOU'RE WELCOME)
+            (SAY YOU/'RE WELCOME)
            (FLUSHME)
            (FLUSHME)
          (OR NN (IOC G))
--- a/src/shrdlu/loader.20
+++ b/src/shrdlu/loader.20
@@ -30,6 +30,7 @@
        ((eq (car x) 'v) (setq ^w nil))
        ((eq (car x) 'r) (setq ^r t))
        ((eq (car x) 'w) (progn (setq ^w t) (clear-output t)))
+        ((eq (car x) 'g) (tyo 7))		; ring the bell
        (t (break (eval (car x))))))

 (SETQ *RSET T) 
--- a/src/shrdlu/newans.80
+++ b/src/shrdlu/newans.80
@@ -367,7 +367,7 @@ TEST-LOOP
 			(PLUS (PLAUSIBILITY? RSS) (CAR ANS)))	       ;AN ANSWER IS VERY IMPLAUSIBILE IF IT MENTIONS
 		       (T (DIFFERENCE (PLAUSIBILITY? RSS) 512.)))      ;AN EVENT THE SYSTEM CAN'T FIND.
 		 (COND ((NULL (CADR ANS))
-			'((SAY I CAN/'TDISCUSSA NON-EXISTENT EVENT)))
+			'((SAY I CAN/'T DISCUSS A NON-EXISTENT EVENT)))
 		       ((APPEND (AND (EQ TYPE 'POLAR)
 				     '((SAY YES)))
 				(LIST (LIST 'EVLIS
@@ -772,8 +772,10 @@ TEST-LOOP
       ;;ANSWER HAS BEEN DECIDED ON.
       (PROG (COUNT EXAM X RES ANS COMMA?) 
 	     (SETQ NAMES (MAPCAR '(LAMBDA (X) (NAMEOBJ X SPEC))
-				 NAMES))			       ;NAMEOBJ RETURNS A LIST OF THE OBJECT AND THE
-	     (COND ((NULL NAMES) (RETURN '(SAY NOTHING))))	       ;THIS PATCH MAY WELL BE TOTALLOUT OF PHASE WITH
+				 (cond ((atom names) (list names))
+				       (t names))))
+	                                                               ;NAMEOBJ RETURNS A LIST OF THE OBJECT AND THE
+	     (COND ((NULL NAMES) (RETURN '((SAY NOTHING)))))	       ;THIS PATCH MAY WELL BE TOTALLOUT OF PHASE WITH
 	UP   (SETQ COUNT 1.)					       ;THE BACKREF HACKER - DDM 5-12-73 INSTRUCTIONS
 	     (SETQ EXAM (CAR NAMES))				       ;FOR NAMING IT.
 	     (SETQ NAMES (CDR NAMES))
@@ -852,15 +854,15 @@ TEST-LOOP
 			  (PRON-PRT 'UP OBJ1)))
 		   ((EQ VERB 'PUTON)
 		    (APPEND (CONS (SAYIFY (VBFIX 'PUT T))
-				  (NAMELIST-EVALED '(NIL)
+				  (car (NAMELIST-EVALED '(NIL)
 					    'DEF
-					    OBJ1))
+					    OBJ1)))
 			    (CONS '(SAY ON)
-				  (NAMELIST-EVALED '(NIL)
+				  (car (NAMELIST-EVALED '(NIL)
 					    'DEF
-					    OBJ2))))
+					    OBJ2)))))
 		   ((EQ VERB 'STACKUP)
-		    (CONS (VBFIX STACK T) (PRON-PRT 'UP OBJ1)))
+		    (CONS (sayify (VBFIX 'STACK T)) (PRON-PRT 'UP OBJ1)))
 		   ((EQ VERB 'RAISEHAND) NIL)
 		   (T (BUG NAMEACTION
 			   -
@@ -1214,7 +1216,7 @@ TEST-LOOP
       ;;PROBLEM AND THE PARTICLE IS ALWAYS PUT BEFORE THE NG.
       ;;;
       (CONS (LIST 'SAY PARTICLE)
-	     (NAMELIST-EVALED  '(NIL) 'DEF NG)))
+	     (car (NAMELIST-EVALED  '(NIL) 'DEF NG))))

 ;;;################################################################

@@ -1533,7 +1535,7 @@ BY)		       (PRINC (COND ((EQ X (Quote IT)) (Quote "IT"))
 ;;;############################################################

 (DEFUN VBFIX (X PP) 
-       (COND ((EQ TENSE 'ING)
+       (COND ((or (EQ TENSE 'ING) (eq tense 'pres-past))
 	      (SETQ X (REVERSE (EXPLODE X)))
 	      (READLIST (REVERSE (APPEND '(G N I)
 					 (VBFIX2 X)
--- a/src/shrdlu/smspec.96
+++ b/src/shrdlu/smspec.96
@@ -72,6 +72,20 @@
 		       ;CLAUSE CONTAINING IT CAN NEVER GET CALLED
 		       ;EXCEPT BY RECURSION,

+; ejs: original sources didn't have this. No sources I could find in ToTS had a 
+; definition for this function. I did, however, in the common lisp SHRDLU 
+; implementation, find a definition like the following one, so I'm adding it here.
+; I ran into this error:
+; 
+; ;SMINCOM UNDEFINED FUNCTION OBJECT
+; 
+; ;BKPT UNDF-FNCTN
+;
+; trying to issue the following command to SHRDLU:  did you move anything to do that?
+;
+(defun smincom ()
+  t)
+
 (DEFUN SMVG NIL 
       ;;CALLED INSIDE ANY VG
       (PROG (TSS TENSE) 
@@ -127,7 +141,7 @@
 	     (PUTPROP TSS TENSE 'TENSE=)
 	     (RETURN T))) 

-(DEFUN SMADJGQSHORT NIL (ERT SMADJQSHORT NOT WRITTEN YET)) 
+(DEFUN SMADJQSHORT NIL (ERT SMADJQSHORT NOT WRITTEN YET)) 

 (DEFUN SMPRON (NODE) 
       (EVAL (SM NODE))
@@ -281,6 +295,7 @@
 	     (AND MVB;IS THIS A "DO IT!" COMMAND?
 		  (ISQ MVB DO)
 		  (CQ OBJ1)
+	          (boundp 'lastevent)
 		  (RETURN (SMSET LASTEVENT)))
 								       ;IF SO, RETURN THE LAST EVENT
 	     (COND ((GET PRONOUN 'BIND)
--- a/src/shrdlu/smutil.150
+++ b/src/shrdlu/smutil.150
@@ -710,7 +710,13 @@
 								       ; <SKELETON>
 		    VARLIST)
 								       ; <VARIABLE DECLARATIONS>
-	      BODY)) 
+	      ;ejs
+	      ; this may be wrong, but there are some bodies that are not THGOALs
+	      ; probably the right thing is to figure out why these are not THGOALs
+	      ; and fix them to be. But I haven't managed to find where the (!direction right nil), aka, LEFT
+	      ; and (!direction right t), aka RIGHT, are being formed.
+	      (cond ((eq (caar body) 'thgoal) body)
+		    (t (list (list 'thgoal (car body)))))))

 ;;;=============================================================