diff --git a/build/shrdlu.tcl b/build/shrdlu.tcl index 4085d6771..3dea7b2dc 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