From ef2a198ac8eb0159edf27e1949281d164788fe83 Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Tue, 13 Aug 2024 15:19:00 -0700 Subject: [PATCH] Fixed lots of bugs and made it so SHRDLU and PLNR can be compiled. Now, we build SHRDLU;TS SHRDLU and SHRDLU;TS PLNR from compiled lisp code. This should allow it to run faster and have fewer issues with garbage collection and running out of LIST space. Found lots of bugs going through the compilation effort. Also fixed several issues that were resulting in weird/incorrect responses to standard demo prompts. Below is a list of prompts that I have tested: pick up a big red block. grasp the pyramid find a block that is taller than the one you are holding and put it into the box. what does the box contain? what is the pyramid supported by? how many blocks are not in the box? is the red cube supported? can the table pick up blocks? can a pyramid be supported by a block? can a pyramid support a pyramid? stack up two pyramids. stack up two red blocks. put the green pyramid on the red cube. which cube is sitting on the table? is there a large block behind a pyramid? put a small one onto the green cube that supports a pyramid. put the littlest pyramid on top of it. does the red cube support anything? what color is the block that supports the green pyramid? how many things are on top of green cubes? had you touched any pyramid before you put the green pyramid on the little cube? when did you pick it up? why did you pick it up? why did you clear off that cube? how did you clean off the red cube? how many objects did you touch while you were doing it? put the blue pyramid on the block in the box. is there anything which is bigger than every pyramid but is not as wide as the thing that supports it? thank you. Of course, lots more things are possible. It is still best to do this without answering "Y" to the Type 340 display prompt at the start. There is either an issue with the GRAPHF module or the SLAVE module (or perhaps with the Type 340 simulator) that is causing crashes after several successful commands with graphic output. --- build/shrdlu.tcl | 100 ++++++- src/shrdlu/{blockl.6 => blockl.7} | 20 +- src/shrdlu/{blockp.5 => blockp.6} | 52 +--- src/shrdlu/data2.1 | 34 +++ src/shrdlu/{dictio.75 => dictio.76} | 30 +- src/shrdlu/{ginter.5 => ginter.6} | 18 +- src/shrdlu/{gramar.28 => gramar.29} | 405 ++++++++++++------------- src/shrdlu/{graphf.4 => graphf.5} | 18 +- src/shrdlu/{loader.20 => loader.21} | 132 +++++---- src/shrdlu/macros.1 | 31 ++ src/shrdlu/{morpho.14 => morpho.15} | 38 ++- src/shrdlu/{newans.80 => newans.81} | 103 ++++--- src/shrdlu/parser.12 | 412 ++++++++++++++++++++++++++ src/shrdlu/{plnr.183 => plnr.184} | 388 ++---------------------- src/shrdlu/proggo.33 | 83 ++++++ src/shrdlu/{progmr.58 => progmr.59} | 21 +- src/shrdlu/{setup.63 => setup.64} | 11 +- src/shrdlu/{show.14 => show.15} | 51 ++-- src/shrdlu/{smass.19 => smass.20} | 8 +- src/shrdlu/{smspec.96 => smspec.97} | 26 +- src/shrdlu/{smutil.150 => smutil.151} | 34 ++- src/shrdlu/{syscom.181 => syscom.182} | 96 +++--- src/shrdlu/{thtrac.23 => thtrac.24} | 16 +- 23 files changed, 1244 insertions(+), 883 deletions(-) rename src/shrdlu/{blockl.6 => blockl.7} (95%) rename src/shrdlu/{blockp.5 => blockp.6} (98%) create mode 100644 src/shrdlu/data2.1 rename src/shrdlu/{dictio.75 => dictio.76} (98%) rename src/shrdlu/{ginter.5 => ginter.6} (83%) rename src/shrdlu/{gramar.28 => gramar.29} (87%) rename src/shrdlu/{graphf.4 => graphf.5} (99%) rename src/shrdlu/{loader.20 => loader.21} (61%) create mode 100644 src/shrdlu/macros.1 rename src/shrdlu/{morpho.14 => morpho.15} (94%) rename src/shrdlu/{newans.80 => newans.81} (95%) create mode 100644 src/shrdlu/parser.12 rename src/shrdlu/{plnr.183 => plnr.184} (89%) create mode 100644 src/shrdlu/proggo.33 rename src/shrdlu/{progmr.58 => progmr.59} (96%) rename src/shrdlu/{setup.63 => setup.64} (96%) rename src/shrdlu/{show.14 => show.15} (95%) rename src/shrdlu/{smass.19 => smass.20} (98%) rename src/shrdlu/{smspec.96 => smspec.97} (98%) rename src/shrdlu/{smutil.150 => smutil.151} (98%) rename src/shrdlu/{syscom.181 => syscom.182} (90%) rename src/shrdlu/{thtrac.23 => thtrac.24} (97%) diff --git a/build/shrdlu.tcl b/build/shrdlu.tcl index 4085d6771..31dabaf45 100644 --- a/build/shrdlu.tcl +++ b/build/shrdlu.tcl @@ -2,25 +2,117 @@ log_progress "ENTERING BUILD SCRIPT: SHRDLU" respond "*" ":cwd shrdlu\r" +# first, compile all the sources that should be compiled + respond "*" ":complr\r" respond "_" "shrdlu; graphf\r" respond "_" "\032" type ":kill\r" +respond "*" ":complr\r" +respond "_" "shrdlu; macros\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; proggo\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; plnr\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; thtrac\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; syscom\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; morpho\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; show\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; progmr\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; ginter\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; gramar\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; dictio\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; smspec\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; smass\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; smutil\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; newans\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; blockp\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":complr\r" +respond "_" "shrdlu; blockl\r" +respond "_" "\032" +type ":kill\r" + +# now load up a compiled version of SHRDLU respond "*" ":lisp\r" respond "Alloc?" "n" respond "*" "(load 'loader)" -respond "T" "(loadshrdlu)" -respond "|CONSTRUCTION COMPLETED|" "(dump-it)" +respond "T" "(shrdlu-compiled)" +respond "COMPLETED" "(dump-shrdlu)" + +# dump it as SHRDLU;TS SHRDLU respond "*" ":pdump shrdlu;ts shrdlu\r" respond "*" ":kill\r" +# load up a compiled version of PLNR respond "*" ":lisp\r" respond "Alloc?" "n" respond "*" "(load 'loader)" respond "T" "(load 'plnrfi)" -respond "T" "(loadplanner)" +respond "T" "(planner-compiled)" respond "(THERT TOP LEVEL))" "(dump-planner)" + +# dump it as SHRDLU;TS PLNR respond "*" ":pdump shrdlu;ts plnr\r" respond "*" ":kill\r" - diff --git a/src/shrdlu/blockl.6 b/src/shrdlu/blockl.7 similarity index 95% rename from src/shrdlu/blockl.6 rename to src/shrdlu/blockl.7 index 78436b5d4..378c7b64d 100644 --- a/src/shrdlu/blockl.6 +++ b/src/shrdlu/blockl.7 @@ -5,7 +5,13 @@ ;;;################################################################ (declare (genprefix blockl) - (*fexpr ert thvsetq thand thsetq thgoal)) + (muzzled t) + (specials t) + (*fexpr ert thvsetq thand thsetq thgoal cleanout thv) + (*expr imperf? start? thadd thvarsubst evlis thval end?)) + +(eval-when (compile) + (load 'macros)) (DEFUN ABSVAL (X) (COND ((MINUSP X) (MINUS X)) (X))) @@ -14,7 +20,7 @@ (DEFUN CLEAR (LOC SIZE OBJ) (PROG (W X1 X2) - (SETQ OBJ (LISTIFY OBJ)) + (SETQ OBJ (LISTIFY2 OBJ)) (AND (MEMQ NIL (MAPCAR (QUOTE (LAMBDA (X Y) (AND (GREATERP X -1) @@ -52,7 +58,7 @@ (DEFUN FINDSPACE (TYPE SURF SIZE OBJ) (PROG (XYMAX XYMIN N V X1 X2) - (SETQ OBJ (LISTIFY OBJ)) + (SETQ OBJ (LISTIFY2 OBJ)) (AND (MEMQ SURF OBJ) (RETURN NIL)) (COND ((EQ SURF (QUOTE :TABLE)) (SETQ XYMIN (QUOTE (0 0))) (SETQ XYMAX (QUOTE (1200 1200))) @@ -124,7 +130,7 @@ (DEFUN GROW (LOC MIN MAX OBJ) (PROG (GROW XL XH XO YL YH YO) - (SETQ OBJ (LISTIFY OBJ)) + (SETQ OBJ (LISTIFY2 OBJ)) (COND ((OR (MINUSP (CAAR (SETQ XL (LIST (LIST (DIFFERENCE (CAR LOC) (CAR MIN)) @@ -200,7 +206,7 @@ (QUOTE (XL XH YL YH))) (GO GO))))) -(DEFUN LISTIFY (X) (COND ((ATOM X) (LIST X)) (X))) +(DEFUN LISTIFY2 (X) (COND ((ATOM X) (LIST X)) (X))) (declare (*expr fn)) @@ -254,7 +260,7 @@ TYPE))) (LIST (LIST (QUOTE X) X))) (SETQ XX (PACKORD X (SIZE X) XX))))) - (listify obj)) + (listify2 obj)) (RETURN (MAPCAR (QUOTE CADR) XX)))) (DEFUN PACKON @@ -318,7 +324,7 @@ (DEFUN SUPPORT (LOC SIZE X) - (COND ((EQ (CADDR LOC) 0) (QUOTE :TABLE)) + (COND ((= (CADDR LOC) 0) (QUOTE :TABLE)) ((SETQ LOC (OCCUPIER (PLUS (CAR LOC) (DIV2 (CAR SIZE))) (PLUS (CADR LOC) (DIV2 (CADR SIZE))) (SUB1 (CADDR LOC)))) diff --git a/src/shrdlu/blockp.5 b/src/shrdlu/blockp.6 similarity index 98% rename from src/shrdlu/blockp.5 rename to src/shrdlu/blockp.6 index ff87d0442..6525012ef 100644 --- a/src/shrdlu/blockp.5 +++ b/src/shrdlu/blockp.6 @@ -1,4 +1,3 @@ - ;################################################################ ; ; BLOCKP > @@ -7,6 +6,14 @@ ; MICRO-PLANNER CODE FOR THE "BLOCKS" MICRO-WORLD ;################################################################ +(declare (muzzled t)) +(declare (specials t)) +(declare (*fexpr ioc)) +(declare (*expr tcent atab listify2)) + +(eval-when (compile) + (load 'macros)) + (DEFPROP TA-AT (THANTE (X Y) (!AT $?X $?Y) (THRPLACA (CDR (ATAB $?X)) $?Y)) THEOREM) @@ -285,7 +292,7 @@ (DEFPROP TC-NAME (THCONSE (X) (!NAME $?X) - (THVSETQ $_X (LISTIFY $?X)) + (THVSETQ $_X (LISTIFY2 $?X)) (THVSETQ $_X (THFIND ALL $?Y (Y Z) @@ -413,7 +420,7 @@ THEOREM) ((THSUCCEED))) (THGOAL (!IS $?Y !BOX)) (THVSETQ $_Z - (UNION (LISTIFY $?X) + (UNION (LISTIFY2 $?X) (THVAL (QUOTE (THFIND ALL $?W (W) @@ -496,7 +503,7 @@ THEOREM) (!STACKUP $?X) (OR (LESSP (APPLY (QUOTE PLUS) (MAPCAR (QUOTE (LAMBDA (X) (CADDR (SIZE X)))) - (listify $?x))) + (listify2 $?x))) 1201) (NOT (DPRINT2 (QUOTE TOO/ HIGH/,)))) (THCOND @@ -778,7 +785,8 @@ THEOREM) (SETQ NOSTACKS T) -(DEFUN SASSQ (X Y Z) (OR (ASSQ X Y) (APPLY Z NIL))) +; ejs: now defined in interpreter +;(DEFUN SASSQ (X Y Z) (OR (ASSQ X Y) (APPLY Z NIL))) (DEFPROP !CLEARTOP (((THGOAL (!SUPPORT $?* ?)))) CHOOSE) @@ -810,40 +818,6 @@ THEOREM) ((THNOT (THGOAL (!IS $?* !PYRAMID))))) CHOOSE) -(THDATA) - -(TC-CALL) - -(TC-CLEARTOP) - -(TC-GET-RID-OF) - -(TC-GRASP) - -(TC-NAME) - -(TC-NOTICE) - -(TC-PACK) - -(TC-PICKUP) - -(TC-PUTIN) - -(TC-PUTON) - -(TC-RAISEHAND) - -(TC-STACKUP) - -(TC-UNGRASP) - -(TC-ON) - -(TC-PHYSOB) - -NIL - (DEFUN UNION (A B) (PROG NIL UP (COND ((NULL A) (RETURN B)) ((MEMQ (CAR A) B)) diff --git a/src/shrdlu/data2.1 b/src/shrdlu/data2.1 new file mode 100644 index 000000000..18fef0e6a --- /dev/null +++ b/src/shrdlu/data2.1 @@ -0,0 +1,34 @@ +(THDATA) + +(TC-CALL) + +(TC-CLEARTOP) + +(TC-GET-RID-OF) + +(TC-GRASP) + +(TC-NAME) + +(TC-NOTICE) + +(TC-PACK) + +(TC-PICKUP) + +(TC-PUTIN) + +(TC-PUTON) + +(TC-RAISEHAND) + +(TC-STACKUP) + +(TC-UNGRASP) + +(TC-ON) + +(TC-PHYSOB) + +NIL + diff --git a/src/shrdlu/dictio.75 b/src/shrdlu/dictio.76 similarity index 98% rename from src/shrdlu/dictio.75 rename to src/shrdlu/dictio.76 index d4d2fc65c..83ff5c1c7 100644 --- a/src/shrdlu/dictio.75 +++ b/src/shrdlu/dictio.76 @@ -1,16 +1,20 @@ - - - - ;;;=========================================================== ;;; ;;; WORDS ;;; ;;;=========================================================== +(declare (muzzled t)) +(declare (specials t)) +(declare (*fexpr defs relation ioc say ertstop)) +(declare (*expr !beint !bethere quantifier? flushme)) + +(eval-when (compile) + (load 'macros)) + (DEFS /, FEATURES (SPECIAL) SPECIAL (COMMA)) -(DEFS " FEATURES (B-SPECIAL RELWRD) B-SPECIAL (DOUBLEQUOTER)) +(DEFS /" FEATURES (B-SPECIAL RELWRD) B-SPECIAL (DOUBLEQUOTER)) (DEFS A SEMANTICS ((DET T)) FEATURES (DET NS INDEF)) @@ -103,7 +107,7 @@ '!1 (LIST 'QUOTE (REFER? !2)))))))) - (T (ERTSTOP SORRY I DON 'T UNDERSTAND THE + (T (ERTSTOP SORRY I DON/'T UNDERSTAND THE VERB BE WHEN YOU USE IT LIKE THAT)))) @@ -175,8 +179,6 @@ (RETURN (PROG (CUT NBB BOTH) (SETQ NBB N) (AND (FLUSHME) -;ejs -; (** N (move-ptw N NW (EQ (WORD PTW) (CAR A)) @@ -953,11 +955,12 @@ (DEFS THANK FEATURES (B-SPECIAL) SEMANTICS (THANK)B-SPECIAL (THANK)) (DEFUN THANK NIL - (COND ((EQ (CADR N) 'YOU) - (SAY YOU/'RE WELCOME) - (FLUSHME) - (FLUSHME) - (OR NN (IOC G)) + (COND ((EQ (CADR N) 'YOU) + (SAY YOU/'RE WELCOME) + (FLUSHME) + (FLUSHME) + (OR NN (IOC G)) + (setq global-message '(||)) (SETQ SPECIAL 'DONE)))) (DEFS THAT @@ -1808,4 +1811,3 @@ MARKERS: (!PLACE) (SHORT !HEIGHT) (THICK !THICKNESS) (THIN !THICKNESS)) -  \ No newline at end of file diff --git a/src/shrdlu/ginter.5 b/src/shrdlu/ginter.6 similarity index 83% rename from src/shrdlu/ginter.5 rename to src/shrdlu/ginter.6 index 443ff418f..2105161e2 100644 --- a/src/shrdlu/ginter.5 +++ b/src/shrdlu/ginter.6 @@ -1,4 +1,10 @@ +(declare (specials t)) +(declare (muzzled t)) +(declare (*expr m rebuild n setr buildnode nb apply-macro)) +(declare (*fexpr isq)) +(eval-when (compile) ; only compile time, since LOADER will load it at runtime + (load 'proggo)) (DEFUN PDEFINE FEXPR (A) ;;THIS PDEFINE MERELY PUT THE PROGRAMMAR FUNCTION ON THE @@ -25,13 +31,12 @@ (SETQ NN T) (SETQ CUT END) (SETQ C (BUILDNODE (SETQ FE (REVERSE REST)) ;FEATURE LIST - (SETQ NB (OR (NB RE) N)) ;BEGINNING IN SENTENCE OF THIS NODE + (SETQ NB (OR (NB RE) N)) ;BEGINNING IN SENTENCE OF THIS NODE N ;SENTENCE POINTER JUST AFTER THIS NODE (SETQ H RE) ;DAUGHTERS OF THIS NODE NIL)) ;SEMANTIC JAZZ (SETR 'PARENT PARENT C) ;SET PARENT REGISTER - (COND ((EQ (APPLY 'PROG - (GET UNIT 'INTERPRET)) + (COND ((EQ (apply-macro '*PROG (GET UNIT 'INTERPRET)) 'RETURN) (GO RETURN))) ;APPLY THE PROGRAMMAR PROGRAM FAIL (SETQ MES ME) @@ -57,11 +62,10 @@ ;;REMEMBER THAT THE GO LEADS TO A POINT SOMEWHERE IN THE ;;PROGRAMMAR PROGRAM UNLESS IT IS 'FAIL OR 'RETURN (COND ((NULL (CADR LABEL)) T) - ((ATOM (CADR LABEL)) (GO (CADR LABEL))) - (T (M (CADR LABEL)) (GO FAIL)))) + ((ATOM (CADR LABEL)) (*GO (CADR LABEL))) + (T (M (CADR LABEL)) (*GO FAIL)))) (DEFUN GOCOND FEXPR (A) ;;GOCOND GOES TO THE 1ST OR 2ND OF TWO TAGS DEPENDING IF THERE ;;REMAINS ANY MORE OF THE SENTENCE YET TO BE PARSED - (COND (NN (GO (CAR A))) (T (GO (CADR A))))) - \ No newline at end of file + (COND (NN (*GO (CAR A))) (T (*GO (CADR A))))) diff --git a/src/shrdlu/gramar.28 b/src/shrdlu/gramar.29 similarity index 87% rename from src/shrdlu/gramar.28 rename to src/shrdlu/gramar.29 index 2b6c828a9..420774f55 100644 --- a/src/shrdlu/gramar.28 +++ b/src/shrdlu/gramar.29 @@ -1,6 +1,14 @@ - (PDEFINE CLAUSE (POSITION-OF-PRT MVB LOCATIONMARKER - SUBJ-VB-BACKUP-TYPE1 POSITION-OF-PTW) +(declare (muzzled t)) +(declare (specials t)) +(declare (*fexpr pdefine both move-ptw isq)) +(declare (*expr flushme apply-grammar cut word parse2 parse3 setr meet secondword? + f fe union)) + +(eval-when (compile) ; only compile time, since LOADER will load it at runtime + (load 'proggo)) +(PDEFINE CLAUSE (POSITION-OF-PRT MVB LOCATIONMARKER + SUBJ-VB-BACKUP-TYPE1 POSITION-OF-PTW) ENTERING-CLAUSE (SETR 'TIME (BUILD TSSNODE= (MAKESYM 'TSS)) C) (: (CQ SIMP) SUBJ NIL) @@ -15,9 +23,9 @@ FIXIT (: (CUT (MOVE-PTW)) INIT MAJOR) MAJOR (CUT END) - (COND ((EQ PUNCT '?) (GO QUEST)) - ((OR (CQ IMPER) (EQ PUNCT '!)) (GO IMPER))) - (GO THEREINIT) + (COND ((EQ PUNCT '?) (*GO QUEST)) + ((OR (CQ IMPER) (EQ PUNCT '!)) (*GO IMPER))) + (*GO THEREINIT) FDEC (FQ DECLAR) ;;; THEREINIT ;CONSTRUCTIONS USING THE FUNCTION WORD "THERE" @@ -32,13 +40,13 @@ FDEC (FQ DECLAR) THER2(AND (NQ PREP) (PARSE PREPG INIT) (OR (CALLSM (SMRELATE H)) ;MORE INITIAL (BEFORE THE SUBJECT) MODIFIERS - (POP))) + (SPOP))) (AND (NQ ADV) (PARSE ADV TIMW) - (OR (CALLSM (SMADVERB)) (POP))) + (OR (CALLSM (SMADVERB)) (SPOP))) (AND (NQ ADV) (PARSE ADJG ADV VBAD) - (OR (CALLSM (SMRELATE H)) (POP))) + (OR (CALLSM (SMRELATE H)) (SPOP))) (PARSE NG TIME) ;;; @@ -55,7 +63,7 @@ FDEC (FQ DECLAR) ;;EVERYTHING IS POPPED OFF (BY THE "INPOP" CODE) INPOP(: (MOVE-PT C DLC) NIL (INPOP)) ;DOES ANYTHING REMAIN ON THE TREE? BICUT(CUT-BACK-ONE) ;"CUT-BACK-ONE" IS THE NORMAL BACKINGUP - (GO INIT) ;MECHANISM FOR THE GRAMMAR, IT SETS PTW (POINTER + (*GO INIT) ;MECHANISM FOR THE GRAMMAR, IT SETS PTW (POINTER ;TO THE WORD) BACK ONE FROM WHERE IT WAS AND ;SETS "CUT" TO PTW. THE FOLLOWING GOTO TELLS ;WHICH BLOCK OF CODE IS TO BE REPEATED. @@ -104,12 +112,12 @@ FDEC (FQ DECLAR) ;IT IS ACTIVE AS A RSQ AND ITS MISSING ELEMENT (RQ REL-NOT-FOUND) ;HAS NOT YET BEEN DETERMINED. SINCE WE CANNOT (SETR 'SUBJECT (GETR 'RELHEAD C) C) ;FIND ANY SUBJECT, WE ASSUME THAT IT IS A - (GO VB)) ;SUBJECT-RELATIVE IN THIS CASE. + (*GO VB)) ;SUBJECT-RELATIVE IN THIS CASE. (SUBJ-VB-BACKUP-TYPE1 (SETQ SUBJ-VB-BACKUP-TYPE1 NIL) - (GO SUBJ11)) ;SEE THE LARGE NOTE ABOUT THIS IN "NOVERB". + (*GO SUBJ11)) ;SEE THE LARGE NOTE ABOUT THIS IN "NOVERB". ((AND H (ISQ H TIME) (ISQ H NG)) (SETR 'SUBJECT H C) - (GO VB)) ;WHAT WAS INITIALLY PARSED AS A TIME-NG MODIFING + (*GO VB)) ;WHAT WAS INITIALLY PARSED AS A TIME-NG MODIFING ((MOVE-PT C U (REL-NOT-FOUND)) ;THE WHOLE CLAUSE MAY PROBABLY BEEN THE SUBJECT ;OF THE CLAUSE THIS WORRIES ABOUT RELATIVE ;CLAUSES. PLEASE NOTE THAT THE CURRENT @@ -118,17 +126,17 @@ FDEC (FQ DECLAR) (SETR 'SUBJECT (GETR 'RELHEAD PT) C) ;DEBUGGED AND HAS GAPS IN IT ESP. WHO SETS WHAT (SETR 'RELHEAD (GETR 'RELHEAD PT) C) ;REGISTER WHEN THIS WILL BE FIXED BEFORE THE (REMOVE-F-PT 'REL-NOT-FOUND PT) ;VERSION IS FINALIZED - (GO VB)) - ((AND (CQ COMPONENT) NN) (FQ SUBJFORK) (GO VB)) ;"SARAH ATE DINNER AND WENT TO THE MOVIES." - (H (POP) (GO SUBJ)) ;POP OFF THE CLOSEST INITIAL MODIFIER AND TRY TO - ((GO FAIL))) ;PARSE A SUBJ AGAIN + (*GO VB)) + ((AND (CQ COMPONENT) NN) (FQ SUBJFORK) (*GO VB)) ;"SARAH ATE DINNER AND WENT TO THE MOVIES." + (H (SPOP) (*GO SUBJ)) ;POP OFF THE CLOSEST INITIAL MODIFIER AND TRY TO + ((*GO FAIL))) ;PARSE A SUBJ AGAIN ;;; ;;; HEAD (: (OR (MOVE-PTW N PW (NOUN)) (MOVE-PTW N PW (PRON))) ;COME HERE (ONLY?) TO TRY TIME PHRASE AS SUBJECT NIL (HEAD)) ;MOVE PTW TO THE CLOSEST NOUN THEN SET THE CUT - SUB2 (: (POP) NIL FAIL) ;POINT TO IT AND ATTEMPT A NEW PARSING IF + SUB2 (: (SPOP) NIL FAIL) ;POINT TO IT AND ATTEMPT A NEW PARSING IF (: (CUT PTW) INIT SUB2) ;NOTHING MORE TO POP, LOSE ;;; @@ -136,7 +144,7 @@ FDEC (FQ DECLAR) (AND (ISQ H LIST) (FQ LIST)) ;HAVE NOTHING FOLLOWING THE SUBJECT OF THE (FQ QUOTED) ;CLAUSE " "MUMBLE", SAID JOHN." (SETQ H (H H)) - (GO RETSM))) + (*GO RETSM))) (AND (CQ REL-NOT-FOUND) ;THIS IS PART OF A BACKUP MECHANISM WHICH NEEDS (MOVE-PT H PV (QAUX)) ;TO BE MORE THROUGHLY THOUGHT OUT. THE SITUATION (COND ((ISQ PT BE) ;IS EXPLAINED IN DETAIL IN QUESTION.NGQST MOVE @@ -145,19 +153,19 @@ FDEC (FQ DECLAR) (SETR 'COMP (GETR 'RELHEAD C) C) (SETR 'SUBJECT H C) ;"WHAT COLOR IS THE BLOCK?" OR "HOW BIG IS THE (SETMVB PT) ;BLOCK?" - (GO ONT)) + (*GO ONT)) ((ISQ PT HAVE) (FQ SUBQ) (RQ REL-NOT-FOUND) (SETR 'SUBJECT (GETR 'RELHEAD C) C) - (GO VBL)))) + (*GO VBL)))) ;;; SUBJ11 (: (CUT-BACK-ONE) SUBJ3 (SUBJ11)) ;IF WE CAN'T CUT BACK ANY FURTHER, THEN FAIL SUBREG (SETR 'SUBJECT H C) ;THIS SETS THE "SUBJECT" REGISTER OF THE CURRENT - (GO VB) ;CURRENT NODE TO WHATEVER IS POINTED TO BY "H" + (*GO VB) ;CURRENT NODE TO WHATEVER IS POINTED TO BY "H" ;(IN THIS CASE THAT WOULD BE THE MOST RECENTLY ;PARSED DAUGHTER OF THE CURRENT NODE) @@ -179,13 +187,13 @@ FDEC (FQ DECLAR) ;;; NOVERB - (COND ((CQ SUBJFORK) (FQ VBFORK) (GO FINDOBJ1)) ;WHAT TO DO IF THE VG CANNOT BE DIRECTLY - ((ISQ H QUOTED) (FQ REL-NOT-FOUND) (GO SUBJ4)) ;PARSED - ((NOT (ISQ H SUBJ)) (GO FAIL)) + (COND ((CQ SUBJFORK) (FQ VBFORK) (*GO FINDOBJ1)) ;WHAT TO DO IF THE VG CANNOT BE DIRECTLY + ((ISQ H QUOTED) (FQ REL-NOT-FOUND) (*GO SUBJ4)) ;PARSED + ((NOT (ISQ H SUBJ)) (*GO FAIL)) ((ISQ H CLAUSE) (SETQ SUBJ-VB-BACKUP-TYPE1 T) - (POP) - (GO SUBJ4)) ;THIS IS EXACTLY WHAT IS LOOKS LIKE. IE. AN + (SPOP) + (*GO SUBJ4)) ;THIS IS EXACTLY WHAT IS LOOKS LIKE. IE. AN ;ARBITRARY, NOT TOO WELL THOUGHTOUT BACKUP ;MECHANISM. (NEEDLESS TO SAY IT WILL GO AWAY ;FAST) WE HAVE BEEN UNABLE TO FIND A VERB AND @@ -193,9 +201,9 @@ FDEC (FQ DECLAR) ;SORT AS THE SUBJECT. HYPOTHESIS: WE ;MISSINTERPRETED SOMETHING WHILE PARSEING THAT ;CLAUSE AND MANAGED TO SWALLOW UP THE VERB OF - ((ISQ H SUBJ) (POP) (FQ SUBJFORK) (GO VBL))) ;THE HIGHER CLAUSE WITH IT. SOLUTION: POP OFF + ((ISQ H SUBJ) (SPOP) (FQ SUBJFORK) (*GO VBL))) ;THE HIGHER CLAUSE WITH IT. SOLUTION: POP OFF VB2 (CUT-BACK-ONE) ;THE CLAUSE AND TRY TO REPARSE THE SEGMENT IN - (GO SUBJ3) ;ANOTHER FASHION. "SUBJ4" IS PLACED THE THE + (*GO SUBJ3) ;ANOTHER FASHION. "SUBJ4" IS PLACED THE THE ;SUBJECT CODE AFTER LOOKING FOR CLAUSES AND ;BEFORE NOUN GROUPS. DEFAULT CUTTING MECHANISM ;FOR VBL @@ -256,9 +264,9 @@ FDEC (FQ DECLAR) (SETR 'OBJ1 H C) ;DISPLACED PARTICLE THEN A GRAMMATICALLY BAD (PARSE PRT) ;FORM IS ASSUMED AND THE PIECES POPED OFF (FQ PRT DPRT) - (GO FINDOBJ2) + (*GO FINDOBJ2) POPRT(POPTO VG) - (GO FINDOBJ1) + (*GO FINDOBJ1) ;;;-------------------------- CHECK THE VERB FOR THE PASSIVE CONSTRUCTION CHECKPASV (: (AND (ISQ H PASV) @@ -268,7 +276,7 @@ FDEC (FQ DECLAR) NIL FINDFAKE2) (FQ ACTV) ;NOT PASV=ACTIVE - (GO FINDOBJ1) + (*GO FINDOBJ1) ;;; BE (FQ BE) @@ -304,7 +312,7 @@ FDEC (FQ DECLAR) NIL) (: (CANPARSE 1. NIL 'ITRNS) ONT NIL) GOOF1(OR GLOBAL-MESSAGE (ERTERR NEW TRANSITIVITY - FIRST OBJ)) - (GO FAIL) + (*GO FAIL) OBJ1REL (SETR 'OBJ1 (GETR 'RELHEAD PT) C) (REMOVE-F-PT 'REL-NOT-FOUND PT) @@ -355,15 +363,15 @@ FDEC (FQ DECLAR) (SETR 'RELHEAD (GETR 'QADJ PT) PT) (SETR 'QADJ NIL PT) (REMOVE-F-PT 'QADJ PT) - (GO ONT) + (*GO ONT) OBJ2REL (SETR 'OBJ2 (GETR 'RELHEAD PT) C) (REMOVE-F-PT 'REL-NOT-FOUND PT) (FQ OBJ2REL) - (GO ONT) + (*GO ONT) FIXSUBJECT (SETR 'SUBJECT (GETR 'OBJ1 C) H) - (GO ONT) + (*GO ONT) CHECKIT ;CHECK FOR THE POSSIBILITY THAT THE SUBJECT WAS (: (EQ (WORD (NB (GETR 'SUBJECT C))) 'IT) ;A DUMMY FUNCTION WORD ( "IT" ), AS IN "IT NIL ;WAS NICE TO SEE HIM."Q @@ -376,9 +384,9 @@ FDEC (FQ DECLAR) ONT) (FQ IT) (SETR 'LOGICAL-SUBJECT H C) ;THE CLAUSE IS THE REAL SUBJECT. - (GO ONT) + (*GO ONT) GOOF2(OR GLOBAL-MESSAGE (ERTERR NEW TRANSITIVITY - SECOND OBJECT)) - (GO FAIL) + (*GO FAIL) ;;; ;;;*************************************************************************************************** @@ -397,7 +405,7 @@ FDEC (FQ DECLAR) PREPSHORT) ;MOVE BACK TO A QUESTION-NOUNGROUP, THEN DOWN TIMEQ(RQ REL-NOT-FOUND) ;AND BACK TO THE NOUN. IF THAT NOUN IS "TIM1" (FQ TIMEQ) ;THEN ASSUME WE HAVE FOUND OUR RELATIVE ELEMENT. - (GO TONT) + (*GO TONT) ;;; PREPSHORT @@ -408,7 +416,7 @@ FDEC (FQ DECLAR) ;BE REMOVED IF THE PREPG DISCOVERS IT CAN'T FIND PONT (AND (NEXTWORD? 'BY) (PARSE PREPG AGENT) (FQ AGENT)) ;AN OBJECT (THE REMOVING WILL BE DONE WHILE IN (SETR 'LOGICAL-SUBJECT (GETR 'OBJ1 H) C) ;PREPG). "LOGICAL" IE. SUBJECT IN RELATIONSHIP - (GO ONT1) ;TO THE PROPER SEMANTIC INTERPRETATION OF THE + (*GO ONT1) ;TO THE PROPER SEMANTIC INTERPRETATION OF THE ;MAIN VERB. AGENT-PREPG CAN BE PARSED (REFLECTS ;THE OPTIONALITY OF THE CONSTRUCTION) @@ -429,7 +437,7 @@ FDEC (FQ DECLAR) ;;;********************************** TIMW (: (AND (NQ TIMW) (PARSE ADV TIMW) - (OR (CALLSM (SMTIME)) (GO FAIL))) + (OR (CALLSM (SMTIME)) (*GO FAIL))) NIL NIL RETSM) @@ -437,13 +445,13 @@ FDEC (FQ DECLAR) ;;;************************************* ADV (: (AND (NOT (CQ BE)) (PARSE ADJG ADV) - (OR (CALLSM (SMRELATE H)) (GO FAIL))) + (OR (CALLSM (SMRELATE H)) (*GO FAIL))) NIL NIL RETSM) ;;;************************************** TIME NOUN GROUP - (: (AND (PARSE NG TIME) (OR (CALLSM (SMTIME)) (GO FAIL))) + (: (AND (PARSE NG TIME) (OR (CALLSM (SMTIME)) (*GO FAIL))) NIL NIL RETSM) @@ -451,7 +459,7 @@ FDEC (FQ DECLAR) ;;;************************************* PLACE (: (AND (NQ PLACE) (PARSE ADV PLACE) - (OR (CALLSM (SMPLACE)) (GO FAIL))) + (OR (CALLSM (SMPLACE)) (*GO FAIL))) NIL NIL RETSM) @@ -459,7 +467,7 @@ FDEC (FQ DECLAR) ;;;************************************ BINDER (: (AND (NQ BINDER) (PARSE CLAUSE BOUND) - (OR (CALLSM (SMBIND)) (GO FAIL))) + (OR (CALLSM (SMBIND)) (*GO FAIL))) NIL NIL RETSM) @@ -467,7 +475,7 @@ FDEC (FQ DECLAR) ;;;************************************** TO CLAUSE (ADJUNCT) (: (AND (NEXTWORD? 'TO) (PARSE CLAUSE TO ADJUNCT) - (OR (CALLSM (SMTOADJ)) (GO FAIL))) + (OR (CALLSM (SMTOADJ)) (*GO FAIL))) NIL NIL RETSM) @@ -476,7 +484,7 @@ FDEC (FQ DECLAR) (: (EQ N POSITION-OF-PTW) NIL TONT RETSM) ;LOOP UNTILL NOTHING ELSE CAN BE PARSED (: (OR (NOT (CQ TOPLEVEL)) (NQ SPECIAL)) RETSM NIL) ;SPECIAL WORD (E.G. COMMA AND) COULD INDICATE A (ERT CLAUSE: SOMETHING LEFT OVER AT TOP LEVEL) ;CONJUNCTION OR A BINDER - (GO FAIL) + (*GO FAIL) ;;;**************************************************************************************** ;;; THERE @@ -494,7 +502,7 @@ FDEC (FQ DECLAR) (: (AND (NQ TIMW) (PARSE ADV TIMW)) NIL NIL (THEREQ)) (: (AND (PARSE VG) (ISQ MVB BE)) THERQ2 NIL) (RQ POLR2) - (GO NOTHE) + (*GO NOTHE) THERQ2 (FQ SUBJTQ) (FQ THERE) ; ;THIS MAY NOT INTERFACE PROPERLY @@ -506,18 +514,18 @@ FDEC (FQ DECLAR) (: (PARSE NG SUBJ SUBJT) NIL THERREL) (FQ THERE) (SETR 'SUBJECT H C) - (GO ONT) + (*GO ONT) ;;; THERREL (: (MOVE-PT C U (REL-NOT-FOUND)) NIL NOTHE) (SETR 'SUBJECT (GETR 'RELHEAD PT) C) (REMOVE-F-PT 'REL-NOT-FOUND PT) - (GO ONT) + (*GO ONT) NOTHE(RQ THERE) - (POP THERE) + (SPOP THERE) (AND (NQ ADV) (PARSE ADV PLACE)) - (GO THER2) + (*GO THER2) ;;;************************************************************************************************ ;;; @@ -532,10 +540,10 @@ FDEC (FQ DECLAR) ;;; IMPE (: (PARSE VG IMPER) NIL IMPOP) (FQ IMPER) - (GO VG1) + (*GO VG1) ;;; - IMPOP(: (POP NIL) IMPE (IMPOP)) + IMPOP(: (SPOP NIL) IMPE (IMPOP)) ;;;*************************************************************************************** ;;; @@ -550,7 +558,7 @@ FDEC (FQ DECLAR) (: (ISQ H QUEST) NIL QUEST) ;IF THE PREPG ISN'T THE QUESTION, TRY AGAIN "ON (SETR 'QADJ H C) ;THAT DAY, WHERE DID YOU GO?" -- MAYBE WE COULD ;MAKE USE OF THE COMMA CLUE. PREPQ IS HANDLED - (GO POLAR) ;MUCH LIKE QADJS LIKE WHEN AND WHERE THE REST OF + (*GO POLAR) ;MUCH LIKE QADJS LIKE WHEN AND WHERE THE REST OF ;THE QUESTION HAS THE SAME SYNTAX AS A POLAR ;(YES-NO). @@ -569,7 +577,7 @@ FDEC (FQ DECLAR) NIL) (FQ SHORTQUES) (CALLSM (SMADJQSHORT)) ;IF ALL THE SENTENCE CONSISTS OF IS THE QUESTION - ADJQS(GO RETURN) ;ADJECTIVE THEN WE SHOULD RETURN DIRECTLY + ADJQS(*GO RETURN) ;ADJECTIVE THEN WE SHOULD RETURN DIRECTLY ;;; NGQST(SETR 'RELHEAD H C) @@ -603,12 +611,12 @@ FDEC (FQ DECLAR) ;;THEN WE KNOW THAT IF ANOTHER VERB FOLLOWS THE NEXT NG WHEN ;;WE SHOULDN'T EXPECT ONE THAT WE HAVE MADE THE WRONG CHOICE ;;AND SHOULD REARRANGE OUR ANALYSIS - (COND ((PARSE VG NAUX) (FQ SUBJQ) (GO VG1)) - ((NQ VB) (FQ REL-NOT-FOUND) (GO POLAR)) + (COND ((PARSE VG NAUX) (FQ SUBJQ) (*GO VG1)) + ((NQ VB) (FQ REL-NOT-FOUND) (*GO POLAR)) (T (MOVE-PTW N PW) - (POP NG QUEST) + (SPOP NG QUEST) (CUT PTW) - (GO NGQUES))) ;POP BACK AND START FIGURING OUT THE QUESTION + (*GO NGQUES))) ;POP BACK AND START FIGURING OUT THE QUESTION QUEST2 ;ALL OVER AGAIN (: (AND (NEXTWORD? 'THERE) (PARSE NIL THERE)) THERQ @@ -623,7 +631,7 @@ FDEC (FQ DECLAR) NIL ;WORRIES ABOUT WHAT SHOULD HAPPEN IF THE SUBJECT SUBJ1) ;SEEMS TO FINISH THE SENTENCE (RQ REL-NOT-FOUND) - (GO BE) + (*GO BE) ;;;************* POLAR POLAR(: (AND (NQ VB) @@ -635,7 +643,7 @@ FDEC (FQ DECLAR) QCHOP) (OR (CQ QADJ) (GETR 'RELHEAD C) (FQ POLAR)) (FQ POLR2) - (GO QUEST2) + (*GO QUEST2) ;;; QCHOP(ERT CLAUSE: QCHOP) @@ -667,19 +675,19 @@ FDEC (FQ DECLAR) ;;; ;;; ;;; - SEC (COND ((CQ BOUND) (GO BOUND)) ;CHECK INITIAL FEATURES AND JUMP ACCORDINGLY - ((CQ TO) (GO TO)) - ((CQ RSQ) (GO RSQ)) - ((CQ REPORT) (GO REPORT)) - ((CQ ING) (GO ING)) - (T (MQ RSNG-TYPE) (GO FAIL))) + SEC (COND ((CQ BOUND) (*GO BOUND)) ;CHECK INITIAL FEATURES AND JUMP ACCORDINGLY + ((CQ TO) (*GO TO)) + ((CQ RSQ) (*GO RSQ)) + ((CQ REPORT) (*GO REPORT)) + ((CQ ING) (*GO ING)) + (T (MQ RSNG-TYPE) (*GO FAIL))) ;;; ;;; ;;; --------------- BINDER --------------- BOUND(: (PARSE BINDER) NIL (BOUND) (BINDER)) (SETQ LOCATIONMARKER N) ; DO THIS TO ACT LIKE MAJOR DECLARATIVE CLAUSE - (GO FDEC) ;"FDEC" IS NEAR THE TOP OF THE MAJOR CLAUSE + (*GO FDEC) ;"FDEC" IS NEAR THE TOP OF THE MAJOR CLAUSE ;;; ;;; @@ -692,24 +700,24 @@ FDEC (FQ DECLAR) (: (CQ PREPREL) NIL RSQ2) (PARSE PREPG PRONREL) ;THIS CALL IS BASED ON INFORMATION PASSED FROM (SETR 'QADJ H c) ;FAR AWAY AND EXPLAINED IN DETAIL IN THE CODE - (GO REPORT) ;FOR PREPOSITION GROUPS + (*GO REPORT) ;FOR PREPOSITION GROUPS ;;; RSQ2 (COND ((PARSE VG EN PASV) ;HAVING DETERMINED THAT THE VERB IS PASSIVE IF - (OR (ISQ MVB TRANS) (GO FAIL)) ;IT WERE NOT ALSO TRANSITIVE, THEN WE WOULDN'T + (OR (ISQ MVB TRANS) (*GO FAIL)) ;IT WERE NOT ALSO TRANSITIVE, THEN WE WOULDN'T (SETR 'SUBJECT (GETR 'RELHEAD C) C) ;KNOW WHAT TO DO WITH WHATEVER WAS PARSED AS A - (GO VG1)) ;SUBJECT - SO WE FAIL + (*GO VG1)) ;SUBJECT - SO WE FAIL ((PARSE VG ING) (SETR 'SUBJECT (GETR 'RELHEAD C) C) - (GO VG1)) - ((NQ PRONREL) (PARSE NG RELWD) (GO REL)) + (*GO VG1)) + ((NQ PRONREL) (PARSE NG RELWD) (*GO REL)) ((CQ COMPONENT) ; IN A COMPONENT RELATIVE THE RELWD MIGHT BE IN (SETR 'RELHEAD ;THE FIRST CLAUSE. (GETR 'RELHEAD (MOVE-PT C PC)) C) ; MAKE RELHEAD SAME AS PREVIOUS COMPONENT RSQ. - (GO REL)) - ((PARSE NG SUBJ) (FQ REL-NOT-FOUND) (GO SUBREG)) - (T (GO FAIL))) ;THIS REALLY ISN'T AN RSQ + (*GO REL)) + ((PARSE NG SUBJ) (FQ REL-NOT-FOUND) (*GO SUBREG)) + (T (*GO FAIL))) ;THIS REALLY ISN'T AN RSQ ;;; REL (SETR 'SUBJECT (GETR 'RELHEAD C) C) @@ -717,7 +725,7 @@ FDEC (FQ DECLAR) ;RELWORD, WAS JUST PROVEN WRONG SINCE WE CANNOT ;PARSE THE VG NEXT. SO WE REVISE OUR FEATURES (FQ REL-NOT-FOUND) ;AND JUMP TO PARSE A REAL FULL SUBJECT AS IN - (GO SUBJ) ;"...WHICH MARY THOUGHT WAS CHAUVANISTIC" AS + (*GO SUBJ) ;"...WHICH MARY THOUGHT WAS CHAUVANISTIC" AS ;OPPOSED TO "...WHICH WAS CHAUVANISTIC" ;;; --------------- TO --------------- @@ -749,13 +757,13 @@ FDEC (FQ DECLAR) REPORT (AND (NEXTWORD? 'THAT) (PARSE NIL THAT) (FQ THAT)) (SETQ LOCATIONMARKER N) ; DO THIS TO ACT LIKE MAJOR DECLARATIVE CLAUSE - (GO FDEC) + (*GO FDEC) ;;;****************************************************************** ;;; RETURN ;;;*********************************************************************** - RETSM(OR (CALLSM (SMCL2)) (GO FAIL)) - (GO RETURN)) + RETSM(OR (CALLSM (SMCL2)) (*GO FAIL)) + (*GO RETURN)) (PDEFINE NG NIL @@ -765,31 +773,31 @@ FDEC (FQ DECLAR) ;;; ;;; NGSTART ;EXAMINE INITIAL FEATURES AND JUMP TO - (COND ((CQ RELWD) (GO RELWD)) ;CORRESPONDING SPECIAL BLOCKS OF CODE - ((CQ QUEST) (GO QUEST)) - ((OR (NQ QDET) (NQ QPRON)) (FQ QUEST) (GO QUEST)) - ((CQ TIME) (GO TIME)) ;LOOK AT FIRST WORD - ((NQ PROPN) (GO PROPN)) - ((NQ TPRON) (GO TPRON)) - ((NQ EVERPRON) (GO EVERPRON)) - ((NQ PRON) (GO PRON))) + (COND ((CQ RELWD) (*GO RELWD)) ;CORRESPONDING SPECIAL BLOCKS OF CODE + ((CQ QUEST) (*GO QUEST)) + ((OR (NQ QDET) (NQ QPRON)) (FQ QUEST) (*GO QUEST)) + ((CQ TIME) (*GO TIME)) ;LOOK AT FIRST WORD + ((NQ PROPN) (*GO PROPN)) + ((NQ TPRON) (*GO TPRON)) + ((NQ EVERPRON) (*GO EVERPRON)) + ((NQ PRON) (*GO PRON))) ;;; ;;; ;;; ;;; - LOOK (COND ((NQ DET) (GO DET)) ;THIS POINT MAY BE JUMPED BACK TO - ((NQ NUM) (GO NUM)) - ((OR (NQ ING) (NQ EN) (NQ ADJ)) (GO ADJ)) - ((NQ CLASF) (GO CLASF)) - ((NQ NUMD) (GO NUMD)) - ((NEXTWORD? 'AT) (GO AT)) - ((NEXTWORD? 'AS) (GO AS)) - ((NQ NOUN) (GO NOUN)) - ((NQ TIMORD) (GO TIMORD)) + LOOK (COND ((NQ DET) (*GO DET)) ;THIS POINT MAY BE JUMPED BACK TO + ((NQ NUM) (*GO NUM)) + ((OR (NQ ING) (NQ EN) (NQ ADJ)) (*GO ADJ)) + ((NQ CLASF) (*GO CLASF)) + ((NQ NUMD) (*GO NUMD)) + ((NEXTWORD? 'AT) (*GO AT)) + ((NEXTWORD? 'AS) (*GO AS)) + ((NQ NOUN) (*GO NOUN)) + ((NQ TIMORD) (*GO TIMORD)) ((AND (CQ COMPONENT) (ISQ (MOVE-PT PC) QUEST)) - (GO QUEST)) - ((MQ START) (GO FAIL))) + (*GO QUEST)) + ((MQ START) (*GO FAIL))) ;;; ;;; @@ -806,7 +814,7 @@ FDEC (FQ DECLAR) (FQ DEF PROPNG) (: (ISQ H POSS) PROPS NIL) (: (AND NN (NQ PROPN)) PROPN NIL) - PROPS(OR (CALLSM (SMPROP)) (GO FAIL)) ;EXAMINE ITS SEMANTICS + PROPS(OR (CALLSM (SMPROP)) (*GO FAIL)) ;EXAMINE ITS SEMANTICS (: (ISQ H POSS) POSS PRAG) ;;; @@ -826,7 +834,7 @@ FDEC (FQ DECLAR) PRAG (SETR 'HEAD H C) (MOVE-PT H) (TRNSF NS NPL NFS NEG) ;MODIFY PN FEATURES TO CORRECT - (GO RETURN) ;NUMBER... + (*GO RETURN) ;NUMBER... ;;; ;;; @@ -837,7 +845,7 @@ FDEC (FQ DECLAR) (TRNSF NS NPL ANY NEG) (SETR 'HEAD C H) (AND NN (NQ ADJ) (PARSE ADJ)) - (GO SMNG) + (*GO SMNG) ;;; ;;; ----- WHATEVER, WHENEVER, WHEVER.... @@ -933,7 +941,7 @@ FDEC (FQ DECLAR) (NUM) INCOM) DET1 (COND ((ISQ H NS) (FQ NS)) (T (FQ NPL))) ;EXPLICIT CHECK FOR THE VALUE 1 - (OR NN (AND (FQ NUMBER) (GO INCOM))) + (OR NN (AND (FQ NUMBER) (*GO INCOM))) NUMBER (FQ DET) (: (NQ OF) OF ADJ) @@ -954,7 +962,7 @@ FDEC (FQ DECLAR) ;;;--------------- PREPG WITH "OF" --------------- OF (: (AND (NQ OF) (PARSE PREPG OF)) SMOF NONE) ;"FIVE OF THE BLOCKS" SMOF (FQ OF) - (: (OR (CALLSM (SMNGOF)) (NOT (POP))) RETSM INCOM) + (: (OR (CALLSM (SMNGOF)) (NOT (SPOP))) RETSM INCOM) ;;; ;;; @@ -968,14 +976,14 @@ FDEC (FQ DECLAR) (AND (ISQ H COMPAR) (FQ COMPARATIVE-MODIFIER) (SETR 'COMPARATIVE-MODIFIER H C)) - (GO ADJ) + (*GO ADJ) EPR (: (OR (ISQ H SUP) (ISQ H COMPAR)) NIL CLASF INCOM) ;WE PARSED AN ADJ AND RAN OUT OF WORDS (FQ ADJ) (AND (NEXTWORD? 'OF) (PARSE PREPG OF) - (OR (CALLSM (SMNGOF)) (GO FAIL)) + (OR (CALLSM (SMNGOF)) (*GO FAIL)) (FQ OF) - (GO RETSM)) + (*GO RETSM)) ;;; ;;; @@ -1037,7 +1045,7 @@ FDEC (FQ DECLAR) ;;; ;;; (: (AND (CQ OBOFJ) (NOT (CQ DEF))) FAIL NIL) ;JUST PARSED - (OR (CALLSM (SMNG1)) (GO FAIL)) + (OR (CALLSM (SMNG1)) (*GO FAIL)) (: (NOT (ISQ H POSS)) NIL POSS RETSM) ;CHECK FOR POSSIVE ;;; @@ -1059,7 +1067,7 @@ FDEC (FQ DECLAR) (: (AND (NEXTWORD? 'TO) (MEET FE '(COMP SUBJ)) (PARSE CLAUSE RSQ TO) - (OR (CALLSM (SMRELATE H)) (GO POPRET))) + (OR (CALLSM (SMRELATE H)) (*GO POPRET))) RETSM NIL) @@ -1074,7 +1082,7 @@ FDEC (FQ DECLAR) (CQ SUBJ) ;THEM OVER AND HACK THEM PROPERLY (ISQ (MOVE-PT C PV) AUX) (ISQ PT BE) - (GO POPRET)) ;AVOIDS ATTACHING MODIFIER WHEN IT GOBBLES TO + (*GO POPRET)) ;AVOIDS ATTACHING MODIFIER WHEN IT GOBBLES TO (: (CALLSM (SMRELATE H)) RSQ-TO POPRET RETSM) ;MUCH E.G. IS THE BLOCK ON THE TABLE? DOESN'T ;WNAT "THE BLOCK ON THE TABLE" AS A CONSTITUENT. ;I ADMIT ITS A HACK. @@ -1096,7 +1104,7 @@ FDEC (FQ DECLAR) (ISQ (MOVE-PT C PV) AUX) (ISQ PT BE) (NOT (ISQ (MOVE-PT U) NGQ)) - (GO POPRET)) + (*GO POPRET)) (: (CALLSM (SMRELATE H)) RSQ-TO POPRET RETSM) ;;; @@ -1137,26 +1145,26 @@ FDEC (FQ DECLAR) ;; IF AT FIRST YOU DON'T SUCEED....... ;;;-------------------------------------------------- RED0 (SETQ FE T1) - RED1 (POP) - RED2 (COND ((NULL H) (MQ NO) (GO FAIL)) - ((ISQ H NUMBER) (GO INCOM)) + RED1 (SPOP) + RED2 (COND ((NULL H) (MQ NO) (*GO FAIL)) + ((ISQ H NUMBER) (*GO INCOM)) ((AND (ISQ H POSS) (OR (ISQ H PRON) (AND (MOVE-PT H DLC) (ISQ PT PRON)))) - (POP) - (GO PRON2)) - ((AND (NULL (CDR H)) (CQ DEFPOSS)) (GO POSSDEF)) - ((AND (CQ QUEST) (NULL (CDR H))) (GO QDETCHECK)) ;(CDR H) = T IF THERE IS ONLY ONE DAUGHTER TO - ((ISQ H ADJ) (GO EPR)) ;THE CURRENT NODE - ((NOT (ISQ H CLASF)) (GO INCOM))) - REDUC(POP) + (SPOP) + (*GO PRON2)) + ((AND (NULL (CDR H)) (CQ DEFPOSS)) (*GO POSSDEF)) + ((AND (CQ QUEST) (NULL (CDR H))) (*GO QDETCHECK)) ;(CDR H) = T IF THERE IS ONLY ONE DAUGHTER TO + ((ISQ H ADJ) (*GO EPR)) ;THE CURRENT NODE + ((NOT (ISQ H CLASF)) (*GO INCOM))) + REDUC(SPOP) (: (AND (NULL H) (NQ PROPN)) PROPN NOUN) ;;; ;;; ;;; POPCOM - (POP) + (SPOP) ;;; ;;;--------------- INCOMPLETE PHRASES --------------- @@ -1167,12 +1175,12 @@ FDEC (FQ DECLAR) (: (AND (NULL CUT) (CQ NUM)) SMNG NIL) QDETCHECK (COND ((AND (ISQ H QDET) (ISQ (NB H) QPRON)) - (POP) - (GO QPRON)) + (SPOP) + (*GO QPRON)) ((AND (ISQ H QDET) (ISQ (NB H) EVERPRON)) - (POP) - (GO EVERPRON))) - (GO FAIL) + (SPOP) + (*GO EVERPRON))) + (*GO FAIL) ;;; ;;; @@ -1182,7 +1190,7 @@ FDEC (FQ DECLAR) ;;;-------------------------------------------------- ;; POSSESSIVE HANDLER ;;;-------------------------------------------------- - POSS (OR (CALLSM (SMNG2)) (GO FAIL)) + POSS (OR (CALLSM (SMNG2)) (*GO FAIL)) POSS2(: (CQ INGSUBJ) RETSM NIL) (SETQ H (BUILDNODE (REVERSE (CONS 'POSS ;IF POSSESSIVE, ALL PREVIOUS MODIFIERS MODIFY (SETDIF FE ;THE POSSESSIVE NOUN, NOT THE NG HEAD @@ -1217,7 +1225,7 @@ possdef ;the placement of this tag is a QUEST(: (PARSE NIL HOW) NIL QDET FAIL) (: (PARSE NIL MANY) NIL FAIL INCOM) (FQ DET NPL INDEF HOWMANY) - (GO OF) + (*GO OF) QDET (: (AND (PARSE DET QDET) (FQ DET NPL QDET NS)) QNUM NIL @@ -1241,27 +1249,27 @@ possdef ;the placement of this tag is a ;;; ;;;- POPRET - (POP) + (SPOP) ;;; ;;;-------------------------------------------------- ;; RETURN AFTER CALLING SMNG2 TO PROCESS THE COMPLETED NOUN ;;GROUP ;;;-------------------------------------------------- - RETSM(OR (CALLSM (SMNG2)) (GO TRYA)) - (GO RETURN) + RETSM(OR (CALLSM (SMNG2)) (*GO TRYA)) + (*GO RETURN) ;;; ;;; ;;; ;;;--------------- YOU PROBABLY GOOFED, CUT AND TRY AGAIN. -------------- TRYA (: (ISQ H NOUN) NIL (TRYA)) - (POP) + (SPOP) (CUT N) - UP (: (POP) UP NIL) ;POP EVERYTHING OFF + UP (: (SPOP) UP NIL) ;POP EVERYTHING OFF (SETQ FE (REVERSE REST)) (SMSET NIL) - (GO NGSTART)) + (*GO NGSTART)) (PDEFINE VG (TENSE) @@ -1273,24 +1281,24 @@ possdef ;the placement of this tag is a ;;;-------------------------------------------------- ;;; ENTERING-VG - (COND ((CQ TO) (GO TO)) - ((CQ EN) (GO EN)) - ((CQ ING) (GO ING)) - ((CQ IMPER) (GO IMPER)) - ((ISQ (MOVE-PT C U) POLR2) (GO POLR2))) ;CHECKS IF THE CLAUSE IS MARKED AS POLR2 + (COND ((CQ TO) (*GO TO)) + ((CQ EN) (*GO EN)) + ((CQ ING) (*GO ING)) + ((CQ IMPER) (*GO IMPER)) + ((ISQ (MOVE-PT C U) POLR2) (*GO POLR2))) ;CHECKS IF THE CLAUSE IS MARKED AS POLR2 ;;; ;;; ;;; ;;;--------------- DISPATCH TABLE FOR EXAMINEING THE FIRST WORD --------------- NEW ;PARSE THE FIRST WORD WITH APPROPRIATE FEATURES - (COND ((NOT (NQ VB)) (MQ VB) (GO FAIL)) ;AND JUMP TO CODE THAT KNOWS WHAT SHOULD BE - ((AND (NQ DO) (PARSE VB AUX DO)) (GO DO)) ;LOOKED FOR NEXT IN EACH CASE - ((AND (NQ MODAL) (PARSE VB AUX MODAL)) (GO MODAL)) - ((AND (NQ WILL) (PARSE VB AUX WILL)) (GO WILL)) - ((AND (NQ BE) (PARSE VB AUX BE)) (GO BE)) - ((AND (NQ HAVE) (PARSE VB AUX HAVE)) (GO HAVE)) - ((NOT (PARSE VB (MVB))) (MQ VB) (GO FAIL))) + (COND ((NOT (NQ VB)) (MQ VB) (*GO FAIL)) ;AND JUMP TO CODE THAT KNOWS WHAT SHOULD BE + ((AND (NQ DO) (PARSE VB AUX DO)) (*GO DO)) ;LOOKED FOR NEXT IN EACH CASE + ((AND (NQ MODAL) (PARSE VB AUX MODAL)) (*GO MODAL)) + ((AND (NQ WILL) (PARSE VB AUX WILL)) (*GO WILL)) + ((AND (NQ BE) (PARSE VB AUX BE)) (*GO BE)) + ((AND (NQ HAVE) (PARSE VB AUX HAVE)) (*GO HAVE)) + ((NOT (PARSE VB (MVB))) (MQ VB) (*GO FAIL))) ;;; ;;; @@ -1308,7 +1316,7 @@ possdef ;the placement of this tag is a '(PAST-PRESENT)) ;IN THE DISPATCH TABLE JUST ABOVE ((ISQ PT PAST) '(PAST)) (T '(PRESENT)))) - (GO REV) + (*GO REV) ;;; ;;; @@ -1321,7 +1329,7 @@ possdef ;the placement of this tag is a (: (OR (PARSE NIL TO) (CQ TODEL)) NIL (TO) (TO)) ;THE AGREEMENT CHECKER AT THE END OF THE PROGRAM ;("REV") WILL NOT BE APPLIED "TODEL" MUST BE (SETQ TENSE '(INFINITIVE)) ;GIVEN AS AN INITIAL FEATURE OR ELSE THIS - (GO MODAL2) ;STATEMENT FAILS TENSE IS USED TO HOLD THE TENSE + (*GO MODAL2) ;STATEMENT FAILS TENSE IS USED TO HOLD THE TENSE ;WHILE IT IS BEING COLLECTED. ;;; @@ -1347,7 +1355,7 @@ possdef ;the placement of this tag is a INGADV (: (OR (PARSE ADV TIMW) (PARSE ADV VBAD)) INGADV NIL) (SETQ TENSE '(PRESENT)) - (GO BE2) + (*GO BE2) ;;; ;;; @@ -1368,16 +1376,16 @@ possdef ;the placement of this tag is a ;;;--------------- POLR2 --------------- POLR2 ;THE CLAUSE COULD ONLY BE MARKED AS "POLR2" (OR (SETQ PT (GETR 'QAUX (MOVE-PT C U))) ;("DID THE...?") IF AN AUX OF SOME VERIETY HAD - (AND (BUG VG:POLR2) (GO FAIL))) ;ALREADY BEEN PARSED, IF THAT IS NOT THE CASE, + (AND (BUG VG:POLR2) (*GO FAIL))) ;ALREADY BEEN PARSED, IF THAT IS NOT THE CASE, (SETQ H (LIST (CAR PT))) ;THEN WE HAVE A BUG IN THE PROGRAM SOMEWHERE SET (TRNSF NEG) ;THE INITIAL DAUGHTER OF THE VG TO BE THE - (COND ((ISQ H DO) (GO DO)) ;PREVIOUSLY PARSED AUX MARK THE VG AS NEG IF - ((ISQ H MODAL) (GO MODAL)) ;APPROPRIATE (SEE PROGMR FILE FOR THE OPPERATION - ((ISQ H WILL) (GO WILL)) ;OF THIS FUNCTION) DISPATCH TABLE , CHECKING THE - ((ISQ H BE) (GO BE)) ;AUX - ((ISQ H HAVE) (GO HAVE))) + (COND ((ISQ H DO) (*GO DO)) ;PREVIOUSLY PARSED AUX MARK THE VG AS NEG IF + ((ISQ H MODAL) (*GO MODAL)) ;APPROPRIATE (SEE PROGMR FILE FOR THE OPPERATION + ((ISQ H WILL) (*GO WILL)) ;OF THIS FUNCTION) DISPATCH TABLE , CHECKING THE + ((ISQ H BE) (*GO BE)) ;AUX + ((ISQ H HAVE) (*GO HAVE))) (ERT BUG VG:POLR2VB) ;NOTHING BUT UNGRAMATICAL NONSENSE SHOULD REACH - (GO FAIL) ;THIS POINT + (*GO FAIL) ;THIS POINT ;;; ;;; @@ -1408,7 +1416,7 @@ possdef ;the placement of this tag is a DO2 (: (AND (PARSE NIL NOT) (FQ NEG)) NIL NIL (NOT)) ADV2 (: (OR (PARSE ADV TIMW) (PARSE ADV VBAD)) ADV2 NIL (ADV)) (: (PARSE VB (MVB) INF) NIL MVB) ;"MVB" ARRANGES FOR A CHECK TO INSURE THAT THE - (GO REV) ;VERB BEING PARSED CAN BE A MAIN VERB + (*GO REV) ;VERB BEING PARSED CAN BE A MAIN VERB ;;; ;;; @@ -1425,8 +1433,8 @@ possdef ;the placement of this tag is a ;;; (COND ((PARSE VB BE INF) (GOCOND BE2 MVB)) ;DISPATCH TABLE FOR THE NEXT VERB ((PARSE VB HAVE INF) (GOCOND HAV2 MVB)) - ((PARSE VB INF (MVB)) (GO REV)) - (T (GO INCOMP))) + ((PARSE VB INF (MVB)) (*GO REV)) + (T (*GO INCOMP))) ;;; ;;; @@ -1454,14 +1462,14 @@ possdef ;the placement of this tag is a ADV4 (: (OR (PARSE ADV TIMW) (PARSE ADV VBAD)) ADV4 NIL (ADV)) ;;; - (COND ((AND (NEXTWORD? 'GOING) (PARSE VB)) (GO GOING)) ;"...WILL BE GOING TO..." + (COND ((AND (NEXTWORD? 'GOING) (PARSE VB)) (*GO GOING)) ;"...WILL BE GOING TO..." ((AND (NQ BE) (PARSE VB ING)) ;"BE BEING" (SETQ TENSE (CONS 'PRESENT TENSE)) - (GO EN2)) ;AS IN "BE BEING X'EN(ED)" + (*GO EN2)) ;AS IN "BE BEING X'EN(ED)" ((AND (NQ ING) (PARSE VB ING (MVB))) ;"BE X'ING" (SETQ TENSE (CONS 'PRESENT TENSE)) - (GO REV)) - ((CQ ING) (MQ ING) (GO FAIL)) ;IF TRUE, IT IMPLYS THAT WE STARTED OFF WITH + (*GO REV)) + ((CQ ING) (MQ ING) (*GO FAIL)) ;IF TRUE, IT IMPLYS THAT WE STARTED OFF WITH ) ;"BEING" - AS IN "BEING EATEN CAN BE UNPLEASANT" ;- OTHERWISE IT IMPLYS THAT WE HAVE SOMETHING ;OTHER THAN A VG ON OUR HANDS AND SHOULD FAIL TO @@ -1477,7 +1485,7 @@ possdef ;the placement of this tag is a EN2 (: (PARSE VB EN (MVB)) NIL MVBE) ;THIS ASKS -DO WE HAVE A VERB IN ITS EN FORM ;WHICH CAN ACT AS A MAIN VERB (IN WHICH CASE IT (FQ PASV) ;IS MARKED AS PASSIVE AND WE RETURN)OTHERWISE - (GO REV) ;CHECK IF THE VERB BEING POINTED AT IS A + (*GO REV) ;CHECK IF THE VERB BEING POINTED AT IS A ;LEGITIMATE FORM OF "BE" IN ITS MAIN VERB SENSE ;- WHICH IS DONE AT "MVBE" @@ -1489,12 +1497,12 @@ possdef ;the placement of this tag is a ;;;--------------- GOING --------------- GOING(: (PARSE NIL TO) NIL GOI) (: (NQ INF) GOING2 NIL NIL) - (POP) + (SPOP) GOI (SETQ TENSE (CONS 'PRESENT TENSE)) ;WE HAVE DETERMINED THAT "GOING" IS THE ACTUAL - (GO MVB) ;MAIN VERB AND SHOULD BE PARSED AS SUCH + (*GO MVB) ;MAIN VERB AND SHOULD BE PARSED AS SUCH GOING2 (SETQ TENSE (CONS 'FUTURE TENSE)) ;HERE WE DETERMINE THAT THE PHRASE IS ACTUALLY - (GO MODAL2) ;OF THE FORM "...IS GOING TO FALL IN LOVE..." + (*GO MODAL2) ;OF THE FORM "...IS GOING TO FALL IN LOVE..." ;AND WE SHOULD RUN THROUGH THE DISPATCH TABLE AT ;"MODAL2" TO DETERMINE HOW TO CONTINUE @@ -1509,7 +1517,7 @@ possdef ;the placement of this tag is a ;ARE NONE THEN CONTINUE AT "MVB" IF WHAT YOU ARE ;POINTING TO (THE "QAUX") IS NOT A FORM OF "BE", (SETMVB PT) ;THEN FAIL BECAUSE OF THE UNGRAMATICALITY OF THE - (GO REV) ;CONSTRUCTION OF "BE"'S OTHERWISE MARK IT AS THE + (*GO REV) ;CONSTRUCTION OF "BE"'S OTHERWISE MARK IT AS THE ;MVB AND PREPARE TO RETURN ;;; @@ -1530,7 +1538,7 @@ possdef ;the placement of this tag is a (GOCOND BE2 MVB) HAV3 (: (PARSE VB (MVB) EN) NIL MVB) (SETQ TENSE (CONS 'PAST TENSE)) ;"HAVE KISSED" - (GO REV) + (*GO REV) ;;; ;;; @@ -1540,7 +1548,7 @@ possdef ;the placement of this tag is a ;;;--------------- INCOM --------------- INCOMP (FQ INCOMP) - (GO FAIL) + (*GO FAIL) ;;; ;;; @@ -1549,9 +1557,9 @@ possdef ;the placement of this tag is a ;;; ;;;--------------- MVB --------------- MVB (: (EQ (FE MVB) (FE H)) MVB2 NIL) - (POP VB) ;POP OFF EVERY THING UNTILL YOU REACH A VERB + (SPOP VB) ;POP OFF EVERY THING UNTILL YOU REACH A VERB (: (PARSE VB (MVB)) NIL (MVB)) - MVB2 (GO REV) + MVB2 (*GO REV) ;;; ;;; @@ -1568,7 +1576,7 @@ possdef ;the placement of this tag is a (ISQ (MOVE-PT C U) IMPER) ;MOVE PT TO THE CLAUSE REMEMBER THAT THE POINTER (ISQ PT THERE) ;STAYS WHERE IT'S PUT UNTILL RETURNING FROM A (ISQ PT RSNG)) ;CALL TO PARSE - (GO NAUX)) + (*GO NAUX)) ((SETQ PT (GETR 'SUBJECT (MOVE-PT C U)))) ;"SUBJECT" IS THE SYNTACTIC SUBJECT OF THE (T (ERTERR VG -- NO SUBJECT TO CHECK FOR AGREEMENT))) ;CLAUSE THAT THE VG IS IN, WHOSE ESSENTIAL ;DISTINGUISHING FEATURE IS AGREEMENT WITH THE @@ -1584,8 +1592,8 @@ possdef ;the placement of this tag is a ;IF IT IS NIL THEN THEY WILL BE CONSIDERED TO ;AGREE ONLY IF THE FEATURE "PAST-PRESENT" IS ON (COND ((ISQ PT NFS) ;THE MVB, IN WHICH CASE, THIS IS EVIDENCE THAT - (OR (SETQ T3 (MEET FE '(VFS INF))) (GO NAGR))) ;THE PROPER CHOISE OF TENSE IS PAST - WHERE - ((ISQ PT CLAUSE) (OR (SETQ T3 (CQ V3PS)) (GO NAGR))) ;AGREEMENT IS IRRELEVANT (SEE BELOW AT "NAGR") + (OR (SETQ T3 (MEET FE '(VFS INF))) (*GO NAGR))) ;THE PROPER CHOISE OF TENSE IS PAST - WHERE + ((ISQ PT CLAUSE) (OR (SETQ T3 (CQ V3PS)) (*GO NAGR))) ;AGREEMENT IS IRRELEVANT (SEE BELOW AT "NAGR") ((OR (ISQ PT NS) (ISQ PT MASS)) (OR (AND (CQ V3PS) (SETQ T3 T)) (FESET PT (SETDIF (FE PT) '(NS MASS)))))) @@ -1626,7 +1634,7 @@ possdef ;the placement of this tag is a ;;; ;;;--------------- POPV --------------- POPV (ERT POPV) - (GO FAIL) + (*GO FAIL) ;;; ;;; @@ -1689,7 +1697,7 @@ possdef ;the placement of this tag is a ;;; ;GIVE IT A PARENT (SETR 'HEAD T1 C) ;SET THE REGESTER "PREP" TO THE CONSTITUENT JUST ;PARSED - IF IT WAS A MULTIPLE-WORD-PREP THEN - (OR NN (GO SHORT)) ;"PREP" IS SET TO THE NODE WHICH CONTAINS THE + (OR NN (*GO SHORT)) ;"PREP" IS SET TO THE NODE WHICH CONTAINS THE ;ENTIRE FORM NN POINTS TO WHATEVER WORDS ARE ;LEFT BEFORE THE CUT POINT @@ -1735,17 +1743,17 @@ possdef ;the placement of this tag is a ;UP THE BOTHERSOME PREPG AS AN INITIAL MODIFIER ;TO THE CLAUSE AND DEAL WITH IT APPROPRIATELY ;RESET THE FAILURE MESSAGE LIST (WE KNOW TO DO - (GO P-RELWRD) ;THIS BECAUSE THE "PRONREL" AS AN INITIAL + (*GO P-RELWRD) ;THIS BECAUSE THE "PRONREL" AS AN INITIAL PRONREL ;FEATURE OF THE CLAUSE IMPLICATES THE PASSAGE OF (REMOVE-F-PT 'REL-NOT-FOUND PT) ;THE PROS CESS DESCRIBED ABOVE) (ADD-F-PT 'PRONREL PT) P-RELWRD (PARSE NG RELWD OBJ) (SETR 'OBJ1 (GETR 'HEAD PT) C) ;THE REGISTER IS ACCESSED BY CODE IN THE PASSIVE - (GO RETT) ;SECTION OF CLAUSE AND BY THE APPROPRIATE + (*GO RETT) ;SECTION OF CLAUSE AND BY THE APPROPRIATE REST (: (PARSE CLAUSE RSNG ING) OBJR SHORT) ;SEMANTIC SPECIALIST "HEAD" IS HERE THE HEAD OF OBJR (SETR 'OBJ1 H C) ;THE HIGHER NOUNGROUP - (GO RETT) + (*GO RETT) ;;; ;;; @@ -1753,7 +1761,7 @@ possdef ;the placement of this tag is a SHORT(: (MEET FE '(NOSHORT Q)) (SHORT) NIL) (OR (ISQ (MOVE-PT C U) REL-NOT-FOUND) (ISQ (GETR 'QUESTION-ELEMENT PT) QADJ) - (GO FAIL)) + (*GO FAIL)) (REMOVE-F-PT 'REL-NOT-FOUND PT) (ADD-F-PT 'PREPREL PT) (SETR 'OBJ1 (GETR 'RELHEAD (MOVE-PT C U)) C) @@ -1799,7 +1807,7 @@ possdef ;the placement of this tag is a (: (ISQ (MOVE-PT C U) THAN) NIL DISP) ;THE WORD "THAN" WAS DETECTED BY THE IMMEDIATELY ;UPSTAIRS NG AS FOLLOWING THE HEAD NOUN (SETR 'HEAD (GETR 'COMPARATIVE-MODIFIER PT) C) ;INDICATING A STURCTURE SUCH AS "..A BIGGER - (GO THAN) ;BLOCK THAN THAT ONE..." "HEAD REFERS TO THE + (*GO THAN) ;BLOCK THAN THAT ONE..." "HEAD REFERS TO THE ;ADJG'S HEAD ADJECTIVE ;;; @@ -1838,11 +1846,11 @@ possdef ;the placement of this tag is a ;FORMS IS CHECKED FOR ;;;------------------ THAN ---------- - THAN (COND ((NOT NN) (GO RETSM))) + THAN (COND ((NOT NN) (*GO RETSM))) (: (PARSE NIL THAN) NIL RETSM (THAN)) (RQ THANNEED) ;THE FEATURE "THANNEEED" MARKS THAT THE WORD (FQ THAN) ;"THAN" IS EXPLICITLY REQUIRED IN THE PHRASE. - (GO SUBJ) + (*GO SUBJ) ;;;-------------------- AS ------- AS (FQ AS) @@ -1858,8 +1866,8 @@ possdef ;the placement of this tag is a (: (CHECK-AGREEMENT H (CDR H)) ;CHECKS FOR AGREEMENT IN NUMBER AND PERSON RETSM ;BETWEEN THE NG PARSED AS SUBJ AND THE NIL) ;JUST-PARSED VERB - (POP) - (GO RETSM) + (SPOP) + (*GO RETSM) ;; AT PRESENT, THIS ENTIRE ROUTINE IS INADIQUATE IN SEVERAL ;;RESPECTS: THE EXISTING BACKUP MECHANISM CORRECTLY REFUSES @@ -1875,8 +1883,8 @@ possdef ;the placement of this tag is a ;;; ;;; ;;; - POPAD(POP) ;IF THE CUT POINT WAS HIT HAVING ONLY PARSED - (GO ADJ) ;ADVERBS, POP OFF THE FINAL ADV AND TRY TO + POPAD(SPOP) ;IF THE CUT POINT WAS HIT HAVING ONLY PARSED + (*GO ADJ) ;ADVERBS, POP OFF THE FINAL ADV AND TRY TO ;REPARSE IT AS AN ADJECTIVE ;;;----------------------- FINAL CHECKS ON COMPARATIVES (SEMANTIC AND OTHERWISE) @@ -1891,7 +1899,7 @@ possdef ;the placement of this tag is a (T (RETURN NIL))))) (DEFUN COMMA NIL - (COND ((SECONDWORD? '") (FLUSHME) T) ;IF " FOLLOWS, FLUSH COMMA AND CONTINUE + (COND ((SECONDWORD? '/") (FLUSHME) T) ;IF " FOLLOWS, FLUSH COMMA AND CONTINUE ((CONJ)) ; IF COMMA IS PART OF CONJOINED STRUCTURE, GREAT ((ISQ RE INIT) (FLUSHME) T) ;IF COMMA FOLLOWS INITIAL-TYPE PHRASE, FLUSH IT ;AND CONTINUE @@ -1923,7 +1931,7 @@ possdef ;the placement of this tag is a (CUT PTW)) (AND (OR (EQ PREV 'BUT) (EQ (CADR PREV) 'BUT)) (NEXTWORD? 'NOT) ;CHECK FOR BUT-NOT COMBINATION - (OR (FLUSHME) (GO LOSE2)) + (OR (FLUSHME) (*GO LOSE2)) (FQ NEGBUT)) (: (COND ((MEMQ (CAR REST) '(ADJ NUM NOUN PREP VB ADV)) @@ -1951,10 +1959,10 @@ possdef ;the placement of this tag is a ;;IF WE HAD COMMA FOLLOWED BY (AND OR BUT NOR) RETURN ;;THE LIST OF GOODIES WE'VE FOUND - (GO RETSM)) + (*GO RETSM)) ((EQ PREV '/,) - (COND ((NEXTWORD? COMMA) (FQ LIST) (GO UP)) - (T (GO LIST)))) + (COND ((NEXTWORD? COMMA) (FQ LIST) (*GO UP)) + (T (*GO LIST)))) ((MEMQ PREV '(AND OR NOR BUT)) (COND ((EQ BOTH (NB H)) (FQ BOTH))) (COND ((OR (NEXTWORD? 'BUT) @@ -1963,8 +1971,8 @@ possdef ;the placement of this tag is a (EQ PREV 'AND))))) ; IF THE 'BOTH' WORD WAS "AND", STOP PARSING (FQ LISTA) ; ELSE GO LOOK FOR THE NEXT COMPONENT (F PREV) - (GO UP)) - (T (GO LISTA))))) + (*GO UP)) + (T (*GO LISTA))))) LOSE2(: (CQ LISTA) LISTA NIL) LIST (: (AND (EQ PREV '/,) ;COME HERE FOR ABORTED LIST AND CHECK FOR (EQUAL (LENGTH H) 2.) ;APPOSITIVE @@ -1975,7 +1983,7 @@ possdef ;the placement of this tag is a (CONJOIN: HOPELESS LIST)) (FLUSHME) ;GET RID OF TRAILING COMMA (FQ APPOSITIVE) - (GO RETSM) + (*GO RETSM) LISTA(F PREV) RETSM(FQ COMPOUND) ;CALL SEMANTICS AND RETURN EVERY PARSED BY THIS (AND (GREATERP (LENGTH H) 2.) (FQ LIST)) ;GOODIE IS COMPOUND IF MORE THAN 2 COMPONENTS @@ -2038,7 +2046,7 @@ possdef ;the placement of this tag is a TYPE) '(R E P))) '(O B) - (LIST (COND ((EQ NUM 1.) + (LIST (COND ((= NUM 1.) '/1) (T '/2))))) VBFEAT)) @@ -2076,4 +2084,3 @@ possdef ;the placement of this tag is a (SETR REG H C))) (OR (NULL FEATURE) (F FEATURE)) (RETURN T)))) - \ No newline at end of file diff --git a/src/shrdlu/graphf.4 b/src/shrdlu/graphf.5 similarity index 99% rename from src/shrdlu/graphf.4 rename to src/shrdlu/graphf.5 index d22e7aeb2..97004104b 100644 --- a/src/shrdlu/graphf.4 +++ b/src/shrdlu/graphf.5 @@ -1,10 +1,8 @@ - - - (DECLARE (SPECIAL PH-BLOCKS GP-LINES GP-SURFACE PH-TURN-ON - DISPLAY-AS GP-HANDIT GP-NEWOBLOCAT MAKE-VERBOSE ) + DISPLAY-AS GP-HANDIT GP-NEWOBLOCAT MAKE-VERBOSE)) +(declare (GENPREFIX GP)) +(declare (muzzled t)) - (GENPREFIX GP) ) (DEFUN GP-PROJECT (X Y Z) (LIST (FIX (*$ 0.9 @@ -1119,13 +1117,3 @@ PRLOOP (DEFUN PLOT-DISPLAY NIL (PLOTLIST (MAPCAR (FUNCTION (LAMBDA (N) (GET (DISGORGE N) 'ARRAY))) (DISLIST)))) - - - - - - - - - -  diff --git a/src/shrdlu/loader.20 b/src/shrdlu/loader.21 similarity index 61% rename from src/shrdlu/loader.20 rename to src/shrdlu/loader.21 index d35f87ed2..7c1f49907 100644 --- a/src/shrdlu/loader.20 +++ b/src/shrdlu/loader.21 @@ -10,18 +10,15 @@ ;;; NEVER NOTICE) ;;; -;(setsyntax 44. 'single 44.) -(setsyntax 34. 'single 34.) -;(setsyntax 35. 'single 35.) -;(sstatus syntax 35. 1) +;(setsyntax 34. 'single 34.) (SETQ GC-OVERFLOW '(LAMBDA (X) T)) -(defun MAKOBLIST (x) +(defun makoblist (x) (cond ((null x) - (LISTARRAY obarray (- (cadr (arraydims 'obarray)) 129.))) + (listarray obarray (- (cadr (arraydims 'obarray)) 129.))) (t - (*ARRAY x 'OBARRAY)))) + (*array x 'obarray)))) (defun ioc fexpr (x) (cond @@ -50,7 +47,7 @@ (RETURN NIL))) (LOADX)) -(DEFUN LOADX NIL +(DEFUN LOADX () (PROG (*!?H *!?F *!?EOF) (SETQ *!?EOF (GENSYM)) (PRINT 'READING) @@ -62,7 +59,10 @@ (PROG2 (PRINT 'ERROR-IN-FILE) (PRINT *!?H))) (GO LOOP))) -(DEFUN FLOAD FEXPR (SPECS) +(defun fload2 (x) + (fload (cons x '(fasl dsk shrdlu)))) + +(DEFUN FLOAD (SPECS) (TERPRI) (PRINC (CAR SPECS)) (princ '/ ) @@ -87,7 +87,20 @@ (MAPC 'LOADER '(PLNR THTRAC)) (THINIT)) -(DEFUN LOADSHRDLU NIL +(defun planner-compiled () + (ALLOC '(LIST 320000 + FIXNUM 15000 + SYMBOL 15000 + array 500 + flonum 4000)) + (SETQ PURE NIL) + (setq car t) + (setq cdr t) + (SETQ THINF NIL THTREE NIL THLEVEL NIL) + (MAPC 'fload2 '(PLNR THTRAC)) + (THINIT)) + +(DEFUN LOADSHRDLU () (ALLOC '(LIST 320000 FIXNUM 15000 SYMBOL 15000 @@ -96,76 +109,69 @@ (SETQ PURE NIL) (setq car t) (setq cdr t) - (SETQ THINF NIL THTREE NIL THLEVEL NIL) + (SETQ THINF NIL THTREE NIL THLEVEL NIL NOSTOP NIL) (load '((lisp) slave fasl)) + (load '((lisp) format fasl)) + (load '((lisp) umlmac fasl)) (MAPC 'LOADER '(PLNR THTRAC)) - (THINIT) + (thinit) (setq errlist nil) ;removes micro-planner's fangs (MAPC 'LOADER '(SYSCOM MORPHO SHOW)) - (MAPC 'LOADER '(PROGMR GINTER GRAMAR DICTIO)) + (MAPC 'LOADER '(PROGMR PROGGO GINTER GRAMAR DICTIO)) (MAPC 'LOADER '(SMSPEC SMASS SMUTIL)) (LOADER 'NEWANS) (load 'blockp) + (load 'data2) (load 'blockl) + (LOADER 'SETUP) (load 'data) (load '((lisp) trace fasl)) + (let ((x nil)) nil) ; forces let to get loaded (load '((shrdlu) graphf fasl)) - (LOADER 'SETUP) (load '((lisp) grinde fasl)) 'CONSTRUCTION/ COMPLETED) -(defun loadparser nil +(DEFUN SHRDLU-COMPILED () + (ALLOC '(LIST 320000 + FIXNUM 15000 + SYMBOL 15000 + array 500 + flonum 3000)) + (SETQ PURE NIL) + (setq car t) + (setq cdr t) + (SETQ THINF NIL THTREE NIL THLEVEL NIL NOSTOP NIL) + (load '((lisp) slave fasl)) + (mapc 'fload2 '(plnr thtrac)) + (thinit) + (setq errlist nil) ;removes micro-planner's fangs + (mapc 'fload2 '(syscom morpho show)) + (mapc 'fload2 '(progmr proggo ginter gramar dictio)) + (mapc 'fload2 '(smspec smass smutil)) + (mapc 'fload2 '(newans blockp)) + (load 'data2) + (fload2 'blockl) + (LOADER 'SETUP) + (load 'data) + (load '((lisp) trace fasl)) + (let ((x nil)) nil) ; forces let to get loaded + (load '((shrdlu) graphf fasl)) + (load '((lisp) grinde fasl)) + (load '((lisp) mlmac fasl)) + 'COMPLETED) + +(defun loadparser () (mapc 'loader '(syscom morpho show)) - (mapc 'loader '(progmr ginter gramar dictio)) + (mapc 'loader '(progmr proggo ginter gramar dictio)) (loader 'setup) - (load parser > dsk shrdlu) ;load is defined on ddm;*load > + (loader 'parser) 'complete-call-setup-num-date) -(DEFUN PARSER-compiled NIL +(DEFUN PARSER-compiled () (SETQ PURE NIL) - (FLOAD FASL SYSCOM DSK SHRDLU) - (FLOAD FASL MORPHO DSK SHRDLU) - (FLOAD FASL SHOW DSK SHRDLU) - ;;; - (FLOAD FASL PROGMR DSK SHRDLU) - (FLOAD FASL GRAMAR DSK SHRDLU) - (LOADER 'DICTIO) - ;;; - (FLOAD TRACE FASL COM COM) - (FLOAD FASL SETUP DSK SHRDLU) - ;;; - (load parser > dsk shrdlu) + (mapc 'fload2 '(syscom morpho show)) + (mapc 'fload2 '(progmr proggo ginter gramar dictio)) + (load '((lisp) trace fasl)) + (loader 'setup) + (loader 'parser) 'PARSER-LOADED) - - - -(DEFUN SHRDLU-COMPILED () -(SETQ PURE NIL) -(FLOAD FASL SYSCOM DSK SHRDLU) -(FLOAD FASL MORPHO DSK SHRDLU) -(FLOAD FASL SHOW DSK SHRDLU) -;; -(FLOAD FASL PROGMR DSK SHRDLU) -(FLOAD FASL gRAMar DSK SHRDLU) -(LOADER 'DICTIO) -;; -(FLOAD FASL SMSPEC DSK SHRDLU) -(FLOAD FASL SMASS DSK SHRDLU) -(FLOAD FASL SMUTIL DSK SHRDLU) -;; -(FLOAD FASL NEWANS DSK SHRDLU) -;; -(FLOAD FASL PLNR DSK SHRDLU) -(LOADER 'THTRAC) -(THINIT) -(SETQ THINF NIL THTREE NIL THLEVEL NIL) -(setq errlist nil) -(FLOAD FASL BLOCKL DSK SHRDLU) -(LOADER 'BLOCKP) -(LOADER 'DATA) -;; -(FLOAD GRAPHF FASL DSK SHRDLU) -(FLOAD TRACE FASL COM COM) -(FLOAD FASL SETUP DSK SHRDLU) -'COMPLETED) - \ No newline at end of file diff --git a/src/shrdlu/macros.1 b/src/shrdlu/macros.1 new file mode 100644 index 000000000..e931676c1 --- /dev/null +++ b/src/shrdlu/macros.1 @@ -0,0 +1,31 @@ + (SSTATUS MACRO $ (QUOTE THREAD)) + (DEFUN THREAD ;FUNCTION FOR THE /$ READ MACRO + + ;;EXPANDS _ TO (THNV (READ)) EXPANDS A TO ASSERT ;EXPANDS G TO GOAL EXPANDS T TO THTBF THTRUE + NIL ;EXPANDS ? TO (THV (READ)) EXPANDS E TO (THEV + ;(READ)) + (PROG (CHAR) ;EXPANDS R TO THRESTRICT + + ;;TREATS & - - & AS A COMMENT + (RETURN (COND ((EQ (SETQ CHAR (READCH)) (QUOTE ?)) + (LIST (QUOTE THV) (READ))) + ((EQ CHAR (QUOTE E)) + (LIST (QUOTE THEV) (READ))) + ((EQ CHAR (QUOTE _)) + (LIST (QUOTE THNV) (READ))) + ((EQ CHAR (QUOTE &)) + (PROG NIL + CHLP (COND ((EQ (QUOTE &) (READCH)) + (RETURN (QUOTE (COMMENT))))) + (GO CHLP))) + ((EQ CHAR (QUOTE T)) + (QUOTE (THTBF THTRUE))) + ((EQ CHAR (QUOTE R)) (QUOTE THRESTRICT)) + ((EQ CHAR (QUOTE G)) (QUOTE THGOAL)) + ((EQ CHAR (QUOTE A)) (QUOTE THASSERT)) + ((EQ CHAR 'N) (LIST 'THANUM (READ))) + ((PRINT (QUOTE ILLEGAL-PREFIX)) + (PRINC (QUOTE $)) + (PRINC CHAR) + (PRINC (READ)) + (ERR NIL)))))) diff --git a/src/shrdlu/morpho.14 b/src/shrdlu/morpho.15 similarity index 94% rename from src/shrdlu/morpho.14 rename to src/shrdlu/morpho.15 index 5e50ab118..cce13eee2 100644 --- a/src/shrdlu/morpho.14 +++ b/src/shrdlu/morpho.15 @@ -1,7 +1,3 @@ - -(declare (genprefix morpho)) - - ;;;******************************************************************************** ;;; ;;; MORPHO - code for morphological analysis @@ -10,9 +6,14 @@ ;;; ;;;******************************************************************************** +(declare (genprefix morpho)) +(declare (*fexpr say bcwl buildwordlist ert bug ioc)) +(declare (*expr word meet sm help print2 % end-of-file-condition sta word mod)) +(declare (specials t)) +(declare (muzzled t)) (DEFUN ETAOIN NIL - (PROG (WORD NEWWORD CHAR ALTN ALREADY-BLGING-NEWWRD WRD LAST + (PROG (WORD NEWWORD CHAR ALTN ALREADY-BLGING-NEWRD WRD LAST NEXT Y WORD1 X RD POSS) THRU (SETQ SENT (SETQ WORD (SETQ PUNCT (SETQ POSS NIL)))) (PRINT 'READY) @@ -86,11 +87,11 @@ (AND WORD (GO WORD)) (GO PUNC))) (AND - (OR (AND (EQ CHAR '") + (OR (AND (EQ CHAR '/") (NOT ALREADY-BLGING-NEWRD) (SETQ NEWWORD (SETQ ALREADY-BLGING-NEWRD T)) (GO CHAR)) - (AND (EQ CHAR '") + (AND (EQ CHAR '/") ALREaDY-BLGING-NEWRD (NOT (SETQ ALREADY-BLGING-NEWRD NIL)) (GO WORD)) @@ -132,7 +133,7 @@ (CAR X))) ((EQ (CAR (LAST WORD)) '=) (BUILDWORD WRD - (COND ((MEMQ '" WORD) + (COND ((MEMQ '/" WORD) '(PROPN NS POSS)) ('(PROPN NS))) '((PROPN T)) @@ -143,15 +144,15 @@ ;;;--------------------------------------------- ;;; MORPHOLOGY CODE ;;;-------------------------------------------- - CUT (COND ((STA WORD '(T " N)) + CUT (COND ((STA WORD '(T /" N)) (SETQ RD (CDDDR WORD)) (SETQ WORD (CONS '* WORD)) (GO TRY)) - ((STA WORD '(S ")) + ((STA WORD '(S /")) (SETQ WORD (CDDR WORD)) (SETQ POSS WRD) (GO WORD)) - ((STA WORD '(")) + ((STA WORD '(/")) (SETQ WORD (CDR WORD)) (SETQ POSS WRD) (GO WORD)) @@ -255,13 +256,13 @@ 'SEMANTICS) ROOT) (CONS POSS SENT)) - ((BUILDWORD '"S + ((BUILDWORD '/"S ; CAN WE GENERALIZE IT??? '(VB BE V3PS PRES) (GET 'BE 'SEMANTICS) 'BE) - (CONS '"S (CONS WRD SENT))))) + (CONS '/"S (CONS WRD SENT))))) ((CONS WRD SENT)))) PUNC (COND (PUNCT (COND ((AND (EQ PUNCT '?) (NULL SENT)) @@ -284,7 +285,7 @@ (OR ALTN (SETQ NEWWORD NIL)) (GO PUNC))) (TERPRI) - (SAY *SORRY I DON/'T KNOW THE WORD ") + (SAY *SORRY I DON/'T KNOW THE WORD /") (PRINC WRD) (PRINC '/ /"/.) (TERPRI) @@ -332,8 +333,8 @@ ) (DEFUN ETNEW NIL - (AND (EQ (CAR WORD) '") - (EQ (CAR (LAST WORD)) '") + (AND (EQ (CAR WORD) '/") + (EQ (CAR (LAST WORD)) '/") (SETQ WRD (READLIST (CDR (REVERSE (CDR WORD))))) (BUILDWORD WRD '(NOUN NS) @@ -344,11 +345,9 @@ (SETQ CONSO '(B C D F G H J K L M N P Q R S T V W X Z)) -0. - (SETQ LIQUID '(L R S Z V)) -(SETQ PUNCL '(/. ? : /; " !)) +(SETQ PUNCL '(/. ? : /; /" !)) (SETQ RUBOUT (ASCII 127.)) @@ -362,4 +361,3 @@ (SETQ VOWEL '(NIL A E I O U Y)) (SETQ SPACE '/ ) -  \ No newline at end of file diff --git a/src/shrdlu/newans.80 b/src/shrdlu/newans.81 similarity index 95% rename from src/shrdlu/newans.80 rename to src/shrdlu/newans.81 index 7623e40e9..bd8a41e9f 100644 --- a/src/shrdlu/newans.80 +++ b/src/shrdlu/newans.81 @@ -1,14 +1,28 @@ -(declare (genprefix newans)) - ;;;################################################################ ;;; ;;; NEWANS - (new) Answering component ;;; ;;;################################################################ +(declare (genprefix newans)) +(declare (muzzled t)) +(declare (specials t)) +(declare (*fexpr global-err bug say ert move-pt sayify cq build isq)) +(declare (*expr print2 thval buildword markers propname h findb refer? oss? rss? tss? plnr-var + plnr-progify plnr-thconsify plnr-remtime negative? number? relations? + istense parsenode? and? or? plausibility? thval2 quotify rel? makesym plnr-junkify + dobackref action? evlis sm quantifier? qtype? n from plnr-findify plnr-describe + variable? nb getr parse2 mapbland ansrss? ambiguities? + markers? listify2 atomify parent?)) + +(declare (*expr ansthm plnr-andorify anseliminate enough-better ansunique ansorder onecheck + pluralize nameobj toplevel nameaction notell namesugar namelistx prepput + thval-mult pron-prt findreduce parap)) + +(eval-when (compile) + (load 'macros)) (DEFUN ANSWER (NODE) - ;;THE TOP LEVEL ANSWER FUNCTION CALLED TO CARRY OUT THE ;;RESULTS OF ANY INPUT SENTENCE, WHETHER COMMAND, QUESTION, OR ;;STATEMENT. @@ -151,9 +165,6 @@ TEST-LOOP (RELATIONS? RSS))) NIL)))) ;ANSTHM GENERATES THE APPROPRIATE ASSERTION OR ;THEOREM. - - - ;;;############################################################ (DEFUN ANSELIMINATE (ANSLIST) @@ -176,14 +187,14 @@ TEST-LOOP ((SETQ AMB (CDR AMB)) (GO UP)) (T (BUG ANSELIMINATE -- NO CONFLICT))) (TERPRI) - (SAY I/'M NOT SURE WHAT YOU MEAN BY ") + (SAY I/'M NOT SURE WHAT YOU MEAN BY /") (MAPC 'PRINT2 (FROM (NB (CADDAR AMB)) (N (CADDAR AMB)))) - (SAY " IN THE PHRASE ") + (SAY /" IN THE PHRASE /") (MAPC 'PRINT2 (FROM (NB (SETQ XX (PARENT? (CADDAR AMB)))) (N XX))) - (PRINC '") + (PRINC '/") (princ '/.) (TERPRI) (SAY DO YOU MEAN:) @@ -200,7 +211,7 @@ TEST-LOOP (SAY PLEASE TYPE ONE OF THE NUMBERS) (TERPRI) (GO READ))) - (SETQ POSSIBILITIES (NTH XX POSSIBILITIES)) + (SETQ POSSIBILITIES (NTH (sub1 XX) POSSIBILITIES)) (RETURN (MAPBLAND '(LAMBDA (ANS) @@ -317,8 +328,7 @@ TEST-LOOP PROCEED THIS AND - DON - 'T + DON/'T WORRY))) (SETQ ANSNAME (APPEND ANSNODE ANSNAME)) ; LEAVE NODE AROUND IT ACCESSABLE PLACE (PUTPROP (CAR (SM ANSNODE)) @@ -466,7 +476,7 @@ TEST-LOOP (ANSBUILD (PLUS PLAUS (PLAUSIBILITY? RSS)) (COND ((NULL ANS) '((SAY YES))) ((CONS '(SAY NO/, NOT) - (PREPPUT (NAMELIST PHRASE + (PREPPUT (NAMELISTX PHRASE 'INDEF ANS))))) T)) @@ -478,7 +488,7 @@ TEST-LOOP (ANSBUILD (PLUS PLAUS (PLAUSIBILITY? RSS) (COND (ANS 512.) (0.))) - (PREPPUT (NAMELIST PHRASE 'DEF ANS)) + (PREPPUT (NAMELISTX PHRASE 'DEF ANS)) T)) ((EQ TYPE 'INDEF) (SETQ NUM (NUMBER? REL)) @@ -500,7 +510,7 @@ TEST-LOOP (APPEND (AND (CDR ANS) (APPEND (NAMESUGAR LENGTH REL) '((PRINC ':)))) - (NAMELIST PHRASE + (NAMELISTX PHRASE 'INDEF ANS))))))))) ((NUMBERP NUM) @@ -513,7 +523,7 @@ TEST-LOOP (T (PREPPUT (APPEND (NAMESUGAR LENGTH REL) ;THE NUMBER IN THE SPECIFICATION. '((PRINC ':)))))) - (PREPPUT (NAMELIST PHRASE + (PREPPUT (NAMELISTX PHRASE 'INDEF ANS)))) ((EQ (CAR NUM) 'EXACTLY) @@ -625,7 +635,8 @@ TEST-LOOP ;;;############################################################ -(DEFUN ATOMIFY (X) (COND ((ATOM X) X) ((CDR X) X) ((CAR X)))) +; defined in SMUTIL +;(DEFUN ATOMIFY (X) (COND ((ATOM X) X) ((CDR X) X) ((CAR X)))) @@ -814,12 +825,6 @@ TEST-LOOP ;;;############################################################ - - - - - - (DEFUN NAMEACTION (TENSE EVENT) ;;THIS FUNCTION SETS UP A LIST OF S-EXPRESSIONS @@ -845,10 +850,13 @@ TEST-LOOP (CONS (SAYIFY (VBFIX 'GET T) ;S-EXPRESSIONS 'RID 'OF) - (NAMELIST-EVALED '(NIL) 'DEF OBJ1))) + (car (NAMELIST-EVALED '(NIL) 'DEF OBJ1)))) ((EQ VERB 'GRASP) (CONS (SAYIFY (VBFIX 'GRASP T)) - (NAMELIST-EVALED '(NIL) 'DEF OBJ1))) + (car (NAMELIST-EVALED '(NIL) 'DEF OBJ1)))) + ((eq verb 'ungrasp) + (cons (sayify (vbfix 'ungrasp t)) + (car (namelist-evaled '(nil) 'def obj1)))) ((EQ VERB 'PICKUP) (CONS (SAYIFY (VBFIX 'PUT T)) (PRON-PRT 'UP OBJ1))) @@ -883,7 +891,7 @@ TEST-LOOP ;;;############################################################ -(DEFUN NAMELIST (ONE SPEC LISTX) +(DEFUN NAMELISTX (ONE SPEC LISTX) ;;GENERATES A LIST OF EXPRESSIONS TO BE EVALUATED WHICH WILL ;;CAUSE THE APPROPRIATE NAMELIST TO BE PRINTED OUT. THE @@ -906,19 +914,18 @@ TEST-LOOP ;;;############################################################ (DEFUN NAMELIST-EVALED (ONE SPEC LISTX) -(PROG (F) -(SETQ F (LIST 'LISTNAMES -(QUOTIFY ONE) -(QUOTIFY SPEC) -(QUOTIFY LISTX))) -(RETURN (LIST (EVAL F))))) + (PROG (F) + (SETQ F (LIST 'LISTNAMES + (QUOTIFY ONE) + (QUOTIFY SPEC) + (QUOTIFY LISTX))) + (RETURN (LIST (EVAL F))))) ;;;############################################################ (DEFUN NAMENUM (X) - ;;GENERATES NUMBER NAMES - (OR (NTH (ADD1 X) + (OR (NTH X '(NONE ONE TWO THREE @@ -1147,8 +1154,6 @@ TEST-LOOP (MAPCAR 'PLNR-GOALIFY (RELATIONS? RSS)))))) - - ;;;############################################################ (DEFUN PREPPUT (X) @@ -1350,14 +1355,13 @@ TEST-LOOP ((SETQ LOOP (CDR LOOP)) (GO UP)) (ANS) ((RETURN NIL))) - DONE (AND (ATOM (VARIABLE? OSS)) + DONE + (AND (ATOM (VARIABLE? OSS)) (PUTPROP (VARIABLE? OSS) (REVERSE ANS) 'BIND)) (RETURN (ATOMIFY (REVERSE ANS))))) - - ;;;############################################################ (DEFUN FINDNUM (X) @@ -1383,6 +1387,11 @@ TEST-LOOP ;;;############################################################ +(DEFPROP SASS + (LAMBDA () + (QUOTE (NIL NIL))) + EXPR) + (DEFPROP IASS (LAMBDA (X) (PROG (XX) @@ -1398,7 +1407,7 @@ BY) (PRINC (COND ((EQ X (Quote IT)) (Quote "IT")) ((Quote "THEM")))) (SAY /, I ASSUME YOU) (PRINC (Quote MEAN)) - (MAPC (FUNCTION PRINT2) (PARAP XX)) + (MAPC (FUNCTION PRINT2) (PARAP)) (RETURN (PRINC (Quote /./ ))))) EXPR) @@ -1429,13 +1438,13 @@ BY) (PRINC (COND ((EQ X (Quote IT)) (Quote "IT")) (ERT NAMEVENT)) (OR (THVAL (LIST 'THGOAL - (COND ((EQ (CAR EV) 2.) + (COND ((= (CAR EV) 2.) '(? $?EVENT)) - ((EQ (CAR EV) 3.) + ((= (CAR EV) 3.) '(? $?EVENT (THNV SUBJ))) ((EQ (CAR EV) 'I3) '(? $?EVENT (THNV OBJ1))) - ((EQ (CAR EV) 4.) + ((= (CAR EV) 4.) '(? $?EVENT (THNV SUBJ) (THNV OBJ1))) @@ -1443,7 +1452,7 @@ BY) (PRINC (COND ((EQ X (Quote IT)) (Quote "IT")) '(? $?EVENT (THNV OBJ1) (THNV OBJ2))) - ((EQ (CAR EV) 5.) + ((= (CAR EV) 5.) '(? $?EVENT (THNV SUBJ) (THNV OBJ1) @@ -1461,7 +1470,7 @@ BY) (PRINC (COND ((EQ X (Quote IT)) (Quote "IT")) (FUNCTION (LAMBDA (X) (AND (CADR X) (SET (CAR X) - (ert undef-fn: names NAMES (LISTIFY (CADR X)) + (ert undef-fn: names NAMES (LISTIFY2 (CADR X)) 'EV))))) (CDR THALIST)) (SETQ ANSBACK2 (OR ANSBACK T)) @@ -1471,8 +1480,6 @@ BY) (PRINC (COND ((EQ X (Quote IT)) (Quote "IT")) '(TO))) (EVAL (CADR EV)))))) - - ;;;############################################################ (DEFUN PARAP () (ERT YOU LOSE/, PARAP IS FLUSHED UNTILL IT CAN BE FIGURED OUT)) @@ -1558,4 +1565,4 @@ BY) (PRINC (COND ((EQ X (Quote IT)) (Quote "IT")) (MEMQ (CAR X) CONSO) (MEMQ (CADR X) VOWEL) (LIST (CAR X)))) -  \ No newline at end of file + diff --git a/src/shrdlu/parser.12 b/src/shrdlu/parser.12 new file mode 100644 index 000000000..82a42da93 --- /dev/null +++ b/src/shrdlu/parser.12 @@ -0,0 +1,412 @@ +;;;################################################################ +;;; +;;; PARSER - setup file for parsing system in programmar +;;; +;;;################################################################ + +(defun setup (gram-num date) + (suspend) + (cursorpos 'c) + (terpri) + (princ 'shrdlu/'/s/ P/a/r/s/e/r/ / / ) + (princ '/u/s/i/n/g/ /g/r/a/m/m/a/r/ ) + (princ gram-num) + (terpri) + (princ date) + (princ '/ / lisp/ ) + (princ (status lispversion)) + (terpri) + (terpri) + (say this is a read-eval-print loop) + (say type "go/ " to enter ready state) + (*catch 'abort-parser (ert)) + (sstatus toplevel '(parser)) + (parser)) + + + +(setq makeintern t ;;; switch for interning the atoms created +;;; for the node structure + sh-standard-printout nil ;;; switch for evaluating display functions +;;; in the function SHSTPO (the SHOW file) + sh-afteranswer-pause t ;;; switch for causing a break after each +;;; sentence is processed. + ) + +(setq annoyance t ;;; turns off the [1] printouts in SHRDLU + smn t ;;; turns off evaluation by real smn-fns +)î + +(setq car t cdr t ;;; annoying patch to keep *RSET happy + ) + +(DEFUN parser NIL + (PROG (ERT-TIME END AMB TIMAMB BOTH BACKREF BACKREF2 ANSNAME + LASTREL WHO PT PTW SENT PUNCT IGNORE H N NB FE SM RE + MES MESP C CUT CURTIME STATE GLOBAL-MESSAGE LEVEL + P-TIME SMN-TIME PLNR-TIME ANS-TIME ANS-PLNR-TIME + SH-GCTIME) + (CLEANOUT TSS EVX NODE ANS OSS RSS X) ;FLUSH OLD GENSYMS + CATCH-LOOP + (*CATCH + 'ABORT-PARSER + (PROG NIL + LOOP (SETQ SENTNO (ADD1 SENTNO) + PARSINGS 0. + LEVEL 0. + LASTSENTNO (ADD1 LASTSENTNO) + LASTSENT C + GLOBAL-MESSAGE NIL + MES 'NOPE + BACKREF NIL ;??????????????????? + RUNTIME (RUNTIME) + SH-GCTIME (STATUS GCTIME) + PLNR-TIME 0. + ANS-PLNR-TIME 0. + SMN-TIME 0. + ERT-TIME 0.) + UP (SETQ N (SETQ SENT (ETAOIN))) + (OR ANNOYANCE (PRINT *1)) + (AND ^Q (%)) + ;(IOC S) + (setq ^q nil) + (AND IGNORE (GO UP)) + ;;; + (COND + ((AND + (COND + (TOPLEVEL-ERRSET? + (ERRSET + (SETQ PT (SETQ C (PARSEVAL PARSEARGS))))) + (T (SETQ PT (SETQ C (PARSEVAL PARSEARGS))))) + C) + (OR ANNOYANCE (PRINT *2)) + (SETQ FE (FE C)) + (SETQ NB SENT) + (SETQ H (H C)) + (SETQ INTERPRETATION (SM C)) +(terpri) +(princ 'time/ spent/ parsing/ ) +(princ p-time)) + ((PRINT *3) + (APPLY 'SAY + (OR GLOBAL-MESSAGE + '(I DON/'T UNDERSTAND/.))))) + (AND MOBYTEST-IN-PROGRESS (AFTER-EACH-SENTENCE)) + (AND SH-STANDARD-PRINTOUT (SHSTPO)) + (AND SH-AFTERANSWER-PAUSE (ERT)) + (GO LOOP))) + (GO CATCH-LOOP))) + + + + +(DEFUN ETAOIN NIL +;;; has a patch added to permit online definition +;;; of an unknown word's syntactic features +;;; + (PROG (WORD NEWWORD CHAR ALTN ALREADY-BLGING-NEWWRD WRD LAST features + NEXT Y WORD1 X RD POSS) + THRU (SETQ SENT (SETQ WORD (SETQ PUNCT (SETQ POSS NIL)))) + (PRINT 'READY) + (TERPRI) + (AND MOBYREAD + ;(IOC Q) + (setq ^q t) + ) + CHAR (COND ((EQUAL (TYIPEEK) 24.) (READCH) (ERT) (GO THRU)); "cntrl-x" break +;left over from CMU + ((= (tyipeek) 3.) +(or (and mobyread (end-of-file-condition)) + (bug etaoin: about to read eof)) ) +) + (setq char (cond ((greaterp 123. (setq char (tyi)) 96.) (- char 32.)) + ((greaterp 91. char 64.) char) + (t char)) + char (ascii char) + ;;this little hack maps all lowercase letters into uppercase. + ;;a more reasonable thing to do would be to hack the chtrans + ;;property of the current readtable, but this was quicker to + ;;patch. + ) + (cond ((EQ char '/ ) (GO WORD)) ;DELIMITER + ((MEMQ CHAR ALTMODE) + (setq char (ascii (uppercase-ify-char (tyi))) ) + (COND ((MEMQ char ALTMODE) + (ERT) + (GO THRU)) + ;ALTMODE-ALTMODE + ((EQ CHAR 'C) (TYO 12.) (GO DO)) + ;ALTMODE-C + ((EQ CHAR 'R) (TERPRI) (GO DO)) + ;ALTMODE-R + ((AND (EQ CHAR 'S) SAVESENT) + ;ALTMODE-S CAUSES THE LAST SENTENCE TYPED IN TO + (SETQ SENT (CAR SAVESENT)) + ;RETURNED AS THE SENTENCE TO BE INTERPRETED + (SETQ PUNCT (CDR SAVESENT)) + (%) + (RETURN SENT)) + ((EQ CHAR 'N) + (SETQ NEWWORD (NOT NEWWORD) + ALTN (NOT ALTN)) + (GO CHAR)) + ;ALTMODE-N COMPLEMENTS THE NEWWORD FLAG, WHICH + ((EQ CHAR 'Q) + ;DETERMINES WHETHER UNRECOGNIZED WORDS WILL BE + ;(IOC Q) + (setq ^q t) + ;CONSIDERED SPELLING ERRORS OR NEW WORDS. + (SETQ IGNORE NIL) + (GO THRU)) + ;ALTMODE-Q CAUSES READIN FROM DISK FILE. + ((EQ CHAR 'M) + ;(IOC Q) + (setq ^q t) + (SETQ IGNORE NIL MOBYREAD T) + (GO thru)) + ((EQ CHAR 'I) + (SETQ IGNORE T) + ;(IOC Q) + (setq ^q t) + (GO THRU)) + ;ALTMODE-I IGNORES SENTENCE READ FROM FILE. + ((GO THRU)))) + ((EQ CHAR RUBOUT) + (COND (WORD (PRINC (CAR WORD)) + (SETQ WORD (CDR WORD))) + (SENT (PRINT (CAR SENT)) + (SETQ SENT (CDR SENT)))) + (GO CHAR)) + ((EQ CHAR CARRET) (GO WORD)) + ((MEMQ CHAR PUNCL) + (SETQ PUNCT CHAR) + ;DELIMITER + (AND WORD (GO WORD)) + (GO PUNC))) + (AND + (OR (AND (EQ CHAR '") + (NOT ALREADY-BLGING-NEWRD) + (SETQ NEWWORD (SETQ ALREADY-BLGING-NEWRD T)) + (GO CHAR)) + (AND (EQ CHAR '") + ALREaDY-BLGING-NEWRD + (NOT (SETQ ALREADY-BLGING-NEWRD NIL)) + (GO WORD)) + ;WITHIN THIS "AND" ARE ALL THE CHARACTERS THAT + (NUMBERP CHAR) + ;ARE UNDERSTOOD BY THE SYSTEM + (AND (EQ CHAR '=) (NULL WORD)) + (MEMQ CHAR VOWEL) + (MEMQ CHAR CONSO)) + (SETQ WORD (CONS CHAR WORD))) + (GO CHAR) + DO (PRINT 'READY) + (TERPRI) + (MAPC (FUNCTION (LAMBDA (X) (PRINT2 X))) (REVERSE SENT)) + (PRINC '/ ) + (MAPC (FUNCTION PRINC) (REVERSE WORD)) + (GO CHAR) + WORD (COND ((NULL WORD) (GO CHAR)) + ((EQUAL WORD '(P L E H)) (HELP) (GO THRU)) + ((AND (SETQ WRD (ERRSET (READLIST (REVERSE WORD)))) + (NUMBERP (SETQ WRD (CAR WRD)))) + (SETQ SENT (CONS WRD SENT)) + (BUILDWORD WRD + (OR (AND (ZEROP (SUB1 WRD)) + '(NUM NS)) + '(NUM)) + (LIST 'NUM WRD) + NIL)) + ;NO ROOT FOR NUMBERS + ((NULL WRD) (SETQ WRD (REVERSE WORD)) (GO NO)) + ((GET WRD 'FEATURES)) + ;IF A WORD HAS FEATURES, IT'S PROPERTIES + ((SETQ X (GET WRD 'IRREGULAR)) + ;ARE ALL SET UP IN THE DICTIONARY + (BUILDWORD WRD + (MOD (GET (CAR X) 'FEATURES) + (CDR X)) + (SM X) + (CAR X))) + ((EQ (CAR (LAST WORD)) '=) + (BUILDWORD WRD + (COND ((MEMQ '" WORD) + '(PROPN NS POSS)) + ('(PROPN NS))) + '((PROPN T)) + NIL)) + ((GO CUT))) + (GO WRD) + + ;;;--------------------------------------------- + ;;; MORPHOLOGY CODE + ;;;-------------------------------------------- + CUT (COND ((STA WORD '(T " N)) + (SETQ RD (CDDDR WORD)) + (SETQ WORD (CONS '* WORD)) + (GO TRY)) + ((STA WORD '(S ")) + (SETQ WORD (CDDR WORD)) + (SETQ POSS WRD) + (GO WORD)) + ((STA WORD '(")) + (SETQ WORD (CDR WORD)) + (SETQ POSS WRD) + (GO WORD)) + ((STA WORD '(Y L)) + (SETQ RD (CDDR WORD)) + (GO LY)) + ((STA WORD '(G N I)) (SETQ RD (CDDDR WORD))) + ((STA WORD '(D E)) (SETQ RD (CDDR WORD))) + ((STA WORD '(N E)) (SETQ RD (CDDR WORD))) + ((STA WORD '(R E)) (SETQ RD (CDDR WORD))) + ((STA WORD '(T S E)) (SETQ RD (CDDDR WORD))) + ((STA WORD '(S)) + (SETQ RD (CDR WORD)) + (GO SIB)) + (T (GO NO))) + (SETQ LAST (CAR RD)) + (SETQ NEXT (CADR RD)) + (COND ((AND (MEMQ LAST CONSO) + (NOT (MEMQ LAST LIQUID)) + (EQ LAST NEXT)) + (SETQ RD (CDR RD))) + ((EQ LAST 'I) + (SETQ RD (CONS 'Y (CDR RD)))) + ((OR (AND (MEMQ LAST CONSO) + (MEMQ NEXT VOWEL) + (NOT (EQ NEXT 'E)) + (MEMQ (CADDR RD) CONSO)) + (AND (MEMQ LAST LIQUID) + (MEMQ NEXT CONSO) + (NOT (MEMQ NEXT LIQUID))) + (AND (EQ LAST 'H) (EQ NEXT 'T)) + (AND (MEMQ LAST '(C G S J V Z)) + (OR (MEMQ NEXT LIQUID) + (AND (MEMQ NEXT VOWEL) + (MEMQ (CADDR RD) VOWEL))))) + (SETQ RD (CONS 'E RD)))) + (GO TRY) + LY (COND ((AND (MEMQ (CAR RD) VOWEL) + (NOT (EQ (CAR RD) 'E)) + (MEMQ (CADR RD) CONSO)) + (SETQ RD (CONS 'E RD)))) + (COND ((MEMQ 'ADJ + (GET (SETQ ROOT (READLIST (REVERSE RD))) + 'FEATURES)) + (BUILDWORD WRD + '(ADV VBAD) + NIL + ;TEMP NIL SEMANTICS + ROOT) + ;ROOT IS THE ADJECTIVE + (GO WRD))) + (GO NO) + SIB (SETQ LAST (CAR RD)) + (SETQ NEXT (CADR RD)) + (COND ((NOT (EQ LAST 'E))) + ((EQ NEXT 'I) + (SETQ RD (CONS 'Y (CDDR RD)))) + ((EQ NEXT 'X) (SETQ RD (CDR RD))) + ((AND (EQ NEXT 'H) + (NOT (EQ (CADDR RD) 'T))) + (SETQ RD (CDR RD))) + ((AND (MEMQ NEXT '(S Z)) + (EQ NEXT (CADDR RD))) + (SETQ RD (CDDR RD)))) + TRY (COND + ((OR + (SETQ FEATURES + (GET (SETQ ROOT (READLIST (REVERSE RD))) + 'FEATURES)) + (AND (SETQ X (GET ROOT 'IRREGULAR)) + (SETQ FEATURES + (MOD (GET (SETQ ROOT (CAR X)) + 'FEATURES) + (CDR X))))) + (BUILDWORD WRD + (MOD FEATURES (GET (CAR WORD) 'MOD)) + (GET ROOT 'SEMANTICS) + ROOT)) + ((EQ (CAR RD) 'E) (SETQ RD (CDR RD)) (GO TRY)) + ((GO NO))) + + ;;;---------------------------------------------------- + ;;; BUILD UP THE PROCESSED LIST OF WORDS TO BE RETURNED + ;;;---------------------------------------------------- + WRD (SETQ + SENT + (COND (POSS (COND ((OR (MEMQ 'NOUN + (SETQ FEATURES + (GET WRD + 'FEATURES))) + ;IF IT'S A NOUN + (MEMQ 'PROPN FEATURES)) + ;OR A PROPER NOUN + (BUILDWORD POSS + (APPEND (MEET FEATURES + ;MARK IT AS POSSESSIVE + (GET 'POSS + 'ELIM)) + '(POSS)) + (GET WRD + 'SEMANTICS) + ROOT) + (CONS POSS SENT)) + ((BUILDWORD '"S + ; CAN WE GENERALIZE IT??? + '(VB BE V3PS PRES) + (GET 'BE + 'SEMANTICS) + 'BE) + (CONS '"S (CONS WRD SENT))))) + ((CONS WRD SENT)))) + PUNC (COND + (PUNCT (COND ((AND (EQ PUNCT '?) (NULL SENT)) + (HELP) + (GO THRU)) + ((MEMQ PUNCT FINAL) + (RETURN (CAR (SETQ SAVESENT + (CONS (REVERSE SENT) + ;RETURN POINT !!!!!!!!!!!!! + PUNCT))))) + ((SETQ SENT (CONS PUNCT SENT)))))) + (SETQ PUNCT NIL) + (SETQ WORD (SETQ POSS NIL)) + (GO CHAR) + NO (COND (NEWWORD (BUILDWORD WRD + '(NOUN NS) + '((NOUN (SMNEWNOUN)) + (PROPN (SMNEWPROPN))) + WRD) + (OR ALTN (SETQ NEWWORD NIL)) + (GO PUNC))) + (TERPRI) + (SAY *SORRY I DON/'T KNOW THE WORD ") + (PRINC WRD) + (PRINC '/ "/.) + (TERPRI) +(cond (define-online +(terpri) +(say what are its syntactic features?) +(setq features (read)) +(buildword wrd features 'dummy wrd) +(terpri) +(mapc '(lambda (w) (print2 w)) (reverse sent)) +(print2 wrd) +(princ '/ ) +(go char) +)) + (SAY PLEASE TYPE AND CONTINUE THE SENTENCE/.) + NOGO (OR (EQUAL (TYI) 10.) (GO NOGO)) + (SETQ PUNCT NIL WORD NIL) + (GO DO))) + + +(defun build fexpr (foo) + ;;; this is a semantic function which packages +;;; semantic nodes. + t ) + + \ No newline at end of file diff --git a/src/shrdlu/plnr.183 b/src/shrdlu/plnr.184 similarity index 89% rename from src/shrdlu/plnr.183 rename to src/shrdlu/plnr.184 index 559d419b5..8269b21fc 100644 --- a/src/shrdlu/plnr.183 +++ b/src/shrdlu/plnr.184 @@ -1,5 +1,3 @@ -;kset fonts;22fg kst,,, - (declare (genprefix plnr)) (COMMENT DO NOT GRIND THIS FILE WITH THE STANDARD GRIND) @@ -45,9 +43,21 @@ THNOT THV)) +(declare (*expr thval thgal thip thputprop thtraces makoblist thpopt thbranchun thbranch thdef + thapply1 thproga thmatch1 thbind thtae thremove thvarsubst thpure thass1 + thbi1 thor2 thtry thtry1 thrplacas thrplacds thvar thv1 thrplacd)) +(declare (*fexpr thnohash thurplaca)) +(declare (genprefix plnr)) +(declare (*fexpr ioc)) +(declare (muzzled t)) +(declare (specials t)) + (DECLARE (MACROS T) (GENPREFIX TH)) -(SETQ SYMBOLS T) +;ejs causes DDTBUG when FORMAT and other FASLs are loaded +; don't think this is really required +;(SETQ SYMBOLS T) + (COND ((ERRSET (AND PURE (SETQ LOW (PAGEBPORG))))) (' (NOT PURIFIED))) @@ -97,7 +107,6 @@ (DEFUN THPRINTC (X) (TERPRI) (PRINC X) (PRINC '/ )) -(DECLARE (SPECIAL THTT THFST THTTL THLAS THNF THWH THFSTP)) (DEFUN THADD ;THADD ADDS THEOREMS OR ASSERTION TO THE ;;INPUT - THPL - PROPERTY LIST TO BE PLACED ON ;ASSERTION @@ -197,9 +206,6 @@ (MAPC (FUNCTION THIP) THFOO) (RETURN THTTL))) -(DECLARE (UNSPECIAL THTT THFST THFSTP THTTL THLAS THNF THWH)) - -(DECLARE (SPECIAL THTREE THALIST THXX)) (DEFUN THAMONG FEXPR (THA) ;EXAMPLE - (THAMONG $?X (THFIND ... )) @@ -220,10 +226,6 @@ NIL) ;IF $?X ASSIGNED, THAMONG REDUCES TO A (T (MEMBER (CADR THXX) (THVAL (CADR THA) THALIST))))) ;MEMBERSHIP TEST -(DECLARE (UNSPECIAL THTREE THALIST THXX)) - -(DECLARE (SPECIAL THALIST THBRANCH THABRANCH THTREE THML)) - (DEFUN THAMONGF ;(CAR THTREE) = (THAMONG OLDBINDINGCELL (NEW NIL ;VALUES)) (COND (THMESSAGE (THPOPT) NIL) @@ -238,20 +240,13 @@ (THPOPT) ;POP TREE AND CONTINUE FAILING. NIL))) -(DECLARE (UNSPECIAL THALIST THBRANCH THABRANCH THTREE THML)) - -(DECLARE (SPECIAL THTREE THEXP)) - (DEFUN THAND FEXPR (A) (OR (NOT A) (PROG2 (THPUSH THTREE (LIST (QUOTE THAND) A NIL)) (SETQ THEXP (CAR A))))) -(DECLARE (UNSPECIAL THTREE THEXP)) - (DEFUN THANDF NIL (THBRANCHUN) NIL) -(DECLARE (SPECIAL THTREE THVALUE THEXP)) (DEFUN THANDT NIL (COND ((CDADAR THTREE) (THBRANCH) @@ -260,14 +255,10 @@ ((THPOPT))) THVALUE) -(DECLARE (UNSPECIAL THTREE THVALUE THEXP)) - (DEFUN THANTE FEXPR (THX) ;DEFINES AND OPTIONALLY ASSERTS ANTECEDENT (THDEF (QUOTE THANTE) THX)) ;THEOREMS) -(DECLARE (SPECIAL THTREE THTRACE THOLIST THALIST)) - (DEFUN THAPPLY FEXPR (L) (THAPPLY1 (CAR L) ;;THAPPLY1 DOES THE REAL WORK, ALL WE DO IS GET THE THEOREM OFF THE @@ -294,12 +285,9 @@ ;;IF THE THEOREM PATTERN DIDN'T MATCH, START FAILING (T (SETQ THALIST THOLIST) (THPOPT) NIL))) -(DECLARE (UNSPECIAL THTREE THTRACE THOLIST THALIST)) - -(DECLARE (SPECIAL THALIST TYPE THX THTREE THEXP THTRACE THY1 THY)) (DEFUN THASS1 (THA P) - (PROG (THX THY1 THY TYPE PSEUDO) + (PROG (THX THY TYPE PSEUDO) (AND (CDR THA) (EQ (CAADR THA) (QUOTE THPSEUDO)) (SETQ PSEUDO T)) @@ -377,12 +365,9 @@ ;;THEXP IS NOW (THDO ) (RETURN THX))) -(DECLARE (UNSPECIAL THALIST TYPE THX THTREE THEXP THTRACE THY1 THY)) - -(DEFUN THASSERT FEXPR (THA) (THASS1 THA T)) ;THASS1 IS USED FOR BOTH ASSERTING AND ERASING, ;THE "T" AS SECOND ARG TELLS IT THAT WE ARE ;ASSERTING. - -(DECLARE (SPECIAL THTREE)) - +(DEFUN THASSERT FEXPR (THA) (THASS1 THA T)) ;THASS1 IS USED FOR BOTH ASSERTING AND ERASING, + ;THE "T" AS SECOND ARG TELLS IT THAT WE ARE + ;ASSERTING. (DEFUN THASSERTF NIL (THREMOVE (COND ((ATOM (CADAR THTREE)) (CADAR THTREE)) @@ -390,23 +375,14 @@ (THPOPT) NIL) -(DECLARE (UNSPECIAL THTREE)) - -(DECLARE (SPECIAL THTREE)) - (DEFUN THASSERTT NIL (PROG2 0. (CADAR THTREE) (THPOPT))) -(DECLARE (UNSPECIAL THTREE)) - -(DECLARE (SPECIAL THALIST)) - (DEFUN THASVAL FEXPR (X) ((LAMBDA (X) (AND X (NOT (EQ (CADR X) (QUOTE THUNASSIGNED))))) (THGAL (CAR X) THALIST))) -(DECLARE (UNSPECIAL THALIST) (SPECIAL THPC)) (DEFUN THBA ;;JUST LIKE ASSQ IN LISP, ONLY RETURN WITH THE POINTER 1 @@ -431,7 +407,6 @@ (OR (CDR (SETQ THP (CDR THP))) (RETURN NIL)) (GO THP1))) -(DECLARE (UNSPECIAL THPC) (SPECIAL THTREE THOLIST THALIST)) (DEFUN THBIND ;;WHEN WE ENTER A NEW THEOREM OR THPROG @@ -479,20 +454,12 @@ ;;REPEAT FOR THE NEXT VARIABLE IN THE LIST (GO GO)))) -(DECLARE (UNSPECIAL THOLIST THTREE THALIST)) - (DEFUN THBI1 (X) (COND ((ATOM X) (LIST X (QUOTE THUNASSIGNED))) (T (LIST (CAR X) (EVAL (CADR X)))))) -(DECLARE (SPECIAL THTRACE THVALUE)) - (DEFUN THBKPT FEXPR (L) (OR (AND THTRACE (THTRACES (QUOTE THBKPT) L)) THVALUE)) -(DECLARE (UNSPECIAL THTRACE THVALUE)) - -(DECLARE (SPECIAL THBRANCH THABRANCH THTREE)) - (DEFUN THBRANCH NIL @@ -522,10 +489,6 @@ ;;SETQ IT AGAIN TO THE POINT OF SUCCESS (SETQ THBRANCH NIL)))) -(DECLARE (UNSPECIAL THBRANCH THABRANCH THTREE)) - -(DECLARE (SPECIAL THTREE THALIST)) - (DEFUN THBRANCHUN NIL @@ -550,29 +513,20 @@ ;;SO JUST RETURN NIL (T (THPOPT) NIL))))) -(DECLARE (UNSPECIAL THTREE THALIST)) - (DECLARE (SPECIAL THTREE THEXP)) - (DEFUN THCOND FEXPR (THA) (THPUSH THTREE (LIST (QUOTE THCOND) THA NIL)) (SETQ THEXP (CAAR THA))) -(DECLARE (UNSPECIAL THTREE THEXP)) - (DEFUN THCONDF NIL (THOR2 NIL)) -(DECLARE (SPECIAL THTREE THVALUE)) - (DEFUN THCONDT NIL (RPLACA (CAR THTREE) (QUOTE THAND)) (RPLACA (CDAR THTREE) (CAADAR THTREE)) THVALUE) -(DECLARE (UNSPECIAL THTREE THVALUE)) - (COMMENT THCONSE DEFINES AND OPTIONALLY ASSERTS CONSEQUENT THEOREMS) (DEFUN THCONSE FEXPR (THX) (THDEF (QUOTE THCONSE) THX)) @@ -608,8 +562,6 @@ (T (PRINT (LIST THMNAME 'REDEFINED)))) (RETURN T))) -(DECLARE (SPECIAL THTREE THEXP)) - (DEFUN THDO FEXPR (A) @@ -617,10 +569,6 @@ (PROG2 (THPUSH THTREE (LIST (QUOTE THDO) A NIL NIL)) (SETQ THEXP (CAR A))))) -(DECLARE (UNSPECIAL THTREE THEXP)) - -(DECLARE (SPECIAL THTREE THEXP THBRANCH THABRANCH)) - (DEFUN THDO1 NIL (RPLACA (CDAR THTREE) (CDADAR THTREE)) @@ -632,16 +580,11 @@ (CONS THABRANCH (CAR (CDDDAR THTREE))))))) -(DECLARE (UNSPECIAL THTREE THEXP THBRANCH THABRANCH)) - -(DECLARE (SPECIAL THTREE)) (DEFUN THDOB NIL (COND ((OR THMESSAGE (NULL (CDADAR THTREE))) (RPLACA (CAR THTREE) (QUOTE THUNDO)) T) ((THDO1)))) -(DECLARE (UNSPECIAL THTREE)) - (DEFUN THDUMP FEXPR (THFILE) @@ -653,8 +596,6 @@ (DEFUN THERASE FEXPR (THA) (THASS1 THA NIL)) -(DECLARE (SPECIAL THTREE)) - (DEFUN THERASEF NIL (THADD (COND ((ATOM (CADAR THTREE)) (CADAR THTREE)) @@ -663,19 +604,12 @@ (THPOPT) NIL) -(DECLARE (UNSPECIAL THTREE)) - -(DECLARE (SPECIAL THTREE)) - (DEFUN THERASET NIL (PROG2 0. (CADAR THTREE) (THPOPT))) -(DECLARE (UNSPECIAL THTREE)) - (COMMENT THERASING DEFINES AND OPTIONALLY ASSERTS ERASING THEOREMS) (DEFUN THERASING FEXPR (THX) (THDEF (QUOTE THERASING) THX)) -(DECLARE (SPECIAL THINF THTREE THMESSAGE)) (DEFUN THFAIL FEXPR (THA) @@ -722,32 +656,19 @@ (SETQ THX (CDR THX)) (GO LP2)))) -(DECLARE (UNSPECIAL THINF THTREE THMESSAGE)) - -(DECLARE (SPECIAL THTREE THVALUE)) - (DEFUN THFAIL? (PRD ACT) (THPUSH THTREE (LIST (QUOTE THFAIL?) PRD ACT)) THVALUE) -(DECLARE (UNSPECIAL THTREE THVALUE)) - -(DECLARE (SPECIAL THTREE THMESSAGE)) (DEFUN THFAIL?F NIL (COND ((EVAL (CADAR THTREE)) (EVAL (PROG2 (SETQ THMESSAGE NIL) (CADDAR THTREE) (THPOPT)))) (T (THPOPT) NIL))) -(DECLARE (UNSPECIAL THTREE THMESSAGE)) - -(DECLARE (SPECIAL THVALUE)) - (DEFUN THFAIL?T NIL (THPOPT) THVALUE) -(DECLARE (UNSPECIAL THVALUE) (SPECIAL THTREE)) - (DEFUN THFINALIZE FEXPR (THA) @@ -785,9 +706,6 @@ DONE (SETQ THTREE (CDR THTREE)) (RETURN T))) -(DECLARE (UNSPECIAL THTREE)) - -(DECLARE (SPECIAL THTREE)) (DEFUN THFIND FEXPR (THA) @@ -816,10 +734,6 @@ (THPUSH THTREE (LIST (QUOTE THPROG) (CDDR THA) NIL (CDDR THA))) (THPROGA)) -(DECLARE (UNSPECIAL THTREE)) - -(DECLARE (SPECIAL THTREE THBRANCH THXX)) - (DEFUN THFINDF NIL (SETQ THBRANCH NIL) @@ -829,9 +743,6 @@ NIL) (T (THPOPT) (CDADR THXX)))) -(DECLARE (UNSPECIAL THTREE THBRANCH THXX)) - -(DECLARE (SPECIAL THTREE THALIST THBRANCH THABRANCH)) (DEFUN THFINDT NIL (PROG (THX THY THZ THCDAR) @@ -850,9 +761,6 @@ (SETQ THBRANCH NIL) (RETURN NIL))) -(DECLARE (UNSPECIAL THTREE THALIST THBRANCH THABRANCH)) - -(DECLARE (SPECIAL B)) (DEFUN THFLUSH ;(THFLUSH) FLUSHES ALL ASSERTIONS AND THEOREMS FEXPR ;INPUT = SEQUENCE OF INDICATORS DEFAULT = @@ -868,10 +776,6 @@ (MAKOBLIST NIL)))) (COND (A) (' (THASSERTION THCONSE THANTE THERASING))))) -(DECLARE (UNSPECIAL B)) - -(DECLARE (SPECIAL THXX)) - (DEFUN THGAL ;(THGAL $?X THALIST) RETURNS THE BINDING CELL (X (X Y) ;-) OF X ON THALIST (SETQ THXX X) @@ -879,22 +783,15 @@ (PRINT THXX) (THERT THUNBOUND THGAL))))) -(DECLARE (UNSPECIAL THXX)) - -(DECLARE (SPECIAL THGENAME)) - (DEFUN THGENAME FEXPR ;GENERATES UNIQUE NAME WITH ARG AS PREFIX (X) (READLIST (NCONC (EXPLODE (CAR X)) (EXPLODE (SETQ THGENAME (ADD1 THGENAME)))))) -(DECLARE (UNSPECIAL THGENAME)) - (DEFUN THGO FEXPR (X) (APPLY (QUOTE THSUCCEED) (CONS (QUOTE THTAG) X))) -(DECLARE (SPECIAL THTREE THTRACE THZ1 THZ THY1 THY THA2)) (DEFUN THGOAL FEXPR (THA) ;THA = (PATTERN RECOMMENDATION) @@ -921,10 +818,6 @@ (RPLACD (CDDAR THTREE) 262143.) (RETURN NIL))) ;FAILS TO THGOALF -(DECLARE (UNSPECIAL THTREE THTRACE THZ1 THZ THY1 THY THA2)) - -(DECLARE (SPECIAL THMESSAGE)) - (DEFUN THGOALF NIL @@ -935,19 +828,12 @@ ;;ALL THPOPT DOES IS TO LOB THE THGOAL ENTRY OFF THTREE (COND (THMESSAGE (THPOPT) NIL) ((THTRY1)) (T (THPOPT) NIL))) -(DECLARE (UNSPECIAL THMESSAGE)) - -(DECLARE (SPECIAL THTREE THVALUE)) - (DEFUN THGOALT NIL (PROG2 0. (COND ((EQ THVALUE (QUOTE THNOVAL)) (THVARSUBST (CADAR THTREE) NIL)) (THVALUE)) (THPOPT))) -(DECLARE (UNSPECIAL THTREE THVALUE)) - -(DECLARE (SPECIAL THTT THFSTP THFST THTTL THLAS THNF THWH)) (DEFUN THIP (THI) @@ -1043,9 +929,6 @@ ;;IS OK SO TELL THADD SO (RETURN (QUOTE THOK)))) -(DECLARE (UNSPECIAL THTT THFST THFSTP THTTL THLAS THNF THWH)) - -(DECLARE (SPECIAL THOLIST THALIST THX THY)) (DEFUN THMATCH2 ;;THX IS ONE ITEM FROM THE PATTERN @@ -1194,20 +1077,14 @@ ;;IF NOT, THEY DON'T, SO REPORT FAILURE (T (ERR NIL)))) -(DECLARE (UNSPECIAL THOLIST THALIST THX THY) (SPECIAL THX THPRD)) - (DEFUN THCHECK (THPRD THX) (OR (NULL THPRD) (EQ THX (QUOTE THUNASSIGNED)) (ERRSET (MAPC (FUNCTION (LAMBDA (THY) - (OR (THY THX) (ERR NIL)))) + (OR (funcall THY THX) (ERR NIL)))) THPRD)))) -(DECLARE (UNSPECIAL THX THPRD) (SPECIAL THY THX THTREE THOLIST THML)) - -(DECLARE (SPECIAL L2)) - (DEFUN THUNION (L1 L2) (MAPC (FUNCTION (LAMBDA (THX) @@ -1216,10 +1093,6 @@ L1) L2) -(DECLARE (UNSPECIAL L2)) - -(DECLARE (SPECIAL THX THALIST THOLIST)) - (DEFUN THMATCH THX ((LAMBDA (THOLIST THALIST) (THMATCH1 (ARG 1.) (ARG 2.))) (COND ((GREATERP THX 2.) (ARG 3.)) (T THALIST)) @@ -1242,7 +1115,7 @@ ;;WE HAVE TO CHECK THAT THE PATTERN AND CANDIDATE ;;ARE OF THE SAME LENGTH SINCE THE USER MAY HAVE ;;SPECIFIED THE CANDIDATE WITH A "THUSE" RECOMMENDATION - (COND ((AND (EQ (LENGTH (COND ((EQ (CAR THX) + (COND ((AND (= (LENGTH (COND ((EQ (CAR THX) (QUOTE THEV)) (SETQ THX (THVAL (CADR THX) @@ -1266,9 +1139,6 @@ ;;WHICH, WHEN EVALED, UNASSIGN THE VARIABLES (T (EVLIS THML) (RETURN NIL))))) -(DECLARE (UNSPECIAL THY THX THTREE THOLIST THML)) - -(DECLARE (SPECIAL THNF THWH THALIST)) (DEFUN THMATCHLIST (THTB THWH) @@ -1379,7 +1249,7 @@ THP2 (COND ;;IF THERE IS NO BUCKET THEN RETURN SINCE NOTHING WILL MATCH THE ;;PATTERN - ((EQ THRN 0.) (RETURN NIL)) + ((= THRN 0.) (RETURN NIL)) ;;IF THE NEW BUCKET IS SMALLER, IT BECOMES THE SMALLEST SO FAR ((GREATERP THL THRN) (SETQ THL1 THA1) @@ -1388,20 +1258,12 @@ ;;GO BACK FOR ANOTHER PASS (GO THP1))) -(DECLARE (UNSPECIAL THNF THWH THALIST)) - -(DECLARE (SPECIAL THTREE THVALUE)) - (DEFUN THMESSAGE FEXPR (THA) (THPUSH THTREE (CONS 'THMESSAGE THA)) THVALUE) -(DECLARE (UNSPECIAL THTREE THVALUE)) - -(DECLARE (SPECIAL THALIST THOLIST THTREE THMESSAGE)) - (DEFUN THMESSAGEF NIL (PROG (BOD) (SETQ BOD (CAR THTREE)) (THPOPT) @@ -1417,30 +1279,15 @@ (T (SETQ THALIST THOLIST) )) (RETURN NIL))) -(DECLARE (UNSPECIAL THALIST THOLIST THTREE THMESSAGE)) - -(DECLARE (SPECIAL THVALUE)) - (DEFUN THMESSAGET NIL (THPOPT) THVALUE) -(DECLARE (UNSPECIAL THVALUE)) - -(DECLARE (SPECIAL THTREE)) - (DEFUN THMUNGF NIL (EVLIS (CADAR THTREE)) (THPOPT) NIL) -(DECLARE (UNSPECIAL THTREE)) - -(DECLARE (SPECIAL THVALUE)) - (DEFUN THMUNGT NIL (THPOPT) THVALUE) -(DECLARE (UNSPECIAL THVALUE)) - (DEFUN THNOFAIL (THX) (COND (THX (DEFPROP THPROG THPROGT THFAIL)) (T (DEFPROP THPROG THPROGF THFAIL)))) -(DECLARE (SPECIAL THA)) (DEFUN THNOHASH FEXPR (THA) @@ -1450,30 +1297,18 @@ (OR (CDR THA) (QUOTE (THASSERTION THCONSE THANTE THERASING))))) -(DECLARE (UNSPECIAL THA)) - -(DECLARE (SPECIAL THEXP)) - (DEFUN THNOT FEXPR (THA) (SETQ THEXP (LIST (QUOTE THCOND) (LIST (CAR THA) (QUOTE (THFAIL THAND))) (QUOTE ((THSUCCEED)))))) -(DECLARE (UNSPECIAL THEXP)) - (DEFUN THNV FEXPR (X) (THV1 (CAR X))) -(DECLARE (SPECIAL THTREE THEXP)) - (DEFUN THOR FEXPR (THA) (AND THA (THPUSH THTREE (LIST (QUOTE THOR) THA)) (SETQ THEXP (CAR THA)))) -(DECLARE (UNSPECIAL THTREE THEXP)) - -(DECLARE (SPECIAL THTREE THEXP)) - (DEFUN THOR2 (P) (COND (THMESSAGE (THPOPT) NIL) ((AND (CADAR THTREE) (CDADAR THTREE)) (RPLACA (CDAR THTREE) (CDADAR THTREE)) @@ -1484,24 +1319,12 @@ ((CAR (CAADAR THTREE)))))) (T (THPOPT) NIL))) -(DECLARE (UNSPECIAL THTREE THEXP)) - (DEFUN THORF NIL (THOR2 T)) -(DECLARE (SPECIAL THVALUE)) - (DEFUN THORT NIL (THPOPT) THVALUE) -(DECLARE (UNSPECIAL THVALUE)) - -(DECLARE (SPECIAL THTREE)) - (DEFUN THPOPT NIL (SETQ THTREE (CDR THTREE))) -(DECLARE (UNSPECIAL THTREE)) - -(DECLARE (SPECIAL THTREE)) - (DEFUN THPROG FEXPR (THA) @@ -1519,10 +1342,6 @@ ;;CALL WORKHORSE (THPROGA)) -(DECLARE (UNSPECIAL THTREE)) - -(DECLARE (SPECIAL THEXP THVALUE THTREE)) - (DEFUN THPROGA NIL ((LAMBDA (X) (COND @@ -1549,9 +1368,6 @@ THVALUE))) (CDAR THTREE))) -(DECLARE (UNSPECIAL THEXP THVALUE THTREE)) - - ;;THBRANCH AND THBRANCHUN ARE THE MAIN FUNCTIONS ;;IN CHARGE OF HANDELING THE EFFECTS OF SUCCESS AND FAILURE ;;THEY ARE ONLY CALLED BY THPROGT AND F @@ -1560,8 +1376,6 @@ (DEFUN THPROGT NIL (THBRANCH) (THPROGA)) -(DECLARE (SPECIAL XX)) - (DEFUN THPURE ;;CHECKS TO MAKE SURE THAT THE PATTERN HAS NO @@ -1576,10 +1390,6 @@ (ERRSET (MAPC (FUNCTION (LAMBDA (Y) (AND (THVAR Y) (ERR NIL)))) XX))) -(DECLARE (UNSPECIAL XX)) - -(DECLARE (SPECIAL THTREE)) - (DEFUN THPUTPROP (ATO VAL IND) (THPUSH THTREE @@ -1590,13 +1400,6 @@ (LIST (QUOTE QUOTE) IND))))) (PUTPROP ATO VAL IND)) -(DECLARE (UNSPECIAL THTREE)) - -(DECLARE (SPECIAL THBS THON THAL THFST THNF THWH)) - -(DECLARE (SPECIAL THFSTP)) - -(DECLARE (SPECIAL THPC)) (DEFUN THREM1 ;;THIS FUNCTION IS ROUGHLY THE SAME AS @@ -1648,7 +1451,7 @@ (OR THA5 (RETURN NIL)) (SETQ THONE (CADR THA5)) (RPLACD THA5 (CDDR THA5)) - (AND (NOT (EQ (CADR THA4) 1.)) + (AND (NOT (= (CADR THA4) 1.)) (OR (SETQ THSV (CDDR THA4)) T) (RPLACA (CDR THA4) (SUB1 (CADR THA4))) (RETURN THONE)) @@ -1661,21 +1464,10 @@ (REMPROP THA THWH) (RETURN THONE))) -(DECLARE (UNSPECIAL THPC THBS THON THAL THFST THFSTP THNF THWH)) - -(DECLARE (SPECIAL THALIST THTREE)) - (DEFUN THREMBINDF NIL (SETQ THALIST (CADAR THTREE)) (THPOPT) NIL) -(DECLARE (UNSPECIAL THTREE)) - -(DECLARE (SPECIAL THTREE THVALUE)) - (DEFUN THREMBINDT NIL (SETQ THALIST (CADAR THTREE)) (THPOPT) THVALUE) -(DECLARE (UNSPECIAL THALIST THTREE THVALUE)) - -(DECLARE (SPECIAL THBS THON THAL THFSTP THFST THNF THWH)) (DEFUN THREMOVE ;;THIS FUNCTION IS ANALAGOUS TO THADD EXCEPT @@ -1727,9 +1519,6 @@ (MAPC (FUNCTION THREM1) THFOO) (RETURN THON))) -(DECLARE (UNSPECIAL THBS THON THAL THFST THFSTP THNF THWH)) - -(DECLARE (SPECIAL THTREE)) (DEFUN THREMPROP (ATO IND) (THPUSH THTREE @@ -1740,10 +1529,6 @@ (LIST (QUOTE QUOTE) IND))))) (REMPROP ATO IND)) -(DECLARE (UNSPECIAL THTREE)) - -(DECLARE (SPECIAL THALIST)) - (DEFUN THRESTRICT FEXPR (THB) @@ -1753,22 +1538,14 @@ ((THRPLACD (CDR X) (THUNION (CDDR X) (CDR THB))))) (RETURN X))) -(DECLARE (UNSPECIAL THALIST)) - (DEFUN THRETURN FEXPR (X) (APPLY (QUOTE THSUCCEED) (CONS (QUOTE THPROG) X))) -(DECLARE (SPECIAL THTREE THML)) - (DEFUN THRPLACA (X Y) (PROG (THML) (THRPLACAS X Y) (THPUSH THTREE (LIST (QUOTE THMUNG) THML)) (RETURN X))) -(DECLARE (UNSPECIAL THTREE THML)) - -(DECLARE (SPECIAL THML)) - (DEFUN THRPLACAS (X Y) (THPUSH THML (LIST (QUOTE THURPLACA) X (CAR X))) @@ -1776,18 +1553,11 @@ (DEFUN THURPLACA FEXPR (L) (RPLACA (CAR L) (CADR L))) -(DECLARE (UNSPECIAL THML)) - -(DECLARE (SPECIAL THTREE THML)) - (DEFUN THRPLACD (X Y) (PROG (THML) (THRPLACDS X Y) (THPUSH THTREE (LIST (QUOTE THMUNG) THML)) (RETURN X))) -(DECLARE (UNSPECIAL THTREE THML)) - -(DECLARE (SPECIAL THML)) (DEFUN THRPLACDS (X Y) (THPUSH THML (LIST (QUOTE THURPLACD) X (CDR X))) @@ -1795,10 +1565,6 @@ (DEFUN THURPLACD FEXPR (L) (RPLACD (CAR L) (CADR L))) -(DECLARE (UNSPECIAL THML)) - -(DECLARE (SPECIAL THTREE THALIST THVALUE THML)) - (DEFUN THSETQ FEXPR (THL1) @@ -1822,9 +1588,6 @@ (SETQ THL (CDDR THL)) (GO LOOP))) -(DECLARE (UNSPECIAL THTREE THALIST THVALUE THML)) - -(DECLARE (SPECIAL X THALIST)) (DEFUN THSGAL (X) (SASSQ (CADR X) @@ -1838,10 +1601,6 @@ (LIST Y)) (RETURN Y)))))) -(DECLARE (UNSPECIAL X THALIST)) - -(DECLARE (SPECIAL THINDICATORS THP THWH THATOM)) - (DEFUN THSTATE FEXPR (THINDICATORS) ;PRINTS THAT PART OF THE STATE OF THE @@ -1878,9 +1637,6 @@ (MAKOBLIST NIL)) (PRINT NIL))) -(DECLARE (UNSPECIAL THINDICATORS THP THWH THATOM)) - -(DECLARE (SPECIAL THTREE THALIST THBRANCH THABRANCH THA)) (DEFUN THSUCCEED FEXPR (THA) @@ -1908,9 +1664,6 @@ (RETURN (THPROGT))) (T (THPOPT) (GO LOOP)))))) -(DECLARE (UNSPECIAL THTREE THALIST THBRANCH THABRANCH THA)) - -(DECLARE (SPECIAL XX TYPE THX THY1 THY THXX)) (DEFUN THTAE (XX) (COND @@ -1928,7 +1681,7 @@ (T (LIST (QUOTE THAPPLY) X (CAR THX)))))) (CDR XX))) ((EQ (CAR XX) (QUOTE THTBF)) - (MAPCAN (FUNCTION (LAMBDA (Y) (COND (((CADR XX) Y) + (MAPCAN (FUNCTION (LAMBDA (Y) (COND ((funcall (CADR XX) Y) (LIST (LIST (QUOTE THAPPLY) Y (CAR THX))))))) @@ -1936,27 +1689,16 @@ (SETQ THY (THMATCHLIST (CAR THX) TYPE)))))) (T (PRINT XX) (THTAE (THERT UNCLEAR RECCOMMENDATION /-THTAE))))) -(DECLARE (UNSPECIAL XX TYPE THX THY1 THY THXX)) - -(DECLARE (SPECIAL THTREE)) - (DEFUN THTAG FEXPR (L) (AND (CAR L) (THPUSH THTREE (LIST (QUOTE THTAG) (CAR L))))) -(DECLARE (UNSPECIAL THTREE)) - (DEFUN THTAGF NIL (THPOPT) NIL) -(DECLARE (SPECIAL THVALUE)) - (DEFUN THTAGT NIL (THPOPT) THVALUE) -(DECLARE (UNSPECIAL THVALUE)) - (DEFUN THTRUE (X) T) -(DECLARE (SPECIAL THTREE THOLIST THALIST)) (DEFUN THTRY1 ;TRIES NEXT RECOMMENDATION ON TREE FOR THGOAL NIL (PROG (THX THY THZ THW THEOREM) @@ -1975,7 +1717,7 @@ (COND ((NULL (CADDR THX)) (RPLACA THY (CDAR THY)) (GO NXTREC)) ;NO MORE CANDIDATES SATISFYING THIS REC. ((PROG2 0. ;TRY NEXT REC - (AND ((CADR THX) (SETQ THW (CAADDR THX))) + (AND (funcall (CADR THX) (SETQ THW (CAADDR THX))) (THMATCH1 (CADR THZ) (CAR THW))) (RPLACA (CDDR THX) (CDADDR THX))) (RETURN THW)) @@ -1994,15 +1736,12 @@ (GO NXTREC)) (T (GO THTBF1))))) (COND ((PROG2 0. - (AND ((CADR THX) (CAADDR THX)) + (AND (funcall (CADR THX) (CAADDR THX)) (THAPPLY1 THEOREM THW (CADR THZ))) (RPLACA (CDDR THX) (CDADDR THX))) (RETURN T)) (T (GO THTBF))))) -(DECLARE (UNSPECIAL THTREE THOLIST THALIST)) - -(DECLARE (SPECIAL THZ1 THZ THY1 THY THA2)) (DEFUN THTRY ;;THTRY IS IN CHARGE OF MAKING UP THE "THINGS TO DO" LIST @@ -2036,10 +1775,6 @@ ((EQ (CAR X) 'THNUM) (LIST X)) (T (PRINT X) (THTRY (THERT UNCLEAR RECOMMENDATION - THTRY))))) -(DECLARE (UNSPECIAL THZ1 THZ THY1 THY THA2)) - -(DECLARE (SPECIAL THTREE THALIST THXX)) - (DEFUN THUNDOF NIL (COND ((NULL (CADDAR THTREE)) (THPOPT)) @@ -2050,12 +1785,8 @@ (RPLACA THXX (CDAR THXX)))) NIL) -(DECLARE (UNSPECIAL THTREE THALIST THXX)) - (DEFUN THUNDOT NIL (THPOPT) T) -(DECLARE (SPECIAL THALIST)) - (DEFUN THUNIQUE FEXPR (THA) @@ -2068,10 +1799,6 @@ (SETQ X (CDR X)) (GO LP))) -(DECLARE (UNSPECIAL THALIST)) - -(DECLARE (SPECIAL THALIST THXX)) - (DEFUN THV1 (X) ;(THV1 'X) IS THE VALUE OF THE PLANNER VARIABLE (SETQ THXX X) ;$?X RETURNS ERROR MESSAGE IF X UNBOUND OR @@ -2087,30 +1814,11 @@ (THERT THUNASSIGNED - THV1)) (T X))) -(DECLARE (UNSPECIAL THALIST THXX)) - (DEFUN THV FEXPR (X) ;(THV X) IS THE VALUE OF THE PLANNER VARIABLE (THV1 (CAR X))) ;$?X -(DECLARE (SPECIAL THLEVEL - THSTEP - THSTEPF - THSTEPT - THSTEPD - THMESSAGE - ^A - THV - THINF - THE - THTREE - THOLIST - THEXP - THALIST - THVALUE - THBRANCH - THABRANCH)) (DEFUN THVAL ;;CORESPONDS TO LISP EVAL @@ -2218,37 +1926,18 @@ ;;FAILURE ASSOCIATED FUNCTION. EVAL IT AND AT THE SAME ;;TIME, SET IT TO NIL IN CASE WE NEED THEXP FOR MORE EXPRESSIONS ;;TO BE PROCESSED - GO2 (SETQ THVALUE ((PROG2 0. THEXP (SETQ THEXP NIL)))) + GO2 (SETQ THVALUE (funcall (PROG2 0. THEXP (SETQ THEXP NIL)))) ;;GO THROUGH ENTIRE PROCESS AGAIN ;;A TYPICAL PROCESS IN SUCCESS IS TO KEEP REMOVING EXPRESSIONS FROM THTREE UNTIL ;;WE GET BACK TO THE THREE ENTRY PUT ON BY THPROG ;;AT THIS POIN IT EVALS THPROGT, AND SEE THAT LISTING (GO GO1))) - (DECLARE (UNSPECIAL THSTEP - THSTEPF - THSTEPT - THSTEPD - THLEVEL - THMESSAGE - ^A - THV - THINF - THE - THTREE - THOLIST - THEXP - THALIST - THVALUE - THBRANCH - THABRANCH)) (DEFUN THVAR (X) ;PREDICATE - IS ITS INPUT A PLANNER VARIABLE (MEMQ (CAR X) (QUOTE (THV THNV)))) -(DECLARE (SPECIAL THALIST THY)) - (DEFUN THVARS2 ;;THIS IS THE WORKHORSE FOR THVARSUBST @@ -2314,10 +2003,6 @@ ;;GO THROUGH IT PLACE BY PLACE WITH THVARS2 (COND ((ATOM THX) THX) (T (MAPCAR (FUNCTION THVARS2) THX)))) -(DECLARE (UNSPECIAL THALIST THY)) - -(DECLARE (SPECIAL THALIST THVALUE THA)) - (DEFUN THVSETQ FEXPR (THA) @@ -2333,8 +2018,6 @@ (SETQ A (CDDR A)) (GO LOOP))) -(DECLARE (UNSPECIAL THALIST THVALUE THA)) - (DEFPROP THTAG THTAGF THFAIL) (DEFPROP THTAG THTAGT THSUCCEED) @@ -2396,7 +2079,6 @@ (DEFPROP THREMBIND THREMBINDF THFAIL) -(DECLARE (SPECIAL THALIST THLEVEL THINF)) (DEFUN THERT FEXPR @@ -2441,15 +2123,6 @@ (T (PRINT (THVAL /0LISTEN THALIST))))) ;THVAL LISTENING AT TOP LEVEL (GO /0LISTEN))) -(DECLARE (SPECIAL PURE - LOW - THXX - THTRACE - THALIST - THTREE - ERRLIST - THGENAME - THLEVEL)) (DEFUN THINIT FEXPR (L) @@ -2481,14 +2154,3 @@ (SETQ THTREE NIL) (SETQ THLEVEL NIL) (THERT TOP LEVEL))))) - -(DECLARE (UNSPECIAL PURE - LOW - THXX - THTRACE - THALIST - ERRLIST - THTREE - THLEVEL - THGENAME - THINF))  \ No newline at end of file diff --git a/src/shrdlu/proggo.33 b/src/shrdlu/proggo.33 new file mode 100644 index 000000000..1e006c68b --- /dev/null +++ b/src/shrdlu/proggo.33 @@ -0,0 +1,83 @@ +(defvar *go-tags* '()) + +;(defmacro *go (where) +; `(let ((found (assq ',where *go-tags*))) +; (print `((*go ,',where) found ,found)) +; (*throw (cdr found) ',where))) + +(defmacro foo (where) + `(let ((label (cond ((atom ',where) ',where) (t ,where)))) + (print label))) + +; (defmacro *go (where) +; `(let* ((label (cond ((atom ',where) ',where) +; (t ,where))) +; (found (assq `,label *go-tags*))) +; ; (print `((*go `,label) found ,found)) +; (*throw (cdr found) `,label))) + +(defmacro *go (where) + `(let* ((label ,(cond ((atom where) `',where) + (t where))) + (found (assq label *go-tags*))) +; (print `((*go ,label) found ,found)) + (*throw (cdr found) label))) + +(defmacro when (x &rest body) + `(if ,x (progn ,@body))) + +(defmacro *prog (bvl &body prog-body) + (let ((clauses '()) + (clause '()) + (first-tag (gensym 'F)) + (next-tag nil) + (restart-tag (gensym 'R)) + (catch-tag (gensym 'C)) + (next-tag-var (gensym 'N)) + (tag-associations '())) + (when (and prog-body (atom (car prog-body))) + (setq first-tag (pop prog-body)) + (push (cons first-tag catch-tag) tag-associations)) + (setq clause (list first-tag)) + (do ((pb prog-body (cdr pb))) + ((null pb)) + (let ((item (car pb))) + (cond ((atom item) + (push clause clauses) + (when item + (push (cons item catch-tag) tag-associations)) + (setq clause (list item))) + (t + (push item clause))))) + (when clause + (push clause clauses)) + (setq clauses + (mapcar #'(lambda (clause) + (let ((new-clause + (nreconc clause + (list + `(*throw ',catch-tag + ',next-tag))))) + (setq next-tag (car new-clause)) + new-clause)) + clauses)) + (setq clauses (nreverse clauses)) + `(let ((,next-tag-var ',first-tag) + (*go-tags* (append ',tag-associations *go-tags*))) + (prog ,bvl ; Need a PROG anyway in case macro user does RETURN + ,restart-tag + (setq ,next-tag-var + (*catch ',catch-tag + (cond ,@(mapcar #'(lambda (clause) + (let ((tag (car clause))) + `((eq ,next-tag-var ',tag) +; (print `(calling tag ,',tag)) + ,@(cdr clause)))) + clauses)))) +; (print `(next-tag ,',next-tag-var)) + (if ,next-tag-var + (go ,restart-tag) ; NOTE: Yes, this is GO, not *GO. + (return nil)))))) + +(defun apply-macro (macro-name macro-body) + (eval (cons macro-name macro-body))) diff --git a/src/shrdlu/progmr.58 b/src/shrdlu/progmr.59 similarity index 96% rename from src/shrdlu/progmr.58 rename to src/shrdlu/progmr.59 index ec85b2e3d..dd7be8bbe 100644 --- a/src/shrdlu/progmr.58 +++ b/src/shrdlu/progmr.59 @@ -1,6 +1,3 @@ - -(DECLARE (GENPREFIX PROGMR)) - ;;;********************************************************** ;;; ;;; PROGMR @@ -8,6 +5,13 @@ ;;; ;;;############################################################ +(DECLARE (GENPREFIX PROGMR)) +(declare (*fexpr ert move-pt spop bug printc)) +(declare (*expr union undefined meet parse-statistics dp from makesym interpret + findb timer setdif)) +(declare (specials t)) +(declare (muzzled t)) + (DEFUN RESTOREPT NIL (SETQ PT SAVEPT)) (DEFUN SETMVB (PTR-MVB) @@ -199,7 +203,7 @@ (RETURN T))))) EXPR) -(DEFUN CUT-BACK-ONE NIL (MOVE-PTW N PW) (POP) (CUT PTW)) +(DEFUN CUT-BACK-ONE NIL (MOVE-PTW N PW) (SPOP) (CUT PTW)) (DEFPROP F (LAMBDA (A) (COND ((MEMBER A FE) T) @@ -215,7 +219,7 @@ (DEFUN FESET (NODE FEATURES) (SETR 'FEATURES FEATURES NODE)) (DEFUN FLUSHME NIL - ;; IF YOU HAVEN'T REAHED THE CUT, FLUSHES THE NEXT WORD IN THE + ;; IF YOU HAVEN'T REACHED THE CUT, FLUSHES THE NEXT WORD IN THE ;;SENTENCE. FAILS IF IT REACHES CUT POINT (AND N NN (SETQ NN (NOT (EQ CUT (SETQ N (CDR N))))))) @@ -395,7 +399,7 @@ (SETQ A (CDR A)) (GO GO))) -(DEFUN POP FEXPR (A) +(DEFUN SPOP FEXPR (A) (COND ((OR (NULL A) (NULL (CAR A))) (COND @@ -418,7 +422,7 @@ BACKREF) (SETQ BACKREF XX))) T))) - ((EVAL (CONS 'POPTO A)) (POP)))) + ((EVAL (CONS 'POPTO A)) (SPOP)))) (DEFUN POPTO FEXPR (A) (PROG (XX) @@ -426,7 +430,7 @@ LOOP (COND ((EVAL (CONS 'ISQ (CONS 'XX A)))) ((SETQ XX (CDR XX)) (GO LOOP)) ((MQ POPTO) (RETURN NIL))) - EX (COND ((EQ XX H) (RETURN C)) ((POP) (GO EX))))) + EX (COND ((EQ XX H) (RETURN C)) ((SPOP) (GO EX))))) (DEFUN PREVIOUS (LIST MEMBER) ;; GET THE ELEMENT OF LIST BEFORE MEMBER @@ -499,4 +503,3 @@ LOBREL LOBQ))))) EXPR) - \ No newline at end of file diff --git a/src/shrdlu/setup.63 b/src/shrdlu/setup.64 similarity index 96% rename from src/shrdlu/setup.63 rename to src/shrdlu/setup.64 index 6225770d9..3768ea22b 100644 --- a/src/shrdlu/setup.63 +++ b/src/shrdlu/setup.64 @@ -222,8 +222,8 @@ ;;; INITIALIZATION ROUTINES ;;;***************************************************************** -(defun dump-it () - (initialstuff 1000 '2024-07-21 '(version reconstructed by ejs))) +(defun dump-shrdlu () + (initialstuff 1000 '2024-08-09 '(version reconstructed by ejs))) (DEFUN INITIALSTUFF (version date note) (SUSPEND) @@ -235,10 +235,10 @@ (PRINC 'LOADED/ ) (PRINC date ) (princ '/ ) - (PRINC 'IN/ BLISP/ ) + (PRINC 'IN/ MACLISP/ ) (princ (status lispversion)) (TERPRI) - (SAY REFER COMMENTS AND QUESTIONS TO DDM) + (SAY REFER COMMENTS AND QUESTIONS TO EJS) (TERPRI) (TERPRI) (and note (progn (terpri)(apply 'say note) @@ -249,8 +249,8 @@ (OR (AND (INTEROGATE DO YOU WANT THE DISPLAY /(TYPE "Y/ " OR "N/ "/)) (SETQ WANT-DISPLAY T)) (SETQ WANT-DISPLAY NIL)) + (putprop (quote blink) (function (lambda (a) nil)) 'expr) (COND ((NOT WANT-DISPLAY) (NO340) - (putprop (quote blink)(function (lambda (a) nil)) 'expr) (putprop (quote moveto)(function (lambda (x y z) nil)) 'expr) (putprop (quote grasp)(function (lambda (a) nil)) 'expr) (putprop (quote ungrasp)(function (lambda () nil)) 'expr) @@ -294,4 +294,3 @@ (setq w1 (boole 7 w1 020202020202) w2 (boole 7 w2 020202020202) ) (sstatus tty w1 w2) -  \ No newline at end of file diff --git a/src/shrdlu/show.14 b/src/shrdlu/show.15 similarity index 95% rename from src/shrdlu/show.14 rename to src/shrdlu/show.15 index 476219cc6..4571e4a87 100644 --- a/src/shrdlu/show.14 +++ b/src/shrdlu/show.15 @@ -1,4 +1,12 @@ (declare (genprefix show)) +(declare (*fexpr say ert printc ioc)) +(declare (*expr thadd makesym dp print2 printext thval nameobj evlis tab + lis2fy listify2)) +(declare (muzzled t)) +(declare (specials t)) + +(eval-when (compile) + (load 'macros)) ;;; quickies @@ -14,12 +22,12 @@ (defun parsetrace labels (cond ((= (arg nil) 0) (setq parsetrace 'all)) - (t (setq parsetrace (listify labels))) )) + (t (setq parsetrace (listify2 labels))) )) (defun parsebreak labels (cond ((= (arg nil) 0) (setq parsebreak 'all)) - (t (setq parsebreak (listify labels))) )) + (t (setq parsebreak (listify2 labels))) )) (defun fancytimer off? (cond ((= (arg nil) 1) @@ -229,7 +237,7 @@ (DEFUN SHOWSCENE (X) (PROG (PLANNERSEE) (TERPRI) - (TAB 16.) +; (TAB 16.) (PRINC 'CURRENT/ SCENE) (TERPRI) (TERPRI) @@ -247,7 +255,7 @@ (THGOAL (!SUPPORT $?OBJ $?X))) (LIST (LIST 'OBJ OBJ)))) - (TAB 13.) + (TAB 80.) (PRINC 'SUPPORTS/ ) (PRINC OBJ))) '(:B1 :B2 :B3 :B4 :B5 :B6 :B7 :B10 :BOX)) @@ -284,10 +292,10 @@ (LIST (LIST NODE)))) (DEFUN SUBLEAF (KID DAD) - (*CATCH nil (AND (MAPC 'SUBL2 (GET DAD SYSTEMS))))) + (*CATCH nil (MAPC 'SUBL2 (GET DAD SYSTEMS)))) (DEFUN SUBL2 (X) - (COND ((EQ X KID) (THROW T)) + (COND ((EQ X KID) (*THROW NIL T)) (T (MAPC 'SUBL2 (GET X SYSTEMS))))) (DEFUN QUERY (TEXT CHOICES HELP) @@ -351,7 +359,7 @@ WANT TO EXAMINE)) - (LISTIFY (REQUEST 'PROPERTY: + (LISTIFY2 (REQUEST 'PROPERTY: '(THE PROPERTY (IES) YOU @@ -790,7 +798,7 @@ (DEFUN SHOWMOVE (X) (SETQ SAVEPT PT) (APPLY 'MOVE-PT - (LISTIFY (OR X + (LISTIFY2 (OR X (REQUEST 'NODE-SPECIFICATION: '(C MEANS CURRENT @@ -828,7 +836,7 @@ OR CONSEQUENT THEOREM)) - (LISTIFY (REQUEST 'VARIABLE-LIST: + (LISTIFY2 (REQUEST 'VARIABLE-LIST: NIL)) (REQUEST 'PATTERN: '(A LIST @@ -917,7 +925,7 @@ TYPE ))) (AND (SHOW MARKER !SYSTEMS) (GO MAR))) - (SETQ MARK (LISTIFY MARK)) + (SETQ MARK (LISTIFY2 MARK)) (COND ((EQ TYPE 'NOUN) (PUTPROP A '(NOUN NS) 'FEATURES) @@ -973,7 +981,7 @@ (T (PUTPROP A '(VB ITRNS INF) 'FEATURES))) (SETQ REST - (LIST (LIST (LISTIFY (REQUEST '(RESTRICTIONS ON + (LIST (LIST (LISTIFY2 (REQUEST '(RESTRICTIONS ON SUBJECT:) '(LIST OF SEMANTIC @@ -983,7 +991,7 @@ (SETQ REST (NCONC REST - (LIST (LISTIFY (REQUEST '(RESTRICTIONS ON + (LIST (LISTIFY2 (REQUEST '(RESTRICTIONS ON OBJECT:) '(LIST OF SEMANTIC @@ -1047,8 +1055,17 @@ (THRUTEXT) '*) -(DEFUN LIS2FY (X) - (COND ((ATOM X) (LIST (LIST X))) - ((ATOM (CAR X)) (LIST X)) - (X))) -  \ No newline at end of file +(DEFUN THRUTEXT () + (PROG () + (IOC Q) + GO + (OR (= (let ((i (tyi))) + (tyo i) + i) 77) + (GO GO)))) + +;ejs removed since defined in SYSCOM +;(DEFUN LIS2FY (X) +; (COND ((ATOM X) (LIST (LIST X))) +; ((ATOM (CAR X)) (LIST X)) +; (X))) diff --git a/src/shrdlu/smass.19 b/src/shrdlu/smass.20 similarity index 98% rename from src/shrdlu/smass.19 rename to src/shrdlu/smass.20 index e5e38e7ff..ff141f357 100644 --- a/src/shrdlu/smass.19 +++ b/src/shrdlu/smass.20 @@ -1,11 +1,14 @@ -(declare (genprefix smass)) - ;;;################################################################ ;;; ;;; SMASS - semantic access functions ;;; ;;;################################################################ +(declare (genprefix smass)) +(declare (specials t)) +(declare (muzzled t)) +(declare (*expr getr setr)) + (DEFUN ACTION? (X) ;;THE WORKING PART OF AN ANSWER -- TELLS WHAT TO DO IF THE ;;ANSWER IS THE ONE TO BE GIVEN. MIGHT INCLUDE ACTIONS ON THE @@ -133,4 +136,3 @@ (X) (GET X 'VARIABLE=)) (DEFUN SMSET (X) (SETR 'SEMANTICS X C) (SETQ SM X)) -  \ No newline at end of file diff --git a/src/shrdlu/smspec.96 b/src/shrdlu/smspec.97 similarity index 98% rename from src/shrdlu/smspec.96 rename to src/shrdlu/smspec.97 index 9cefa452d..b2ff7bd45 100644 --- a/src/shrdlu/smspec.96 +++ b/src/shrdlu/smspec.97 @@ -1,5 +1,3 @@ -(declare (genprefix smspec)) - ;;;############################################################ ;;; ;;; SMSPEC @@ -7,6 +5,15 @@ ;;; ;;;############################################################ +(declare (genprefix smspec)) +(declare (specials t)) +(declare (muzzled t)) +(declare (*fexpr ert ertstop object build erterr move-pt rq bug fq global-err isq cq)) +(declare (*expr findevents relfind rel? makesym h root plnr-mung number? thval2 relations? + nb n from plnr-describe quantifier? mapbland parsenode? findmeasure + compare-build plnr-findify variable? setr fe meet setdif remove-f-pt + add-f-pt refer? setr sm newcopy smset getr)) + (DEFUN SMTIME NIL (ERT SMTIME NOT WRITTEN YET)) (DEFUN SMTIME2 NIL (ERT SMTIME2 NOT WRITTEN YET)) @@ -146,9 +153,9 @@ (DEFUN SMPRON (NODE) (EVAL (SM NODE)) (COND ((NULL SM) - (SETQ GLOBAL-MESSAGE (APPEND '(I DON/'T KNOW WHAT ") + (SETQ GLOBAL-MESSAGE (APPEND '(I DON/'T KNOW WHAT /") (FROM (NB H) (N H)) - '(" REFERS TO))))) + '(/" REFERS TO))))) SM) (DEFUN SMVAUX NIL @@ -633,10 +640,10 @@ WHAT YOU MEAN - BY - ") + BY + /") (FROM NB N) - '("/.))) + '(/"/.))) (RETURN NIL)) ;IF WE AREN'T REMEMBERING ((MEMQ WHO '(HE NIL)) @@ -662,7 +669,7 @@ ((EQ WHO 'HE) ;LIST ALREADY FOUND (LIST (SUB1 LASTSENTNO) (ADD1 LASTSENTNO))) - ((OR (NOT MUNG) (EQ (CAR WHO) 1.)) + ((OR (NOT MUNG) (= (CAR WHO) 1.)) (SETQ WHO 'HE) (GO TOOFEW)) ((CONS (SUB1 (CAR WHO)) (CDR WHO))))) @@ -1020,7 +1027,7 @@ ;;event???) (SETQ TSS (GETR 'TIME C)) (OR (SETQ EVENT (FINDEVENTS (CAR (SM H)))) - (GLOBAL-ERR '(NO SUCH THING EVER HAPPENED))) + (GLOBAL-ERR NO SUCH THING EVER HAPPENED)) (SETQ EVENT (CAR EVENT)) (SETQ START (GET EVENT 'START)) (SETQ END (GET EVENT 'END)) @@ -1035,4 +1042,3 @@ ;;SPECIFICATION ON WHEN IT ENDS. (PUTPROP TSS START-EV 'START=) (PUTPROP TSS END-EV 'END=)) -  \ No newline at end of file diff --git a/src/shrdlu/smutil.150 b/src/shrdlu/smutil.151 similarity index 98% rename from src/shrdlu/smutil.150 rename to src/shrdlu/smutil.151 index 6f37f94fc..e17f9ce0f 100644 --- a/src/shrdlu/smutil.150 +++ b/src/shrdlu/smutil.151 @@ -1,12 +1,19 @@ -(declare (genprefix smutil)) - - ;;;############################################################ ;;; ;;; SMUTIL ;;; ;;;############################################################ +(declare (genprefix smutil)) +(declare (muzzled t)) +(declare (specials t)) +(declare (*fexpr ert iterate global-err disp bug cq isq erterr)) +(declare (*expr timer thval number? quantifier? oss? relations? negative? or? and? tss? + variable? refer? setr smset sm makesym getr rss? root meet h rel? tense? dp + quotify union rssvar? nb plnr-orify)) + +(declare (*expr check setqqcheck plnr-recommendify plnr-remtime plnr-var expand)) + (DEFUN ATOMIFY (X) (COND ((ATOM X) X) ((CDR X) X) (T (CAR X)))) (DEFUN ISTENSE (NODE ARG) @@ -318,8 +325,6 @@ SMOBL SMCOMP)) -1. - ;;;============================================================ (DEFUN DOBACKREF (ANSWER) @@ -353,8 +358,8 @@ (REMPROP PRONOUN 'BIND)) '(IT THEY ONE)) (OR - (CQ MODAL) - (CQ DECLAR) + (CQ MODAL) + (CQ DECLAR) (MAP '(LAMBDA (BACKNODE) (COND ((CDR (SM BACKNODE)) @@ -389,7 +394,7 @@ ) ;;;=======================================================I -(setsyntax 35. 'single 1) +;(setsyntax 35. 'single 1) (DEFUN EVALCHECK (L) ;;EVALCHECK CHECKS FOR THE PRESENCE OF (!EVAL (MUMBLE ...)...) @@ -478,7 +483,7 @@ ;;SIDE-EFFECTS). (PROG (ANS F) (AND (NULL L) (SETQ L '(NIL))) - A (COND ((NULL (SETQ F ((EVAL 'FN) (CAR L))))) + A (COND ((NULL (SETQ F (funcall FN (CAR L))))) ((ATOM F) (SETQ ANS (NCONC ANS (CONS F NIL)))) ((SETQ ANS (APPEND ANS F)))) (SETQ L (CDR L)) @@ -500,7 +505,7 @@ (PROG (DUMMY) ;DUMMY IS USED TO ESCAPE FROM A SYSTEM ERROR A (COND ((NULL L) (RETURN T))) ;WHICH OCCURS WHEN NIL IS USED - ((EVAL 'FN) (CAR L) (CADR L)) + (funcall FN (CAR L) (CADR L)) ; FN APPLIED TO TOP TWO ELEMENTS. EVAL (SETQ L (CDDR L)) ;IS TO AVOID CONFLICT WITH FUNCTION REALLY NAMED @@ -859,7 +864,7 @@ ;LOOK A RELATION UP IN THE DICTIONARY. THE (EVAL (COND ((NUMBERP (CAAR %ELEMENT)) ;ENTRIES ARE SET UP AS A PROPERTY LIST. THERE - (CADR (OR (ASSQ (LENGTH %PLNRPHRASE) + (CADR (OR (ASSOC (LENGTH %PLNRPHRASE) ;ARE DIFFERENT RECOMMENDATIONS FOR THE SAME %ELEMENT) '(NIL NIL)))) @@ -936,7 +941,7 @@ (COND ((SETQ X (ASSOC 'MEASURE (GET (ROOT (NB NODE)) 'SEMANTICS))) (CADR X)) - ((GLOBAL-ERR (APPEND '(I DON"T + ((GLOBAL-ERR (APPEND '(I DON/"T KNOW HOW TO @@ -1079,7 +1084,7 @@ FREEVARS)))))) ((ATOM EXP) (BUG EXPAND - ATOMIC MODIFIER)) ((EQ (CAR EXP) '*ORDINAL*) - (COND (ORDINAL (GLOBAL-ERR '(I CAN"T + (COND (ORDINAL (GLOBAL-ERR '(I CAN/"T HANDLE TWO ORDINALS @@ -1187,7 +1192,7 @@ (DEFUN ERQSET (X) ;;USED BY EXPAND TO MAKE SURE IT ISN"T GETTING CONFUSED BY TOO ;;MANY CONNECTIVES AND QUANTIFIERS IN THE SAME EXPRESSION - (COND (QUANTIFIER (GLOBAL-ERR '(I CAN"T + (COND (QUANTIFIER (GLOBAL-ERR '(I CAN/"T HANDLE COMBINATIONS OF @@ -1337,4 +1342,3 @@ ;MAPCAN. ((MAPCAN 'CHECKREL RELATION)))) (RELATIONS? OSS))))) -  \ No newline at end of file diff --git a/src/shrdlu/syscom.181 b/src/shrdlu/syscom.182 similarity index 90% rename from src/shrdlu/syscom.181 rename to src/shrdlu/syscom.182 index dbd3e5e38..4bb0d029f 100644 --- a/src/shrdlu/syscom.181 +++ b/src/shrdlu/syscom.182 @@ -1,22 +1,30 @@ - -(DECLARE (GENPREFIX SYSCOM)) - ;;;********************************************************************* ;;; ;;; SYSCOM - TOPLEVEL AND GENERAL UTILITY FUNCTIONS ;;; ;;;********************************************************************** +(DECLARE (GENPREFIX SYSCOM)) +(declare (*fexpr ert printc interogate deflist disp dsay cleanout cleanup thert + erterr bug global-err combination? say defs ioc thflush + isq)) +(declare (*expr n fe nb sm h word starthistory shstpo etaoin sprint listify2)) +(declare (muzzled t)) +(declare (specials t)) + +(eval-when (compile) + (load '((lisp)umlmac))) + (DEFUN SHRDLU NIL (PROG (ERT-TIME END AMB TIMAMB BOTH BACKREF BACKREF2 ANSNAME - LASTREL WHO PT PTW SENT PUNCT IGNORE H N NB FE SM RE + LASTREL WHO PT PTW SENT PUNCT IGNORE HV N NB FE RE MES MESP C CUT CURTIME STATE GLOBAL-MESSAGE LEVEL P-TIME SMN-TIME PLNR-TIME ANS-TIME ANS-PLNR-TIME SH-GCTIME) (CLEANOUT TSS EVX NODE ANS OSS RSS X) ;FLUSH OLD GENSYMS CATCH-LOOP (*CATCH 'abort-parser - (PROG NIL + (PROG () LOOP (SETQ SENTNO (ADD1 SENTNO) PARSINGS 0. LEVEL 0. @@ -49,7 +57,7 @@ (OR ANNOYANCE (PRINT *2)) (SETQ FE (FE C)) (SETQ NB SENT) - (SETQ H (H C)) + (SETQ HV (H C)) (SETQ INTERPRETATION (SM C)) (AND SH-BEFOREANSWER-PAUSE (ERT BEFORE ANSWERING)) @@ -259,7 +267,7 @@ (TERPRI)) (SPRINT (COND ((CDR 0A) (GET (CAR 0A) (CADR 0A))) ((EVAL (CAR 0A)))) - LINEL + (linel t) 0.) *4) FEXPR) @@ -286,13 +294,13 @@ (TERPRI) (TAB 4.) (PRINC (CAR PLIST)) - (SPRINT (CADR PLIST) (*DIF LINEL 18.) 18.) + (SPRINT (CADR PLIST) (*DIF (linel t) 18.) 18.) B (COND ((SETQ PLIST (CDDR PLIST)) (GO A))) (TERPRI) (AND DPSTOP (ERT)) (RETURN '*))) -(DEFUN FEXPR DSAY (L) (APPLY 'SAY L)) +(DEFUN DSAY fexpr (L) (APPLY 'SAY L)) ;;*page @@ -408,7 +416,7 @@ (READCH) (GO LISTEN)) ;;CHECK FOR DELIMITER - ((EQ (TYIPEEK) 13.) ;CARRIAGE RETURN + ((= (TYIPEEK) 13.) ;CARRIAGE RETURN (COND (BUILDING-ST-FORM (SETQ EXP ;DELIMITER CASE (REVERSE ST-BUFFER)) (GO EVAL-EXP)) @@ -510,17 +518,17 @@ (SETQ A (CDR A)) (GO GO))) -(DEFPROP MOD (LAMBDA (A B) (UNION (SETDIF A (CADR B)) (CAR B))) EXPR) +(DEFPROP MOD (LAMBDA (A B) (UNION2 (SETDIF A (CADR B)) (CAR B))) EXPR) -(DEFUN NTH (NUM LIST) - (COND ((ATOM LIST) (ERT NTH - ILLEGAL LIST)) - ((LESSP NUM 1.) (ERT NTH - ILLEGAL NUMBER))) - (PROG NIL - UP (COND ((EQUAL NUM 1.) (RETURN (CAR LIST))) - ((SETQ LIST (CDR LIST)) - (SETQ NUM (SUB1 NUM)) - (GO UP)) - (T (ERT NTH - LIST TOO SHORT))))) +;(DEFUN NTH (NUM LIST) +; (COND ((ATOM LIST) (ERT NTH - ILLEGAL LIST)) +; ((LESSP NUM 1.) (ERT NTH - ILLEGAL NUMBER))) +; (PROG NIL +; UP (COND ((EQUAL NUM 1.) (RETURN (CAR LIST))) +; ((SETQ LIST (CDR LIST)) +; (SETQ NUM (SUB1 NUM)) +; (GO UP)) +; (T (ERT NTH - LIST TOO SHORT))))) (DEFPROP PR1 (LAMBDA (A) @@ -552,8 +560,8 @@ A))) EXPR) -(defun chrct () - (cdr (cursorpos))) +(defmacro chrct () + `(linel t)) (DEFUN PRINT2 (X) (COND ((GREATERP (chrct) (FLATSIZE X)) (PRINC '/ )) @@ -567,7 +575,7 @@ (DEFUN PRINTEXT (TEXT) (COND (TEXT (TERPRI) - (EVAL (CONS 'SAY (LISTIFY TEXT)))))) + (EVAL (CONS 'SAY (LISTIFY2 TEXT)))))) (DEFPROP PRINTC (LAMBDA (L) (PROG (TEST) @@ -603,7 +611,7 @@ (GO GO))))) EXPR) -(DEFUN UNION (A B) +(DEFUN UNION2 (A B) (PROG (SET) (SETQ SET (REVERSE A)) GO (COND ((NULL B) (RETURN (REVERSE SET))) @@ -633,16 +641,28 @@ (COND ((SETQ L (CDDR L)) (GO LOOP))) (RETURN A))) -(DEFPROP TAB - (LAMBDA (N) (PROG (P) - (COND ((GREATERP N LINEL) - (RETURN '))) - A (SETQ P (DIFFERENCE LINEL (chrct))) - (COND ((NOT (GREATERP N P)) - (RETURN '))) - (PRINC '/ ) - (GO A))) - EXPR) +;(defun xxxx () +; (- (linel t) (cdr (cursorpos t)))) + +;(DEFPROP TAB +; (LAMBDA (N) (PROG (P) +; (COND ((GREATERP N (linel t)) +; (RETURN '))) +; A (SETQ P (DIFFERENCE (linel t) (xxxx))) +; (COND ((NOT (GREATERP N P)) +; (RETURN '))) +; (PRINC '/ ) +; (GO A))) +; EXPR) + +(defun tab (n) + (let ((nn (* n 8))) + (cond ((or (> n (linel t)) + (< n (cdr (cursorpos t)))) + ') + (t (let ((num-spaces (- n (cdr (cursorpos t))))) + (dotimes (x num-spaces) (princ '/ )) + '))))) (DEFUN SPACE (N) (PROG (NN) @@ -650,4 +670,10 @@ (PRINC '/ ) (SETQ N (SUB1 N)) (GO A))))) -  \ No newline at end of file + +(DEFUN ERTSTOP FEXPR (/,ERT) + ((LAMBDA (NOSTOP) + (ERTEX /,ERT NIL NIL)) + NIL)) + + diff --git a/src/shrdlu/thtrac.23 b/src/shrdlu/thtrac.24 similarity index 97% rename from src/shrdlu/thtrac.23 rename to src/shrdlu/thtrac.24 index 82b51e07a..301b804b4 100644 --- a/src/shrdlu/thtrac.23 +++ b/src/shrdlu/thtrac.24 @@ -1,10 +1,12 @@ - -(COMMENT FOR PLNR 159 AND GREATER/, THPRINTC CAN BE ELIMINATED) - ;SYSTEM FUNCTIONS SUCH AS THGOAL, THASSERT, THERASE AND THEOREM ;(ALL THMS) ARE TRACED IF THEY ARE ON 'THTRACE'. THTRACES1 PUTS ;THEM THERE AND THUNTRACE TAKES THEM OFF. +(declare (*fexpr thert)) +(declare (*expr thval)) +(declare (muzzled t)) +(declare (specials t)) + ;THTRACE IS INITIALLY SET TO NIL BY TS PLNR (DEFUN THTRACE FEXPR (L) (MAPC (FUNCTION THTRACE1) L)) @@ -78,7 +80,7 @@ (THERT THTRACES - TRACE LOSSAG)) ;THE TRACE FN IS EXECUTED - (THZ THL THB) + (funcall THZ THL THB) ;IF THB IS NON-NIL, BREAK THB @@ -187,7 +189,7 @@ ;PREDICATES OF PARTICULAR THMS ON THTRACE (DEFUN THSEL (THF) (PROG (THX) (RETURN (AND (SETQ THX (ASSQ THL THTRACE)) - (SETQ THX (THF THX)) + (SETQ THX (funcall THF THX)) (THVAL THX THALIST))))) @@ -196,7 +198,3 @@ (EXPLODE (SETQ THGENS (ADD1 THGENS)))))) (SETQ THGENS 0) - - -(DEFUN THPRINTC (X) (TERPRI) (PRINC X) (PRINC '/ )) -  \ No newline at end of file