;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Diploma Thesis:
;;; "Solving Bit-Vector Equations 
;;;  - A Decision Procedure for Hardware Verifikation"
;;;
;;; M. Oliver M"oller
;;; University of Ulm
;;; Faculty of Computer Science (Informatik)
;;; AI Department (Abteilung f"ur k"unstliche Intelligenz)
;;; Supervising Professor:  Friedrich W. von Henke
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ------------------------------------------------------------
;;; - Method:  Equational Transformation System
;;; -          in Connection with Context Splits
;;; -          Includes SAME-extraction rule
;;; -          and epsilon & MACRO BV-ITERATE
;;; - File:    split_chop.cl
;;; - Purpose: Implement a non-strategical equational transformation
;;; -          system for the core theory of bit-vectors with variable
;;; -          width
;;; - USES: bvec_structure.cl
;;; -       bvec_arith.cl
;;; -       bvec_slicing.cl
;;; -       fm_elimination.cl
;;; ------------------------------------------------------------
;;; - USAGE:
;;; -  (1) Load files in order listed above
;;; -       [compilation recommended]
;;; -  (2) Customize level of observation
;;; -       [modify constant *observe-level*] 
;;; -  (2) Start algorithm with
;;; -       (start-split-chop (BV-EQUAL <term-1> <term-2>))
;;; -
;;; - NOTES:
;;; - (a)
;;: -  The term notation is NOT identic with the one in the
;;; -  Diploma Thesis!
;;; -  Due to an (obsolete) design decision, the least significant
;;; -  bit is at the rightmost position and concatenations are the
;;; -  other way round as a consequence;
;;; -  eg. ( x{4} o y{4} ) ^ (1,0) = y{4} ^ (1,0)
;;; -  For chunks, the notation    xx ^ (1,0) 
;;; -  is equivalent to            xx [0:1]
;;; - (b)
;;; -  The procession is designed to be observed;
;;; -  The level of observation can be customized in constant *observe-level*
;;; -  If a output to a file is desired, call
;;; -     (start-split-chop-log (BV-EQUAL <term-1> <term-2>)
;;; -                           :NAME <file-name> )
;;; - (c) 
;;; -  In general, termination can not be guaranteed;
;;; -  The algorithms performs case-splits up to a limit in >>depth<<
;;; -  of the tree of possible worlds;
;;; -  Customize the constant: *split-chop-max-depth*
;;; - (d)
;;; -  Note that this is an experimental version;
;;; -  That means you should not trust it's results or
;;; -  be surprised if a LISP error occurs.
;;; -  Feel free to modify the RULES and obtain a diferent
;;  -  Equational Transformation System
;;; ------------------------------------------------------------
;;;
;;; Allegro Common Lisp
;;; Begun:        Dezember, 1st 1997
;;; Last Changes: March, 16th   1998
;;; Version: 4.0 [Experimental]
;;;


;;; NOTES on Term Structure:
;;;
;;; Introduces cs-rules (CS-INFO <var> (<vector>|
;;;                                     <Iteration struct>|
;;;                                     <free-list>) )
;;; With recognizers  
;;; For >> coarsest slicing information <<
;;;


(in-package user)

;;; ******************************
;;;  Compiler Macros
;;; ******************************

;; For Observation

(defvar *number-of-ctr-hits* 0)

