;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)
;;; Competent Professor:  Friedrich W. von Henke
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ------------------------------------------------------------
;;; - Using Conditional Term Rewriting
;;; - Simple algorithm
;;; -        Reduced to chopping rules
;;; - File:    reduced_chopper.cl
;;; - Purpose: implement a non-strategical narrowing algorithm
;;; -          for the core theory of bit-vectors
;;; - Version: Spartanically reduced;
;;; -          fixed size, comp. and extr.;
;;; -          no introduction of fresh variables, just CHUNKS x^(.,.)
;;; -          
;;; - USES: bvec_structure.cl,
;;; -       bvec_arith.cl
;;; ------------------------------------------------------------
;;; - USAGE:
;;; -  (1) Load additional files bvec_structure.cl
;;; -                            bvec_arith.cl
;;; -       [compilation recommended]
;;; -  (2) Start with
;;; -       (start-reduced-chopper
;;; -          '(BV-EQUAL <term-1> <term-2>)
;;; -      If an output to a file is required, use the function
;;; -        start-reduced-chopper-log :NAME <file-name>
;;; -      instead.
;;; -
;;; - NOTE: 
;;: -  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]
;;; -
;;; - Examples are given at the end of this file
;;; ------------------------------------------------------------
;;;
;;; Allegro Common Lisp
;;; Begun:        Dezember, 1st 1997
;;; Last Changes: March, 14th   1998 
;;;
;;; Version: 2.0

(in-package user)

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

;; For Observation

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

(defconstant *observe-level* '(0 1 6))  ;; Usual: 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_arith.cl")
  (load "./reduced_chopper.cl")
  )

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

(defun cc ()
  (compile-file "./bvec_structure.cl")
  (compile-file "./bvec_arith.cl")
  (compile-file "./reduced_chopper.cl")
  (load "./bvec_structure.fasl")
  (load "./bvec_arith.fasl")
  (load "./reduced_chopper.fasl")
  )


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

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

