A first look at compiling a defrule.lisp

; (defrule foo
;  (?o (o (a ?a (evenp ?a))))
;  (?p (p (a ?a)))
;  =>
;  (print ?a))

(DEFUN FOO1 (KEY FACT TIMESTAMP)
  (WHEN (AND)
    (STORE KEY TOKEN 'FOO1-ALPHA-MEMORY)
    (FOO1-RIGHT KEY TOKEN TIMESTAMP))) 

(PROGN
 (DEFUN FOO1-RIGHT (KEY FACT TIMESTAMP)
   (DOLIST (TOK (CONTENTS-OF FOO0-BETA-MEMORY))
     (LET* ((TOKEN (APPEND TOK (LIST FACT)))
            (?P (NTH 1 TOKEN))
            (?O (NTH 0 TOKEN))
            (?A (P-A (NTH 1 TOKEN))))
       (WHEN (AND T)
         (STORE KEY TOKEN FOO1-BETA-MEMORY)
         (FOO2-LEFT KEY TOKEN TIMESTAMP)))))) 

(DEFUN FOO0 (KEY FACT TIMESTAMP)
  (WHEN (AND (EVENP ?A))
    (STORE KEY TOKEN 'FOO0-ALPHA-MEMORY)
    (FOO0-RIGHT KEY TOKEN TIMESTAMP))) 

(PROGN
 (DEFUN FOO0-LEFT (KEY TOK TIMESTAMP)
   (DOLIST (FACT (CONTENTS-OF FOO-1-ALPHA-MEMORY))
     (LET* ((TOKEN (APPEND TOK (LIST FACT)))
            (?P (NTH 1 TOKEN))
            (?O (NTH 0 TOKEN))
            (?A (P-A (NTH 1 TOKEN))))
       (WHEN (AND (EQUALP (P-A (NTH 1 TOKEN)) (O-A (NTH 0 TOKEN))))
         (STORE KEY TOKEN FOO0-BETA-MEMORY)
         (FOO1-LEFT KEY TOKEN TIMESTAMP)))))

 (DEFUN FOO0-RIGHT (KEY FACT TIMESTAMP)
   (DOLIST (TOK (CONTENTS-OF FOO-1-BETA-MEMORY))
     (LET* ((TOKEN (APPEND TOK (LIST FACT)))
            (?P (NTH 1 TOKEN))
            (?O (NTH 0 TOKEN))
            (?A (P-A (NTH 1 TOKEN))))
       (WHEN (AND (EQUALP (P-A (NTH 1 TOKEN)) (O-A (NTH 0 TOKEN))))
         (STORE KEY TOKEN FOO0-BETA-MEMORY)
         (FOO1-LEFT KEY TOKEN TIMESTAMP)))))) 

(DEFUN OBJECT-TYPE-NODE (&REST FACTS)
  (DOLIST (FACT FACTS)
    (CASE (TYPE-OF FACT)
      (P (PROGN (FOO1 FACT)))
      (O (PROGN (FOO1 FACT) (FOO0 FACT)))))) 

(DEFUN FOO-PRODUCTION-LEFT (KEY TOKEN TIMESTAMP)
  (STORE-ACTIVATION KEY TOKEN TIMESTAMP)) 

(DEFUN FOO-RHS (TOKEN)
  (LET ((?P (NTH 1 TOKEN))
        (?O (NTH 0 TOKEN))
        (?A (P-A (NTH 1 TOKEN))))
    (PRINT ?A)))