(defconstant *observe-level* '(0 1 6)) ;;; Recommended: '(0 1 6)
;;  0  -> Entering/Leaving
;;  1  -> Added/Deleted
;;  2  -> Final list and Hits
;;  3  -> Attempts and Results
;;  4  -> Tries (all)
;;  5  -> Local bindings & Sigma Lists
;;  6  -> Sucessful tries
;;  7  -> Local evaluation
;;  8  -> CS Rules
;; --------------------

(defmacro obs0 (x)
  (if (member 0 *observe-level*) x))

(defmacro obs1 (x)
  (if (member 1 *observe-level*) x))

(defmacro obs2 (x)
  (if (member 2 *observe-level*) x))

(defmacro obs3 (x)
  (if (member 3 *observe-level*) x))

(defmacro obs4 (x)
  (if (member 4 *observe-level*) x))

(defmacro obs5 (x)
  (if (member 5 *observe-level*) x))

(defmacro obs6 (x)
  (if (member 6 *observe-level*) x))

(defmacro obs7 (x)
  (if (member 7 *observe-level*) x))

(defmacro obs8 (x)
  (if (member 8 *observe-level*) x))


;;; ********************
;;;  Loading
;;; ********************

(defun ll ()
  (load "./bvec_structure.cl")
  (load "./bvec_slicing.cl")
  (load "./bvec_arith.cl")
  (load "./fm_elimination.cl")
  (load "./split_chop.cl"))

(defun cc ()
  (compile-file "./bvec_structure.cl")
  (compile-file "./bvec_slicing.cl")
  (compile-file "./bvec_arith.cl")
  (compile-file "./fm_elimination.cl")
  (compile-file "./split_chop.cl")
  (load "./bvec_structure.fasl")
  (load "./bvec_slicing.fasl")
  (load "./bvec_arith.fasl")
  (load "./fm_elimination.fasl")
  (load "./split_chop.fasl")
  )


(defun c1 ()
  (compile-file "./split_chop.cl")
  (load "./split_chop.fasl"))

(defun l1 ()
  (load "./split_chop.cl"))


;;; ****************************************
;;;  Context for possible worlds
;;; ****************************************

(defstruct chop-context
  equations            ;; List; may contain >> FALSE << 
  integer-constraints  ;; Tuple according to Definition 5.1 in Thesis
  depth                ;; Number of parents 
  (closed nil)         ;;  t      : fully elaborated -> a frame or 'leaf'
                       ;;  nil    : still open context
                       ;;  ABORT  : aborted context (due to depth) 
  )

(defconstant *split-chop-max-depth* 5)

(defun context-alive? (context)
  (null (chop-context-closed context)))

(defun context-failed? (context)
  (or (member 'FAIL (context-equations context))
      (member 'FAIL (integer-constraints-LEQ
		     (context-integer-constraints context)))))

(defun context-trivial? (context)
  (and (null (context-equations context))
       (null (integer-constraints-LEQ
	      (context-integer-constraints context)))))

;;; ========================================
;;;  The Rules
;;; ========================================

(defstruct bv-unify-rule
  name
  term1
  term2
  condition-1
  condition-2
  new-eq-list
  (remove 'NONE)  ;; either 'NONE, 'FIRST, 'SECOND, 'BOTH
  )

;;; The construct CONTEXT-SPLIT
;;; is used in the following syntax:
;;; (CONTEXT-SPLIT <RETURN CODE FOR NEW-EQ LIST>
;;;                ;; -- context 1 --
;;;                (LIST <list-of-additional-LEQs>
;;;                      <list-of-additional-INTs>
;;;                      <list-of-bv-equations>)
;;;                ;; -- context 2 --
;;;                (LIST ....)
;;;                ...
;;;                )
;;; It splits up the actual context to arbitrary many sons that are all
;;; copies of the old context, except that the additional terms are added.

(defconstant *VAR-solving-rules*
 (list

  ;; --------------------
  ;;  Slicing
  ;; --------------------
  (make-bv-unify-rule
   :NAME "(1-FIXED-FIXED) Slice Composition"
   :term1 '(BV-EQUAL
	    (BV-COMPOSE (BV-JOKER 1) (BV-JOKER 2))
	    (BV-JOKER 3))
   :term2 nil
   :condition-1 '(AND (IS-FIXED? (LEN (SIGMA (BV-JOKER 1))))
		      (IS-FIXED? (LEN (SIGMA (BV-JOKER 3)))))
   :condition-2 nil
   :new-eq-list '(LET ((chunk_a (SIGMA (BV-JOKER 1)))
		       (chunk_b (SIGMA (BV-JOKER 2)))
		       (N (LEN chunk_a))
		       (chunk_c (SIGMA (BV-JOKER 3)))
		       (M (LEN chunk_c))
		       (c_left (ALPHA (MAKE-BV-EXTRACTION
				       chunk_c
				       (1- M)
				       (- M N))))
		       (c_right (ALPHA (MAKE-BV-EXTRACTION
					chunk_c
					(- M N 1)
					0))))
		  (IF (EQUAL (ALPHA (BV-COMPOSE c_left c_right))
		             chunk_c)
		   ;; There was already a cut
		   (LIST (BV-EQUAL c_left  chunk_a)
		         (BV-EQUAL c_right chunk_b))
		   ;; There has to be a new cs-rule
		   (LET ((at_cut      (pic-pos chunk_c (- M N 1)))
			 (at_cut_left  (pic-pos c_left 0))
			 (at_cut_right (pic-pos c_right (- M N 1)))
			 (cs_list (LIST (1- (LEN at_cut_right)) (1- (LEN at_cut)))))
		    (IF (OR (NOT (VALID-CS-LIST? cs_list)
			    (is-const? at_cut)))
		       (LIST (BV-EQUAL c_left  chunk_a)
		             (BV-EQUAL c_right chunk_b))
		       (LIST (BV-EQUAL c_left  chunk_a)
		             (BV-EQUAL c_right chunk_b)
			     (CS-INFO-FROM-LIST at_cut cs_list))))))
   :REMOVE 'FIRST)
  
  (make-bv-unify-rule
   :NAME "(1-VAR-FIXED) Slice Composition"
   :term1 '(BV-EQUAL
	    (BV-COMPOSE (BV-JOKER 1) (BV-JOKER 2))
	    (BV-COMPOSE (BV-JOKER 3) (BV-JOKER 4)))
   :term2 nil
   :condition-1 '(OR (NOT (IS-FIXED? (LEN (SIGMA (BV-JOKER 1)))))
		     (NOT (IS-FIXED? (LEN (SIGMA (BV-JOKER 3))))))
   :condition-2 nil
   :new-eq-list '(LET ((chunk_a (SIGMA (BV-JOKER 1)))
		       (chunk_b (SIGMA (BV-JOKER 2)))
		       (N (LEN chunk_a))
		       (chunk_c (SIGMA (BV-JOKER 3)))
		       (chunk_d (SIGMA (BV-JOKER 4)))
		       (M (LEN chunk_c)))
		  (CONTEXT-SPLIT NIL
                    ;;; -- Context 1 --		    
		    (LIST (list (MAKE-< n m))
		          NIL
		          (LIST
			   (BV-EQUAL
			    (ALPHA (MAKE-BV-EXTRACTION chunk_a (- N 1) (- N M)))
			    chunk_c)
			   (BV-EQUAL
			    (BV-COMPOSE
			     (ALPHA (MAKE-BV-EXTRACTION chunk_a (- N M 1) 0))
			     chunk_b)
			    chunk_d)
			   ;;; New CS-Rule:
			   ;; (LET ((CS-VAR (PIC-POS chunk_c (- M N 1))))
			   ;;	(CS-INFO CS-VAR
			   ;;		 (FREE-LIST (1- M) (1+ (- M N))))) 
			   ))
		   ;;; -- Context 2 --
		   (LIST (list (MAKE-<= n m)
			  (MAKE-<= m n))
		    nil
		    (LIST (BV-EQUAL chunk_a chunk_c)
		     (BV-EQUAL chunk_b chunk_d))
		    )
		   ;;; -- Context 3 --
		   (LIST (list (MAKE-< m n))
		         NIL
		         (LIST
			  (BV-EQUAL
			   (ALPHA (MAKE-BV-EXTRACTION (BV-COMPOSE chunk_a chunk_b)
						      (1- (+ n (LEN chunk_b)))
						      (-  (+ n (LEN chunk_b)) m)))
			   chunk_c)
			  (BV-EQUAL
			   (ALPHA (MAKE-BV-EXTRACTION (BV-COMPOSE chunk_a chunk_b)
						      (- (+ n (LEN chunk_b)) 1)
						      0))
			   chunk_d)))
			   
		    
		    ) )
   :REMOVE 'FIRST)
  
  (make-bv-unify-rule
   :name "(7) Redirect Equation"
   :term1 '(BV-EQUAL
	    (BV-JOKER 1)
	    (BV-JOKER 2))
   :term2 nil
   :condition-1 '(LET ((term_a (SIGMA (BV-JOKER 1)))
		       (term_b (SIGMA (BV-JOKER 2))))
		  (OR (AND (NOT (is-cs-rule? (BV-EQUAL term_a term_b)))
		           (is-composition? term_b)
		           (NOT (is-composition? term_a)))
		      (AND (is-const? term_a)
		           (not (is-const? term_b)))))
   :condition-2 nil
   :new-eq-list '(LIST
		  (BV-EQUAL
		    (SIGMA (BV-JOKER 2))
		    (SIGMA (BV-JOKER 1))))
   :remove 'FIRST)

  ;; --------------------
  ;;  Failure
  ;; --------------------
  (make-bv-unify-rule
   :NAME "(4) Constant Failure"
   :term1 '(BV-EQUAL
	    (BV-JOKER 1) (BV-JOKER 2))
   :term2 nil
   :condition-1 '(AND (is-const? (sigma (BV-JOKER 1)))
		      (is-const? (sigma (BV-JOKER 2)))
		      (NOT (EQUAL (sigma (BV-JOKER 1))
			          (sigma (BV-JOKER 2)))))
   :condition-2 nil
   :new-eq-list '(LIST
		  FAIL)
   :remove 'NONE)

  (make-bv-unify-rule
   :NAME "(3) Redundance"
   :term1 '(BV-EQUAL
	    (BV-JOKER 1)
	    (BV-JOKER 1))
   :term2 nil
   :condition-1 t
   :condition-2 t
   :new-eq-list nil
   :remove 'FIRST)

  ;; --------------------
  ;;  Csolve
  ;; --------------------
  
  (make-bv-unify-rule
   :name "(2) csolve SAME extraction"
   :term1 '(BV-EQUAL
	    (BV-EXTRACT (BV-JOKER 1) (TUPCONS (BV-JOKER 2) (BV-JOKER 3)))
	    (BV-EXTRACT (BV-JOKER 1) (TUPCONS (BV-JOKER 5) (BV-JOKER 6))))
   :term2 nil
   :condition-1 '(AND (is-var? (SIGMA (BV-JOKER 1)))
		      (not (equal (SIGMA (BV-JOKER 2))
		                  (SIGMA (BV-JOKER 5))))
		      (<= (MAX (SIGMA (BV-JOKER 3)) (SIGMA (BV-JOKER 6)))
		          (MIN (SIGMA (BV-JOKER 2)) (SIGMA (BV-JOKER 5))))
		  
		  )
   :condition-2 t
   :new-eq-list '(LET ((xxx (SIGMA (BV-JOKER 1)))
		       (xl  (SIGMA (BV-JOKER 2)))
		       (xr  (SIGMA (BV-JOKER 3)))
		       (yl  (SIGMA (BV-JOKER 5)))
		       (yr  (SIGMA (BV-JOKER 6)))
		       (hl (max xl yl))
		       (hr (max xr yr))
		       (ll (min xl yl))
		       (lr (min xr yr))
		       (length1 (1+ (- xl xr)))
		       (length2 (1+ (- yl yr)))
		       (cs_term (ALPHA (MAKE-BV-EXTRACTION xxx hl lr)))
		       (overlap (1+ (- ll hr)))
		       (delta (- hr lr))
		       (gamma (+ overlap delta delta))
		       (lambda  (MOD gamma delta))
		       (k-times (DIV gamma delta))
		       (fresh_1 (FRESH lambda))
		       (fresh_2 (FRESH (- delta lambda))))
		  ;;; The case [first] cannot occur
		  ;;; The cases [second]&[third] turned out to be the same
		  ;;; CONTEXT SPLIT on LAMBDA = 0
		  (CONTEXT-SPLIT nil
		   ;;; --- Context 1 --- .. LAMBDA=0
		   (LIST NIL
		         (LIST (/ (1+ (- hl lr)) (- hr lr)))
		         (LIST (BV-EQUAL
				(ALPHA (BV-ITERATE k-times fresh_2))
				cs_term)))
		   ;;; --- Context 2 --- .. LAMBDA>0		   
		   (LIST (LIST (MAKE-< 0 lambda))
			 NIL
		         (LIST
			  (BV-EQUAL
			   (ALPHA (BV-COMPOSE
				   fresh_1
				   (ALPHA (BV-ITERATE k-times (BV-COMPOSE fresh_2 fresh_1)))))
			   cs_term)))
		   ) )
   :REMOVE 'FIRST)
   
  (make-bv-unify-rule
   :NAME "(6) Atomar Match"
   :term1 '(BV-EQUAL
	    (BV-JOKER 1)
	    (BV-JOKER 2))
   :term2 '(BV-EQUAL
	    (BV-JOKER 1)
	    (BV-JOKER 3))
   :condition-1 '(is-atomic? (SIGMA (BV-JOKER 1)))
   :condition-2 t
   :NEW-EQ-LIST '(LIST
		  (BV-EQUAL (SIGMA (BV-JOKER 2))
		            (SIGMA (BV-JOKER 3))))
   :REMOVE 'FIRST)

 (make-bv-unify-rule
  :NAME "(5) Subterm Match"
  :term1 '(BV-EQUAL (BV-JOKER 1) (BV-JOKER 2))
  :condition-1 '(is-cs-rule? (BV-EQUAL (SIGMA (BV-JOKER 1)) (SIGMA (BV-JOKER 2))))
  :term2 '(BV-EQUAL (BV-JOKER 3)
	            (BV-JOKER 4))
  :condition-2 '(AND (IS-ATOMIC? (SIGMA (BV-JOKER 3)))
		     (is-contained-as-subterm? (SIGMA (BV-JOKER 1)) (SIGMA (BV-JOKER 4))))
  :new-eq-list '(LIST
		 (IF (is-cs-rule? (BV-EQUAL (SIGMA (BV-JOKER 3)) (SIGMA (BV-JOKER 4))))
		  (BV-EQUAL
		   (SIGMA (BV-JOKER 3))
		   (ALPHA (REPLACE-IN-SUBTERM (SIGMA (BV-JOKER 1)) (SIGMA (BV-JOKER 2)) (SIGMA (BV-JOKER 4)))))
		 (BV-EQUAL
		  (ALPHA (REPLACE-IN-SUBTERM (SIGMA (BV-JOKER 1)) (SIGMA (BV-JOKER 2)) (SIGMA (BV-JOKER 4))))
		  (SIGMA (BV-JOKER 3)))))
  :remove 'SECOND)

 ;;; --------------------
 ;;;  Propagation
 ;;; --------------------

 (make-bv-unify-rule
  :NAME "(8) Atomic Propagate"
  :TERM1 '(BV-EQUAL
	   (BV-JOKER 1)
	   (BV-JOKER 2))
  :CONDITION-1 '(AND (IS-ATOMIC? (SIGMA (BV-JOKER 1)))
		     (IS-ATOMIC? (SIGMA (BV-JOKER 2)))
		     (NOT (is-overlapping-extraction?
			   (SIGMA (BV-JOKER 1))
			   (SIGMA (BV-JOKER 2)))))
  :TERM2 '(BV-EQUAL
	   (BV-JOKER 2)
	   (BV-JOKER 3))
  :CONDITION-2 '(OR (IS-ATOMIC? (SIGMA (BV-JOKER 3)))
		    (IS-CONST?  (SIGMA (BV-JOKER 3))))
  :new-eq-list '(LIST (BV-EQUAL (SIGMA (BV-JOKER 1))
		                (SIGMA (BV-JOKER 3))))
  :remove 'FIRST) 

 (make-bv-unify-rule
  :NAME "(9) Atomic Loop"
  :TERM1 '(BV-EQUAL (BV-JOKER 1) (BV-JOKER 2))
  :CONDITION-1 '(AND (IS-ATOMIC? (SIGMA (BV-JOKER 1)))
		     (IS-ATOMIC? (SIGMA (BV-JOKER 2))))
  :TERM2 '(BV-EQUAL (BV-JOKER 2) (BV-JOKER 1))
  :CONDITION-2 t
  :NEW-EQ-LIST nil
  :REMOVE 'SECOND)


 ;; --------------------
 ;;  CS-Rules
 ;; --------------------

 (make-bv-unify-rule
  :NAME "(10) CS-info match"
  :TERM1 '(CS-INFO (BV-JOKER 1) (BV-JOKER 2))
  :CONDITION-1 '(IS-VAR? (SIGMA (BV-JOKER 1)))
  :TERM2 '(CS-INFO (BV-JOKER 3) (BV-JOKER 4))
  :CONDITION-2 '(LET ((var (SIGMA (BV-JOKER 1)))
		      (exp (SIGMA (BV-JOKER 3))))
		 (IF (IS-VAR? exp)
		  (EQUAL var exp)
		  (AND (is-extraction? exp)
		       (EQUAL (EXTRACTION-BV exp) var))))
  :NEW-EQ-LIST '(LIST (CS-INFO (SIGMA (BV-JOKER 1))
		               (ADD-TO-SLICING (SIGMA (BV-JOKER 2))
				(SIGMA (BV-JOKER 3)) (SIGMA (BV-JOKER 4)))))
  :REMOVE 'BOTH)

 (make-bv-unify-rule
  :NAME "(11) Slicing required LHS"
  :TERM1 '(CS-INFO (BV-JOKER 1) (BV-JOKER 2))
  :CONDITION-1 '(IS-VAR? (SIGMA (BV-JOKER 1)))
  :TERM2 '(BV-EQUAL (BV-JOKER 3) (BV-JOKER 4))
  :CONDITION-2 '(REQUIRES-SLICING?
		 (SIGMA (BV-JOKER 3))
		 (SIGMA (BV-JOKER 1))
		 (SIGMA (BV-JOKER 2)))
  :NEW-EQ-LIST '(LIST
		 (BV-EQUAL
		  (SLICE-ACCORDING-TO (SIGMA (BV-JOKER 3))
		                      (SIGMA (BV-JOKER 1))
		                      (SIGMA (BV-JOKER 2)))
		  (SIGMA (BV-JOKER 4))))
  :REMOVE 'SECOND)

 (make-bv-unify-rule
  :NAME "(12) Slicing required RHS"
  :TERM1 '(CS-INFO (BV-JOKER 1) (BV-JOKER 2))
  :CONDITION-1 '(IS-VAR? (SIGMA (BV-JOKER 1)))
  :TERM2 '(BV-EQUAL (BV-JOKER 4) (BV-JOKER 3))
  :CONDITION-2 '(REQUIRES-SLICING?
		 (SIGMA (BV-JOKER 3))
		 (SIGMA (BV-JOKER 1))
		 (SIGMA (BV-JOKER 2)))
  :NEW-EQ-LIST '(LIST
		 (BV-EQUAL
		  (SLICE-ACCORDING-TO (SIGMA (BV-JOKER 3))
		                      (SIGMA (BV-JOKER 1))
		                      (SIGMA (BV-JOKER 2)))
		  (SIGMA (BV-JOKER 4))))
  :REMOVE 'SECOND)
 
 
 ))