(defconstant *core-solving-rules*
 (list

  ;; --------------------
  ;;  Slicing
  ;; --------------------
  (make-bv-unify-rule
   :NAME "(1) Slice Equal Composition"
   :term1 '(BV-EQUAL
	    (BV-COMPOSE (BV-JOKER 1) (BV-JOKER 2))
	    (BV-COMPOSE (BV-JOKER 3) (BV-JOKER 4)))
   :term2 nil
   :condition-1 '(EQUAL (LEN (SIGMA (BV-JOKER 1)))
		        (LEN (SIGMA (BV-JOKER 3))))
   :condition-2 nil
   :new-eq-list '(LIST
		  (BV-EQUAL (SIGMA (BV-JOKER 1))
		            (SIGMA (BV-JOKER 3)))
		  (BV-EQUAL (SIGMA (BV-JOKER 2))
		            (SIGMA (BV-JOKER 4))))
   :REMOVE 'FIRST)

  (make-bv-unify-rule
   :NAME "(1') Slice Less Composition"
   :term1 '(BV-EQUAL
	    (BV-COMPOSE (BV-JOKER 1) (BV-JOKER 2))
	    (BV-COMPOSE (BV-JOKER 3) (BV-JOKER 4)))
   :term2 nil
   :condition-1 '(not (equal (LEN (SIGMA (BV-JOKER 1)))
		             (LEN (SIGMA (BV-JOKER 3)))))
   :condition-2 nil
   :new-eq-list '(LET ((crit (< (LEN (SIGMA (BV-JOKER 1)))
			        (LEN (SIGMA (BV-JOKER 3)))))
		       (p (IF crit (SIGMA (BV-JOKER 1))
			           (SIGMA (BV-JOKER 3))))
		       (q (IF crit (SIGMA (BV-JOKER 3))
			           (SIGMA (BV-JOKER 1))))
		       (n (LEN p))
		       (m (LEN q))
		       (t (IF crit (SIGMA (BV-JOKER 2))
			           (SIGMA (BV-JOKER 4))))
		       (u (IF crit (SIGMA (BV-JOKER 4))
			           (SIGMA (BV-JOKER 2)))))
		  (LIST
		   (BV-EQUAL p
		    (ALPHA (MAKE-BV-EXTRACTION
			    q (1- m) (- m n))))
		   (BV-EQUAL (BV-COMPOSE
			      (ALPHA (MAKE-BV-EXTRACTION
				      q (- m n 1) 0))
			      u)
		             t)
		   (BV-EQUAL q (BV-COMPOSE
				(ALPHA
				 (MAKE-BV-EXTRACTION
				  q (- m 1) (- m n)))
				(ALPHA
				 (MAKE-BV-EXTRACTION
				  q (- m n 1) 0))))))
   :REMOVE 'FIRST)
  
  
  (make-bv-unify-rule
   :NAME "(1'') Slice Less (than atomic) Composition"
   :term1 '(BV-EQUAL
	    (BV-COMPOSE (BV-JOKER 1) (BV-JOKER 2))
	    (BV-JOKER 3))
   :term2 nil
   :condition-1 '(IS-ATOMIC? (SIGMA (BV-JOKER 3)))
   :condition-2 nil
   :new-eq-list '(LET ((p (SIGMA (BV-JOKER 1)))
		       (q (SIGMA (BV-JOKER 3)))
		       (n (LEN p))
		       (m (LEN q)))
		  (LIST
		   (BV-EQUAL p
		    (ALPHA (MAKE-BV-EXTRACTION
			    q (1- m) (- m n))))
		   (BV-EQUAL (ALPHA (MAKE-BV-EXTRACTION
				     q (- m n 1) 0))
		             (SIGMA (BV-JOKER 2)))
		   (BV-EQUAL q (BV-COMPOSE
				(ALPHA
				 (MAKE-BV-EXTRACTION
				  q (- m 1) (- m n)))
				(ALPHA
				 (MAKE-BV-EXTRACTION
				  q (- m n 1) 0))))))
   :REMOVE 'FIRST)
  
  (make-bv-unify-rule
   :NAME "(1''') Slice Less (than atomic) Composition"
   :term1 '(BV-EQUAL
	    (BV-JOKER 3)
	    (BV-COMPOSE (BV-JOKER 1) (BV-JOKER 2)))
   :term2 nil
   :condition-1 '(AND (IS-ATOMIC? (SIGMA (BV-JOKER 3)))
		      (NOT (IS-CS-RULE? (BV-EQUAL (SIGMA (BV-JOKER 3))
					 (ALPHA
					  (BV-COMPOSE (SIGMA (BV-JOKER 1))
						      (SIGMA (BV-JOKER 2))))))))
   :condition-2 nil
   :new-eq-list '(LET ((p (SIGMA (BV-JOKER 1)))
		       (q (SIGMA (BV-JOKER 3)))
		       (n (LEN p))
		       (m (LEN q)))
		  (LIST
		   (BV-EQUAL p
		    (ALPHA (MAKE-BV-EXTRACTION
			    q (1- m) (- m n))))
		   (BV-EQUAL (ALPHA (MAKE-BV-EXTRACTION
				     q (- m n 1) 0))
		             (SIGMA (BV-JOKER 2)))
		   (BV-EQUAL q (BV-COMPOSE
				(ALPHA
				 (MAKE-BV-EXTRACTION
				  q (- m 1) (- m n)))
				(ALPHA
				 (MAKE-BV-EXTRACTION
				  q (- m n 1) 0))))))
   :REMOVE 'FIRST)
 
  (make-bv-unify-rule
   :name "(8) 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 "(2) 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)

  ;; --------------------
  ;;  Equal lhs
  ;; --------------------  
  (make-bv-unify-rule
   :NAME "(7) Atomar LHS 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 "(4) CS 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 "(5) 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 "(6) 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)
 
 ))

(defconstant *n-core-solving-rules* (length *core-solving-rules*))
			      
