(COMMENT : "Prolog/KR Interpreter  (by H. Nakashima)")
(DEFUN P:VERSION NIL (FORMAT "Version /c-/c/n" "C" "16.4"))
(COMMENT : "ASSERT(A/Z) copies outer definition -- Vers. 12.0" 
 "EQ is fixed -- Vers. 12.1" "READ revised -- Vers. 12.2" 
 "ASSERT(A/Z) knows (DEFINE p NIL) -- Vers. 12.4" 
 "TERPRI may take one argument (stream) -- Vers. 12.8" 
 "P:FETCHVALUE does not remove ' -- Vers. 12.9" "HELP installed -- Vers. 12.9")
(DECLARE
   (:VARIABLE-PREFIX :TRACE :FREE :DATABASE :DAEMON :NUMDATA :LAST-RESULT)
   SPECIAL)
(DEFUN PROLOG NIL (P:INIT) (P:VERSION) (PGO))
(DEFUN P:INIT NIL
   (SETQ :PROLOG-WORLD '(STANDARD-WORLD))
   (SETQ :DEFINITION-STACK NIL)
   (SETQ :PRINTLEVEL 7)
   (SETQ :VARIABLE-PREFIX '(92 110 76))
   (SETQ :TRACE NIL)
   (SETQ :TRACEALL NIL)
   (SETQ :STEP NIL)
   (SETQ :STEPLEVEL 99999)
   (SETQ :SELECTSTEP NIL)
   (SETQ :DEBUG1 NIL)
   (SETQ :FREE NIL)
   (SETQ :DATABASE (VECTOR 1000))
   (SETQ :DAEMON (VECTOR 1000))
   (DO ((I 0 (ADD1 I))) ((EQ I 1000)) (PUSH I :FREE))
   (SETQ :NUMDATA NIL)
   (P:INITCODE)
   (PR:INIT 256)
   (SETQ :TOPLEVEL (NCONS TOPLEVEL)))
(DEFUN P:ERROR (MES (AT ""))
   (R:PUSH-CUE (NCONS (LIST 'ERROR MES AT)) :OLD-SUBST))
(DECLARE
   (:DEBUG :DEBUG1 :STEP :SELECTSTEP :STEPLEVEL :TRACEALL :TRACELEVEL :PRINTLEVEL)
   SPECIAL)
(DEFUN PGO NIL (PUSH-TOPLEVEL 'PROLOG-TOPLEVEL) (TOPLEVEL))
(DECLARE (:TOPLEVEL) SPECIAL)
(DEFUN PUSH-TOPLEVEL (TOP) (PUSH TOPLEVEL :TOPLEVEL) (SETQ TOPLEVEL TOP))
(DEFUN POP-TOPLEVEL NIL
   (COND ((NULL :TOPLEVEL) NIL) (T (SETQ TOPLEVEL (POP :TOPLEVEL)))))
(DEFUN PROLOG-TOPLEVEL NIL
   (LETS ((ATTENTION-HANDLER
             (FUNCTION (LAMBDA NIL (RIND (COND (:DEBUG1 "D:") (T ":"))))))
          (ERR:READ
             (FUNCTION
              (LAMBDA (STREAM (X NIL))
               (FORMAT "ILLEGAL OBJECT READ : /C/N" (READLINE STREAM))
               (THROW ':PROLOGLOOP NIL)))))
    (CATCH ':TOP
       (LET ((INPUT (CATCH ':PROLOGLOOP (RIND (COND (:DEBUG1 "D:") (T ":"))))) 
             (:BACKTRACE NIL))
        (COND ((NULL INPUT))
              ((SYMBOLP INPUT) (P:OS INPUT (READLINE)))
              (T (P:EXECUTE INPUT)
                 (AND (EQ STANDARD-INPUT TERMINAL-INPUT)
                      (GRIND (P:FETCHVALUE (CAR :LAST-RESULT) (CDR :LAST-RESULT) :PRINTLEVEL)))))))))
(DECLARE (:COMMAND :PARAMETER) SPECIAL)
(DEFUN P:OS (:COMMAND :PARAMETER)
   (CATCH ':COMMAND
      (LET ((ATTENTION-HANDLER (FUNCTION (LAMBDA NIL (THROW ':COMMAND NIL)))))
       (COND ((STRING-SEARCH-NOT-CHAR " " :PARAMETER) (CALL :COMMAND :PARAMETER))
             (T (CALL :COMMAND))))))
(DECLARE (:UNDOLIST :DEFINITION-STACK :ITEM) SPECIAL)
(DEFUN P:EXECUTE (:ITEM)
   (LET ((:DEBUG (OR :TRACEALL :TRACE :STEP :DEBUG1)))
    (CATCH ':PROLOGLOOP
       (LETS ((ATTENTION-HANDLER (FUNCTION P:ATTENTION)) (BREAK (FUNCTION P:BREAK)) 
              ($SUBST (P:NEWSUBST)) (:UNDOLIST NIL) (RESULT (REFUTE :ITEM $SUBST)))
        (SETQ :LAST-RESULT (CONS RESULT $SUBST))))
    (PUTPROP 'LAST-INPUT (NCONS (NCONS (NCONS :ITEM))) (CAR :PROLOG-WORLD))))
(DEFUN P:ASSERT (CLAUSE)
   (PUTPROP (CAAR CLAUSE)
      (ASSERT:POS (R:GETDEF (CAR CLAUSE)) (CONS (CDAR CLAUSE) (CDR CLAUSE)))
      (CAR :PROLOG-WORLD))
   (P:PUSH-WORLD (CAR :PROLOG-WORLD) (CAAR CLAUSE)))
(DEFUN ASSERT:POS (OLDDEF NEWDEF)
   (COND ((NULL OLDDEF) (NCONS NEWDEF))
         ((NULL (CAR OLDDEF)) (CONS NEWDEF OLDDEF))
         ((AND (ASSERT:UNIT NEWDEF) (NOT (ASSERT:UNIT (CAR OLDDEF))))
          (CONS NEWDEF OLDDEF))
         ((AND (ASSERT:UNIT (CAR OLDDEF)) (NOT (ASSERT:UNIT NEWDEF)))
          (CONS (CAR OLDDEF) (ASSERT:POS (CDR OLDDEF) NEWDEF)))
         ((ASSERT:SPECIFICP (CAR NEWDEF) (CAAR OLDDEF)) (CONS NEWDEF OLDDEF))
         (T (CONS (CAR OLDDEF) (ASSERT:POS (CDR OLDDEF) NEWDEF)))))
(DEFUN ASSERT:SPECIFICP (P1 P2)
   (COND ((P:VARP P1) NIL)
         ((P:VARP P2) T)
         ((ATOM P1) (NOT (ATOM P2)))
         ((ATOM P2) NIL)
         (T (DO ((X (POP P1) (POP P1)) (Y (POP P2) (POP P2)))
                (NIL)
                (COND ((ASSERT:SPECIFICP X Y) (EXIT T))
                      ((AND (ATOM Y) (OR (LISTP X) (P:VARP X))) (EXIT NIL))
                      ((P:VARP P1) (EXIT))
                      ((P:VARP P2) (EXIT T))
                      ((ATOM P1) (EXIT (NOT (ATOM P2))))
                      ((ATOM P2) (EXIT)))))))
(DEFUN ASSERT:UNIT (DEF) (NULL (CDR DEF)))
(DEFUN P:ASSERTZ (CLAUSE)
   (PUTPROP (CAAR CLAUSE)
      (ASSERT:LAST (CONS (CDAR CLAUSE) (CDR CLAUSE)) (R:GETDEF (CAR CLAUSE)))
      (CAR :PROLOG-WORLD))
   (P:PUSH-WORLD (CAR :PROLOG-WORLD) (CAAR CLAUSE)))
(DEFUN P:ASSERTA (CLAUSE)
   (PUTPROP (CAAR CLAUSE)
      (CONS (CONS (CDAR CLAUSE) (CDR CLAUSE)) (R:GETDEF (CAR CLAUSE)))
      (CAR :PROLOG-WORLD))
   (P:PUSH-WORLD (CAR :PROLOG-WORLD) (CAAR CLAUSE)))
(DEFUN *ASSERT (X INDENT CLOSE)
   (PRIN1 (POP X))
   (PRINC " ")
   (*PRIND (POP X) (CURSOR) 0)
   (COND ((PRINTABLE X (/- (COLLEFT) CLOSE 2))
          (PRINC "  ")
          (*BLOCK X (/+ INDENT 5) CLOSE))
         (T (TAB (/+ INDENT 5)) (*BLOCK X (/+ INDENT 5) CLOSE))))
(PUTPROP 'ASSERT (FUNCTION *ASSERT) 'PRIND)
(PUTPROP 'ASSERTZ (FUNCTION *ASSERT) 'PRIND)
(PUTPROP 'ASSERTA (FUNCTION *ASSERT) 'PRIND)
(DEFUN P:ATTENTION NIL
   (REFUTE '(ATTENTION) :OLD-SUBST :LEVEL :CUE :STACK)
   (THROW 'REFUTE T))
(DEFUN P:BREAK NIL
   (LET ((STANDARD-OUTPUT TERMINAL-OUTPUT) (:STEP T)) (P:STEP)))
(DEFUN P:PUSH-WORLD (WORLD PRED)
   (LET ((DEFS (GET WORLD ':WORLD)))
    (COND ((MEMQ PRED DEFS)) (T (PUTPROP WORLD (CONS PRED DEFS) ':WORLD)))))
(DEFUN ASSERT:LAST (CLAUSE DEFS)
   (COND ((NULL DEFS) (NCONS CLAUSE))
         ((NULL (CAR DEFS)) (CONS CLAUSE DEFS))
         (T (CONS (CAR DEFS) (ASSERT:LAST CLAUSE (CDR DEFS))))))
(DECLARE (:FETCHED-VALUE :FETCHED-SUBST :PROLOG-WORLD) SPECIAL)
(DEFUN UNIFY (X XSUBST Y YSUBST)
   (AND (P:VARP Y)
        (P:ASSIGNED Y YSUBST)
        (SETQ Y (P:FETCH (CADR :FETCHED-VALUE) (CDDR :FETCHED-VALUE)))
        (SETQ YSUBST :FETCHED-SUBST))
   (COND ((OR (EQ X '?) (EQ Y '?)))
         ((LISTP X)
          (COND ((AND (SYMBOLP (CAR X)) (EQ (SREF (CAR X) 0) (CHARACTER "!")))
                 (!:REFUTE (SUBSTRING (CAR X) 1) (CDR X) XSUBST Y YSUBST))
                ((AND (EQ (CAR X) 'QUOTE) (EQ (LENGTH X) 2))
                 (COND ((ATOM Y) (EQUAL (SECOND X) Y))
                       ((AND (EQ (CAR Y) 'QUOTE) (EQ (LENGTH Y) 2)) (EQUAL (SECOND X) (SECOND Y)))
                       (T (EQUAL (SECOND X) Y))))
                ((P:VARP Y) (P:LINK Y YSUBST X XSUBST))
                ((ATOM Y) NIL)
                ((AND (EQ (CAR Y) 'QUOTE) (EQ (LENGTH Y) 2)) (EQUAL X (SECOND Y)))
                ((AND (SYMBOLP (CAR Y)) (EQ (SREF (CAR Y) 0) (CHARACTER "!")))
                 (!:REFUTE (SUBSTRING (CAR Y) 1) (CDR Y) YSUBST X XSUBST))
                ((UNIFY (CAR X) XSUBST (CAR Y) YSUBST) (UNIFY (CDR X) XSUBST (CDR Y) YSUBST))))
         ((LISTP Y)
          (COND ((AND (SYMBOLP (CAR Y)) (EQ (SREF (CAR Y) 0) (CHARACTER "!")))
                 (!:REFUTE (SUBSTRING (CAR Y) 1) (CDR Y) YSUBST X XSUBST))
                ((AND (EQ (CAR Y) 'QUOTE) (EQ (LENGTH Y) 2)) (EQUAL X (SECOND Y)))
                ((P:VARP X)
                 (COND ((P:ASSIGNED X XSUBST)
                        (UNIFY (CADR :FETCHED-VALUE) (CDDR :FETCHED-VALUE) Y YSUBST))
                       (T (P:LINK X XSUBST Y YSUBST))))))
         ((P:VARP X)
          (COND ((P:ASSIGNED X XSUBST)
                 (UNIFY (CADR :FETCHED-VALUE) (CDDR :FETCHED-VALUE) Y YSUBST))
                (T (P:LINK X XSUBST Y YSUBST))))
         ((P:VARP Y) (P:LINK Y YSUBST X XSUBST))
         (T (EQUAL X Y))))
(DEFUN S:UNIFY (FORMAL FSUBST ACTUAL ASUBST)
   (AND (P:VARP ACTUAL)
        (P:ASSIGNED ACTUAL ASUBST)
        (SETQ ACTUAL (P:FETCH (CADR :FETCHED-VALUE) (CDDR :FETCHED-VALUE)))
        (SETQ ASUBST :FETCHED-SUBST))
   (COND ((EQ FORMAL '?))
         ((LISTP ACTUAL)
          (COND ((AND (SYMBOLP (CAR ACTUAL)) (EQ (SREF (CAR ACTUAL) 0) (CHARACTER "!")))
                 (R:LAMBDA-BIND
                    ASUBST
                    (LET ((VAR (INTERN (STRING (CAR :VARIABLE-PREFIX)))))
                     (R:LAMBDA-LINK VAR ASUBST (GENSYM VAR) ASUBST)
                     (AND (REFUTE (CDR ACTUAL) ASUBST (ADD1 :LEVEL))
                          (S:UNIFY FORMAL FSUBST VAR ASUBST)))))
                ((AND (SYMBOLP FORMAL) (EQ (SREF FORMAL 0) 92))
                 (P:LINK FORMAL FSUBST ACTUAL ASUBST))
                ((ATOM FORMAL) NIL)
                ((S:UNIFY (CAR FORMAL) FSUBST (CAR ACTUAL) ASUBST)
                 (S:UNIFY (CDR FORMAL) FSUBST (CDR ACTUAL) ASUBST))))
         ((AND (SYMBOLP FORMAL) (EQ (SREF FORMAL 0) 92))
          (P:LINK FORMAL FSUBST ACTUAL ASUBST))
         ((P:VARP ACTUAL) (P:LINK ACTUAL ASUBST FORMAL FSUBST))
         (T (EQUAL FORMAL ACTUAL))))
(MACRO P:VARP (X)
   (LIST 'AND
         (LIST 'SYMBOLP (CAR X))
         (LIST 'MEMQ (LIST 'SREF (CAR X) '0) ':VARIABLE-PREFIX)))
(MACRO P:NEWSUBST (SB)
   (COND (SB (LIST 'NCONS (CAR SB))) (T '(NCONS (GENSYM "_")))))
(MACRO P:ASSIGNED (X)
   (LIST 'SETQ ':FETCHED-VALUE (LIST 'ASSQ (FIRST X) (LIST 'CDR (SECOND X)))))
(DEFUN P:LINK (X XSUBST Y YSUBST)
   (OR (AND (EQ XSUBST YSUBST) (EQ X Y))
       (PUSH (CONS (RPLACD XSUBST (CONS (CONS X (CONS Y YSUBST)) (CDR XSUBST)))
                   (SECOND XSUBST))
             :UNDOLIST)))
(DEFUN P:FETCH (X S)
   (COND ((P:ASSIGNED X S) (P:FETCH (CADR :FETCHED-VALUE) (CDDR :FETCHED-VALUE)))
         (T (SETQ :FETCHED-SUBST S) X)))
(DEFUN P:UNDO (UP)
   (LOOP (AND (EQ :UNDOLIST UP) (EXIT))
         (DELQ (CDAR :UNDOLIST) (CAAR :UNDOLIST))
         (POP :UNDOLIST)))
(DEFUN P:FETCHVALUE (X ($SUBST NIL) (FETCH-LEVEL 0))
   (COND ((P:VARP X)
          (COND ($SUBST (COND ((P:ASSIGNED X $SUBST)
                               (P:FETCHVALUE (CADR :FETCHED-VALUE) (CDDR :FETCHED-VALUE) FETCH-LEVEL))
                              (T (INTERN (STRING-APPEND X (CAR $SUBST))))))
                (T X)))
         ((ATOM X) X)
         ((ZEROP (SUB1 FETCH-LEVEL)) '?)
         (T (CONS (P:FETCHVALUE (CAR X) $SUBST (SUB1 FETCH-LEVEL))
                  (P:FETCHVALUE (CDR X) $SUBST (SUB1 FETCH-LEVEL))))))
(DEFUN P:TRACE:R (RESULT $FORM $SUBST $LEVEL)
   (PRIN1 '=)
   (PRIN1 :LEVEL)
   (GRIND (P:FETCHVALUE (AND RESULT $FORM) $SUBST :PRINTLEVEL)))
(DEFUN P:TRACE ($FORM $SUBST $LEVEL)
   (PRIN1 $LEVEL)
   (GRIND (P:FETCHVALUE $FORM $SUBST :PRINTLEVEL)))
(DECLARE (:BACKTRACE) SPECIAL)
(DEFUN P:STEP NIL
   (COND ((AND (OR :STEP (MEMQ (CAR :FORM) :SELECTSTEP)) (>= :STEPLEVEL :LEVEL))
          (SETQ :STEPLEVEL 1000)
          (P:TRACE :FORM :OLD-SUBST :LEVEL)
          (DO ((COM (RIND "S:") (RIND "S:")))
              (NIL)
              (COND ((LISTP COM)
                     (LETS ((:SELECTSTEP NIL) (:STEP NIL))
                      (P:EXECUTE COM)
                      (GRIND (P:FETCHVALUE (CAR :LAST-RESULT) (CDR :LAST-RESULT) :PRINTLEVEL))))
                    (T (SELECTQ COM
                          (C (EXIT))
                          (F (EXIT (SETQ :STEP NIL)))
                          (G (EXIT (SETQ :STEPLEVEL :LEVEL)))
                          (BT (P:BACKTRACE :PRINTLEVEL))
                          (BACKTRACE (P:BACKTRACE 99))
                          ((Q Z) (SETQ :LAST-RESULT (NCONS NIL)) (THROW ':PROLOGLOOP NIL))
                          (PP (GRIND (P:FETCHVALUE :FORM :OLD-SUBST)))
                          (S (SETQ :STEP NIL) (PUSH (RIND "FUNCTION:") :SELECTSTEP))
                          (ALL (EXIT (SETQ :STEP T)))
                          (LEVEL (SETQ :PRINTLEVEL (RIND "LEVEL:")))
                          (X (LETS ((:SELECTSTEP NIL) (:STEP NIL))
                              (P:EXECUTE (RIND "Form:"))
                              (GRIND (P:FETCHVALUE (CAR :LAST-RESULT) (CDR :LAST-RESULT) :PRINTLEVEL))))
                          ((? HELP)
                           (FORMAT "Available commands are:/n")
                           (PRINC "All, ")
                           (PRINC "BackTrace, ")
                           (PRINC "Continue, ")
                           (PRINC "Finish, ")
                           (PRINC "Go, ")
                           (PRINC "Level, ")
                           (PRINC "PrettyPrint, ")
                           (PRINC "Quit, ")
                           (PRINC "eXecute, ")
                           (PRINC "Z, ")
                           (FORMAT "/nand normal predicate calls./n"))
                          (T (FORMAT "Undefined command : /s/nTry HELP/n" COM)))))))))
(DEFUN R:SUCCEED NIL
   (COND ((NULL :CUE) (THROW 'REFUTE :GOAL))
         (T (LET ((CUE (POP :CUE)))
             (SETQ :CLAUSE (VREF CUE 0))
             (SETQ :OLD-SUBST (VREF CUE 1))
             (SETQ :LEVEL (VREF CUE 2))
             (SETQ :FORM (POP :CLAUSE))
             (SETQ :DEFINITIONS (R:GETDEF :FORM))
             (SETQ :UNDO-POINT :UNDOLIST)
             (SETQ :NEW-SUBST (P:NEWSUBST))
             (SETQ :FATHER (VREF CUE 3))))))
(DEFUN R:PUSH-CUE ($CLAUSE $SUBST ($LEVEL :LEVEL) ($STACK :STACK))
   (LET ((CUE (VECTOR 4)))
    (VSET CUE 0 $CLAUSE)
    (VSET CUE 1 $SUBST)
    (VSET CUE 2 $LEVEL)
    (VSET CUE 3 :FATHER)
    (PUSH CUE :CUE)))
(DEFUN R:FAIL NIL
   (COND (:STACK (R:POP) (P:UNDO :UNDO-POINT))
         (T (P:UNDO :FINAL-UNDO-POINT) (THROW 'REFUTE NIL))))
(COMMENT
   (DEFUN R:PUSH ($FORM $DEFINITIONS ($SUBST :OLD-SUBST))
      (SETQ :STACK (CONS $FORM
                         (CONS $DEFINITIONS
                               (CONS $SUBST
                                     (CONS :LEVEL (CONS :CUE (CONS :UNDO-POINT (CONS :FINAL-UNDO-POINT :STACK))))))))))
(DEFUN R:PUSH ($FORM $DEFINITIONS ($SUBST :OLD-SUBST))
   (LET ((V (VECTOR 8)))
    (VSET V 0 $FORM)
    (VSET V 1 $DEFINITIONS)
    (VSET V 2 $SUBST)
    (VSET V 3 :LEVEL)
    (VSET V 4 :CUE)
    (VSET V 5 :UNDO-POINT)
    (VSET V 6 :FINAL-UNDO-POINT)
    (VSET V 7 :FATHER)
    (PUSH V :STACK)))
(COMMENT
   (DEFUN R:POP NIL
      (SETQ :FORM (POP :STACK))
      (SETQ :CLAUSE NIL)
      (SETQ :DEFINITIONS (POP :STACK))
      (SETQ :OLD-SUBST (POP :STACK))
      (SETQ :LEVEL (POP :STACK))
      (SETQ :CUE (POP :STACK))
      (SETQ :UNDO-POINT (POP :STACK))
      (SETQ :FINAL-UNDO-POINT (POP :STACK))))
(DEFUN R:POP NIL
   (LET ((V (POP :STACK)))
    (SETQ :FORM (VREF V 0))
    (SETQ :CLAUSE NIL)
    (SETQ :DEFINITIONS (VREF V 1))
    (SETQ :OLD-SUBST (VREF V 2))
    (SETQ :LEVEL (VREF V 3))
    (SETQ :CUE (VREF V 4))
    (SETQ :UNDO-POINT (VREF V 5))
    (SETQ :FINAL-UNDO-POINT (VREF V 6))
    (SETQ :FATHER (VREF V 7))))
(DEFUN POP:CHECK (CGOAL)
   (DO ((D (R:GETDEF :FORM)))
       ((NULL D) (R:PUSH :FORM :DEFINITIONS))
       (AND (MEMQ CGOAL (POP D)) (EXIT))))
(DEFUN P:BACKTRACE (LEVEL)
   (GRIND (P:FETCHVALUE
             (MAPCAR :BACKTRACE
                (FUNCTION (LAMBDA (X) (P:FETCHVALUE (CAR X) (CDR X) LEVEL))))
             (P:NEWSUBST "")
             (ADD1 LEVEL))))
(DEFUN R:GETDEF ($FORM)
   (AND (LISTP $FORM) (R:GET-PRED-VALUE (CAR $FORM) :PROLOG-WORLD)))
(DEFUN R:CLEAR NIL (SETQ :CUE NIL :STACK NIL) T)
(DEFUN R:PAUSE NIL
   (PUSH (CONS (LIST :LEVEL :FORM) :OLD-SUBST) :BACKTRACE)
   (P:STEP)
   (AND (OR :TRACEALL (MEMQ (CAR :FORM) :TRACE))
        (P:TRACE :FORM :OLD-SUBST :LEVEL)))
(DEFUN R:PAUSE2 (RESULT)
   (OR RESULT
       (PUSH (LIST :LEVEL 'FAIL (CAR (P:FETCHVALUE :FORM :OLD-SUBST 2))) :BACKTRACE))
   (AND (OR :TRACEALL
            (MEMQ (CAR :FORM) :TRACE)
            (AND (OR :STEP (MEMQ (CAR :FORM) :SELECTSTEP)) (>= :STEPLEVEL :LEVEL)))
        (P:TRACE:R RESULT :FORM :OLD-SUBST :LEVEL)))
(DECLARE
   (:FORM :OLD-SUBST :LEVEL :CUE :STACK :FATHER :GOAL :CLAUSE :DEFINITIONS 
    :UNDO-POINT :NEW-SUBST :FINAL-UNDO-POINT)
   SPECIAL)
(DEFUN REFUTE (:FORM (:OLD-SUBST (P:NEWSUBST)) (:LEVEL 0) (:CUE NIL) (:STACK NIL))
   (LETS ((:NEW-SUBST (P:NEWSUBST)) (:GOAL :FORM) (:CLAUSE NIL) 
          (:DEFINITIONS (R:GETDEF :FORM)) (:UNDO-POINT :UNDOLIST) 
          (:FINAL-UNDO-POINT :UNDOLIST) (:FATHER (CONS :STACK :CUE)))
    (CATCH 'REFUTE (LOOP (REFUTE:ONE)))))
(DEFUN REFUTE:ONE NIL
   (AND :CLAUSE (R:PUSH-CUE :CLAUSE :OLD-SUBST))
   (LOOP (COND ((LISTP :FORM)
                (AND (P:VARP (CAR :FORM))
                     (SETQ :FORM (CONS (P:FETCHVALUE (CAR :FORM) (CONS "" (CDR :OLD-SUBST))) (CDR :FORM)))
                     (SETQ :DEFINITIONS (R:GETDEF :FORM)))
                (EXIT))
               ((P:VARP :FORM)
                (SETQ :FORM (P:FETCH :FORM :OLD-SUBST))
                (OR (LISTP :FORM) (EXIT (P:ERROR "ILLEGAL FORM" :FORM)))
                (SETQ :OLD-SUBST :FETCHED-SUBST :DEFINITIONS (R:GETDEF :FORM)))
               (T (EXIT (P:ERROR "ILLEGAL FORM" :FORM)))))
   (AND :DEBUG (R:PAUSE))
   (COND ((NULL :DEFINITIONS)
          (COND ((P:SYSTEM (CAR :FORM) (CDR :FORM) :OLD-SUBST) (R:SUCCEED))
                (T (AND :DEBUG (R:PAUSE2 NIL)) (R:FAIL))))
         (T (SETQ :FATHER (CONS :STACK :CUE))
            (LOOP (COND ((NULL :DEFINITIONS) (AND :DEBUG (R:PAUSE2 NIL)) (EXIT (R:FAIL) NIL))
                        ((NULL (CAR :DEFINITIONS)) (EXIT (R:FAIL) NIL))
                        ((UNIFY (CAAR :DEFINITIONS) :NEW-SUBST (CDR :FORM) :OLD-SUBST)
                         (COND ((CDR :DEFINITIONS) (R:PUSH :FORM (CDR :DEFINITIONS)))
                               (:DEBUG (R:PUSH (LIST 'FAIL: :FORM) NIL)))
                         (EXIT (AND :DEBUG (R:PAUSE2 T))
                               (COND ((SETQ :CLAUSE (CDR (CAR :DEFINITIONS)))
                                      (SETQ :FORM (POP :CLAUSE))
                                      (SETQ :LEVEL (ADD1 :LEVEL))
                                      (SETQ :UNDO-POINT :UNDOLIST)
                                      (SETQ :OLD-SUBST :NEW-SUBST)
                                      (SETQ :NEW-SUBST (P:NEWSUBST))
                                      (SETQ :DEFINITIONS (R:GETDEF :FORM))
                                      T)
                                     ((R:SUCCEED)))))
                        (T (P:UNDO :UNDO-POINT) (POP :DEFINITIONS)))))))
(DEFUN REFUTE:N (:CLAUSE (:OLD-SUBST (P:NEWSUBST)) (:LEVEL :LEVEL) (:CUE NIL) (:STACK NIL))
   (LETS ((:FORM (POP :CLAUSE)) (:GOAL :FORM) (:DEFINITIONS (R:GETDEF :FORM)) 
          (:UNDO-POINT :UNDOLIST) (:NEW-SUBST (P:NEWSUBST)) 
          (:FINAL-UNDO-POINT :UNDOLIST))
    (CATCH 'REFUTE (LOOP (REFUTE:ONE)))))
(DECLARE (:NAME :ARGS :SUBST) SPECIAL)
(DEFUN P:SYSTEM (:NAME :ARGS $SUBST)
   (LET ((CODE (R:GET-PRED-VALUE :NAME ':CODE)))
    (COND (CODE (LET ((:SUBST (P:NEWSUBST "")))
                 (COND ((S:UNIFY (POP CODE) :SUBST :ARGS $SUBST) (FUNCALL CODE))
                       (T (P:ERROR "ILLEGAL FORM" (P:FETCHVALUE (CONS :NAME :ARGS) $SUBST))))))
          ((LISTP :NAME) (COMMENT LAMBDA FORM) (R:LAMBDA :NAME :ARGS $SUBST))
          ((DEFINEDP :NAME)
           (P:LISPFUNCTION
              :NAME
              :ARGS
              $SUBST
              (R:GET-PRED-VALUE :NAME ':LISP-PREDICATE)
              (AND (LISTP (GETD :NAME)) (EQ (CAR (GETD :NAME)) 'MACRO))))
          ((AND (P:VARP :NAME) (P:ASSIGNED :NAME $SUBST))
           (SETQ :FORM (CONS (P:FETCH (CADR :FETCHED-VALUE) (CDDR :FETCHED-VALUE)) :ARGS))
           (REFUTE:ONE))
          (T (P:ERROR "UNDEFINED PREDICATE" :NAME)))))
(DEFUN R:LAMBDA (LAMBDA-FORM $ARGS $SUBST)
   (R:LAMBDA-BIND
      $SUBST
      (REFUTE (THIRD LAMBDA-FORM)
              (R:LAMBDA-LINK (SECOND LAMBDA-FORM) $SUBST $ARGS $SUBST)
              (ADD1 :LEVEL))))
(DEFUN S:CONVERT (X $SUBST ELIMINATE-LAST?)
   (COND ((P:VARP X)
          (COND ((P:ASSIGNED X $SUBST)
                 (S:CONVERT (CADR :FETCHED-VALUE) (CDDR :FETCHED-VALUE) ELIMINATE-LAST?))
                (T X)))
         ((ATOM X) X)
         ((AND ELIMINATE-LAST? (NULL (CDR X))) NIL)
         ((AND (SYMBOLP (CAR X)) (EQ (SREF (CAR X) 0) (CHARACTER "!")))
          (R:LAMBDA-BIND
             $SUBST
             (LETS ((VAR (INTERN (STRING (CAR :VARIABLE-PREFIX)))))
              (R:LAMBDA-LINK VAR $SUBST (GENSYM VAR) $SUBST)
              (AND (REFUTE (CDR X) $SUBST) (S:CONVERT VAR $SUBST NIL)))))
         (T (CONS (S:CONVERT (CAR X) $SUBST NIL)
                  (S:CONVERT (CDR X) $SUBST ELIMINATE-LAST?)))))
(DECLARE (:BIND) SPECIAL)
(MACRO R:LAMBDA-BIND (X)
   (LIST 'LET
         '((:BIND NIL))
         (LIST 'PROG1 (SECOND X) (LIST 'DELQ ':BIND (FIRST X)))))
(DEFUN R:LAMBDA-LINK (VAR VAR-SUBST ARGS A-SUBST)
   (PROG1 (RPLACD VAR-SUBST
             (CONS (SETQ :BIND (CONS VAR (CONS ARGS A-SUBST))) (CDR VAR-SUBST)))
          (OR (EQ (STRING-LENGTH VAR) 1) (SETQ :BIND NIL))))
(DEFUN !:REFUTE (NAME BODY BSUBST OPPORNENT OSUBST)
   (R:LAMBDA-BIND
      BSUBST
      (REFUTE BODY
              (R:LAMBDA-LINK
                 (INTERN (STRING-APPEND (STRING (CAR :VARIABLE-PREFIX)) NAME))
                 BSUBST
                 OPPORNENT
                 OSUBST)
              (ADD1 :LEVEL))))
(DEFUN R:GET-PRED-VALUE (PRED IND)
   (COND ((SYMBOLP PRED)
          (LOOP (COND ((ATOM IND) (EXIT (GET PRED IND)))
                      ((GET PRED (CAR IND)) (EXIT (GET PRED (CAR IND)))))
                (POP IND)))
         ((LISTP PRED)
          (COND ((AND (SYMBOLP (CAR PRED)) (EQ (SREF (CAR PRED) 0) (CHARACTER "!")))
                 (!:REFUTE (SUBSTRING (CAR PRED) 1) (CDR PRED) :OLD-SUBST '*: :NEW-SUBST)
                 (R:GET-PRED-VALUE (P:FETCHVALUE '*: :NEW-SUBST) IND))
                ((EQ (CAR PRED) 'LAMBDA) NIL)
                (T (P:ERROR "Illegal Predicate" PRED) (R:SUCCEED) NIL)))
         (T (P:ERROR "ILLEGAL PREDICATE" PRED) (R:SUCCEED) NIL)))
(DEFUN P:LISPFUNCTION ($NAME $ARGS $SUBST DO-NOT-NEED-VALUE? MACRO?)
   (LET ((ARGS (S:CONVERT $ARGS $SUBST (NOT DO-NOT-NEED-VALUE?))))
    (COND (MACRO? (COND (DO-NOT-NEED-VALUE? (EVAL (CONS $NAME ARGS)))
                        (T (UNIFY (EVAL (CONS $NAME ARGS))
                                  (NCONS "")
                                  (COND ($ARGS (CAR (LAST $ARGS))) (T NIL))
                                  $SUBST))))
          (DO-NOT-NEED-VALUE? (APPLY $NAME ARGS))
          (T (UNIFY (APPLY $NAME ARGS) (NCONS "") (COND ($ARGS (CAR (LAST $ARGS)))) $SUBST)))))
(COMMENT
   (DEFUN R:POP-CUE NIL
      (COND ((NULL :CUE) NIL)
            (T (LET ((CUE (POP :CUE)))
                (SETQ :CLAUSE (VREF CUE 0))
                (SETQ :OLD-SUBST (VREF CUE 1))
                (SETQ :LEVEL (VREF CUE 2))
                (SETQ :FORM (POP :CLAUSE))
                (SETQ :DEFINITIONS (R:GETDEF :FORM))
                (SETQ :UNDO-POINT :UNDOLIST)
                (SETQ :NEW-SUBST (P:NEWSUBST))
                (SETQ :STACK (VREF CUE 3))
                (SETQ :FATHER (VREF CUE 4)))
               T))))
(DECLARE (:ARGS :SUBST :LEVEL LOADED :FILE :DEF-LIST) SPECIAL)
(MACRO P:DEFINE (CP)
   (COND ((SYMBOLP (CAR CP))
          (LIST 'PUSH
                (LIST 'CONS
                      (LIST 'QUOTE (CAR CP))
                      (LIST 'CONS
                            (LIST 'QUOTE (SECOND CP))
                            (LIST 'FUNCTION (LIST 'LAMBDA NIL (CONS 'AND (CDDR CP))))))
                ':DEF-LIST))
         ((LISTP (CAR CP))
          (CONS 'PROGN
                (MAPCAR (CAR CP) (FUNCTION (LAMBDA (X) (CONS 'P:DEFINE (CONS X (CDR CP))))))))))
(DEFUN P:INITCODE NIL
   (LET ((:DEF-LIST NIL))
    (INIT:DEF)
    (INIT:CONTROL)
    (INIT:IO)
    (INIT:DB)
    (INIT:ERROR)
    (INIT:MISC)
    (MAPC :DEF-LIST (FUNCTION (LAMBDA (X) (PUTPROP (CAR X) (CDR X) ':CODE))))
    (MAPC '(ATOM BSET CALL CLOSE COMMENT DEFUN DEFCS DELCS EXFILE FIXP FLOATP FORMAT FREE 
            GREATERP INOPEN LISTP LESSP LISTP MEMQ MINUSP NUMBERP ODDP OUTOPEN PLUSP PRINC 
            REFERENCEP SETREF SKIPLINE STRING-LESSP SSET STREAMP STRING-EQUAL STRING-LESSP 
            STRINGP SYMBOLP TYO VECTORP VSET ZEROP /0= /0=$ /0> /0>$ /0< /0<$ > >$ < <$ >= 
            >=$ <= <=$ <> <>$ # #$ =$)
       (FUNCTION (LAMBDA (X) (PUTPROP X T ':LISP-PREDICATE))))
    (MAPC '(EC:B EC:BI EC:BO EC:C EC:D EC:E EC:F EC:FN EC:I EC:IB EC:IN EC:IT EC:K EC:L 
            EC:LAST EC:LEVEL EC:LI EC:N EC:O EC:P EC:POP EC:PP EC:Q EC:R EC:RA EC:RI EC:S 
            EC:SC EC:ST EC:STACK EC:TOP EC:U EC:V EC:VAR EC:X EC:Z E:MOVE E:DEFCOM)
       (FUNCTION (LAMBDA (X) (PUTPROP X T ':LISP-PREDICATE))))))
(DEFUN INIT:DEF NIL
   (COMMENT ********** DEFINITIONS)
   (P:DEFINE
      (ASSERT AS)
      (*PRED . *BODY)
      (P:ASSERT (P:FETCHVALUE :ARGS (CONS "" (CDR :OLD-SUBST))))
      T)
   (P:DEFINE
      (ASSERTA AA)
      (*PRED . *BODY)
      (P:ASSERTA (P:FETCHVALUE :ARGS (CONS "" (CDR :OLD-SUBST))))
      T)
   (P:DEFINE
      (ASSERTZ AZ)
      (*PRED . *BODY)
      (P:ASSERTZ (P:FETCHVALUE :ARGS (CONS "" (CDR :OLD-SUBST))))
      T)
   (P:DEFINE
      DEFINE
      (*NAME . *DEF)
      (PROG1 T
             (PUTPROP (P:FETCHVALUE '*NAME :SUBST)
                (P:FETCHVALUE (CDR :ARGS) (CONS "" (CDR :OLD-SUBST)))
                (CAR :PROLOG-WORLD))
             (P:PUSH-WORLD (CAR :PROLOG-WORLD) (P:FETCHVALUE '*NAME :SUBST))))
   (P:DEFINE
      DEFINITION
      (*NAME *DEF)
      (UNIFY (GET (P:FETCHVALUE '*NAME :SUBST) (CAR :PROLOG-WORLD))
             (NCONS "")
             '*DEF
             :SUBST))
   (P:DEFINE (LISTING LIS) *ARGS (P:LISTING (P:FETCHVALUE '*ARGS :SUBST)))
   (P:DEFINE RETRACT (*NAME) (P:RETRACT (P:FETCH '*NAME :SUBST) :FETCHED-SUBST))
   (P:DEFINE
      SET
      (*NAME . *VALUE)
      (PUTPROP (P:FETCHVALUE '*NAME :SUBST)
         (NCONS (NCONS (P:FETCHVALUE (CDR :ARGS) (CONS "" (CDR :OLD-SUBST)))))
         (CAR :PROLOG-WORLD))))
(DEFUN INIT:DB NIL
   (COMMENT ********** INTERNAL DATA BASE)
   (P:DEFINE
      ERASE
      (*PATTERN)
      (LOOP (OR (P:ERASE (FIRST :ARGS) :OLD-SUBST) (EXIT NIL))
            (AND (P:CONTINUE) (EXIT (R:CLEAR) T))))
   (P:DEFINE
      RECORD
      (*PATTERN)
      (LET ((LOC (P:RECORD (P:FETCHVALUE '*PATTERN :SUBST))))
       (COND (LOC (COND ((P:CONTINUE)) (T (REC:ERASEL LOC) NIL))) (T NIL)))
      (R:CLEAR))
   (P:DEFINE
      RECORDED
      (*PATTERN)
      (P:RECORDED (FIRST :ARGS) :OLD-SUBST :CUE)
      (R:CLEAR))
   (P:DEFINE
      RECORDING
      (*PATTERN *PRED)
      (LETS ((DAEMONBODY (P:FETCHVALUE '*PRED :SUBST)) 
             (LOC (P:RECORD (P:FETCHVALUE '*PATTERN :SUBST) T DAEMONBODY)))
       (COND (LOC (VSET :DAEMON LOC DAEMONBODY))))))
(DEFUN INIT:IO NIL
   (COMMENT ********** INPUTS AND OUTPUTS)
   (P:DEFINE
      ADD
      (*FILE . *NAMES)
      (LET ((FN (INTERN (P:FETCHVALUE '*FILE :SUBST))) (X (P:FETCHVALUE '*NAMES :SUBST)))
       (PRINT (PUTPROP FN (UNION X (GET FN 'LOADED)) 'LOADED))))
   (P:DEFINE
      CLOSE
      (*FILE)
      (LET ((FILE (P:FETCHVALUE '*FILE :SUBST)))
       (COND ((STREAMP FILE) (CLOSE FILE))
             (T (P:ERROR "ILLEGAL ARGUMENT TO INOPEN" FILE)))))
   (P:DEFINE
      DEL
      (*FILE . *NAMES)
      (LET ((FN (INTERN (P:FETCHVALUE '*FILE :SUBST))) 
            (NAMES (P:FETCHVALUE '*NAMES :SUBST)))
       (PRINT (PUTPROP FN
                 (LET ((LOADED (GET FN 'LOADED)))
                  (MAPC NAMES (FUNCTION (LAMBDA (X) (SETQ LOADED (DELQ X LOADED)))))
                  LOADED)
                 'LOADED))))
   (P:DEFINE
      DUMP
      (*FILE *NAMES)
      (P:DUMP (P:FETCHVALUE (P:FETCH '*FILE :SUBST) :FETCHED-SUBST)
              (P:FETCHVALUE (P:FETCH '*NAMES :SUBST) :FETCHED-SUBST)))
   (P:DEFINE GRIND (*X) (PROG1 T (GRIND (P:FETCHVALUE '*X :SUBST))))
   (P:DEFINE
      INOPEN
      (*FILE *STREAM)
      (LET ((FILE (P:FETCHVALUE '*FILE :SUBST)))
       (UNIFY (COND ((STREAMP FILE) (INOPEN FILE))
                    ((OR (SYMBOLP FILE) (STRINGP FILE)) (INOPEN (STREAM (ALLOC FILE))))
                    (T (P:ERROR "ILLEGAL ARGUMENT TO INOPEN" FILE)))
              :SUBST
              '*STREAM
              :SUBST)))
   (P:DEFINE LOAD (*FILE) (P:LOAD (P:FETCHVALUE '*FILE :SUBST)))
   (P:DEFINE
      LOAD-WORLD
      (*FILE *WORLD)
      (LET ((:PROLOG-WORLD (CONS (P:FETCHVALUE '*WORLD :SUBST) :PROLOG-WORLD)))
       (P:LOAD (P:FETCHVALUE '*FILE :SUBST))))
   (P:DEFINE
      LOADED
      (*FILE *LOADED)
      (UNIFY '*LOADED
             :SUBST
             (GET (INTERN (P:FETCHVALUE '*FILE :SUBST)) 'LOADED)
             :SUBST))
   (P:DEFINE
      NEW-FILE
      (*NAME)
      (STRINGP (P:ALLOC-NEW-FILE (P:FETCHVALUE '*NAME :SUBST))))
   (P:DEFINE
      OUTOPEN
      (*FILE *STREAM)
      (LET ((FILE (P:FETCHVALUE '*FILE :SUBST)))
       (UNIFY (COND ((STREAMP FILE) (OUTOPEN FILE))
                    ((OR (SYMBOLP FILE) (STRINGP FILE)) (OUTOPEN (STREAM (ALLOC FILE))))
                    (T (P:ERROR "ILLEGAL ARGUMENT TO INOPEN" FILE)))
              :SUBST
              '*STREAM
              :SUBST)))
   (P:DEFINE
      PRINT
      (*X . *Y)
      (LETS ((ARGS (P:FETCHVALUE '*Y :SUBST)) (A2 (AND ARGS (FIRST ARGS))) 
             (A3 (AND (EQ (LENGTH ARGS) 2) (SECOND ARGS))) 
             (STANDARD-OUTPUT
                (COND ((STREAMP A2) A2) ((STREAMP A3) A3) (T (P:STANDARD-OUTPUT))))
             ($PRINTLEVEL (COND ((NUMBERP A2) A2) ((NUMBERP A3) A3) (T :PRINTLEVEL))))
       (OR (AND (NULL A2) (NULL A3))
           (STREAMP A2)
           (STREAMP A3)
           (NUMBERP A2)
           (NUMBERP A3)
           (P:ERROR "ILLEGAL ARGUMENT TO PRINT" (LIST A2 A3)))
       (GRIND (P:FETCHVALUE '*X :SUBST $PRINTLEVEL))
       T))
   (P:DEFINE
      PRIN1
      (*X . *Y)
      (LETS ((ARGS (P:FETCHVALUE '*Y :SUBST)) (A2 (AND ARGS (FIRST ARGS))) 
             (A3 (AND (EQ (LENGTH ARGS) 2) (SECOND ARGS))) 
             (STANDARD-OUTPUT
                (COND ((STREAMP A2) A2) ((STREAMP A3) A3) (T (P:STANDARD-OUTPUT))))
             ($PRINTLEVEL (COND ((NUMBERP A2) A2) ((NUMBERP A3) A3) (T :PRINTLEVEL))))
       (OR (AND (NULL A2) (NULL A3))
           (STREAMP A2)
           (STREAMP A3)
           (NUMBERP A2)
           (NUMBERP A3)
           (P:ERROR "ILLEGAL ARGUMENT TO PRIN1" (LIST A2 A3)))
       (PRIN1 (P:FETCHVALUE '*X :SUBST $PRINTLEVEL))
       T))
   (P:DEFINE
      PRINC
      (*X . *Y)
      (LETS ((ARGS (P:FETCHVALUE '*Y :SUBST)) (A2 (AND ARGS (FIRST ARGS))) 
             (A3 (AND (EQ (LENGTH ARGS) 2) (SECOND ARGS))) 
             (STANDARD-OUTPUT
                (COND ((STREAMP A2) A2) ((STREAMP A3) A3) (T (P:STANDARD-OUTPUT))))
             ($PRINTLEVEL (COND ((NUMBERP A2) A2) ((NUMBERP A3) A3) (T :PRINTLEVEL))))
       (OR (AND (NULL A2) (NULL A3))
           (STREAMP A2)
           (STREAMP A3)
           (NUMBERP A2)
           (NUMBERP A3)
           (P:ERROR "ILLEGAL ARGUMENT TO PRINC" (LIST A2 A3)))
       (PRINC (P:FETCHVALUE '*X :SUBST $PRINTLEVEL))
       T))
   (P:DEFINE
      PRINT-LEVEL
      (*LEVEL)
      (OR (UNIFY (P:FETCH '*LEVEL :SUBST) :FETCHED-SUBST :PRINTLEVEL :FETCHED-SUBST)
          (LET ((L (P:FETCHVALUE '*LEVEL :SUBST)))
           (COND ((NUMBERP L) (SETQ :PRINTLEVEL L))
                 (T (P:ERROR "ILLEGAL ARGUMENT TO PRINT-LEVEL" L))))))
   (P:DEFINE PROMPT ("-:"))
   (P:DEFINE
      READ
      (*X . *STREAM)
      (CATCH ':READ
         (UNIFY '*X
                :SUBST
                (LET ((PROMPT (COND ((GET 'PROMPT (CAR :PROLOG-WORLD)) (CAAAR (GET 'PROMPT (CAR :PROLOG-WORLD))))
                                    (T (CAAR (GET 'PROMPT ':CODE)))))
                      (ERR:END-OF-FILE (FUNCTION (LAMBDA (S) (THROW ':READ NIL)))) 
                      (STANDARD-INPUT
                         (LET ((S (P:FETCHVALUE '*STREAM :SUBST)))
                          (COND (S (FIRST S)) (T (P:STANDARD-INPUT))))))
                 (RIND PROMPT))
                (P:NEWSUBST ""))))
   (P:DEFINE
      STANDARD-INPUT
      (*STREAM)
      (LET ((STREAM (P:FETCHVALUE '*STREAM :SUBST)))
       (COND ((EQ STREAM 'TERMINAL-INPUT) (SETQ STANDARD-INPUT TERMINAL-INPUT))
             ((STREAMP STREAM) (SETQ STANDARD-INPUT STREAM))
             ((P:VARP STREAM) (UNIFY '*STREAM :SUBST STANDARD-INPUT :SUBST))
             (T (P:ERROR "ILLEGAL ARGUMENT TO STANDARD-INPUT" STREAM)))))
   (P:DEFINE
      STANDARD-OUTPUT
      (*STREAM)
      (LET ((STREAM (P:FETCHVALUE '*STREAM :SUBST)))
       (COND ((EQ STREAM 'TERMINAL-OUTPUT) (SETQ STANDARD-OUTPUT TERMINAL-OUTPUT))
             ((STREAMP STREAM) (SETQ STANDARD-OUTPUT STREAM))
             ((P:VARP STREAM) (UNIFY '*STREAM :SUBST STANDARD-OUTPUT :SUBST))
             (T (P:ERROR "ILLEGAL ARGUMENT TO STANDARD-OUTPUT" STREAM)))))
   (P:DEFINE
      STORE
      (*FILE)
      (P:STORE (P:FETCHVALUE (P:FETCH '*FILE :SUBST) :FETCHED-SUBST)))
   (P:DEFINE
      TAB
      (*TAB . *R)
      (LETS ((N (P:FETCHVALUE '*TAB :SUBST)) (REST (P:FETCHVALUE '*R :SUBST)) 
             (A2 (AND REST (FIRST REST))) 
             (STANDARD-OUTPUT (COND ((STREAMP A2) A2) (T (P:STANDARD-OUTPUT)))))
       (OR (NULL A2) (STREAMP A2) (P:ERROR "ILLEGAL ARGUMENT TO TAB" REST))
       (TAB N)
       T))
   (P:DEFINE
      TERMINAL-INPUT
      (*STREAM)
      (UNIFY '*STREAM :SUBST TERMINAL-INPUT :SUBST))
   (P:DEFINE
      TERMINAL-OUTPUT
      (*STREAM)
      (UNIFY '*STREAM :SUBST TERMINAL-OUTPUT :SUBST))
   (P:DEFINE
      TERPRI
      *X
      (LETS ((ARGS (P:FETCHVALUE '*X :SUBST)) (A2 (AND ARGS (FIRST ARGS))) 
             (STANDARD-OUTPUT (COND ((STREAMP A2) A2) (T (P:STANDARD-OUTPUT)))))
       (OR (NULL A2) (STREAMP A2) (P:ERROR "ILLEGAL ARGUMENT TO TERPRI" ARGS))
       (TERPRI)
       T)))
(DEFUN INIT:CONTROL NIL
   (COMMENT ********** CONTROLS)
   (P:DEFINE
      ACCUMULATE
      (? ? ?)
      (P:ACCUMULATE (FIRST :ARGS) (SECOND :ARGS) (THIRD :ARGS) :OLD-SUBST))
   (P:DEFINE
      AND
      *ARGS
      (LET ((ARGS (P:FETCH '*ARGS :SUBST)))
       (AND ARGS (R:PUSH-CUE ARGS :FETCHED-SUBST))
       T))
   (P:DEFINE CANDIDATES ? (P:CANDIDATES (CAR :ARGS) (CDR :ARGS) :OLD-SUBST))
   (P:DEFINE
      CATCH
      (*PRED)
      (R:PUSH (LIST ':CATCH '*PRED) NIL :SUBST)
      (R:PUSH-CUE (NCONS (P:FETCH '*PRED :SUBST)) :FETCHED-SUBST))
   (P:DEFINE :CATCH (*ANY) NIL)
   (P:DEFINE
      (CO-BEGIN PAR)
      *ARGS
      (P:PAR (P:FETCH '*ARGS :SUBST) :FETCHED-SUBST (ADD1 :LEVEL))
      (R:CLEAR))
   (P:DEFINE
      COND
      *ARGS
      (LETS ((A (P:FETCH '*ARGS :SUBST)) ($SUBST :FETCHED-SUBST))
       (DO ((W))
           ((NULL A))
           (COND ((ATOM (SETQ W (POP A))) (P:ERROR "ILLEGAL ARGUMENT TO COND" W))
                 ((REFUTE (CAR W) $SUBST :LEVEL)
                  (EXIT (COND ((CDR W) (R:PUSH-CUE (CDR W) $SUBST)) (T))))))))
   (P:DEFINE
      CREATE
      (*FORM *NAME)
      (UNIFY '*NAME :SUBST (P:CREATE (P:FETCH '*FORM :SUBST) :FETCHED-SUBST) :SUBST))
   (P:DEFINE CUT NIL (PROG1 T (SETQ :STACK (CAR :FATHER))))
   (P:DEFINE
      DAND
      ?
      (DO ((A :ARGS (CDR A)))
          ((NULL A) (EXIT T))
          (COND ((REFUTE (CAR A) :OLD-SUBST :LEVEL)) (T (EXIT NIL)))))
   (P:DEFINE DO ? (P:DO :ARGS :OLD-SUBST))
   (P:DEFINE
      DOR
      *ARGS
      (DO ((A :ARGS (CDR A)))
          ((NULL A))
          (AND (REFUTE (CAR A) :OLD-SUBST :LEVEL NIL) (EXIT T))))
   (P:DEFINE FAIL NIL (P:FAIL))
   (P:DEFINE FAIL: (*FORM) NIL)
   (P:DEFINE FALSE NIL NIL)
   (P:DEFINE
      FOR-ALL
      (*PRED . *BODY)
      (P:FOR-ALL (P:FETCH '*PRED :SUBST) (P:FETCH '*BODY :SUBST) :FETCHED-SUBST))
   (P:DEFINE
      IF
      (*IF *THEN . *ELSE)
      (COND ((REFUTE (P:FETCH '*IF :SUBST) :FETCHED-SUBST :LEVEL NIL)
             (R:PUSH-CUE (NCONS (P:FETCH '*THEN :SUBST)) :FETCHED-SUBST))
            ((P:FETCH '*ELSE :SUBST) (R:PUSH-CUE (P:FETCH '*ELSE :SUBST) :FETCHED-SUBST))
            (T)))
   (P:DEFINE
      INITIATE
      (*FORM *NAME)
      (UNIFY '*NAME
             :SUBST
             (P:INITIATE (P:FETCH '*FORM :SUBST) :FETCHED-SUBST)
             :SUBST))
   (P:DEFINE LOOP ? (CATCH ':LOOP (P:LOOP :ARGS :OLD-SUBST)))
   (P:DEFINE
      EXIT
      NIL
      (LET ((ERR:CATCH (FUNCTION (LAMBDA (X) (P:ERROR "NOT IN LOOP" '(EXIT))))))
       (THROW ':LOOP T)))
   (P:DEFINE
      NEXT
      (*NAME . *ARGS)
      (P:NEXT (P:FETCHVALUE '*NAME :SUBST) (P:FETCH '*ARGS :SUBST) :FETCHED-SUBST))
   (P:DEFINE
      NOT
      ?
      (NOT (REFUTE:N (P:FETCH :ARGS :OLD-SUBST) :FETCHED-SUBST (ADD1 :LEVEL))))
   (COMMENT
      (P:DEFINE
         NOT
         (*PRED)
         (LET ((:LEVEL (ADD1 :LEVEL)))
          (R:PUSH '(TRUE) NIL)
          (R:PUSH-CUE (LIST (P:FETCH '*PRED :SUBST) '(FAIL)) :FETCHED-SUBST))))
   (P:DEFINE
      ONBT
      (*PRED)
      (LET ((:FATHER (CONS :STACK :CUE)))
       (R:PUSH (LIST 'AND (P:FETCH '*PRED :SUBST) '(FAIL)) NIL :FETCHED-SUBST)))
   (P:DEFINE
      OR
      *ARGS
      (LETS (($ARGS (P:FETCH '*ARGS :SUBST)) ($SUBST :FETCHED-SUBST))
       (COND ($ARGS (AND (CDR $ARGS) (R:PUSH (CONS 'OR (CDR $ARGS)) NIL))
                    (R:PUSH-CUE (NCONS (FIRST $ARGS)) $SUBST)
                    T)
             (T NIL))))
   (P:DEFINE
      POR
      *ARGS
      (P:POR (P:FETCH '*ARGS :SUBST) :FETCHED-SUBST (ADD1 :LEVEL))
      (R:CLEAR))
   (P:DEFINE RECEIVE (*PRED) (P:RECEIVE (P:FETCH '*PRED :SUBST) :FETCHED-SUBST))
   (P:DEFINE RETURN *ARGS (P:RETURN (P:FETCH '*ARGS :SUBST) :FETCHED-SUBST))
   (P:DEFINE
      SEND
      (*NAME . *ARGS)
      (P:SEND (P:FETCHVALUE '*NAME :SUBST) (P:FETCH '*ARGS :SUBST) :FETCHED-SUBST))
   (P:DEFINE THROW (*PATTERN) (P:THROW '*PATTERN :SUBST))
   (P:DEFINE TRUE NIL)
   (P:DEFINE WAIT (*PRED) (P:WAIT (P:FETCH '*PRED :SUBST) :FETCHED-SUBST)))
(DEFUN INIT:MISC NIL
   (COMMENT ********** MISCELLANEOUS)
   (P:DEFINE
      ATOM
      (*X)
      (LET ((V (P:FETCHVALUE '*X :SUBST))) (AND (ATOM V) (NOT (P:VARP V)))))
   (P:DEFINE
      CASE
      (*CASE)
      (LET ((CASE (P:FETCHVALUE '*CASE :SUBST)))
       (COND ((EQ CASE 'LOWER) (SETQ USE-LOWER T))
             ((EQ CASE 'UPPER) (SETQ USE-LOWER NIL) T)
             (T (UNIFY '*CASE :SUBST (COND (USE-LOWER 'LOWER) (T 'UPPER)) :SUBST)))))
   (P:DEFINE
      CREATE-WORLD
      (*WORLD . *DEFS)
      (P:WORLD (P:FETCHVALUE '*WORLD :SUBST) (P:FETCHVALUE '*DEFS :SUBST)))
   (P:DEFINE HELP *NAME (P:HELP (P:FETCHVALUE '*NAME :SUBST)))
   (P:DEFINE
      MANUAL
      ?
      (P:MANUAL
         (LET (($ARGS (P:FETCHVALUE :ARGS :OLD-SUBST)))
          (COND ((NULL $ARGS) 0) (T (CAR $ARGS))))))
   (P:DEFINE
      PEEK-WORLD
      (*NAME *LIST)
      (UNIFY (GET (P:FETCHVALUE '*NAME :SUBST) ':WORLD) :SUBST '*LIST :SUBST))
   (P:DEFINE WORLD-NAME (*NAME) (UNIFY '*NAME :SUBST (CAR :PROLOG-WORLD) :SUBST))
   (P:DEFINE
      EDIT
      (*NAME . *COMMANDS)
      (P:EDIT (P:FETCHVALUE '*NAME :SUBST)
              (P:FETCHVALUE (P:FETCH '*COMMANDS :SUBST) (CONS "" (CDR :FETCHED-SUBST)))))
   (P:DEFINE
      EQ
      (*X *Y)
      (LETS ((X (P:FETCH (P:FETCH '*X :SUBST) :FETCHED-SUBST)) (XS :FETCHED-SUBST) 
             (Y (P:FETCH (P:FETCH '*Y :SUBST) :FETCHED-SUBST)) (YS :FETCHED-SUBST))
       (COND ((P:VARP X) (AND (EQ X Y) (EQ XS YS))) (T (EQ X Y)))))
   (P:DEFINE ERASE-WORLD (*NAME) (P:ERASE-WORLD (P:FETCHVALUE '*NAME :SUBST)))
   (P:DEFINE (QUIT END EPILOG) NIL (PRINT 'EPILOG) (QUIT))
   (P:DEFINE
      FORMAT
      (*FORMAT . *ARGS)
      (PROG1 T
             (EVAL (CONS 'FORMAT
                         (CONS (P:FETCHVALUE '*FORMAT :SUBST)
                               (MAPCAR (P:FETCHVALUE '*ARGS :SUBST) (FUNCTION (LAMBDA (X) (LIST 'QUOTE X)))))))))
   (P:DEFINE
      GT
      (*X *Y)
      (GREATERP (P:FETCHVALUE '*X :SUBST) (P:FETCHVALUE '*Y :SUBST)))
   (P:DEFINE
      LT
      (*X *Y)
      (LESSP (P:FETCHVALUE '*X :SUBST) (P:FETCHVALUE '*Y :SUBST)))
   (P:DEFINE
      LAST-RESULT
      (*R)
      (UNIFY '*R :SUBST (CAR :LAST-RESULT) (CDR :LAST-RESULT)))
   (P:DEFINE
      LINESIZE
      (*L)
      (COND ((UNIFY '*L :SUBST (LINESIZE) :SUBST))
            (T (LET ((L (P:FETCHVALUE '*L :SUBST)))
                (COND ((NUMBERP L) (LINESIZE L))
                      (T (P:ERROR "ILLEGAL ARGUMENT TO LINESIZE" L)))))))
   (P:DEFINE LISP NIL (POP-TOPLEVEL) (TOPLEVEL))
   (P:DEFINE
      (MATCH =)
      (? ?)
      (UNIFY (FIRST :ARGS) :OLD-SUBST (SECOND :ARGS) :OLD-SUBST))
   (P:DEFINE
      NEWS
      NIL
      (PROG1 T
             (MORE (INOPEN (STREAM (ALLOC (STRING-APPEND "'" MANAGER-ID FILE-SEPARATOR "PKR.NEWS'")))) 20)))
   (P:DEFINE
      PRED
      (*X *Y)
      (UNIFY '*Y :SUBST (SUB1 (P:FETCHVALUE '*X :SUBST)) (NCONS NIL)))
   (P:DEFINE
      SELECT
      (? . ?)
      (DO ((PAT (FIRST :ARGS)) (SELECT (CDR :ARGS) (CDR SELECT)) (U :UNDOLIST))
          ((NULL SELECT) NIL)
          (COND ((UNIFY PAT :OLD-SUBST (CAAR SELECT) :OLD-SUBST)
                 (R:PUSH-CUE (CDAR SELECT) :OLD-SUBST)
                 (EXIT T))
                (T (P:UNDO U)))))
   (P:DEFINE
      SUCC
      (*X *Y)
      (UNIFY '*Y :SUBST (ADD1 (P:FETCHVALUE '*X :SUBST)) (NCONS NIL)))
   (P:DEFINE TECO NIL (PROG1 T (TECO)))
   (P:DEFINE
      TIME
      (*PRED *TIME)
      (LETS ((TM (TIME)) (RS (REFUTE (P:FETCH '*PRED :SUBST) :FETCHED-SUBST :LEVEL NIL)))
       (PROG1 (UNIFY '*TIME :SUBST (/- (TIME) TM) (NCONS NIL))
              (AND (EQ (CAR :GOAL) 'TIME)
                   (SETQ :GOAL (LIST 'TIME RS (P:FETCH '*TIME :SUBST)))))))
   (P:DEFINE
      PREFIX
      *ARGS
      (SETQ :VARIABLE-PREFIX (MAPCAR (P:FETCHVALUE '*ARGS :SUBST) 'CHARACTER)))
   (P:DEFINE
      REWRITE
      (*X *Y)
      (P:REWRITE (P:FETCHVALUE '*X :SUBST) (P:FETCHVALUE '*Y :SUBST)))
   (P:DEFINE
      VAR
      (*X)
      (LET ((X (P:FETCH '*X :SUBST)))
       (AND (P:VARP X)
            (COND ((P:ASSIGNED X :FETCHED-SUBST)
                   (AND (P:VARP (CADR :FETCHED-VALUE))
                        (NOT (P:ASSIGNED (CADR :FETCHED-VALUE) (CDDR :FETCHED-VALUE)))))
                  (T)))))
   (P:DEFINE VERSION NIL (P:VERSION))
   (P:DEFINE
      WITH
      (*DEF . *PRED)
      (P:WITH (P:FETCHVALUE '*DEF :SUBST) (P:FETCH '*PRED :SUBST) :FETCHED-SUBST))
   (P:DEFINE X *ARGS (SETQ :GOAL (EVAL (P:FETCHVALUE '*ARGS :SUBST)))))
(DEFUN P:MANUAL (OUTPUT)
   (COND ((NUMBERP OUTPUT)
          (MORE (INOPEN (STREAM (ALLOC (STRING-APPEND "'" MANAGER-ID FILE-SEPARATOR "PKR.MANUAL'"))))
                OUTPUT)
          T)
         ((EQ OUTPUT 'LP)
          (COND ((EQUAL SYSTEM-NAME "MTS") 
                 (CALL 'COPY
                        (STRING-APPEND MANAGER-ID FILE-SEPARATOR "PKR.MANUAL.LP *PRINT* ")))
                (T
                 (CALL 'LIST
                       (STRING-APPEND "'" MANAGER-ID ".PKR.MANUAL.LP' NONUM SYSPRINT(T) "))))
          T)
         ((STRINGP OUTPUT)
          (LET ((OUTFILE (ALLOC OUTPUT)))
           (COND ((STRINGP OUTFILE)
                  (LET ((TERMINAL-OUTPUT (OUTOPEN (STREAM OUTFILE))))
                   (MORE (INOPEN (STREAM (ALLOC (STRING-APPEND "'" MANAGER-ID FILE-SEPARATOR "PKR.MANUAL'"))))
                         0)
                   (CLOSE TERMINAL-OUTPUT)
                   T))
                 (T (FORMAT "Output file does not exist. Use NEW-FILE to create./n")))))
         (T (P:ERROR "ILLEGAL ARGUMENT TO MANUAL" OUTPUT))))
(DECLARE (:PROLOGHELP) SPECIAL)
(DEFUN P:HELP (NAME)
   (COND ((AND (BOUNDP ':PROLOGHELP) :PROLOGHELP))
         (T (HELP-INIT (STRING-APPEND "'" MANAGER-ID FILE-SEPARATOR "pkr.manual'") ':PROLOGHELP)
            (SETQ :PROLOGHELP T)))
   (COND ((NULL NAME) (FORMAT "Usage: (HELP predicate-name)/n"))
         (:PROLOGHELP
            (HELP-PRINT
               (CAR NAME)
               (STRING-APPEND "'" MANAGER-ID FILE-SEPARATOR "pkr.manual'")
               ':PROLOGHELP)))
   T)
(DEFUN INIT:ERROR NIL
   (P:DEFINE
      (ATTENTION BREAK)
      NIL
      (LET ((STANDARD-OUTPUT TERMINAL-OUTPUT) (:STEP T)) (P:STEP)))
   (P:DEFINE BACKTRACE (*BT) (UNIFY '*BT :SUBST :BACKTRACE :SUBST))
   (P:DEFINE
      DEBUG
      (*FLAG)
      (SELECTQ (P:FETCHVALUE '*FLAG :SUBST)
         (ON (SETQ :DEBUG1 T))
         (OFF (SETQ :DEBUG1 NIL) T)
         (T (UNIFY '*FLAG :SUBST (COND (:DEBUG1 'ON) (T 'OFF)) :SUBST))))
   (P:ASSERT '((ERROR *MES *AT) (STANDARD-ERROR-HANDLER *MES *AT)))
   (P:DEFINE PROLOG NIL (PGO))
   (P:DEFINE STANDARD-ERROR-HANDLER (*STATEMENT *AT) (P:BREAK))
   (P:DEFINE
      STEP
      (*PRED . *SELECT)
      (LET ((:DEBUG T) (:DEBUG1 T) (:TRACEALL NIL) (:TRACE NIL) (:SELECTSTEP NIL) 
            (:STEPLEVEL 1000))
       (COND ((P:FETCH '*SELECT :SUBST)
              (SETQ :STEP NIL)
              (SETQ :SELECTSTEP (P:FETCH '*SELECT :SUBST))))
       (LET ((PRED (P:FETCH '*PRED :SUBST)))
        (SELECTQ PRED
           (ON (SETQ :STEP T))
           (OFF (SETQ :STEP NIL))
           (T (LET ((:STEP T)) (REFUTE PRED :FETCHED-SUBST)))))))
   (P:DEFINE TOP NIL (THROW ':TOP T))
   (P:DEFINE TOPLEVEL (*NAME) (P:TOPLEVEL (P:FETCH '*NAME :SUBST) :FETCHED-SUBST))
   (P:DEFINE
      TRACE
      *ARGS
      (SETQ :TRACE (APPEND (P:FETCHVALUE '*ARGS :SUBST) :TRACE)))
   (P:DEFINE TRACE-ALL NIL (SETQ :TRACEALL T))
   (P:DEFINE
      UNTRACE
      *ARGS
      (PROG1 T
             (MAPC (P:FETCHVALUE '*ARGS :SUBST)
                (FUNCTION (LAMBDA (X) (SETQ :TRACE (DELQ X :TRACE)))))))
   (P:DEFINE
      UNTRACE-ALL
      NIL
      (PROG1 T (SETQ :TRACEALL NIL) (SETQ :TRACE NIL) (SETQ :TRACELEVEL NIL))))
(DEFPROP MEMBER
   (((*ELEMENT (*ELEMENT . *REST)))
    ((*ELEMENT (*TOP . *REST)) (MEMBER *ELEMENT *REST)))
   STANDARD-WORLD)
(DEFUN P:STANDARD-INPUT NIL
   (LET ((SI (R:GETDEF '(STANDARD-INPUT))))
    (COND (SI (CAAAR SI)) (T STANDARD-INPUT))))
(DEFUN P:STANDARD-OUTPUT NIL
   (LET ((SO (R:GETDEF '(STANDARD-OUTPUT))))
    (COND (SO (CAAAR SO)) (T STANDARD-OUTPUT))))
(DEFUN P:CONTINUE NIL
   (COND ((NULL :CUE) T)
         (T (LET ((CUE (CAR :CUE)))
             (REFUTE:N (VREF CUE 0) (VREF CUE 1) (VREF CUE 2) (CDR :CUE))))))
(DECLARE
   (EDIT-NAME EDIT-COMMAND EDITOR-CHAIN EDITOR-STACK EDITOR-VARIABLE-PREFIX FIND 
    EDITOR-GET-DEFINITION EDITOR-RESTORE-DEFINITION EDITOR-EXECUTE LOADED 
    EDIT-FILE)
   SPECIAL)
(DEFUN P:EDIT (EDIT-NAME (COM NIL))
   (AMUSE EDIT-NAME
          COM
          (FUNCTION
           (LAMBDA (NAME)
            (COND ((SYMBOLP NAME) (E:FETCHVALUE (GET NAME (CAR :PROLOG-WORLD))))
                  ((STRINGP NAME) (E:GETFILE NAME)))))
          (FUNCTION
           (LAMBDA (DEF)
            (COND ((SYMBOLP EDIT-NAME)
                   (PUTPROP EDIT-NAME (E:FETCHVALUE DEF) (CAR :PROLOG-WORLD)))
                  ((STRINGP EDIT-NAME) (E:PUTFILE EDIT-NAME DEF)))))
          (FUNCTION
           (LAMBDA (FORM)
            (P:EXECUTE FORM)
            (P:FETCHVALUE (CAR :LAST-RESULT) (CDR :LAST-RESULT) :PRINTLEVEL))))
   T)
(DEFUN P:RECORD (DATA (NEWDAEMON NIL) (DAEMONBODY NIL))
   (OR (LISTP DATA) (P:ERROR "ILLEGAL ARGUMENT TO RECORD" DATA))
   (LET ((IND (CAR DATA)) (PAT (CDR DATA)) (LOC NIL) (SUBST (P:NEWSUBST)))
    (COND ((NOT (SYMBOLP IND)) (P:ERROR "ILLEGAL ARGUMENT TO RECORD" DATA))
          ((SETQ LOC (P:RECORDED DATA SUBST NIL T))
           (LET ((DAEMON (VREF :DAEMON LOC)))
            (COND (DAEMON (COND (NEWDAEMON NIL) (T (VSET :DAEMON LOC NIL) (REFUTE DAEMON SUBST) LOC)))
                  (NEWDAEMON (REFUTE DAEMONBODY SUBST) NIL))))
          (T (LET ((LOC (REC:ALLOC DATA)) (L (GET IND (LENGTH PAT))))
              (COND ((NULL L) (PUTPROP IND (NCONS LOC) (LENGTH PAT)))
                    (T (NCONC L (NCONS LOC))))
              (P:RECORD2 IND PAT 1 LOC)
              LOC)))))
(DEFUN P:RECORD2 (IND PAT POS LOC)
   (COND ((NULL PAT) LOC)
         ((SYMBOLP (CAR PAT))
          (LET ((L (GET (CAR PAT) IND)) (L1 NIL))
           (COND ((NULL L) (PUTPROP (CAR PAT) (NCONS (LIST POS LOC)) IND))
                 ((NULL (SETQ L1 (ASSQ POS L))) (NCONC L (NCONS (LIST POS LOC))))
                 (T (REC:MERGE LOC L1))))
          (P:RECORD2 IND (CDR PAT) (ADD1 POS) LOC))
         ((NUMBERP (CAR PAT))
          (COND (:NUMDATA
                   (LET ((L (ASSQ (CAR PAT) :NUMDATA)) (L1 NIL))
                    (COND ((NULL L) (NCONC :NUMDATA (NCONS (LIST (CAR PAT) (LIST IND (LIST POS LOC))))))
                          ((NULL (SETQ L1 (ASSQ IND L))) (NCONC L (NCONS (LIST IND (LIST POS LOC)))))
                          ((NULL (SETQ L (ASSQ POS L1))) (NCONC L1 (NCONS (LIST POS LOC))))
                          (T (REC:MERGE LOC L)))))
                (T (SETQ :NUMDATA (NCONS (LIST (CAR PAT) (LIST IND (LIST POS LOC)))))))
          (P:RECORD2 IND (CDR PAT) (ADD1 POS) LOC))
         (T (P:RECORD2 IND (CDR PAT) (ADD1 POS) LOC))))
(DECLARE (:PATTERN :PATVALUE :NEWDAEMON) SPECIAL)
(DEFUN P:RECORDED (:PATTERN (:SUBST (NCONS "")) (:CUE NIL) (:NEWDAEMON NIL))
   (LET ((:PATVALUE (P:FETCHVALUE :PATTERN :SUBST)))
    (AND (LISTP :PATVALUE) (CATCH 'RECORDED (REC:SEARCH)))))
(DEFUN REC:SEARCH NIL
   (LETS ((IND (CAR :PATVALUE)) (PAT (CDR :PATVALUE)) 
          (N (DO ((W PAT (CDR W)) (N 0))
                 ((NULL W) N)
                 (AND (OR (NUMBERP (CAR W)) (SYMBOLP (CAR W)))
                      (NOT (P:VARP (CAR W)))
                      (SETQ N (ADD1 N)))))
          (V (VECTOR N)))
    (OR (AND (SYMBOLP IND) (NOT (P:VARP IND)))
        (P:ERROR "ILLEGAL PATTERN" :PATVALUE))
    (COND ((ZEROP N)
           (THROW 'RECORDED
              (DO ((:U :UNDOLIST) (CAND (GET IND (LENGTH PAT)) (CDR CAND)))
                  ((NULL CAND))
                  (AND (OR :NEWDAEMON (NULL (VREF :DAEMON (CAR CAND))))
                       (UNIFY :PATTERN :SUBST (VREF :DATABASE (CAR CAND)) (NCONS ""))
                       (P:CONTINUE)
                       (EXIT (CAR CAND)))
                  (P:UNDO :U)))))
    (DO ((I 0) (POS 1 (ADD1 POS)) (X NIL))
        ((>= I N))
        (SETQ X (POP PAT))
        (COND ((P:VARP X))
              ((OR (NUMBERP X) (SYMBOLP X))
               (VSET V
                     I
                     (LET ((P (ASSQ POS
                                 (COND ((SYMBOLP X) (GET X IND)) ((NUMBERP X) (ASSQ IND (ASSQ X :NUMDATA)))))))
                      (COND (P (CDR P)) ((THROW 'RECORDED NIL)))))
               (SETQ I (ADD1 I)))))
    (DO ((I 0) (N1 (SUB1 N)) (X NIL) (Y NIL))
        (NIL)
        (DO ((:U :UNDOLIST) (CAND (VREF V 0)))
            ((< I N1) (VSET V 0 CAND))
            (COND ((NULL CAND) (THROW 'RECORDED NIL))
                  ((AND (OR :NEWDAEMON (NULL (VREF :DAEMON (CAR CAND))))
                        (UNIFY :PATTERN :SUBST (VREF :DATABASE (CAR CAND)) (NCONS ""))
                        (P:CONTINUE))
                   (THROW 'RECORDED (CAR CAND)))
                  (T (P:UNDO :U) (POP CAND) (SETQ I 0))))
        (SETQ X (VREF V I))
        (SETQ Y (VREF V (ADD1 I)))
        (AND (NULL X) (THROW 'RECORDED NIL))
        (LOOP (COND ((NULL Y) (THROW 'RECORDED NIL))
                    ((GREATERP (CAR X) (CAR Y)) (POP Y))
                    ((EXIT (VSET V (ADD1 I) Y)))))
        (LOOP (COND ((NULL X) (THROW 'RECORDED NIL))
                    ((LESSP (CAR X) (CAR Y)) (POP X))
                    ((EXIT (VSET V I X)))))
        (COND ((EQ (CAR X) (CAR Y)) (SETQ I (ADD1 I)))
              ((ZEROP I))
              (T (SETQ I (SUB1 I)) (SETQ Y X) (SETQ X (VREF V I)))))))
(DEFUN REC:ALLOC (PAT)
   (COND ((NULL :FREE) (P:ERROR "NO MORE DATA AREA"))
         (T (VSET :DATABASE (CAR :FREE) PAT) (POP :FREE))))
(DEFUN REC:MERGE (A L)
   (COND ((NULL (CDR L)) (NCONC L (NCONS A)))
         ((EQ A (SECOND L)))
         ((LESSP A (SECOND L)) (RPLACD L (CONS A (CDR L))))
         (T (REC:MERGE A (CDR L)))))
(DEFUN P:ERASE (PAT $SUBST)
   (LET ((LOC (P:RECORDED PAT $SUBST)))
    (COND ((NULL LOC) NIL) (T (REC:ERASEL LOC) T))))
(DEFUN REC:ERASEL (LOC)
   (LETS ((:PATTERN (VREF :DATABASE LOC)) (IND (CAR :PATTERN)) (PAT (CDR :PATTERN)) 
          (N (LENGTH PAT)) (POS 1))
    (PUSH LOC :FREE)
    (VSET :DAEMON LOC NIL)
    (PUTPROP IND (DELQ LOC (GET IND N)) N)
    (MAPC PAT
       (FUNCTION
        (LAMBDA (PAT)
         (DELQ LOC
            (ASSQ POS
               (COND ((SYMBOLP PAT) (GET PAT IND))
                     ((NUMBERP PAT) (ASSQ IND (ASSQ PAT :NUMDATA))))))
         (SETQ POS (ADD1 POS)))))))
(DEFUN P:WITH (DEFS BODY $SUBST (DEFSPTR :DEFINITION-STACK))
   (PROG1 (LET ((:PROLOG-WORLD
                   (COND ((ATOM DEFS) (CONS DEFS :PROLOG-WORLD)) (T :PROLOG-WORLD))))
           (MAPC DEFS
              (FUNCTION
               (LAMBDA (D)
                (COND ((AND (LISTP D) (SYMBOLP (CAR D)))
                       (PUSH (CONS (CAR D) (R:GETDEF D)) :DEFINITION-STACK)
                       (PUTPROP (CAR D) (CDR D) (CAR :PROLOG-WORLD)))
                      (T (P:ERROR "ILLEGAL ARGUMENT TO WITH" D))))))
           (REFUTE:N BODY $SUBST :LEVEL))
          (P:RESET :DEFINITION-STACK DEFSPTR)))
(DEFUN P:RESET (DEFS UNTIL)
   (DO ((X DEFS (CDR X)))
       ((EQ X UNTIL))
       (PUTPROP (CAAR X) (CDAR X) (CAR :PROLOG-WORLD))))
(DECLARE (FOR-PRED DO-PRED) SPECIAL)
(DEFUN P:FOR-ALL (FOR-PRED DO-PRED :SUBST) (CATCH ':FOR-ALL (FOR-ALL:LOOP)))
(DEFUN FOR-ALL:LOOP NIL
   (DO ((:FORM FOR-PRED)
        (:CLAUSE NIL)
        (:DEFINITIONS (R:GETDEF FOR-PRED))
        (:OLD-SUBST :SUBST)
        (:NEW-SUBST (P:NEWSUBST))
        (:UNDO-POINT :UNDOLIST)
        (:FINAL-UNDO-POINT :UNDOLIST)
        (:STACK NIL)
        (:CUE NIL))
       ((NOT (CATCH 'REFUTE
                (AND (CATCH 'REFUTE (LOOP (REFUTE:ONE)))
                     (COND ((REFUTE:N DO-PRED :SUBST :LEVEL) (R:FAIL) T) (T (THROW ':FOR-ALL NIL))))))
        T)))
(COMMENT
   (DEFUN P:FAIL (LEVEL)
      (DO ((FLEVEL (/+ :LEVEL (COND (LEVEL (P:FETCHVALUE (FIRST LEVEL) :SUBST)) (T 1)) -1))
           (:LEVEL 8388607))
          ((> FLEVEL :LEVEL) (R:PUSH :FORM :DEFINITIONS) NIL)
          (COND (:STACK (R:POP)) (T (EXIT NIL))))))
(DEFUN P:FAIL NIL (SETQ :STACK (CAR :FATHER)) NIL)
(DEFUN P:RETURN ($FORM $SUBST)
   (PROG1 T
          (SETQ :STACK (CAR :FATHER))
          (SETQ :CUE (CDR :FATHER))
          (COND (:CUE (SETQ :FATHER (VREF (CAR :CUE) 3)))
                (T (SETQ :FATHER (CONS NIL NIL))))
          (AND $FORM (R:PUSH-CUE $FORM $SUBST))))
(DECLARE (:RESULT) SPECIAL)
(DECLARE (:VARIABLE) SPECIAL)
(DEFUN P:CANDIDATES (:VARIABLE :CLAUSE :SUBST (:FORM (POP :CLAUSE)))
   (COND ((P:VARP :VARIABLE)
          (DO ((:DEFINITIONS (R:GETDEF :FORM))
               (:OLD-SUBST :SUBST)
               (:NEW-SUBST (P:NEWSUBST))
               (:UNDO-POINT :UNDOLIST)
               (:FINAL-UNDO-POINT :UNDOLIST)
               (:STACK NIL)
               (:CUE NIL)
               (:RESULT NIL))
              ((NOT (CATCH 'REFUTE
                       (AND (CATCH 'REFUTE (LOOP (REFUTE:ONE)))
                            (PROGN (PUSH (P:FETCHVALUE :VARIABLE :SUBST) :RESULT) (R:FAIL) T))))
               (UNIFY :VARIABLE :SUBST (NREVERSE :RESULT) :SUBST)
               T)))
         (T (P:ERROR "ILLEGAL ARGUMENT TO CANDIDATES" :VARIABLE))))
(DECLARE (:STRUCTURE) SPECIAL)
(DEFUN P:ACCUMULATE (:STRUCTURE :FORM VARIABLE :SUBST)
   (DO ((:CLAUSE NIL)
        (:DEFINITIONS (R:GETDEF :FORM))
        (:OLD-SUBST :SUBST)
        (:NEW-SUBST (P:NEWSUBST))
        (:UNDO-POINT :UNDOLIST)
        (:FINAL-UNDO-POINT :UNDOLIST)
        (:STACK NIL)
        (:CUE NIL)
        (:RESULT NIL))
       ((NOT (CATCH 'REFUTE
                (AND (CATCH 'REFUTE (LOOP (REFUTE:ONE)))
                     (PROGN (PUSH (P:FETCHVALUE :STRUCTURE :SUBST) :RESULT) (R:FAIL) T))))
        (UNIFY VARIABLE :SUBST (NREVERSE :RESULT) :SUBST)
        T)))
(DEFUN UNION (X Y)
   (COND ((NULL X) Y)
         ((NULL Y) X)
         ((MEMBER (CAR X) Y) (UNION (CDR X) Y))
         (T (CONS (CAR X) (UNION (CDR X) Y)))))
(DEFUN P:TOPLEVEL (NAME SUBST)
   (LET ((PRED (P:FETCHVALUE NAME SUBST)))
    (COND ((P:VARP PRED)
           (UNIFY NAME
                  SUBST
                  (COND ((ATOM TOPLEVEL) TOPLEVEL)
                        ((EQ (CAR TOPLEVEL) 'LAMBDA) (SECOND (SECOND (THIRD TOPLEVEL))))
                        (T NIL))
                  SUBST))
          ((LISTP PRED)
           (SETQ TOPLEVEL (LIST 'LAMBDA NIL (LIST 'P:EXECUTE (LIST 'QUOTE PRED)))))
          ((EQ PRED 'RESET) (SETQ TOPLEVEL 'PROLOG-TOPLEVEL) (TOPLEVEL))
          (T (FORMAT "TRY ""(TOPLEVEL RESET)"" TO RESET./N")))))
(DEFUN P:REWRITE (FROM TO)
   (EXFILE "#a4154.pkr.rewrite")
   (FUNCALL 'P:REWRITE FROM TO))
(DEFUN P:THROW ($FORM $SUBST)
   (DO (($STACK :STACK))
       ((AND (LISTP :FORM)
             (EQ (CAR :FORM) ':CATCH)
             (UNIFY $FORM $SUBST (SECOND :FORM) :OLD-SUBST))
        T)
       (COND (:STACK (R:POP))
             (T (SETQ :STACK $STACK)
                (EXIT (P:ERROR "NO CATCHING STRUCTURE" (P:FETCHVALUE $FORM $SUBST)))))))
(DEFUN P:LOOP (BODY $SUBST)
   (LET ((U :UNDOLIST)) (LOOP (REFUTE:N BODY $SUBST :LEVEL) (P:UNDO U))))
(DEFUN P:DO (BODY $SUBST)
   (DO ((:CALUSE NIL NIL)
        (:CUE NIL NIL)
        (:STACK NIL NIL)
        (:FORM (CAR BODY) (CAR BODY))
        (:DEFINITIONS (R:GETDEF (CAR BODY)) (R:GETDEF (CAR BODY)))
        (:UNDO-POINT :UNDOLIST :UNDOLIST)
        (:NEW-SUBST (P:NEWSUBST) (P:NEWSUBST))
        (:FINAL-UNDO-POINT :UNDOLIST :UNDOLIST))
       (NIL)
       (CATCH 'REFUTE (LOOP (REFUTE:ONE)))
       (POP BODY)
       (COND ((NULL BODY) (EXIT T)) ((ATOM BODY) (EXIT T)))))
(DEFUN P:LOAD (:FILE)
   (LETS ((STANDARD-INPUT (INOPEN (STREAM (ALLOC :FILE)))) (LOADED NIL) 
          (ERR:END-OF-FILE
             (FUNCTION
              (LAMBDA (S) (THROW 'LOAD (PUTPROP (INTERN :FILE) (NREVERSE LOADED) 'LOADED)))))
          (ATTENTION-HANDLER
             (FUNCTION
              (LAMBDA NIL (THROW 'LOAD (PUTPROP (INTERN :FILE) (NREVERSE LOADED) 'LOADED)))))
          (ERR:READ
             (FUNCTION
              (LAMBDA (STREAM (X NIL))
               (FORMAT "ILLEGAL OBJECT READ : /C/N" (READLINE STREAM))
               (THROW 'LOAD NIL)))))
    (CATCH 'LOAD
       (DO ((X (READ) (READ)) (:BACKTRACE NIL NIL))
           (NIL)
           (P:EXECUTE X)
           (COND ((EQ (CAR X) 'DEFINE) (PUSH (SECOND X) LOADED))
                 ((MEMQ (CAR X) '(ASSERT AS ASSERTZ AZ ASSERTA))
                  (SETQ LOADED (UNION (NCONS (CAR (SECOND X))) LOADED)))
                 (T (PUSH X LOADED)))))))
(DEFUN P:DUMP (FILENAME NAMES)
   (PROG (FLIST (STANDARD-OUTPUT STANDARD-OUTPUT) DEF FILE)
      (SETQ FLIST (COND ((SYMBOLP NAMES) (GET NAMES ':WORLD)) ((LISTP NAMES) NAMES) (T NIL)))
      (COND (FLIST (PUTPROP (INTERN FILENAME) FLIST 'LOADED))
            (T (P:ERROR "NOTHING TO BE DUMPED" NAMES) (RETURN T)))
      (SETQ STANDARD-OUTPUT (COND ((STRINGP (SETQ FILE (ALLOC FILENAME)))
                                   (FORMAT "FILE ALREADY EXISTS./N")
                                   (COND ((MEMQ (RIND "WANNA OVER WRITE? (Y/N)") '(Y YES))
                                          (SETQ FILE (OUTOPEN (STREAM FILE))))
                                         (T (FORMAT "USE STORE INSTEAD./N") (RETURN NIL))))
                                  (T (SETQ FILE (OUTOPEN (STREAM (P:ALLOC-NEW-FILE FILENAME)) 255 2560)))))
      (COND ((ATOM FLIST) (P:ERROR "ILLEGAL ARGUMENT TO DUMP" FLIST) (RETURN T))
            (T (LET ((:PROLOG-WORLD
                        (COND ((SYMBOLP NAMES) (CONS NAMES :PROLOG-WORLD)) (T :PROLOG-WORLD))))
                (MAPC FLIST
                   (FUNCTION
                    (LAMBDA (NAME)
                     (COND ((SYMBOLP NAME)
                            (COND ((SETQ DEF (GET NAME (CAR :PROLOG-WORLD)))
                                   (GRIND (CONS 'DEFINE (CONS NAME DEF))))
                                  (T (LET ((STANDARD-OUTPUT TERMINAL-OUTPUT))
                                      (PRINC "UNDEFINED PREDICATE :")
                                      (GRIND NAME)
                                      (TERPRI)))))
                           (T (GRIND NAME)))))))))
      (CLOSE FILE)
      (RETURN T)))
(DEFUN P:STORE (FILENAME)
   (PROG (FLIST (STANDARD-OUTPUT STANDARD-OUTPUT) DEF FILE)
      (SETQ FLIST (GET (INTERN FILENAME) 'LOADED))
      (COND (FLIST) (T (P:ERROR "NOT LOADED YET" FILENAME) (RETURN T)))
      (SETQ STANDARD-OUTPUT (COND ((STRINGP (SETQ FILE (ALLOC FILENAME))) (SETQ FILE (OUTOPEN (STREAM FILE))))
                                  (T (SETQ FILE (OUTOPEN (STREAM (P:ALLOC-NEW-FILE FILENAME)) 255 2560)))))
      (COND ((ATOM FLIST) (P:ERROR "ILLEGAL ARGUMENT TO DUMP" FLIST) (RETURN T))
            (T (MAPC FLIST
                  (FUNCTION
                   (LAMBDA (NAME)
                    (COND ((SYMBOLP NAME)
                           (COND ((SETQ DEF (GET NAME (CAR :PROLOG-WORLD)))
                                  (GRIND (CONS 'DEFINE (CONS NAME DEF))))
                                 (T (LET ((STANDARD-OUTPUT TERMINAL-OUTPUT))
                                     (PRINC "UNDEFINED PREDICATE :")
                                     (GRIND NAME)
                                     (TERPRI)))))
                          (T (GRIND NAME))))))))
      (CLOSE FILE)
      (RETURN T)))
(DEFUN P:NEXT (:NAME :ARGS :SUBST)
   (CATCH ':NEXT
      (P:NEXT1
         :NAME
         :ARGS
         (GET :NAME ':CONTEXT)
         (GET :NAME ':COUNT)
         (GET :NAME ':ORIGINAL-SUBST))))
(DEFUN P:NEXT1 (NAME ARGS CONTEXT COUNT ORIGINAL-SUBST)
   (COND (CONTEXT
            (LETS ((:FORM (POP CONTEXT)) (:CLAUSE (POP CONTEXT)) (:DEFINITIONS (POP CONTEXT)) 
                   (:OLD-SUBST (POP CONTEXT)) (:NEW-SUBST (POP CONTEXT)) 
                   (:UNDOLIST (POP CONTEXT)) (:UNDO-POINT NIL) (:FINAL-UNDO-POINT NIL) 
                   (:STACK (POP CONTEXT)) (:CUE (POP CONTEXT)))
             (OR (ZEROP COUNT) (CATCH 'REFUTE (PROG1 T (R:FAIL))) (THROW ':NEXT NIL))
             (COND ((CATCH 'REFUTE (LOOP (REFUTE:ONE)))) (T (THROW ':NEXT NIL)))
             (PROG1 (UNIFY:SEND
                       ARGS
                       :SUBST
                       (P:FETCHVALUE (GET NAME 'ARGS) ORIGINAL-SUBST)
                       ORIGINAL-SUBST)
                    (PUTPROP NAME
                       (LIST :FORM :CLAUSE :DEFINITIONS :OLD-SUBST :NEW-SUBST :UNDOLIST :STACK :CUE)
                       ':CONTEXT)
                    (PUTPROP NAME (/1+ COUNT) ':COUNT))))
         (T (P:ERROR "ILLEGAL ARGUMENT TO NEXT" NAME))))
(DEFUN P:SEND (:NAME :ARGS :SUBST)
   (P:WAKE :NAME)
   (CATCH 'REFUTE (P:SEND1 :NAME :ARGS (GET :NAME ':CONTEXT))))
(DEFUN P:WAKE (NAME) (PUTPROP NAME (P:WAKE1 (GET NAME ':WAIT)) ':WAIT))
(DEFUN P:WAKE1 (WAIT-LIST)
   (COND ((NULL WAIT-LIST) NIL)
         ((REFUTE (FIRST (CAR WAIT-LIST)) (SECOND (CAR WAIT-LIST)) (ADD1 :LEVEL))
          (PUSH (THIRD (CAR WAIT-LIST)) :ACTIVE-PROCESS)
          (SETQ :WAIT-PROCESS (DELQ (THIRD (CAR WAIT-LIST)) WAIT-LIST))
          (P:WAKE1 (CDR WAIT-LIST)))
         (T (CONS (CAR WAIT-LIST) (P:WAKE1 (CDR WAIT-LIST))))))
(DECLARE (:PROCESS-NAME) SPECIAL)
(DEFUN P:SEND1 (:PROCESS-NAME ARGS CONTEXT)
   (COND (CONTEXT
            (LETS ((:FORM (POP CONTEXT)) (:CLAUSE (POP CONTEXT)) (:DEFINITIONS (POP CONTEXT)) 
                   (:OLD-SUBST (POP CONTEXT)) (:NEW-SUBST (POP CONTEXT)) (:UNDOLIST NIL) 
                   (:FINAL-UNDO-POINT NIL) (:STACK NIL) (:CUE NIL) 
                   (:PROLOG-WORLD (GET :PROCESS-NAME ':WORLD)))
             (AND (UNIFY:SEND ARGS :SUBST (CDR :FORM) :OLD-SUBST)
                  (LET ((:UNDO-POINT :UNDOLIST)) (CATCH ':SEND (LOOP (REFUTE:ONE)))))))
         (T (P:ERROR "ILLEGAL ARGUMENT TO SEND" :PROCESS-NAME))))
(DEFUN P:RECEIVE (PRED $SUBST)
   (COND ((BOUNDP ':PROCESS-NAME)
          (PUTPROP :PROCESS-NAME
             (LIST PRED NIL (R:GETDEF PRED) :OLD-SUBST :NEW-SUBST :UNDOLIST NIL :CUE)
             ':CONTEXT))
         (T (P:ERROR "RECEIVE USED IN ILLEGAL CONTEXT" PRED)))
   (THROW ':SEND T))
(DEFUN P:WAIT (PRED SUBST)
   (COND ((BOUNDP ':PROCESS-NAME)
          (COND ((REFUTE PRED SUBST (ADD1 :LEVEL)) T)
                ((BOUNDP ':PROCESS-NUMBER)
                 (PUSH :PROCESS-NUMBER :WAIT-PROCESS)
                 (SETQ :ACTIVE-PROCESS (DELQ :PROCESS-NUMBER :ACTIVE-PROCESS))
                 (PUTPROP :PROCESS-NAME
                    (CONS (LIST PRED SUBST :PROCESS-NUMBER) (GET :PROCESS-NAME ':WAIT))
                    ':WAIT))
                (T (P:ERROR "WAIT USED IN ILLEGAL CONTEXT" "(OUTSIDE PAND)"))))
         (T (P:ERROR "WAIT USED IN ILLEGAL CONTEXT" "(OUTSIDE PROCESS)"))))
(DEFUN P:INITIATE (FORM SUBST)
   (LET ((NAME (GENSYM (CAR FORM))))
    (PUTPROP NAME
       (LIST FORM NIL (R:GETDEF FORM) SUBST (P:NEWSUBST) NIL NIL NIL)
       ':CONTEXT)
    (PUTPROP NAME (CDR FORM) 'ARGS)
    (PUTPROP NAME 0 ':COUNT)
    (PUTPROP NAME SUBST ':ORIGINAL-SUBST)
    NAME))
(DEFUN P:CREATE (FORM SUBST)
   (LET ((NAME (GENSYM (CAR FORM))))
    (PUTPROP NAME (LIST FORM NIL (R:GETDEF FORM) SUBST (P:NEWSUBST)) ':CONTEXT)
    (PUTPROP NAME :PROLOG-WORLD ':WORLD)
    NAME))
(DEFUN P:RETRACT (P P-SUBST)
   (COND ((P:VARP P)
          (COND ((P:ASSIGNED P P-SUBST)
                 (P:RETRACT (CADR :FETCHED-VALUE) (CDDR :FETCHED-VALUE)))
                (T (P:ERROR "UNDEFINED VARIABLE" P))))
         ((SYMBOLP P) (REMPROP P (CAR :PROLOG-WORLD)) T)
         ((P:VARP (CAR P))
          (COND ((P:ASSIGNED (CAR P) P-SUBST)
                 (P:RETRACT (CONS (P:FETCHVALUE (CAR P) P-SUBST) (CDR P)) P-SUBST))
                (T (P:ERROR "ILLEGAL ARGUMENT TO RETRACT" P))))
         ((LISTP P)
          (LETS ((DEF (R:GETDEF P)) (NAME (POP P)))
           (DO ((D DEF (CDR D)))
               ((OR (NULL D) (NULL (CAR D))))
               (COND ((UNIFY P P-SUBST (CAAR D) (P:NEWSUBST ""))
                      (EXIT (PUTPROP NAME (DELETE (CAR D) DEF) (CAR :PROLOG-WORLD)) T))))))
         (T (P:ERROR "ILLEGAL ARGUMENT TO RETRACT" P))))
(DEFUN P:WORLD (NAME DEFS)
   (COND ((ATOM NAME)
          (LET ((NL NIL))
           (MAPC DEFS
              (FUNCTION
               (LAMBDA (D)
                (COND ((AND (LISTP D) (SYMBOLP (CAR D)))
                       (PUSH (CAR D) NL)
                       (PUTPROP (CAR D) (CDR D) NAME))
                      (T (P:ERROR "ILLEGAL ARGUMENT TO WORLD" D))))))
           (PUTPROP NAME NL ':WORLD)))
         (T (P:ERROR "ILLEGAL ARGUMENT TO WORLD" NAME))))
(DEFUN P:ERASE-WORLD (NAME)
   (MAPC (GET NAME ':WORLD) (FUNCTION (LAMBDA (X) (REMPROP X NAME))))
   (REMPROP NAME ':WORLD))
(DEFUN UNIFY:SEND (SEND-PATTERN SEND-SUBST RECEIVE-PATTERN RECEIVE-SUBST)
   (COND ((NULL SEND-PATTERN) T)
         ((UNIFY (CAR SEND-PATTERN) SEND-SUBST (CAR RECEIVE-PATTERN) RECEIVE-SUBST)
          (UNIFY:SEND (CDR SEND-PATTERN) SEND-SUBST (CDR RECEIVE-PATTERN) RECEIVE-SUBST))))
(DEFUN P:LISTING (NAME-LIST)
   (MAPC NAME-LIST
      (FUNCTION
       (LAMBDA (:NAME)
        (COND ((SYMBOLP :NAME)
               (MAPC (GET :NAME (CAR :PROLOG-WORLD))
                  (FUNCTION
                   (LAMBDA (D)
                    (COND ((ATOM D) (PRINT D))
                          (T (GRIND (CONS 'ASSERT (CONS (CONS :NAME (CAR D)) (CDR D))))))))))
              (T (P:ERROR "ILLEGAL ARGUMENT TO LISTING" :NAME)))))))
(DEFUN P:ALLOC-NEW-FILE (NAME)
   (COND ((EQUAL SYSTEM-NAME "MTS")
           (OR (CALL 'CREATE NAME) (ALLOC NAME)))
          (T
           (OR (CALL 'ALLOC (STRING-APPEND "ds(" NAME ") sp(1 1) tr reu")) (ALLOC NAME)))))
(DEFUN DELETE (E L)
   (COND ((ATOM L) L)
         ((EQ E (CAR L)) (CDR L))
         (T (CONS (CAR L) (DELETE E (CDR L))))))
(DECLARE
   (:CLAUSE-LENGTH :CLAUSE-VECTOR :UNDO-VECTOR :STACK-VECTOR :SUBST-VECTOR :HOPE 
    :CURRENT-PROCESSES :SAVED-PROCESSES :MAX-PROCESSES)
   SPECIAL)
(DEFUN PR:INIT (SIZE)
   (SETQ :CLAUSE-VECTOR (VECTOR SIZE))
   (SETQ :SUBST-VECTOR (VECTOR SIZE))
   (SETQ :UNDO-VECTOR (VECTOR SIZE))
   (SETQ :STACK-VECTOR (VECTOR SIZE))
   (SETQ :ACTIVE-PROCESS NIL)
   (SETQ :WAIT-PROCESS NIL)
   (SETQ :CURRENT-PROCESSES 0)
   (SETQ :MAX-PROCESSES (SUB1 SIZE)))
(DEFUN P:POR (CLAUSES :OLD-SUBST :LEVEL)
   (LETS ((:GOAL ':SUCCEED:) (:CLAUSE NIL) (:DEFINITIONS NIL) (:UNDOLIST NIL) 
          (:UNDO-POINT NIL) (:FINAL-UNDO-POINT NIL) (:WAIT-PROCESS NIL) 
          (:SAVED-PROCESSES :CURRENT-PROCESSES) (:ACTIVE-PROCESS (PARA:SETUP CLAUSES)))
    (PROG1 (PARA:REFUTE (FUNCTION POR:REFUTE))
           (SETQ :CURRENT-PROCESSES :SAVED-PROCESSES))))
(DECLARE (:TOPLEVEL-FUNCTION) SPECIAL)
(DEFUN PARA:REFUTE (:TOPLEVEL-FUNCTION)
   (COND ((ZEROP :SAVED-PROCESSES)
          (COMMENT : TOPLEVEL PARALLEL ROUTINE)
          (CATCH 'PARA (LOOP (PARA:CALL :TOPLEVEL-FUNCTION))))
         (T (CATCH 'PARA (PARA:CALL :TOPLEVEL-FUNCTION))
            (R:PUSH-CUE
               (NCONS (LIST 'PARA:REENTRY
                            :TOPLEVEL-FUNCTION
                            :ACTIVE-PROCESS
                            :WAIT-PROCESS
                            :CURRENT-PROCESSES
                            :SAVED-PROCESSES
                            '*))
               :OLD-SUBST)
            T)))
(DEFUN PARA:CALL (TOPLEVEL-FUNCTION)
   (LET ((:HOPE NIL))
    (FUNCALL TOPLEVEL-FUNCTION)
    (COND ((NULL :HOPE) (THROW 'PARA NIL))
          (:ACTIVE-PROCESS)
          (:WAIT-PROCESS (THROW 'PARA (P:ERROR "DEAD LOCK")))
          (T (THROW 'PARA T)))))
(DEFUN PARA:SETUP (CLAUSES)
   (DO ((ACTIVE-PROCESS NIL)
        (N :CURRENT-PROCESSES (ADD1 N))
        (:STACK NIL NIL)
        (:CUE NIL)
        (:NEW-SUBST (P:NEWSUBST) (P:NEWSUBST)))
       ((NULL CLAUSES) (SETQ :CURRENT-PROCESSES N) (NREVERSE ACTIVE-PROCESS))
       (AND (> N :MAX-PROCESSES) (EXIT (P:ERROR "TOO MANY PROCESSES")))
       (R:PUSH (CAR CLAUSES) (R:GETDEF (POP CLAUSES)))
       (PR:SAVE N)
       (PUSH N ACTIVE-PROCESS)))
(DEFUN PARA:REENTRY (:TOPLEVEL-FUNCTION :ACTIVE-PROCESS :WAIT-PROCESS :CURRENT-PROCESSES 
                     :SAVED-PROCESSES)
   (LET ((:GOAL ':SUCCEED:) (:OLD-SUBST NIL) (:LEVEL (ADD1 :LEVEL)) (:CLAUSE NIL) 
         (:DEFINITIONS NIL) (:CUE NIL) (:UNDOLIST NIL) (:UNDO-POINT NIL) 
         (:FINAL-UNDO-POINT NIL) (:STACK NIL))
    (CATCH 'PARA (FUNCALL :TOPLEVEL-FUNCTION))
    (R:PUSH (LIST 'PARA:REENTRY
                  :TOPLEVEL-FUNCTION
                  :ACTIVE-PROCESS
                  :WAIT-PROCESS
                  :CURRENT-PROCESSES
                  :SAVED-PROCESSES
                  '*)
            NIL
            :OLD-SUBST)))
(DEFUN P:PAR (CLAUSES :OLD-SUBST :LEVEL)
   (LETS ((:GOAL ':SUCCEED:) (:FORM NIL) (:CLAUSE NIL) (:DEFINITIONS NIL) 
          (:UNDOLIST NIL) (:UNDO-POINT NIL) (:FINAL-UNDO-POINT NIL) (:WAIT-PROCESS NIL) 
          (:SAVED-PROCESSES :CURRENT-PROCESSES) (:ACTIVE-PROCESS (PARA:SETUP CLAUSES)))
    (PROG1 (PARA:REFUTE (FUNCTION PAR:REFUTE))
           (SETQ :CURRENT-PROCESSES :SAVED-PROCESSES))))
(DEFUN POR:REFUTE NIL
   (DO ((ACTIVE :ACTIVE-PROCESS (CDR ACTIVE)))
       ((NULL ACTIVE))
       (LETS ((:PROCESS-NUMBER (CAR ACTIVE)) (:UNDOLIST (VREF :UNDO-VECTOR :PROCESS-NUMBER)) 
              (:STACK (VREF :STACK-VECTOR :PROCESS-NUMBER)) (:CUE NIL) 
              (:NEW-SUBST (VREF :SUBST-VECTOR :PROCESS-NUMBER)) (:FORM NIL))
        (COND (:STACK (R:POP)
                      (SETQ :CLAUSE (VREF :CLAUSE-VECTOR :PROCESS-NUMBER))
                      (PR:SWITCH:IN :UNDOLIST)
                      (AND (EQ (PARA-SER:INTERFACE) ':SUCCEED:) (THROW 'PARA T))
                      (PR:SWITCH:OUT :UNDOLIST)
                      (PR:SAVE :PROCESS-NUMBER))))))
(DECLARE (:PROCESS-NUMBER :ACTIVE-PROCESS :WAIT-PROCESS) SPECIAL)
(DEFUN PAR:REFUTE NIL
   (DO ((ACTIVE :ACTIVE-PROCESS (CDR ACTIVE)))
       ((NULL ACTIVE))
       (LETS ((:PROCESS-NUMBER (CAR ACTIVE)) (:UNDOLIST (VREF :UNDO-VECTOR :PROCESS-NUMBER)) 
              (:STACK (VREF :STACK-VECTOR :PROCESS-NUMBER)) (:CUE NIL) 
              (:NEW-SUBST (VREF :SUBST-VECTOR :PROCESS-NUMBER)) (:FORM NIL))
        (COND (:STACK (R:POP)
                      (SETQ :CLAUSE (VREF :CLAUSE-VECTOR :PROCESS-NUMBER))
                      (COND ((EQ (PARA-SER:INTERFACE) ':SUCCEED:)
                             (SETQ :ACTIVE-PROCESS (DELQ :PROCESS-NUMBER :ACTIVE-PROCESS))
                             (SETQ :HOPE T))))))))
(DEFUN PARA-SER:INTERFACE NIL
   (LETS ((:UNDO-POINT :UNDOLIST))
    (CATCH 'REFUTE
       (PROGN (REFUTE:ONE)
              (COND ((R:GETDEF :FORM) (AND :DEFINITIONS (R:PUSH :FORM :DEFINITIONS)))
                    (T (R:PUSH :FORM NIL)))
              (PR:SAVE :PROCESS-NUMBER)
              (SETQ :HOPE T)))))
(DEFUN PR:SWITCH:OUT (U)
   (DO ((W U (CDR W))) ((NULL W)) (DELQ (CDAR W) (CAAR W))))
(DEFUN PR:SWITCH:IN (U)
   (DO ((W U (CDR W))) ((NULL W)) (RPLACD (CAAR W) (CONS (CDAR W) (CDAAR W)))))
(DEFUN PR:SAVE (N)
   (VSET :UNDO-VECTOR N :UNDOLIST)
   (VSET :STACK-VECTOR N :STACK)
   (VSET :SUBST-VECTOR N :NEW-SUBST)
   (VSET :CLAUSE-VECTOR N :CLAUSE))