 +
 +(defmethod add-slot-filter ((self join-node) slot)
 +  (join-node-add-test self (make-inter-pattern-test slot)))
-diff -Nurp lisa_ORIGINAL/src/rete/reference/join-node.lisp~ lisa/src/rete/reference/join-node.lisp~
---- lisa_ORIGINAL/src/rete/reference/join-node.lisp~	1969-12-31 16:00:00.000000000 -0800
-+++ lisa/src/rete/reference/join-node.lisp~	2008-02-19 08:28:47.328125000 -0800
-@@ -0,0 +1,112 @@
-+;;; This file is part of LISA, the Lisp-based Intelligent Software
-+;;; Agents platform.
-+
-+;;; Copyright (C) 2000 David E. Young (de.young@computer.org)
-+
-+;;; This library is free software; you can redistribute it and/or
-+;;; modify it under the terms of the GNU Lesser General Public License
-+;;; as published by the Free Software Foundation; either version 2.1
-+;;; of the License, or (at your option) any later version.
-+
-+;;; This library is distributed in the hope that it will be useful,
-+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-+;;; GNU Lesser General Public License for more details.
-+
-+;;; You should have received a copy of the GNU Lesser General Public License
-+;;; along with this library; if not, write to the Free Software
-+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
-+
-+;;; File: join-node.lisp
-+;;; Description:
-+
-+;;; $Id: lisa3_2-inter-pattern-filter.patch,v 1.1 2008/03/07 23:47:27 amallavarapu Exp $
-+
-+(in-package "LISA")
-+
-+(defclass join-node ()
-+  ((successor :initform nil
-+              :accessor join-node-successor)
-+   (logical-block :initform nil
-+                  :reader join-node-logical-block)
-+   (tests :initform (list)
-+          :accessor join-node-tests)
-+   (left-memory :initform (make-hash-table :test #'equal)
-+                :reader join-node-left-memory)
-+   (right-memory :initform (make-hash-table :test #'equal)
-+                 :reader join-node-right-memory)))
-+
-+(defun mark-as-logical-block (join-node marker)
-+  (setf (slot-value join-node 'logical-block) marker))
-+
-+(defun logical-block-p (join-node)
-+  (numberp (join-node-logical-block join-node)))
-+
-+(defun remember-token (memory token)
-+  (setf (gethash (hash-key token) memory) token))
-+
-+(defun forget-token (memory token)
-+  (remhash (hash-key token) memory))
-+
-+(defun add-tokens-to-left-memory (join-node tokens)
-+  (remember-token (join-node-left-memory join-node) tokens))
-+
-+(defun add-token-to-right-memory (join-node token)
-+  (remember-token (join-node-right-memory join-node) token))
-+
-+(defun remove-tokens-from-left-memory (join-node tokens)
-+  (forget-token (join-node-left-memory join-node) tokens))
-+
-+(defun remove-token-from-right-memory (join-node token)
-+  (forget-token (join-node-right-memory join-node) token))
-+
-+(defmethod left-memory-count ((self join-node))
-+  (hash-table-count (join-node-left-memory self)))
-+
-+(defmethod right-memory-count ((self join-node))
-+  (hash-table-count (join-node-right-memory self)))
-+
-+(defmethod test-tokens ((self join-node) left-tokens right-token)
-+  (token-push-fact left-tokens (token-top-fact right-token))
-+  (prog1
-+      (every #'(lambda (test)
-+                 (funcall test left-tokens))
-+             (join-node-tests self))
-+    (token-pop-fact left-tokens)))
-+
-+(defmethod pass-tokens-to-successor ((self join-node) left-tokens)
-+  (call-successor (join-node-successor self) left-tokens))
-+
-+(defmethod combine-tokens ((left-tokens token) (right-token token))
-+  (token-push-fact (replicate-token left-tokens) (token-top-fact right-token)))
-+
-+(defmethod combine-tokens ((left-tokens token) (right-token t))
-+  (token-push-fact (replicate-token left-tokens) right-token))
-+
-+(defmethod add-successor ((self join-node) successor-node connector)
-+  (setf (join-node-successor self)
-+    (make-successor successor-node connector)))
-+
-+(defmethod join-node-add-test ((self join-node) test)
-+  (push test (join-node-tests self)))
-+
-+(defmethod clear-memories ((self join-node))
-+  (clrhash (join-node-left-memory self))
-+  (clrhash (join-node-right-memory self)))
-+
-+(defmethod accept-tokens-from-left ((self join-node) (left-tokens reset-token))
-+  (clear-memories self)
-+  (pass-tokens-to-successor self left-tokens))
-+
-+(defmethod accept-token-from-right ((self join-node) (left-tokens reset-token))
-+  nil)
-+
-+(defmethod print-object ((self join-node) strm)
-+  (print-unreadable-object (self strm :type t :identity t)
-+    (format strm "left ~S ; right ~S ; tests ~S"
-+            (left-memory-count self)
-+            (right-memory-count self)
-+            (length (join-node-tests self)))))
-+
-+(defmethod add-slot-filter ((self join-node) slot)
-+  (join-node-add-test self (make-inter-pattern-test slot)))
-diff -Nurp lisa_ORIGINAL/src/rete/reference/node-tests.lisp~ lisa/src/rete/reference/node-tests.lisp~
---- lisa_ORIGINAL/src/rete/reference/node-tests.lisp~	1969-12-31 16:00:00.000000000 -0800
-+++ lisa/src/rete/reference/node-tests.lisp~	2008-02-17 07:23:04.421875000 -0800
-@@ -0,0 +1,182 @@
-+;;; This file is part of LISA, the Lisp-based Intelligent Software
-+;;; Agents platform.
-+
-+;;; Copyright (C) 2000 David E. Young (de.young@computer.org)
-+
-+;;; This library is free software; you can redistribute it and/or
-+;;; modify it under the terms of the GNU Lesser General Public License
-+;;; as published by the Free Software Foundation; either version 2.1
-+;;; of the License, or (at your option) any later version.
-+
-+;;; This library is distributed in the hope that it will be useful,
-+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-+;;; GNU Lesser General Public License for more details.
-+
-+;;; You should have received a copy of the GNU Lesser General Public License
-+;;; along with this library; if not, write to the Free Software
-+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
-+
-+;;; File: node-tests.lisp
-+;;; Description:
-+
-+;;; $Id: lisa3_2-inter-pattern-filter.patch,v 1.1 2008/03/07 23:47:27 amallavarapu Exp $
-+
-+(in-package "LISA")
-+
-+(defvar *node-test-table*)
-+
-+(defun find-test (key constructor)
-+  (or (gethash key *node-test-table*)
-+      (setf (gethash key *node-test-table*)
-+            (funcall constructor))))
-+  
-+(defun clear-node-test-table ()
-+  (clrhash *node-test-table*))
-+
-+(defmethod class-matches-p ((instance inference-engine-object) fact class)
-+  (eq (fact-name fact) class))
-+  
-+(defmethod class-matches-p ((instance t) fact class)
-+  (or (eq (fact-name fact) class)
-+      (has-superclass fact class)))
-+
-+(defun make-class-test (class)
-+  (find-test class
-+             #'(lambda ()
-+                 (function
-+                  (lambda (token)
-+                    (declare (optimize (speed 3) (debug 1) (safety 0)))
-+                    (let ((fact (token-top-fact token)))
-+                      (class-matches-p 
-+                       (find-instance-of-fact fact) fact class)))))))
-+
-+(defun make-simple-slot-test-aux (slot-name value negated-p)
-+  (find-test 
-+   `(,slot-name ,value ,negated-p)
-+   #'(lambda ()
-+       (let ((test
-+              (function
-+               (lambda (token)
-+                 (declare (optimize (speed 3) (debug 1) (safety 0)))
-+                 (equal value
-+                        (get-slot-value
-+                         (token-top-fact token)
-+                         slot-name))))))
-+         (if negated-p
-+             (complement test)
-+           test)))))
-+
-+(defun make-simple-slot-test (slot)
-+  (declare (type pattern-slot slot))
-+  (make-simple-slot-test-aux
-+   (pattern-slot-name slot)
-+   (pattern-slot-value slot)
-+   (pattern-slot-negated slot)))
-+
-+#+ignore
-+(defmacro make-variable-test (slot-name binding)
-+  `(function
-+    (lambda (tokens)
-+      (equal (get-slot-value (token-top-fact tokens) ,slot-name)
-+             (get-slot-value 
-+              (token-find-fact tokens (binding-address ,binding))
-+              (binding-slot-name ,binding))))))
-+
-+;;;; (defun make-inter-pattern-test (slot)
-+;;;;   (let* ((binding (pattern-slot-slot-binding slot))
-+;;;;          (test
-+;;;;           (function
-+;;;;            (lambda (tokens)
-+;;;;              (declare (optimize (speed 3) (debug 1) (safety 0)))
-+;;;;              (equal (get-slot-value (token-top-fact tokens) ; top-token is the right token
-+;;;;                                     (pattern-slot-name slot))
-+;;;;                     (get-slot-value  ; this is the left-token
-+;;;;                      (token-find-fact tokens (binding-address binding))
-+;;;;                      (binding-slot-name binding)))))))
-+;;;;     (if (negated-slot-p slot) (complement test) test)))
-+
-+(defun make-inter-pattern-test (slot) 
-+  (let ((binding (pattern-slot-slot-binding slot)))
-+    (%make-inter-pattern-test :slot-name (pattern-slot-name slot)
-+                              :binding-slot-name (binding-slot-name binding)
-+                              :binding-address (binding-address binding)
-+                              :negated (pattern-slot-negated slot))))
-+
-+(defun make-predicate-test (forms bindings &optional (negated-p nil))
-+  (let* ((special-vars
-+          (mapcar #'binding-variable bindings))
-+         (body
-+          (if (consp (first forms)) 
-+              forms
-+            (list forms)))
-+         (predicate
-+          (compile nil `(lambda ()
-+                          (declare (special ,@special-vars))
-+                          ,@body)))
-+         (test
-+          (function
-+           (lambda (tokens)
-+             (progv
-+                 `(,@special-vars)
-+                 `(,@(mapcar #'(lambda (binding)
-+                                 (if (pattern-binding-p binding)
-+                                     (token-find-fact 
-+                                      tokens (binding-address binding))
-+                                   (get-slot-value
-+                                    (token-find-fact 
-+                                     tokens (binding-address binding))
-+                                    (binding-slot-name binding))))
-+                             bindings))
-+               (funcall predicate))))))
-+    (if negated-p (complement test) test)))
-+
-+(defun make-intra-pattern-predicate (forms bindings negated-p)
-+  (let* ((special-vars
-+          (mapcar #'binding-variable bindings))
-+         (body
-+          (if (consp (first forms)) 
-+              forms
-+            (list forms)))
-+         (predicate
-+          (compile nil `(lambda ()
-+                          (declare (special ,@special-vars))
-+                          (declare (optimize (speed 3) (debug 1) (safety 0)))
-+                          ,@body)))
-+         (test
-+          (function
-+           (lambda (tokens)
-+             (progv
-+                 `(,@special-vars)
-+                 `(,@(mapcar #'(lambda (binding)
-+                                 (declare (optimize (speed 3) (debug 1) (safety 0)))
-+                                 (if (pattern-binding-p binding)
-+                                     (token-find-fact 
-+                                      tokens (binding-address binding))
-+                                   (get-slot-value
-+                                    (token-top-fact tokens)
-+                                    (binding-slot-name binding))))
-+                             bindings))
-+               (funcall predicate))))))
-+    (if negated-p (complement test) test)))
-+         
-+(defun make-intra-pattern-constraint-test (slot)
-+  (make-intra-pattern-predicate
-+   (pattern-slot-constraint slot)
-+   (pattern-slot-constraint-bindings slot)
-+   (negated-slot-p slot)))
-+
-+(defun make-intra-pattern-test (slot)
-+  (let ((test
-+         (function
-+          (lambda (tokens)
-+            (declare (optimize (speed 3) (debug 1) (safety 0)))
-+            (equal (get-slot-value (token-top-fact tokens)
-+                                   (pattern-slot-name slot))
-+                   (get-slot-value (token-top-fact tokens)
-+                                   (binding-slot-name 
-+                                    (pattern-slot-slot-binding slot))))))))
-+    (if (negated-slot-p slot) (complement test) test)))
-+
-+(defun make-behavior (function bindings)
-+  (make-predicate-test function bindings))
-diff -Nurp lisa_ORIGINAL/src/rete/reference/node2-not.lisp~ lisa/src/rete/reference/node2-not.lisp~
---- lisa_ORIGINAL/src/rete/reference/node2-not.lisp~	1969-12-31 16:00:00.000000000 -0800
-+++ lisa/src/rete/reference/node2-not.lisp~	2007-09-11 14:14:10.000000000 -0700
-@@ -0,0 +1,71 @@
-+;;; This file is part of LISA, the Lisp-based Intelligent Software
-+;;; Agents platform.
-+
-+;;; Copyright (C) 2000 David E. Young (de.young@computer.org)
-+
-+;;; This library is free software; you can redistribute it and/or
-+;;; modify it under the terms of the GNU Lesser General Public License
-+;;; as published by the Free Software Foundation; either version 2.1
-+;;; of the License, or (at your option) any later version.
-+
-+;;; This library is distributed in the hope that it will be useful,
-+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-+;;; GNU Lesser General Public License for more details.
-+
-+;;; You should have received a copy of the GNU Lesser General Public License
-+;;; along with this library; if not, write to the Free Software
-+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
-+
-+;;; File: node2-not.lisp
-+;;; Description:
-+
-+;;; $Id: lisa3_2-inter-pattern-filter.patch,v 1.1 2008/03/07 23:47:27 amallavarapu Exp $
-+
-+(in-package "LISA")
-+
-+(defclass node2-not (join-node) ())
-+
-+(defmethod test-against-right-memory ((self node2-not) left-tokens)
-+  (loop for right-token being the hash-values of (join-node-right-memory self)
-+      do (when (test-tokens self left-tokens right-token)
-+           (token-increment-not-counter left-tokens)))
-+  (unless (token-negated-p left-tokens)
-+    (pass-tokens-to-successor 
-+     self (combine-tokens left-tokens self))))
-+
-+(defmethod test-against-left-memory ((self node2-not) 
-+                                     (right-token add-token))
-+  (loop for left-tokens being the hash-values of (join-node-left-memory self)
-+      do (when (test-tokens self left-tokens right-token)
-+           (token-increment-not-counter left-tokens)
-+           (pass-tokens-to-successor 
-+            self (combine-tokens (make-remove-token left-tokens) self)))))
-+  
-+(defmethod test-against-left-memory ((self node2-not) 
-+                                     (right-token remove-token))
-+  (loop for left-tokens being the hash-values of (join-node-left-memory self)
-+      do (when (and (test-tokens self left-tokens right-token)
-+                    (not (token-negated-p
-+                          (token-decrement-not-counter left-tokens))))
-+           (pass-tokens-to-successor 
-+            self (combine-tokens left-tokens self)))))
-+  
-+(defmethod accept-tokens-from-left ((self node2-not) (left-tokens add-token))
-+  (add-tokens-to-left-memory self left-tokens)
-+  (test-against-right-memory self left-tokens))
-+
-+(defmethod accept-tokens-from-left ((self node2-not) (left-tokens remove-token))
-+  (when (remove-tokens-from-left-memory self left-tokens)
-+    (pass-tokens-to-successor self (combine-tokens left-tokens self))))
-+
-+(defmethod accept-token-from-right ((self node2-not) (right-token add-token))
-+  (add-token-to-right-memory self right-token)
-+  (test-against-left-memory self right-token))
-+
-+(defmethod accept-token-from-right ((self node2-not) (right-token remove-token))
-+  (when (remove-token-from-right-memory self right-token)
-+    (test-against-left-memory self right-token)))
-+
-+(defun make-node2-not ()
-+  (make-instance 'node2-not))
-diff -Nurp lisa_ORIGINAL/src/rete/reference/node2.lisp lisa/src/rete/reference/node2.lisp
---- lisa_ORIGINAL/src/rete/reference/node2.lisp	2008-02-20 12:48:13.015625000 -0800
-+++ lisa/src/rete/reference/node2.lisp	2008-02-20 16:16:15.906250000 -0800
+Index: src/rete/reference/node2.lisp
+===================================================================
+RCS file: /cvsroot/lisa/lisa/src/rete/reference/node2.lisp,v
+retrieving revision 1.21
+diff -u -r1.21 node2.lisp
+--- src/rete/reference/node2.lisp	11 Sep 2007 21:14:10 -0000	1.21
++++ src/rete/reference/node2.lisp	6 Jun 2008 16:25:20 -0000
 @@ -24,43 +24,105 @@
  
  (in-package "LISA")

            (add-slot-constraint-test (slot)
              (join-node-add-test join-node
                                  (make-predicate-test
diff -Nurp lisa_ORIGINAL/src/rete/reference/rete-compiler.lisp~ lisa/src/rete/reference/rete-compiler.lisp~
--- lisa_ORIGINAL/src/rete/reference/rete-compiler.lisp~	1969-12-31 16:00:00.000000000 -0800
+++ lisa/src/rete/reference/rete-compiler.lisp~	2008-02-19 08:25:28.093750000 -0800
@@ -0,0 +1,239 @@
+;;; This file is part of LISA, the Lisp-based Intelligent Software
+;;; Agents platform.
+
+;;; Copyright (C) 2000 David E. Young (de.young@computer.org)
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+;;; File: rete-compiler.lisp
+;;; Description:
+
+;;; $Id: lisa3_2-inter-pattern-filter.patch,v 1.1 2008/03/07 23:47:27 amallavarapu Exp $
+
+(in-package "LISA")
+
+(defvar *root-nodes* nil)
+(defvar *rule-specific-nodes* nil)
+(defvar *leaf-nodes* nil)
+(defvar *logical-block-marker*)
+
+(declaim (inline set-leaf-node leaf-node left-input right-input logical-block-marker))
+
+(defun set-leaf-node (node address)
+  (setf (aref *leaf-nodes* address) node))
+
+(defun leaf-node ()
+  (aref *leaf-nodes* (1- (length *leaf-nodes*))))
+
+(defun left-input (address)
+  (aref *leaf-nodes* (1- address)))
+
+(defun right-input (address)
+  (aref *leaf-nodes* address))
+
+(defun logical-block-marker ()
+  *logical-block-marker*)
+  
+(defclass rete-network ()
+  ((root-nodes :initform (make-hash-table)
+               :initarg :root-nodes
+               :reader rete-roots)
+   (node-test-cache :initform (make-hash-table :test #'equal)
+                    :initarg :node-test-cache
+                    :reader node-test-cache)))
+
+(defun record-node (node parent)
+  (when (typep parent 'shared-node)
+    (increment-use-count parent))
+  (push (make-node-pair node parent) *rule-specific-nodes*)
+  node)
+
+(defmethod remove-node-from-parent ((self rete-network) (parent t) child)
+  (remhash (node1-test child) (rete-roots self)))
+
+(defmethod remove-node-from-parent ((self rete-network) 
+                                    (parent shared-node) child)
+  (remove-successor parent child))
+
+(defun make-root-node (class)
+  (let* ((test (make-class-test class))
+         (root (gethash test *root-nodes*)))
+    (when (null root)
+      (setf root (make-node1 test))
+      (setf (gethash test *root-nodes*) root))
+    (record-node root t)))
+
+(defmethod add-successor ((parent t) new-node connector)
+  (declare (ignore connector))
+  new-node)
+
+(defmethod add-successor :around ((parent shared-node) new-node connector)
+  (declare (ignore new-node connector))
+  (record-node (call-next-method) parent))
+
+(defun make-intra-pattern-node (slot)
+  (let ((test
+         (cond ((simple-slot-p slot)
+                (make-simple-slot-test slot))
+               ((constrained-slot-p slot)
+                (make-intra-pattern-constraint-test slot))
+               (t
+                (make-intra-pattern-test slot)))))
+    (make-node1 test)))
+
+(defun distribute-token (rete-network token)
+  (loop for root-node being the hash-values 
+      of (rete-roots rete-network)
+      do (accept-token root-node token)))
+
+(defmethod make-rete-network (&rest args &key &allow-other-keys)
+  (apply #'make-instance 'rete-network args))
+
+;;; The following functions serve as "connectors" between any two
+;;; nodes. PASS-TOKEN connects two pattern (one-input) nodes, or a join node 
+;;; to a terminal node; ENTER-JOIN-NETWORK-FROM-LEFT connects a pattern node
+;;; to a join node; ENTER-JOIN-NETWORK-FROM-RIGHT also connects a pattern node
+;;; to a join node; both PASS-TOKENS-ON-LEFT and PASS-TOKEN-ON-RIGHT connect
+;;; two join nodes.
+
+(defun pass-token (node token)
+  (accept-token node token))
+
+(defun pass-tokens-on-left (node2 tokens)
+  (accept-tokens-from-left node2 tokens))
+
+(defun pass-token-on-right (node2 token)
+  (accept-token-from-right node2 token))
+
+(defun enter-join-network-from-left (node2 tokens)
+  (pass-tokens-on-left node2 (replicate-token tokens)))
+
+(defun enter-join-network-from-right (node2 token)
+  (pass-token-on-right node2 (replicate-token token)))
+
+;;; end connector functions
+
+(defun add-intra-pattern-nodes (patterns)
+  "The alpha memory nodes and tests"
+  (dolist (pattern patterns)
+    (cond ((test-pattern-p pattern)
+           (set-leaf-node t (parsed-pattern-address pattern)))
+          (t
+           (let ((node
+                  (make-root-node (parsed-pattern-class pattern)))
+                 (address (parsed-pattern-address pattern)))
+             (set-leaf-node node address)
+             (dolist (slot (parsed-pattern-slots pattern))
+               (when (intra-pattern-slot-p slot)
+                 (setf node
+                   (add-successor node (make-intra-pattern-node slot)
+                                  #'pass-token))
+                 (set-leaf-node node address))))))))
+
+(defun add-join-node-tests (join-node pattern)
+  (labels ((add-simple-join-node-test (slot)
+             (unless (= (binding-address (pattern-slot-slot-binding slot))
+                        (parsed-pattern-address pattern))
+               (add-slot-filter join-node slot)))
+           (add-slot-constraint-test (slot)
+             (join-node-add-test join-node
+                                 (make-predicate-test
+                                  (pattern-slot-constraint slot)
+                                  (pattern-slot-constraint-bindings slot)
+                                  (negated-slot-p slot))))
+           (add-test-pattern-predicate ()
+             (join-node-add-test join-node
+                                 (make-predicate-test
+                                  (parsed-pattern-test-forms pattern)
+                                  (parsed-pattern-test-bindings pattern))))
+           (add-generic-pattern-tests ()
+             (dolist (slot (parsed-pattern-slots pattern))
+               (cond ((simple-bound-slot-p slot)
+                      (add-simple-join-node-test slot))
+                     ((constrained-slot-p slot)
+                      (add-slot-constraint-test slot))))))
+    (if (test-pattern-p pattern)
+        (add-test-pattern-predicate)
+      (add-generic-pattern-tests))
+    join-node))
+
+(defun make-join-node (pattern)
+  (let ((join-node
+         (cond ((negated-pattern-p pattern)
+                (make-node2-not))
+               ((test-pattern-p pattern)
+                (make-node2-test))
+               ((existential-pattern-p pattern)
+                (make-node2-exists))
+               (t (make-node2)))))
+    (when (eql (parsed-pattern-address pattern) (logical-block-marker))
+      (mark-as-logical-block join-node (logical-block-marker)))
+    join-node))
+
+(defun make-left-join-connection (join-node node)
+  (if (typep node 'shared-node)
+      (add-successor node join-node #'enter-join-network-from-left)
+    (add-successor node join-node #'pass-tokens-on-left))
+  join-node)
+
+(defun make-right-join-connection (join-node node)
+  (if (typep node 'shared-node)
+      (add-successor node join-node #'enter-join-network-from-right)
+    (add-successor node join-node #'pass-token-on-right))
+  join-node)
+
+(defun add-inter-pattern-nodes (patterns)
+  "The beta memory nodes and tests"
+  (dolist (pattern (rest patterns))
+    (let ((join-node (make-join-node pattern))
+          (address (parsed-pattern-address pattern)))
+      (add-join-node-tests join-node pattern)
+      (make-left-join-connection join-node (left-input address))
+      (make-right-join-connection join-node (right-input address))
+      (set-leaf-node join-node address))))
+
+(defun add-terminal-node (rule)
+  (add-successor (leaf-node) (make-terminal-node rule) #'pass-token))
+
+;;; addresses a problem reported by Andrew Philpot on 9/6/2007
+(defun copy-node-test-table (src) src) 
+;;;;   (let ((target (make-hash-table :test #'equal)))
+;;;;     (maphash (lambda (key value)
+;;;;                (setf (gethash key target) value))
+;;;;              src)
+;;;;     target))
+
+(defun compile-rule-into-network (rete-network patterns rule)
+  (let ((*root-nodes* (rete-roots rete-network))
+        (*rule-specific-nodes* (list))
+        (*leaf-nodes* (make-array (length patterns)))
+        (*logical-block-marker* (rule-logical-marker rule))
+        (*node-test-table* (node-test-cache rete-network)))
+    (add-intra-pattern-nodes patterns)
+    (add-inter-pattern-nodes patterns)
+    (add-terminal-node rule)
+    (attach-rule-nodes rule (nreverse *rule-specific-nodes*))
+    (setf (slot-value rete-network 'root-nodes) *root-nodes*)
+    rete-network))
+
+(defun merge-rule-into-network (to-network patterns rule &key (loader nil))
+  (let ((from-network
+         (compile-rule-into-network
+          (make-rete-network :node-test-cache (copy-node-test-table (node-test-cache to-network)))
+          patterns rule)))
+    (when loader
+      (funcall loader from-network))
+    (attach-rule-nodes rule (merge-networks from-network to-network))
+    to-network))

                          (:file "shared-node")
                          (:file "successor")
                          (:file "node-pair")
Index: src/rete/reference/inter-pattern-filter.lisp
===================================================================
RCS file: src/rete/reference/inter-pattern-filter.lisp
diff -N src/rete/reference/inter-pattern-filter.lisp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ src/rete/reference/inter-pattern-filter.lisp	6 Jun 2008 16:25:18 -0000
@@ -0,0 +1,195 @@
+
+;;; Copyright (C) 2008 Aneil Mallavarapu