(defun start-reduced-chopper
    (&optional (examples *reduced-chopper-simple-examples*)
     &key      (stream nil)
	       (break nil)
	       (start-time #'start-time)
	       (stop-time  #'stop-time  )  ) "Test ctr 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) month day year) stream))
     (ifuncall start-time)
     
     (loop for e in examples do
	   (if break (break))
	   (setf *number-of-ctr-hits* 0)
	   (start-time-1)
	   (let* ((t1 (canonize-core-bv (cadr e)))
		  (t2 (canonize-core-bv (caddr e)))
		  (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)))
		  (dummy (stop-time-1))
		  (assumptions (if (equal len1 len2)
				   nil
				 (list (make-nat-equal len1 len2))))
		  (res (solve-via-reduced-chopper eq-list
						  :STREAM stream
						  :ASSUMPTIONS assumptions
						  :START-TIME nil
						  :STOP-TIME #'stop-time)))
	     (declare (ignore dummy))
	     (princ (format nil "     ===>   ~a~%"
			    (cond
			     ((null res)
			      "*TAUTOLOGY*")
			     ((atom res)
			      "*UNSATISFIABLE*")
			     (t (CLOS::string-append (princ-to-string (length res))
						     " Equations"))))
		    stream)
	     
	     (princ (format nil "----------------------------------------~%") stream)
	     (princ (format nil "Term Width       : ~3d~%" len1) stream)
	     (princ (format nil "#Atomic Terms    : ~3d~%" (+ nterms1 nterms2)) 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) month day year) stream))
     'done))
   

(defun start-reduced-chopper-log
    (&optional (examples *reduced-chopper-simple-examples*)
     &key (name "reduced-chopper-log.txt"))
  (with-open-file (stream name
		   :direction :output
		   :if-does-not-exist :create
		   :if-exists :supersede)
    (start-reduced-chopper examples :stream stream)))
		      

;;; ****************************************
;;;  Pre-Processing   [computing init-CS]
;;; ****************************************

(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 (slice-bv-via-vec v vec)))))
	 (res nil))
    ;; -- Add Slices for Chunks 
    (loop for ex in extr do
	  (let ((new-extr (core-alpha
			   (make-bv-extraction
			    (cdr (assoc (bv-extraction-bv ex) var-slice :TEST #'equal))
			    (bv-extraction-left ex)
			    (bv-extraction-right ex)))))
	    (unless (equal new-extr ex)
	      (pushnew (make-bv-equation ex new-extr)
		       res
		       :TEST #'equal))))
    ;; -- Add slices for variables    
    (loop for v in vars do
	  (let ((new-extr (cdr (assoc v var-slice :TEST #'equal))))
	    (unless (equal new-extr v)
	      (push
	       (make-bv-equation v new-extr)
	       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))
    (core-alpha
     (make-bv-composition-from-list res))))



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

(defun solve-via-reduced-chopper (eq-list &key (stream nil) (assumptions nil) (start-time nil) (stop-time nil))
  (obs0 (progn
	  (princ (format nil "~%**** Entering new Solving Frame ****~%") stream)
	  (create-output-from-list (mapcar #'bv-term-to-ascii eq-list) :stream stream :first-word "Equations: ")
	  (create-output-from-list (mapcar #'bv-term-to-ascii assumptions) :stream stream :first-word "Assumtions: ")))
  (if start-time (funcall start-time))
  (let* ((ovars (remove-duplicates
		 (loop for e in eq-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)
	 (local-binding nil)
	 (equation-list eq-list)
	 (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)
	     (core-alpha x))
      (len   (x)
	      (bv-length 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))
      (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)))
	      (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))
	      (REPLACE-IN-SUBTERM
	       (replace-in-subterm (local-eval (cadr x))
				   (local-eval (caddr x))
				   (local-eval (cadddr x))))
	      (+  (apply #'+ (mapcar #'local-eval (cdr x))))
	      (-  (apply #'- (mapcar #'local-eval (cdr x))))
	      (1- (1- (local-eval (cadr x))))
	      (1+ (1+ (local-eval (cadr x))))
	      (MIN (apply #'min (mapcar #'local-eval (cdr x))))
	      (MAX (apply #'max (mapcar #'local-eval (cdr x))))
	      (<   (< (local-eval (cadr x))
		      (local-eval (caddr x))))
	      (<=  (<= (local-eval (cadr x))
		       (local-eval (caddr x))))
	      (MOD (MOD (local-eval (cadr x))
			(local-eval (caddr x))))
	      (DIV (DIV (local-eval (cadr x))
			(local-eval (caddr x))))
	      (COMPOSE-K-TIMES (let ((arg (local-eval (caddr x))))
				 (make-bv-composition-from-list
				  (loop for i from 1 to (local-eval (cadr x)) collect arg))))
	      (ALPHA (alpha (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-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) (core-beta (caddr arg))))))
		 (obs8 (princ (format nil "!?! IS-CS-RULE ~a~%    -> ~a~%" arg res) stream))
		 res))
	      (LEN (len (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)))
	      
	      (t (error-misc "local-eval" x "not caught.")))
	  
	  (let ((find (assoc x local-binding :TEST #'equal)))
	    (if find
		(cdr find)
	      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-core-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-core-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-core-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 *core-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))
			       ;; --------------------
			       ))
			   ;; --------------------
			   ))
			 (setf rule-n (car ord)
			       ord    (cdr ord))
			 ) ;; loop end
		       ;; --------------------
	       res	       
      )))
      )

     (loop while (and (listp equation-list) (match)) do (incf *number-of-ctr-hits*))
     (if stop-time (funcall stop-time))
     (obs0
      (create-output-from-list (bv-term-list-to-ascii equation-list)
			       :STREAM stream
			       :FIRST-WORD "Result: "))
     equation-list
      )))
     
     
;;; ****************************************
;;;  AUX Functions (Core Theory)
;;; ****************************************

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

(defun core-alpha (x)
;;; Canonize Terms in the core theory
  (cond
   ((rec-bv-var? x) 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 (+ 1 (- left right))))
      (cond
       ((= len times) (core-alpha arg))
       ((rec-bv-var? arg) x)
       ((rec-bv-extraction? arg)
	(let ((arg2 (bv-extraction-bv arg))
	      (rr (bv-extraction-right arg)))
	  (core-alpha (make-bv-extraction arg2 (+ left rr) (+ right rr)))))
       ((rec-bv-composition? arg)
	(let* ((argl (bv-decompose-left arg))
	       (argr (bv-decompose-right arg))
	       (lr   (bv-length argr)))
	  (cond ((< left lr)
		 (core-alpha (make-bv-extraction argr left right)))
		((>= right lr)
		 (core-alpha (make-bv-extraction argl (- left lr) (- right lr))))
		(t
		 (make-bv-composition
		  (core-alpha (make-bv-extraction argl (- left lr) 0))
		  (core-alpha (make-bv-extraction argr (- lr 1) right)))))))
       ((rec-bv-const? arg)
	(extract-bv-const (bv-const-value arg) left right))
       (t (error-misc "core-alpha" x " (extraction) not caught")))))
   ((rec-bv-composition? x)
    (make-bv-composition
     (core-alpha (bv-decompose-left x))
     (core-alpha (bv-decompose-right x))))
   (t (error-misc "core-alpha" x "not caught."))))

(defun core-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)
			      (core-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))

;;; ****************************************
;;;  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-core-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))
  (ifassert (consp term))
  (cond
   ((rec-joker? rule)
    (acons rule term nil)) 
   ((eq (car rule)
	(car term))
    (case (car rule)
      (BV-EQUAL
       (let ((uni1 (rule-core-term-unify (cadr rule) (cadr term)))
	     (uni2 (rule-core-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-core-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-core-term-unify
		    (bv-decompose-left rule)
		    (bv-decompose-left term)))
	     (uni2 (rule-core-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))


;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;; ************************************************************
;;;  Display Lace [TAKEN FROM bvec_experiments.cl]
;;; ************************************************************

(defun bv-term-to-ascii (term &key (ulm-notation nil))
  ;;; Also processes natural variables
  (flet ((make-string-from-op-list (op list)
	   (eval `(CLOS::string-append
		   "( "
		   ,@(loop for e in (butlast list) append
			   (list (bv-term-to-ascii e)
				 op))
		   ,(bv-term-to-ascii (car (last list)))
		   " )"))))
    (cond
     ((arrayp term) ;; Slicing Vector!
      (eval `(CLOS::string-append "["
				  ,@(loop for i in (reverse (slicing-to-chop-list term)) collect
					  (princ-to-string
					   (format nil " ~d" i)))
				  " ]")))
     ((atom term) (princ-to-string term))
   ;;; ---
   ;;;  Nat section
   ;;; ---
     ((rec-nat-var? term)
      (princ-to-string (nat-var-name term)))
     ((rec-addition? term)
      (make-string-from-op-list " + " (cdr term)))
     ((rec-subtraction? term)
      (make-string-from-op-list " - " (cdr term)))
     ((rec-multiplication? term)
      (CLOS::string-append
       (bv-term-to-ascii (cadr term))
       " * "
       (bv-term-to-ascii (caddr term))))
     ((rec-nat-max? term)
      (CLOS::string-append
       "MAX"
       (make-string-from-op-list " " (cdr term))))
     ((rec-nat-min? term)
      (CLOS::string-append
       "MIN"
       (make-string-from-op-list " " (cdr term))))
     ((rec-nat-between? term)
      (CLOS::string-append
       (bv-term-to-ascii (cadr term))
       " in { "
       (bv-term-to-ascii (caddr term))
       " , ... , "
       (bv-term-to-ascii (cadddr term))
       " }"))   
     
     ((rec-nat-leq? term)
      (CLOS::string-append
       (bv-term-to-ascii (cadr term))
       " <= "
       (bv-term-to-ascii (caddr term))))
     ((rec-nat-equation? term)
      (CLOS::string-append
       (bv-term-to-ascii (cadr term))
       "  =[Nat] "
       (bv-term-to-ascii (caddr term))))
   ;;; ---
     
     ((rec-cs-info? term)
      (CLOS::string-append "CS: "
			   (bv-term-to-ascii (cadr term))
			   " -> "
			   (bv-term-to-ascii (caddr term))))
     ((and (consp term)
	   (eq (car term) 'BV-EQUAL))
      (CLOS::string-append (bv-term-to-ascii (cadr term))
			   "  =[bv]  "
			   (bv-term-to-ascii (caddr term))))
     ((rec-bv-const? term)
      (princ-to-string
       (format nil "~a{~a}" (bv-const-value term)
	       (bv-const-length term))))
     ((rec-bv-var? term)
      (princ-to-string
       (format nil "~a{~a}" (bv-var-name term) (bv-var-length term))))
     ((rec-bv-composition? term)
      (let ((con (bv-composition-content term)))
	(eval `(CLOS::string-append
		"( "
		,@(loop for i in (butlast con) append
			`(,(bv-term-to-ascii i) " o "))
		,(bv-term-to-ascii (car (last con)))
		" )"))))
     ((rec-bv-extraction? term)
      (if ulm-notation
	  (CLOS::string-append
	   "( "
	   (bv-term-to-ascii (bv-extraction-bv term))
	   ")^("
	   (bv-term-to-ascii (bv-extraction-left term))
	   ","
	   (bv-term-to-ascii (bv-extraction-right term))
	   ")")
	(CLOS::string-append
	 "( "
	 (bv-term-to-ascii (bv-extraction-bv term))
	 ")["
	 (bv-term-to-ascii (bv-extraction-right term))
	 ":"
	 (bv-term-to-ascii (bv-extraction-left term))
	 "]")))
     ((rec-bv-addition? term)
      (let ((width (bv-addition-modulo term))
	    (args (bv-addition-args term)))
	(eval `(CLOS::string-append
		"( "
		,@(loop for i in (butlast args) append
			`(,(bv-term-to-ascii i)
			  ,(princ-to-string (format nil " +[~d] " width))))
		,(bv-term-to-ascii (car (last args)))
		" )"))))
     ((rec-bv-bool? term)
      (case (bv-recognizer term)
	(bv-not (CLOS::string-append
		 "~( "
		 (bv-term-to-ascii (car (bv-bool-args term)))
		 " )"))
	(bv-and (CLOS::string-append
		 "( "
		 (bv-term-to-ascii (car (bv-bool-args term)))
		 " AND "
		 (bv-term-to-ascii (cadr (bv-bool-args term)))
		 " )"))
	(bv-or  (CLOS::string-append
		 "( "
		 (bv-term-to-ascii (car (bv-bool-args term)))
		 " OR "
		 (bv-term-to-ascii (cadr (bv-bool-args term)))
		 " )"))
	(bv-xor  (CLOS::string-append
		  "( "
		  (bv-term-to-ascii (car (bv-bool-args term)))
		  " XOR "
		  (bv-term-to-ascii (cadr (bv-bool-args term)))
		  " )"))
	(t (error-misc "bv-term-to-ascii [bool]" term "not caught."))))      
     (t (error-misc "bv-term-to-ascii" term "not caught.")))))


(defun bv-term-list-to-ascii (list)
  (if (listp list)
      (mapcar #'bv-term-to-ascii list)
    list))
		 
(defun create-output-from-list (list &key (stream nil) (first-word ""))
  (let ((offset (make-string (length first-word) :initial-element #\Space)))
    (princ (format nil "~a" first-word) stream)
    (cond
     ((null list)
      (princ (format nil "-~%") stream))
     ((atom list)
      (princ (format nil "~a~%" (princ-to-string list)) stream))
     (t	(loop for e in (butlast list) do
	      (princ (format nil "~a~%~a" e offset) stream))
	(princ (format nil "~a~%" (car (last list))) stream)))))


;;; TIME


(defvar *marked-time* 0)
(defvar *stopped-time* 0)
(defvar *marked-time-1* 0)
(defvar *stopped-time-1* 0)
(defvar *marked-time-2* 0)
(defvar *stopped-time-2* 0)
    

(defun start-time ()
  (setf *marked-time* (get-internal-real-time)))

(defun stop-time ()
  ;; result in seconds
  (setf *stopped-time*
    (float (/ (- (get-internal-real-time) *marked-time*)
	      1000))))

(defun clear-time ()
  (setf *stopped-time* 0.0))

;;; --

(defun start-time-1 ()
  (setf *marked-time-1* (get-internal-real-time)))

(defun stop-time-1 ()
  ;; result in seconds
  (setf *stopped-time-1*
    (float (/ (- (get-internal-real-time) *marked-time-1*)
	      1000))))

(defun clear-time-1 ()
  (setf *stopped-time-1* 0.0))

;;; --
(defun start-time-2 ()
  (setf *marked-time-2* (get-internal-real-time)))

(defun stop-time-2 ()
  ;; result in seconds
  (setf *stopped-time-2*
    (float (/ (- (get-internal-real-time) *marked-time-2*)
	      1000))))

(defun clear-time-2 ()
  (setf *stopped-time-2* 0.0))


;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

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

(defconstant *reduced-chopper-simple-examples*
    (list '(bv-equal
	    (bv-compose (bv-var x 64) (bv-var y 64))
	    (bv-compose (bv-var x 64) (bv-var y 64)))
	  '(bv-equal
	    (bv-compose (bv-var x 64) (bv-var x 64))
	    (bv-compose (bv-const 0 64) (bv-const 1 64)))
	  '(bv-equal
	    (bv-compose (bv-const 0 2) (bv-var x 6))
	    (bv-compose (bv-var x 6) (bv-const 0 2)))))	  

(defun ex-1 () "Tautology, cf. A3 [at width 128] in Thesis"
  (start-reduced-chopper (first *reduced-chopper-simple-examples*)))

(defun ex-2 () "Unsatisfiable, cf. B1 [at width 128] in Thesis"
  (start-reduced-chopper (second *reduced-chopper-simple-examples*)))

(defun ex-3 () "Satisfiable, but not valid, cf. C3 [at width 8] in Thesis"
  (start-reduced-chopper (third *reduced-chopper-simple-examples*)))