(defconstant *n-VAR-solving-rules* (length *VAR-solving-rules*))
			      
(defun start-split-chop
    (&optional (examples *split-chop-simple-examples*)
     &key      (stream nil)
	       (break nil)) "Test split-chop algorithm"
  (let ((examples
	 (if (rec-bv-equation? examples)
	     (list examples)
	   examples)))
    (create-output-from-list
     (append (obs0 '("Entering/Leaving"))
	     (obs1 '("Added/Deleted"))
	     (obs2 '("Fineal List & Hits"))
	     (obs3 '("Attempts & Results"))
	     (obs4 '("ALL Tries"))
	     (obs5 '("Local Bindings & Sigma Lists"))
	     (obs6 '("Successfull tries"))
	     (obs7 '("Local Evalutation"))
	     (obs8 '("Coarsest-Slicing Rules")))
     :STREAM stream
     :FIRST-WORD "** Observing : ")
    
    (multiple-value-bind
	(sec min hour day month year)
	(get-decoded-time)
      (princ (format nil "** Start Time: ~2d:~1d~1d:~1d~1d  ~d/~d/~d~%"
		     hour (div min 10) (mod min 10) (div sec 10) (mod sec 10) day month year) stream))
    
    (loop for e in examples do
	  (if break (break))
	  (princ (format nil "============================================================~% ** Starting New Context ~% ** Equation:~% ** ~a~%============================================================~%"
			 (bv-term-to-ASCII e)) stream)
	  (setf *number-of-ctr-hits* 0)
	  (start-time-1)
	  (let* ((t1 (canonize-VAR-bv (cadr e)))
		 (t2 (canonize-VAR-bv (caddr e)))
		 (nframe 0)
		 (len1 (bv-length t1))
		 (len2 (bv-length t2))
		 (nterms1 (if (rec-bv-composition? t1)
			      (length (bv-composition-content t1))
			    1))
		 (nterms2 (if (rec-bv-composition? t2)
			      (length (bv-composition-content t2))
			    1))
		 (eq-list (expand-with-cs-rules
			   (make-bv-equation t1 t2)))
		 (all-nat-vars (remove-duplicates
				(append
		     (all-recognized-in-arith-bool-bv-term t1 #'is-nat-var?)
		     (all-recognized-in-arith-bool-bv-term t2 #'is-nat-var?))
		     :TEST #'EQUAL))			     
		 (dummy (stop-time-1))
		 (dummy (start-time))
		 (assumptions (append
			       (if (equal len1 len2)
				   nil
				 (list (make-nat-leq len1 len2)
				       (make-nat-leq len2 len1)))
			       (loop for v in all-nat-vars collect
				     (make-nat-leq 1 v))))
		 (context-list
		  (list (make-chop-context
			 :EQUATIONS eq-list
			 :INTEGER-CONSTRAINTS
			   (make-integer-constraints
			    :LEQ assumptions)
			 :DEPTH 0
			 :CLOSED nil)))
		 (new-context-list nil))
	    (loop while (some #'context-alive? context-list) do
		   (loop for ctx in context-list do
			 (if (context-alive? ctx)
			     (loop for res-ctx in (solve-context-via-split-chop ctx :STREAM stream) do
				   (push res-ctx new-context-list))))
		   (setf context-list new-context-list
			 new-context-list nil))
	    (stop-time)
	    (obs0
	     (progn
	       (princ (format nil "============================================================~%Results in ~d Frame(s):~%" (length context-list)) stream)
	       (loop for ctx in context-list do
		     (princ (format nil "----------------------------------------~%") stream)
		     (princ (format nil "** Frame #~d [depth ~d] **~%STATUS: ~a~%" (incf nframe) (chop-context-depth ctx) (princ-to-string (chop-context-closed ctx))) stream)
		     
		     (create-output-from-list (mapcar #'bv-term-to-ASCII (integer-constraints-LEQ (chop-context-integer-constraints ctx)))
					      :FIRST-WORD "LEQ: "
					      :STREAM stream)
		     (create-output-from-list (mapcar #'bv-term-to-ASCII (integer-constraints-BET (chop-context-integer-constraints ctx)))
					      :FIRST-WORD "BET: "
					      :STREAM stream)
		     (create-output-from-list (mapcar #'(lambda (x)
							  (CLOS::string-append (bv-term-to-ASCII (car x))
									       " |-> "
									       (bv-term-to-ASCII (cdr x))))
						      (integer-constraints-MAP (chop-context-integer-constraints ctx)))
					      :FIRST-WORD "MAP: "
					      :STREAM stream)		  
		     (create-output-from-list (mapcar #'bv-term-to-ASCII (integer-constraints-INT (chop-context-integer-constraints ctx)))
					      :FIRST-WORD "INT: "
					      :STREAM stream)
		     (create-output-from-list (mapcar #'bv-term-to-ASCII (chop-context-equations ctx)) :FIRST-WORD "Equations: " :STREAM stream)
		     
		     )))))
    (obs0
     (progn
       (princ (format nil "============================================================~%") stream)
       (princ (format nil "Number of Matches: ~3d~%" *number-of-ctr-hits*) stream)
       (princ (format nil "Preparation Time : ~7,3f [sec]~%" *stopped-time-1*) stream)
       (princ (format nil "Solving     Time : ~7,3f [sec]~%" *stopped-time*) stream)
       (princ (format nil "============================================================~%") stream)))
    (multiple-value-bind
	(sec min hour day month year)
	(get-decoded-time)
      (princ (format nil "~%**  Stop Time: ~2d:~1d~1d:~1d~1d  ~d/~d/~d~%"
		     hour (div min 10) (mod min 10) (div sec 10) (mod sec 10) day month year) stream)))
    'DONE)
  

(defun start-split-chop-log (&optional (examples *split-chop-simple-examples*)
			     &key (name "/home/hiwi/moeller/SRI/l.txt"))
  (with-open-file (stream name
		   :direction :output
		   :if-does-not-exist :create
		   :if-exists :supersede)
    (start-split-chop examples :stream stream)))
		      

;;; ******************************
;;;  Pre-Processing
;;; ******************************

(defun expand-with-cs-rules (eq)
  ;; Add the neccessary cs-conditions to an equation
  ;; Returns a list
  (let* ((extr (all-recognized-in-arith-bool-bv-term
	       eq
		#'(lambda (x) (rec-bv-extraction? x))))
	 (vars (delete-duplicates
		(mapcar #'bv-extraction-bv extr)
		:TEST #'EQUAL))
	 (var-slice
	  (loop for v in vars collect
		(let* ((len (bv-var-length v))
		       (vec (make-array len :initial-element nil)))
		  (setf (aref vec (1- len)) t)
		  (loop for e in extr do
			(if (equal v (bv-extraction-bv e))
			    (setf (aref vec (mod (bv-extraction-left e) len)) t
				  (aref vec (mod (1- (bv-extraction-right e)) len)) t)))
		  (cons v vec))))
	 (res nil))
    ;; -- Add Slices for Chunks 
;    (loop for ex in extr do
;	  (let ((slc (extract-slice
;		      (cdr (assoc (bv-extraction-bv ex) var-slice :TEST #'equal))
;		      (bv-extraction-left ex)
;		      (bv-extraction-right ex))))
;	    (unless (is-nullslice? slc)
;	      (pushnew (make-cs-info ex slc)
;		       res
;		       :TEST #'equalp))))
    ;; -- Add slices for variables    
    (loop for v in vars do
	  (let ((slc (cdr (assoc v var-slice :TEST #'equal))))
	    (unless (is-nullslice? slc)
	      (push
	       (make-cs-info v slc)
	       res))))
    
    (cons eq res)))
    
(defun slice-bv-via-vec (bv-term vec)
  (let ((len (length vec))
	(res nil)
	(last 0)
	(actual 0))
    (loop while (< actual len) do
	  (if (aref vec actual)
	      (progn
		(push (make-bv-extraction
		       bv-term
		       actual
		       last)
		      res)
		(setf last (1+ actual))))
	  (incf actual))
    (VAR-alpha
     (make-bv-composition-from-list res))))



;;; ****************************************
;;;  Start of Equation Processing
;;; ****************************************

(defun solve-context-via-split-chop (context
				     &key (stream nil))
  ;; Always returns a LIST of contexts
  ;;
  (let* ((integer-constraints
	  (int-close-ic (chop-context-integer-constraints context)
		        :STREAM stream))
	 (MAP (integer-constraints-MAP integer-constraints))
	 (equation-list
	  ;;(chop-context-equations context)
	  (mapcar #'(lambda (x) (arith-term-replace-via-alist x MAP))
				(chop-context-equations context)))
	 )

    (obs0 (progn
	    
	    (princ (format nil "~%**** Entering new Solving Context [depth ~d] ****~%" (chop-context-depth context)) stream)
	    (create-output-from-list (mapcar #'bv-term-to-ASCII (integer-constraints-LEQ integer-constraints))
				     :FIRST-WORD "LEQ: "
				     :STREAM stream)
	    (create-output-from-list (mapcar #'bv-term-to-ASCII (integer-constraints-BET integer-constraints))
				     :FIRST-WORD "BET: "
				     :STREAM stream)
	    (create-output-from-list (mapcar #'(lambda (x)
		  (CLOS::string-append (bv-term-to-ASCII (car x))
				       " |-> "
				       (bv-term-to-ASCII (cdr x))))
		  (integer-constraints-MAP integer-constraints))
				     :FIRST-WORD "MAP: "
				     :STREAM stream)		  
	    (create-output-from-list (mapcar #'bv-term-to-ASCII (integer-constraints-INT integer-constraints))
				     :FIRST-WORD "INT: "
				     :STREAM stream)
	    (create-output-from-list (mapcar #'bv-term-to-ASCII equation-list) :FIRST-WORD "Equations: " :STREAM stream)))
    (if (> (chop-context-depth context)
	   *split-chop-max-depth*)
	(return-from solve-context-via-split-chop
	  (list
	   (make-chop-context
	    :EQUATIONS equation-list
	    :INTEGER-CONSTRAINTS integer-constraints
	    :CLOSED 'ABORTED
	    :DEPTH (chop-context-depth context)))))
    ;;----------------------------------------
    (if (some #'(lambda (x)
		  (and (rec-bv-equation? x)
		       (not (equal (canonize-nat-term (bv-length (second x)))
				   (canonize-nat-term (bv-length (third x)))))))
	      equation-list)
	(return-from solve-context-via-split-chop
	  (list
	   (make-chop-context
	    :EQUATIONS (cons 'FAIL equation-list)
	    :INTEGER-CONSTRAINTS integer-constraints
	    :CLOSED 't
	    :DEPTH (chop-context-depth context)))))
    ;;----------------------------------------
  (let* ((ovars (remove-duplicates
		 (loop for e in (remove-if-not #'(lambda (x) (rec-bv-equation? x)) equation-list) append
		       (append (all-recognized-in-arith-bool-bv-term
				(cadr e)
				#'(lambda (x) (rec-bv-var? x)))
			       (all-recognized-in-arith-bool-bv-term
				(caddr e)
				#'(lambda (x) (rec-bv-var? x)))))
		 :TEST #'equal))
	 (local-running-number 0)
	 (trigger-split nil)
	 (local-binding nil)
	 (sigma '(lambda (&rest l) (break))))
    (labels
     ;;; --------------------
     ;;; Predicates
     ;;; --------------------
     ((is-ovar? (x)
		(if (member x ovars :TEST #'equal)
		    t nil))
      (is-atomic? (x)
		  (or (rec-bv-var? x)
		      (rec-bv-const? x)
		      (and (rec-bv-extraction? x)
			   (rec-bv-var? (bv-extraction-bv x)))))
      (is-original? (x)
	(obs7 (princ (format nil "Entered is-original? [~a]~%" x) stream))
		    (or (is-ovar? x)
			(and (rec-bv-extraction? x)
			     (is-ovar? (bv-extraction-bv x)))
			(and (rec-bv-composition? x)
			     (some #'is-original? (bv-composition-content x)))))
      (is-const? (x)
		 (rec-bv-const? x))
      (is-composition? (x)
	(rec-bv-composition? x))
      ;;;--------------------
      ;;; Functions
      ;;;--------------------
      (alpha (x)
	     (VAR-alpha x))
      (len   (x)
	      (bv-length x))
      (fresh (x)
	     (make-bv-var (CLOS::string-append "FRESH_"
					       (princ-to-string (incf local-running-number)))
			  x))
      (pic-pos (x pos)
	;; Returns the atomar sub-term in x covering position pos
	(if (rec-bv-composition? x)
	    (let* ((left (bv-decompose-left x))
		   (right (bv-decompose-right x))
		   (len_right (bv-length right)))
	      (if (< pos len_right)
		  (pic-pos right pos)
		(pic-pos left (- pos len_right))))
	  x))
      
      (replace-in-subterm (old new term)
	(cond
	 ((equal old term) new)
	 ((rec-bv-const? term) term)
	 ((rec-bv-var? term) term)
	 ((rec-bv-extraction? term)
	  (make-bv-extraction (replace-in-subterm old new (bv-extraction-bv term)) (bv-extraction-left term) (bv-extraction-right term)))
	 ((is-composition? term)
	  (make-bv-composition-from-list
	   (mapcar #'(lambda (x) (replace-in-subterm old new x))
		   (bv-composition-content term))))
	 (t (error-misc "[local] replace-in subterm" term "no match."))))
      (clear-local-binding () (setf local-binding nil))
      (fresh-local-eval (x)
	(clear-local-binding)
	(local-eval x))
      (save-<= (x y)
	(if (and (numberp x) (numberp y))
	    (<= x y)))
      (save-< (x y)
	(if (and (numberp x) (numberp y))
	    (< x y)))
      (save-MOD (a b)
	(if (and (numberp a) (numberp b))
	    (MOD a b)
	  `(MOD ,a ,b)))
      (save-DIV (a b)
	(if (and (numberp a) (numberp b))
	    (DIV a b)
	  `(DIV ,a ,b)))
      (save-/ (a b)
	(if (and (numberp a) (numberp b))
	    (/ a b)
	  `(/ ,a ,b)))
      (is-fixed? (a)
	(numberp a))
      (local-eval (x)
        (obs7 (princ (format nil "Entered local-eval [~a]~%" x) stream))
	(if (consp x)
	    (case (car x)
	      (LIST    (mapcar #'local-eval (cdr x)))
	      (CS-APPEND
	       (let* ((arg1 (local-eval (cadr x)))
		      (arg2 (local-eval (caddr x))))
		 (make-cs-list
		  (append (if (rec-cs-list? arg1)
			      (cdr arg1) (list arg1))
			  (if (rec-cs-list? arg2)
			      (cdr arg2) (list arg2))))))
	      (CS-LIST (make-cs-list (local-eval (cadr x))))
	      (BV-EQUAL (make-bv-equal (local-eval (cadr x))
				       (local-eval (caddr x))))
	      (MAKE-BV-EXTRACTION (make-bv-extraction
				   (local-eval (cadr x))
				   (local-eval (caddr x))
				   (local-eval (cadddr x))))
	      (BV-COMPOSE (make-bv-composition-from-list
			   (mapcar #'local-eval (bv-composition-content x))))
	      (BV-DECOMPOSE-LEFT
	       (bv-decompose-left (local-eval (cadr x))))
	      (BV-VAR x)
	      (BV-CONST x)
	      (BV-JOKER x)
	      (PIC-POS (pic-pos (local-eval (cadr x))
				(local-eval (caddr x))))
	      (IS-CONTAINED-AS-SUBTERM?
	       (let* ((t1 (local-eval (cadr x)))
		      (t2 (local-eval (caddr x)))
		      (res (or (EQUAL t1 t2)
			       (AND (is-composition? t2)
				    (EQUAL t1 (bv-composition-content t2)))
			       (AND (is-composition? t2)
				    (member t1 (bv-composition-content t2) :TEST #'equal)))))
		 (obs8 (princ (format nil "!?! IS-CONTAINED-AS-SUBTERM? ~a in ~a~%    -> ~a~%" t1 t2 res) stream))
		 res))
	      (BV-ITERATE
	       (let ((k-times (local-eval (cadr x)))
		     (arg (local-eval (caddr x))))
		 (VAR-alpha
		  (make-bv-iteration k-times arg))))
	      (CS-ITERATE
	       (let ((k-times (local-eval (cadr x)))
		     (arg (local-eval (caddr x))))
		 (canonize-cs-info
		  (make-cs-iteration k-times arg))))
	      (REPLACE-IN-SUBTERM
	       (replace-in-subterm (local-eval (cadr x))
				   (local-eval (caddr x))
				   (local-eval (cadddr x))))
	      (+  (canonize-nat-term `(+ ,@(mapcar #'local-eval (cdr x)))))
	      (-  (canonize-nat-term `(- ,@(mapcar #'local-eval (cdr x)))))
	      (1- (canonize-nat-term `(- ,(local-eval (cadr x)) 1)))
	      (1+ (canonize-nat-term `(+ 1 ,@(mapcar #'local-eval (cdr x)))))
	      (MIN (symbolic-min (mapcar #'local-eval (cdr x))))
	      (MAX (symbolic-max (mapcar #'local-eval (cdr x))))
	      (MAKE-<  (make-nat-less-from-list (mapcar #'local-eval (cdr x))))
	      (MAKE-<= (make-nat-leq-from-list (mapcar #'local-eval (cdr x))))
	      (<   (save-< (local-eval (cadr x))
			   (local-eval (caddr x))))
	      (<=  (save-<= (local-eval (cadr x))
			    (local-eval (caddr x))))
	      (MOD (save-MOD (local-eval (cadr x))
			     (local-eval (caddr x))))
	      (DIV (save-DIV (local-eval (cadr x))
			     (local-eval (caddr x))))
	      (/   (save-/ (canonize-nat-term (local-eval (cadr x)))
			   (canonize-nat-term (local-eval (caddr xx)))))
	      (IS-FIXED? (is-fixed? (local-eval (cadr x))))
	      (CS-INFO-FROM-LIST
	       (make-cs-info (local-eval (cadr x))
			     (list-to-slicing (local-eval (caddr x)))))
	      (CS-INFO (make-cs-info (local-eval (cadr x))
				     (local-eval (caddr x))))
	      (ADD-TO-SLICING
	       (let* ((slc  (local-eval (cadr x)))
		      (slc2 (make-nullslice (length slc)))
		      (arg2 (local-eval (caddr x)))
		      (vec2 (local-eval (cadddr x))))
		 (if (rec-bv-extraction? arg2)
		     (let ((offset (bv-extraction-right arg2)))
		       (loop for i from 0 to (1- (length vec2)) do
			     (setf (aref slc2 (+ i offset))
			           (aref vec2 i)))
		       (overlay-vector-list `(,slc ,slc2)))
		   (overlay-vector-list `(,slc ,vec2)))))
	      (REQUIRES-SLICING?
	       (let* ((arg (local-eval (cadr x)))
		      (var (local-eval (caddr x)))
		      (slc (local-eval (cadddr x))))
		 (cond
		  ((rec-bv-var? arg)
		   (and (equal arg var)
			(not (is-nullslice? slc))))
		  ((rec-bv-extraction? arg)
		   (if (equal (bv-extraction-bv arg) var)
		       (let ((new-arg
			      (VAR-alpha
			       (make-bv-extraction
				(slice-bv-via-vec var slc)
				(bv-extraction-left arg)
				(bv-extraction-right arg)))))
			     (not (equal new-arg arg)))
		     nil))
		  (t nil))))
	      (SLICE-ACCORDING-TO
	       (let* ((arg (local-eval (cadr x)))
		      (var (local-eval (caddr x)))
		      (slc (local-eval (cadddr x)))
		      (new-arg (slice-bv-via-vec var slc)))
		 (if (rec-bv-extraction? arg)
		     (VAR-alpha
		      (make-bv-extraction new-arg
					  (bv-extraction-left arg)
					  (bv-extraction-right arg)))
		      
		   new-arg)))
	      (ALPHA (alpha (local-eval (cadr x))))
	      (CS-ALPHA (canonize-cs-info (local-eval (cadr x))))
	      (SIGMA ;;;(princ (format nil "Sigma: ~a~%" sigma))
		     ;;;(princ (format nil "Successfull -> ~a~%" (funcall sigma (cadr x))))
	       (funcall sigma (cadr x)))
	      (IS-VAR? (rec-bv-var? (local-eval (cadr x))))
	      (IS-CONST? (is-const? (local-eval (cadr x))))
	      (IS-COMPOSITION? (is-composition? (local-eval (cadr x))))
	      (IS-EXTRACTION? (rec-bv-extraction? (local-eval (cadr x))))
	      (IS-OVERLAPPING-EXTRACTION?
	       (let ((arg1 (local-eval (cadr x)))
		     (arg2 (local-eval (caddr x))))
		 (and
		  (rec-bv-extraction? arg1)
		  (rec-bv-extraction? arg2)
		  (equal (bv-extraction-bv arg1) (bv-extraction-bv arg2))
		  (<= (max (bv-extraction-right arg1)
			   (bv-extraction-right arg2))
		      (min (bv-extraction-left arg1)
			   (bv-extraction-left arg2))))))
	      (IS-ATOMIC? (is-atomic? (local-eval (cadr x))))
	      (is-cs-rule?
	       (let* ((arg (local-eval (cadr x)))
		      (res  (and (consp arg)
				 (eq (car arg) 'BV-EQUAL)
				 (is-atomic? (cadr arg))
				 (is-composition? (caddr arg))
				 (equal (cadr arg) (VAR-beta (caddr arg))))))
		 (obs8 (princ (format nil "!?! IS-CS-RULE ~a~%    -> ~a~%" arg res) stream))
		 res))
	      (EXTRACTION-BV (bv-extraction-bv (local-eval (cadr x))))
	      (LEN (len (local-eval (cadr x))))
	      (FRESH (fresh (local-eval (cadr x))))
	      (IS-OVAR? (is-ovar? (local-eval (cadr x))))
	      (IS-ORIGINAL? (is-original? (local-eval (cadr x))))
	      (OR  (if (null (cdr x))
		       nil
		     (or (local-eval (cadr x))
			 (local-eval (cons 'OR (cddr x))))))
	      (AND (every #'(lambda (y) y) (mapcar #'local-eval (cdr x))))
	      (NOT (not (local-eval (cadr x))))
	      (EQUAL (equal (local-eval (cadr x))
			    (local-eval (caddr x))))
	      (IF (if (local-eval (cadr x))
		      (local-eval (caddr x))
		    (local-eval (cadddr x))))
	      (LET (loop for e in (cadr x) do
			 (push (cons (car e)
				     (local-eval (cadr e)))
			       local-binding))
		   (obs5 (princ (format nil ":: LOCAL BINDINGS: ~a~%" local-binding) stream))
		   (local-eval (caddr x)))
	      (NAT-VAR x)
	      (FREE-LIST (make-free-list (mapcar #'local-eval (cdr x))))
	      (VALID-CS-LIST? (every #'is-fixed-nat? (local-eval (cadr x))))
	      (CONTEXT-SPLIT
	        (setf trigger-split
		  (loop for ctx in (cddr x) collect
			(local-eval ctx)))
		(local-eval (cadr x))) ;; <- Return for NEW-EQ-LIST
	      
	      (t (error-misc "local-eval" x "not caught.")))
	  
	  (or (cdr (assoc x local-binding :TEST #'equal))
	      x)))
	(find-match-for-rule (rule)
	;; Returns values   Positions of matching equation in equation-list
	;;                  Substitutions sigma1 and sigma2
	(obs3 (princ (format nil "Attemp matching rule: ~a~%" (bv-unify-rule-name rule)) stream))
	(let* ((l (length equation-list))
	       (ord1 (permutate-n-list l))
	       (ord2 nil)
	       (pos1 (car ord1))
	       (pos2 nil)
	       (ord1 (cdr ord1))
	       (sigma1 'FAIL)
	       (sigma2 'FAIL)
	       (nomatch1 t)
	       (nomatch2 t)
	       (term-2-consistent nil))
	  ;; Match first argument
	  (loop while (and nomatch1 pos1) do
		(setf sigma1 (rule-VAR-term-unify (bv-unify-rule-term1 rule) (nth pos1 equation-list)))
		(obs4 (princ (format nil " -- with ~a~% -- found ~a~%" (bv-term-to-ascii (nth pos1 equation-list)) sigma1) stream))
		(unless (not (listp sigma1))
		  (setf sigma `(lambda (x) (or (cdr (assoc x (quote ,sigma1) :TEST #'equal)) x)))
		  (obs5 (princ (format nil "SIGMA::~a~%" sigma) stream))
		  (obs4 (princ (format nil " -- : Condition evals to ~a~%" (fresh-local-eval (bv-unify-rule-condition-1 rule))) stream)))
		(cond
		 ((and (listp sigma1)
		       (fresh-local-eval (bv-unify-rule-condition-1 rule))
		       (null (bv-unify-rule-term2 rule)))
		  (setf nomatch1 nil))
		 ((and (listp sigma1)
		       (fresh-local-eval (bv-unify-rule-condition-1 rule)))
		  ;; -- search for second argument --
		  (unless (null (bv-unify-rule-term2 rule))
		    (obs4 (princ (format nil " --- Search for second matching term:~%") stream))
		    (setf ord2 (delete pos1 (permutate-n-list l))
			  pos2 (car ord2)
			  ord2 (cdr ord2))
		    (loop while (and nomatch2 pos2) do
			  (setf sigma2 (rule-VAR-term-unify (bv-unify-rule-term2 rule) (nth pos2 equation-list)))
			  (obs4 (princ (format nil " --- and ~a~% --- found ~a~%" (bv-term-to-ascii (nth pos2 equation-list)) sigma2) stream))
			  (unless (not (listp sigma2))
			    
			    (setf term-2-consistent (unificator-consistent? sigma1 sigma2))
			    (obs4 (princ (format nil " --- Consistent? ~a~%" term-2-consistent) stream))
			    (unless (not term-2-consistent)
			      (setf sigma `(lambda (x) (or (cdr (assoc x (quote ,(append sigma1 sigma2)) :TEST #'equal)) x)))
			      (let ((con2 (fresh-local-eval (bv-unify-rule-condition-2 rule))))
				(obs4 (princ (format nil " --- : Condition2 evals to ~a~%" con2) stream))
				(if con2
				    (setf nomatch2 nil
					  nomatch1 nil)
				  (setf nomatch2 t))
				)))
			  (if nomatch2
			      (setf pos2 (car ord2)
				    ord2 (cdr ord2)))))
		    (if nomatch2
			(setf pos1 (car ord1)
			      ord1 (cdr ord1))))
		    (t
		     (setf pos1 (car ord1)
			   ord1 (cdr ord1)))))
	  (cond
	   ((not nomatch2)
	    (values pos1 sigma1 pos2 sigma2))
	   ((and (not nomatch1)
		 (null (bv-unify-rule-term2 rule)))
	    (values pos1 sigma1 nil nil))
	   (t
	    (values nil nil nil nil))
	    
	   
	   )))
      
      (match () "Choose ONE rule (nondeterministically) and look for matching equations"
	     ;; Returns NIL if failing
	     (let* ((ord nil)
		    (actual-rule nil)
		    (rule-n nil)
		    (res nil)
		    (p1 nil)
		    (p2 nil)
		    (s1 nil)
		    (s2 nil)
		    )
	       (flet ((new-dice ()
			(setf ord (permutate-n-list *n-VAR-solving-rules*)
			      rule-n (car ord)
			      ord (cdr ord))))
		 (new-dice)
		 (loop while (and (null res) rule-n) do
		       (setf actual-rule (nth rule-n *VAR-solving-rules*))
		       ;; --  Here try to find a matching --
		       (multiple-value-bind (p1 s1 p2 s2)
			   (find-match-for-rule actual-rule)
			 (obs3 (princ (format nil "--> Returned ~a ~a~%             ~a ~a~%" p1 s1 p2 s2) stream))
			 (unless (null p1)
			   ;; Perform the transformation
			    (obs6 (progn
				      (princ (format nil "-- RULE ~a~%--> HIT ~a~%" (bv-unify-rule-name actual-rule) (bv-term-to-ascii (nth p1 equation-list))) stream)
				    (if p2 (princ (format nil "        ~a~%" (bv-term-to-ascii (nth p2 equation-list))) stream ))))
			    (if (null (bv-unify-rule-term2 actual-rule))
				(progn ;; -- One Equation --
				  (setf res t)
				  (if (eq (bv-unify-rule-remove actual-rule)
					  'FIRST)
				     (progn
				       (obs1 (princ (format nil "Deleting: ~a~%" (bv-term-to-ascii (nth p1 equation-list))) stream))
				       (setf equation-list
					 (delete (nth p1 equation-list)
						 equation-list
						 :TEST #'equal))
				      (obs2 (create-output-from-list (bv-term-list-to-ascii equation-list) :STREAM stream :FIRST-WORD     "New List: "))
				       ))
				 (setf sigma `(lambda (x) (cdr (assoc x (quote ,s1) :TEST #'equal))))
				 (let ((new-eqs (fresh-local-eval (bv-unify-rule-new-eq-list actual-rule))))
				   (obs1 (create-output-from-list (bv-term-list-to-ascii new-eqs) :STREAM stream :FIRST-WORD "Added   : "))
				   (if (equal new-eqs '(FAIL))
				       (setf equation-list 'FAIL)
				     (setf equation-list
				       (delete-duplicates
					(nconc equation-list new-eqs)
					:TEST #'equal))))
				 (obs2 (create-output-from-list (bv-term-list-to-ascii equation-list) :FIRST-WORD "Final List: " :STREAM stream))
				 
				 )
			     (progn ;; -- Two Equations --
			       (setf res t)
			       (case (bv-unify-rule-remove actual-rule)
			         (NONE  nil)
				 (FIRST
				  (obs1 (princ (format nil "Deleting: ~a~%" (bv-term-to-ascii (nth p1 equation-list))) stream))
				  (setf equation-list
				    (delete (nth p1 equation-list)
					    equation-list
					    :TEST #'equal)))
				 (SECOND
				   (obs1 (princ (format nil "Deleting: ~a~%" (bv-term-to-ascii (nth p2 equation-list))) stream))
				   (setf equation-list
				     (delete (nth p2 equation-list)
					     equation-list
					     :TEST #'equal)))
				 (BOTH
				  (let ((term2 (nth p2 equation-list)))
				    (obs1 (princ (format nil "Deleting: ~a~%          ~a~%" (bv-term-to-ascii (nth p1 equation-list)) (bv-term-to-ascii term2)) stream))
				    (setf equation-list
				      (delete term2
				       (delete (nth p1 equation-list)
					       equation-list
					       :TEST #'equal)
				       :TEST #'equal))))
				 (NONE
				  (obs1 (princ (format nil "Deleting: -~%") stream))))
			       (setf sigma `(lambda (x) (cdr (assoc x (quote ,(append s1 s2)) :TEST #'equal))))
			       (let ((new-eqs (fresh-local-eval (bv-unify-rule-new-eq-list actual-rule))))
				 (obs1 (create-output-from-list (bv-term-list-to-ascii new-eqs) :FIRST-WORD "Added   : " :STREAM stream ))
				 (if (equal new-eqs '(FAIL))
				     (setf equation-list 'FAIL)
				   (setf equation-list
				     (delete-duplicates
				      (nconc equation-list new-eqs)
				      :TEST #'EQUAL))))
			       
			       (obs2 (create-output-from-list (bv-term-list-to-ascii equation-list) :FIRST-WORD "Final List: " :STREAM stream))
			       ;; --------------------
			       ))
			   ;; --------------------
			   ;;  Split Context here, if necessary
			   ;; --------------------
			    (if trigger-split
			     (progn
			       (obs0 (progn
				 (princ (format nil "****************************************~%** Split Context here according to:~%------------------------------~%") stream)
				 (loop for i from 1 to (length trigger-split) do
				       (let ((s (nth (1- i) trigger-split)))
					 (create-output-from-list
					  (mapcar #'bv-term-to-ASCII (first s))
					   :FIRST-WORD (CLOS::string-append (princ-to-string i) ". LEQ: ")
					   :STREAM stream)
					 (create-output-from-list
					  (mapcar #'bv-term-to-ASCII (second s))
					  :FIRST-WORD "** INT: "
					  :STREAM stream)
					 (create-output-from-list
					  (mapcar #'bv-term-to-ASCII (third s))
					  :FIRST-WORD "** "
					  :STREAM stream)))))
			       (return-from solve-context-via-split-chop
				 (mapcar #'(lambda (x)
					     (make-chop-context
					      :EQUATIONS (append equation-list (third x))
					      :INTEGER-CONSTRAINTS
					      (make-integer-constraints
					       :LEQ (append
						     (integer-constraints-LEQ integer-constraints)
						     (first x))
					       :BET (integer-constraints-BET integer-constraints)
					       :MAP (integer-constraints-MAP integer-constraints)
					       :INT (append
						     (integer-constraints-INT integer-constraints)
						     (second x)))
					      :CLOSED nil
					      :DEPTH (1+ (chop-context-depth context))))
					 trigger-split))))
			    ;; --------------------------------
			   ))
			 (setf rule-n (car ord)
			       ord    (cdr ord))
			 ) ;; loop end
		       ;; --------------------
	       res	       
      )))
      )

     (loop while (and (listp equation-list) (match)) do (incf *number-of-ctr-hits*))
     (obs0
      (progn
      (create-output-from-list (bv-term-list-to-ascii equation-list)
			       :STREAM stream
			       :FIRST-WORD "Result: ")
      (princ (format nil "----------------------------------------~%") stream)))
     (list
      (make-chop-context
       :EQUATIONS equation-list
       :INTEGER-CONSTRAINTS integer-constraints
       :DEPTH (1+ (chop-context-depth context))
       :CLOSED t)
      )
   ))))
     
;;; ****************************************
;;;  AUX Functions (VAR Theory)
;;; ****************************************

(defun canonize-VAR-bv (x)
  (VAR-beta (VAR-alpha x)))

(defun VAR-alpha (x)
;;; Canonize Terms in the VAR theory
;;; Expands BV-ITERATE (if possible)
  (cond
   ((rec-bv-epsilon? x) x)
   ((rec-bv-var? x)
    (if (eq (bv-var-length x) 0)
	'BV-EPSILON
      x))
   ((rec-bv-const? x) x)
   ((rec-bv-extraction? x)
    (let* ((arg (bv-extraction-bv x))
	   (len (bv-length arg))
	   (left (bv-extraction-left x))
	   (right (bv-extraction-right x))
	   (times (canonize-nat-term `(+ 1 (- ,left ,right)))))
      (cond
       ((equal len times) (VAR-alpha arg))
       ((equal 0   times) 'bv-epsilon)
       ((rec-bv-var? arg) x)
       ((rec-bv-extraction? arg)
	(let ((arg2 (bv-extraction-bv arg))
	      (rr (bv-extraction-right arg)))
	  (VAR-alpha (make-bv-extraction arg2
					 (canonize-nat-term `(+ ,left ,rr))
					 (canonize-nat-term `(+ ,right ,rr))))))
       ((rec-bv-composition? arg)
	(let* ((argl (bv-decompose-left arg))
	       (argr (bv-decompose-right arg))
	       (lr   (bv-length argr)))
	  (cond ((is-trivial-assumption? (canonize-nat-leq
					  (make-nat-leq `(+ 1 ,left) lr)))
		 (VAR-alpha (make-bv-extraction argr left right)))
		((is-trivial-assumption? (canonize-nat-leq
					  (make-nat-leq `(+ 1 ,lr) right)))
		 (VAR-alpha (make-bv-extraction argl
						(canonize-nat-term `(- ,left ,lr))
						(canonize-nat-term `(- ,right ,lr)))))
		(t 
		   (make-bv-composition
		    (VAR-alpha (make-bv-extraction argl (canonize-nat-term `(- ,left ,lr)) 0))
		    (VAR-alpha (make-bv-extraction argr (canonize-nat-term `(- ,lr 1)) right)))))))
       ((rec-bv-const? arg)
	(cond
	 ((and (numberp left)
	       (numberp right))
	  (extract-bv-const (bv-const-value arg) left right))
	 (t x)))
       (t (error-misc "VAR-alpha" x " (extraction) not caught")))))
   ((rec-bv-composition? x)
    (make-bv-composition
     (VAR-alpha (bv-decompose-left x))
     (VAR-alpha (bv-decompose-right x))))
   ((rec-bv-iteration? x)
    (let ((times (canonize-nat-term (bv-iteration-times x)))
	  (arg (canonize-VAR-bv    (bv-iteration-bv    x))))
      (if (is-fixed-nat? times)
	  (make-bv-composition-from-list
	   (loop for i from 1 to times collect arg))
	(make-bv-iteration times arg))))
   (t (error-misc "VAR-alpha" x "not caught."))))

(defun VAR-beta (x)
  (if (rec-bv-composition? x)
      (let* ((list (bv-composition-content x))
	     (actual (car list))
	     (next (cadr list))
	     (rest (cddr list))
	     (res nil))
	(flet ((matches ()
		 (or (and (rec-bv-const? actual)
			  (rec-bv-const? next))
		     (and (rec-bv-extraction? actual)
			  (rec-bv-extraction? next)
			  (equal (bv-extraction-bv actual)
				 (bv-extraction-bv next))
			  (= (1+ (bv-extraction-left next))
			     (bv-extraction-right actual)))))
	       (melt ()
		 (setf
		     actual (if (rec-bv-const? actual)
				(append-bv-const actual next)
			      (VAR-alpha (make-bv-extraction
					   (bv-extraction-bv actual)
					   (bv-extraction-left actual)
					   (bv-extraction-right next))))
		     next   (car rest)
		     rest   (cdr rest))))
	  (loop while next do
		(loop while (and next (matches)) do (melt))
		(push actual res)
		(setf actual next
		      next   (car rest)
		      rest   (cdr rest)))
	  (if actual (push actual res))
	  (make-bv-composition-from-list (reverse res))))
    x))

;;; ******************************
;;;  Special Treatment of CS Infos
;;; ******************************

(defun canonize-cs-info (l)
  (cond
   ((numberp l) l)
   ((arrayp l) l)
   ((rec-nat-term? l)
    (canonize-nat-term l))
   ((rec-cs-list? l)
    (canonize-cs-list l))
   ((rec-cs-iterate? l)
    (let* ((k-times (canonize-nat-term (cadr l)))
	   (arg (caddr l))
	   (arglist (cond
		     ((arrayp arg)
		      (slicing-to-chop-list arg))
		     ((rec-cs-list? arg)
		      (mapcar #'canonize-nat-term (cdr arg)))
		     (t (error-misc "canonize-cs-info [arglist]" arg "not caught.")))))
	(if (numberp k-times)
	    (canonize-cs-info
	     (make-cs-list (loop for i from 1 to k-times append arglist)))
	  (make-cs-iterate k-times (make-cs-list arglist)))))
   (t
    (error-misc "canonize-cs-info" l "not caught."))))

(defun canonize-cs-list (l)
  (let ((list (loop for e in (mapcar #'canonize-cs-info (cdr l)) append
		    (cond
		     ((rec-cs-list? e)
		      (cdr e))
		     ((eq 0 e) nil)
		     (t (list e))))))
    (if (every #'(lambda (x) (or (numberp x) (arrayp x))) list)
	(let ((newlist (loop for e in list append
			     (if (numberp e)
				 (list e)
			       (slicing-to-chop-list e))))
	      (res nil)
	      (sofar -1))
	  (loop for e in newlist do
		(incf sofar e)
		(push sofar res))
	  (list-to-slicing (reverse res)))
      (make-cs-list list))))


   
(defmacro rec-cs-iterate? (l)
  `(and (consp ,l)
	(eq (car ,l) 'CS-ITERATE)))

(defmacro make-cs-iteration (k term)
  ``(CS-ITERATE ,,k ,,term))

(defmacro make-cs-list (list)
  ;; INPUT IS A LIST
  ``(CS-LIST ,@,list))

(defmacro rec-cs-list? (l)
  `(and (consp ,l)
	(eq (car ,l) 'CS-LIST)))


;;; ****************************************
;;;  AUX Functions (general)
;;; ****************************************

(defun permutate-n-list (n)
  ;; Random Permutation of {0,1,...,n-1}
  (let ((l (loop for i from 0 to (1- n) collect i))
	(res nil))
    (loop for i from 0 to (1- n) do
	  (let ((el (nth (random (- n i)) l)))
	    (push el res)
	    (setf l (delete el l))))
    res))
	    

;;; ******************************
;;;  Unification
;;; ******************************

(defun rule-VAR-term-unify (rule term)
  ;; Returns either a substitution (by means of an assoc-list)
  ;; or 'FAIL (which is not listp) , if a unification is not possible
  (ifassert (consp rule))
  (cond
   ((rec-joker? rule)
    (acons rule term nil)) 
   ((eq (car rule)
	(car term))
    (case (car rule)
      (CS-INFO
       (let ((uni1 (rule-VAR-term-unify (cadr rule) (cadr term)))
	     (uni2 (rule-VAR-term-unify (caddr rule) (caddr term))))
	 (if (and (listp uni1)
		  (listp uni2))
	     (append uni1 uni2)
	   'FAIL)))
      (BV-EQUAL
       (let ((uni1 (rule-VAR-term-unify (cadr rule) (cadr term)))
	     (uni2 (rule-VAR-term-unify (caddr rule) (caddr term))))
	 (if (and (listp uni1)
		  (listp uni2)
		  (unificator-consistent? uni1 uni2))
	     (append uni1 uni2)
	   'FAIL)))
      
      (BV-CONST
       (if (equal rule term)
	   nil
	 'FAIL))
      
      (BV-VAR
       (acons rule term nil))
      
      (BV-EXTRACT
       (let ((uni (rule-VAR-term-unify
		   (bv-extraction-bv rule)
		   (bv-extraction-bv term))))
	 (if (listp uni)
	     (acons (bv-extraction-left rule)
		    (bv-extraction-left term)
		    (acons (bv-extraction-right rule)
			   (bv-extraction-right term)
			   uni))
	   'FAIL)))
      
      (BV-COMPOSE
       (let ((uni1 (rule-VAR-term-unify
		    (bv-decompose-left rule)
		    (bv-decompose-left term)))
	     (uni2 (rule-VAR-term-unify
		    (bv-decompose-right rule)
		    (bv-decompose-right term))))
	 (if (and (listp uni1)
		  (listp uni2)
		  (unificator-consistent? uni1 uni2))
	     (append uni1 uni2)
	   'FAIL)))	 
       
       ))
      (t 'FAIL)))

(defun unificator-consistent? (u1 u2)
  (let ((int (remove-duplicates
	      (append u1 u2)
	      :TEST #'equal)))
    (= (length int)
       (length (remove-duplicates
		int
		:TEST #'(lambda (x y) (equal (car x) (car  y))))))))

(defmacro rec-joker? (x)
  `(eq (car ,x)
       'BV-JOKER))


;;; ******************************
;;; * Examples
;;; ******************************

(defconstant *split-chop-simple-examples*
    (list
      '(bv-equal (bv-compose (bv-var x (nat-var n))
	                  (bv-var y (nat-var m))
	                  (bv-var y (nat-var m))
	                  (bv-var c 1)
	                  (bv-var z (nat-var p))
	                  (bv-var b 1)
	                  (bv-var z (nat-var p))
	                  (bv-const 1 1)
	                  (bv-var x (nat-var n)))
              (bv-compose (bv-var y (nat-var m))
	                  (bv-var x (nat-var n))
	                  (bv-var c 1)
	                  (bv-var y (nat-var m)) 
	                  (bv-var b 1)
	                  (bv-var z (nat-var p))
	                  (bv-var x (nat-var n))
	                  (bv-const 0 1)
	                  (bv-var y (nat-var m))))
      '(bv-equal (bv-compose (bv-var x (nat-var n))
	                  (bv-const 1 1)
	                  (bv-const 0 1))
              (bv-compose (bv-const 1 1)
                          (bv-const 0 1)
                          (bv-var x (nat-var n)))) 
       '(bv-equal (bv-compose (bv-var x (nat-var n))
	                      (bv-const 0 1)
	                      (bv-var y (nat-var m)))
                  (bv-compose (bv-var z 2)
                  	      (bv-const 1 1)
		              (bv-var w 2)))))

(defun ex-1 () "Unsatisfiable; cf. Example 3.1 in Thesis"
       (start-split-chop (first *split-chop-simple-examples*)))
	       
(defun ex-2 () "Satisfiable, but not valid; cf. Example 5.1 in Thesis"
       (start-split-chop (second *split-chop-simple-examples*)))

(defun ex-3 () "Satisifabe, but not valid; cf. Example 5.2 in Thesis"
       (start-split-chop (third *split-chop-simple-examples*)))