;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ------------------------------------------------------------
;;; -              SOLVER FOR BITVECTOR-THEORY                 -
;;; -              ~~~~~~~~~~~~~~~~~~~~~~~~~~~                 -
;;; - WITH  +variable size                                     -
;;; -       +variable extraction                               -
;;; -       +composition                                       -
;;; -       +boolean operations                                -
;;; ------------------------------------------------------------
;;; -      Oliver M"oller (moeller@ki.informatik.uni-ulm.de)   -
;;; ------------------------------------------------------------
;;; - File:     bvec_structure.cl                              -
;;; - Purpose:  Constructor, Destructor, Recognizer            -
;;; -           of <bvec_term> and subclasses                  -
;;; - USES:     -                                              -
;;; ------------------------------------------------------------
;;;
;;; Allegro Common Lisp
;;; Begun:         October, 12th 1997
;;; Last Changes:  March, 16th    1998
;;; Version 2.0

(in-package user)

(defconstant *ifsafe* nil) ;;; Process Assertions and safety-requests?

(defmacro ifassert (body)
  (if *ifsafe* `(assert ,body)))

(if *ifsafe*
    (proclaim '(optimize (speed 1) (safety 3) (space 0) (debug 3)))
  (proclaim '(optimize (speed 3) (safety 1) (space 0) (debug 0))))


;;; BOOLEAN SECTION
(defconstant *true_bit* 'TRUE)
(defconstant *false_bit* 'FALSE)
(defconstant *bvec_value_range* `(,*true_bit* ,*false_bit*))

(defconstant *bvec_bool_mops*      '(BV-NOT))
(defconstant *bvec_bool_binops*    '(BV-AND BV-OR BV-XOR  BV-EQUIV))
(defconstant *bvec_bool_ternops*   '() ) ;;BV-ITE))
(defconstant *bvec_bool_ops*
    (append *bvec_bool_mops*
	    *bvec_bool_binops*
	    *bvec_bool_ternops*))


(defconstant *inf* EXCL::*INFINITY-DOUBLE*)

(defconstant   *bvec_recognizers*
  '(BV-COMPOSE
    BV-EXTRACT
    BV-VAR
    BV-CONST
    ;; BV-FILL
    BV-AND
    BV-OR
    BV-NOT
    BV-XOR
    BV-ITE
    BV-EQUIV
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)
;;;
;;;  "composition" is a synonym to concatenation
;;;
;;; ----------------------------------------------------------------------
;;; - Access to the data-structures
;;; ----------------------------------------------------------------------
;;;
;;; <bvec>               ::= <bv-var>|<bv-const>|<composition>|<extraction>
;;; <bv-var>             ::= '('BV-VAR <var_name> <nat> ')'
;;; <composition>        ::= '('BV-COMPOSE <bvec> {<bvec>}+ ')'
;;; <extraction>         ::= '('BV-EXTRACT <bvec> '(' <nat> <nat> ')'
;;;
;;; <bv-const>           ::= '('BV-CONST <fixed-nat>       <fixed-nat> ')'
;;;                                      Meaning the VALUE 
;;; 
;;; <bv-bdd>             ::= #NODE
;;; ----------------------------------------------------------------------
;;;
;;; <nat>                ::= <nat-var>|<fixed-nat>
;;; <nat-var>            ::= '('nat-var <var-name>')'
;;; <fixed-nat>          ::= {0,1,2,3, ...}
;;; <fixed-int>          ::= {... -2,-1,0,1,2, ...}
;;; <posnat>             ::= <nat-var>|<fixed-nat>
;;; <fixed-posnat>       ::= {  1,2,3, ...}
;;; 
;;; <fixed-bvec>         ::= <bv-fixed-var>|<bv-const>|<fixed-composition>|<fixed-extraction>
;;; <bv-fixed-var>       ::= '('BV-VAR <var_name> <fixed-nat> ')'
;;; <fixed-composition>  ::= '('BV-COMPOSE <fixed-bvec> {<fixed-bvec>}+ ')'
;;; <fixed-extraction>   ::= '('BV-EXTRACT <fixed-bvec> 
;;;                              '(TUPCONS' <fixed-nat> <fixed-nat> '))'
;;;
;;; ----------------------------------------------------------------------
;;;
;;;		      CONSTRUCTORS                   DESTRUCTORS	
;;; - <bv-var>         make-fresh-bv-var              bv-var-length
;;;                    make-bv-var                    bv-var-name
;;;                                          
;;; - <extraction>     make-bv-extraction             bv-extraction-length
;;;                                                   bv-extraction-bv
;;;                                                   bv-extraction-left
;;;                                                   bv-extraction-right
;;;				
;;; - <composition>    make-bv-composition            bv-decompose-left
;;;                    make-bv-composition-from-list  bv-decompose-right
;;;                                                   bv-composition-content
;;;
;;; - <bv-const>       make-bv-const                  bv-const-length
;;;                    append-bv-const                bv-const-value
;;;                    extract-bv-const
;;;
;;; - <bv-obdds>       (make-node)
;;;		       [see bvec_bdd_solve.cl]
;;;                    NOTE: BDD is a synonym to OBDD
;;;                          (Ordered Binary Decision Diagram)
;;; ----------------------------------------------------------------------
;;;
;;; - <bvec-fixed> :   SUBCLASS of <bvec>
;;;
;;; - <bv-equation>         make-bv-equal
;;; - <nat-equation>        make-nat-equal
;;; - <nat-leq>             make-nat-leq
;;; - <nat-less>            make-nat-less
;;;
;;; The theory also contains the empty bit-vector BV-EPSILON : bvec[0]
;;;  due to structural reasons.
;;; This is not consitent with the concept in the diploma thesis but
;;;  turned out to make canonization of variable width much simpler.
;;;------------------------------------------------------------------------


;;; -------------------------------------------------------------
;;;   Checking of (Sub-)types
;;; -------------------------------------------------------------

(defun is-bv? (l) 
  (or   (is-bv-epsilon? l)
        (is-bv-var? l)
	(is-bv-const? l)
        (is-bv-extraction? l)
        (is-bv-composition? l)
	(is-bdd? l)
	))

(defun is-bv-var? (var) 
  (and (consp var)
       (=  (length var) 3)
       (eq (car var) 'BV-VAR)
       (is-nat? (caddr var))))

(defun is-bv-const? (l)
  (and (consp l)
       (eq (length l) 3)
       (eq (car l) 'bv-const)
       (is-fixed-nat? (cadr l))
       (is-fixed-posnat? (caddr l))))
       
(defun is-bv-extraction? (l)
  (and (consp l)
       (=  (length l) 3)
       (eq (car l) 'BV-EXTRACT)   
       (consp (caddr l))
       (= (length (caddr l)) 3)
       (is-bv? (cadr l))
       (eq (caaddr l) 'TUPCONS)
       (is-nat? (cadr (caddr l)))
       (is-nat? (caddr (caddr l)))))

(defun is-bv-composition? (l) 
   (and (consp l)
        (> (length l) 2)
	(equal (car l) 'BV-COMPOSE)
	(every #'is-bv? (cdr l))))

(defun is-nat? (l)
  (or (is-nat-var? l)
      (is-fixed-nat? l)))


(defun is-nat-var? (l)
  (and (consp l)
       (= (length l) 2)
       (eq (car l) 'NAT-VAR)))

(defun is-fixed-nat? (l)
  (and (integerp l)
   (>= l 0)))

(defun is-fixed-int? (l)
  (or
   (integerp l)
   (eq l *inf*)
   (eq l (- 0 *inf*))))

(defmacro rec-fixed-int? (l)
  `(integerp ,l))


(defun is-fixed-posnat? (l)
  (and (integerp l)
       (> l 0)))

;;; ------------------------------------------------------------
;;;  Recognizing Types
;;; ------------------------------------------------------------

(defmacro rec-bv? (bv)
  `(or (rec-bv-epsilon? ,bv)
       (rec-bv-var? ,bv)
       (rec-bv-const? ,bv)
       (rec-bv-extraction? ,bv)
       (rec-bv-composition? ,bv)
       (rec-bdd? ,bv)))

(defmacro rec-bv-var? (bv)
  `(and (consp ,bv)
        (eq (car ,bv) 'BV-VAR)))

(defmacro rec-bv-const? (bv)
  `(and (consp ,bv)
	(eq (car ,bv) 'BV-CONST)))

(defmacro rec-bv-composition? (bv)
  `(and (consp ,bv)
        (eq (car ,bv) 'BV-COMPOSE)))

(defmacro rec-bv-extraction? (bv)
  `(and (consp ,bv)
        (eq (car ,bv) 'BV-EXTRACT)))

(defmacro rec-bv-addition? (bv)
  `(and (consp ,bv)
	(eq (car ,bv) 'bv-addition)))

;; ---

(defmacro rec-nat? (l)
  `(or (rec-fixed-nat? ,l)
       (rec-nat-var? ,l)))

(defmacro rec-nat-var? (l)
  `(and (consp ,l)
	(= (length ,l) 2)
	(eq (car ,l) 'NAT-VAR)))

(defmacro rec-fixed-nat? (l)
  `(and (integerp ,l)
	(>= ,l 0)))

(defmacro rec-fixed-posnat? (l)
  `(and (integerp ,l)
	(> ,l 0)))

(defmacro rec-nat-term? (l)
  `(or (rec-fixed-nat? ,l)
       (and (consp ,l)
	    (member (car ,l) '(+ - * MOD DIV expt2 nat-var)))))

(defmacro rec-bv-bool? (l)
  `(or  (node-p ,l)
	(and (consp ,l)
	     (member (car ,l) *bvec_bool_ops*))))

(defmacro rec-bv-bool-apply? (l)
  `(and (consp ,l)
	(member (car ,l) *bvec_bool_ops*)))

(defmacro rec-bv-negation? (l)
  `(and (consp ,l)
	(eq (car ,l) 'bv-not)))

;;; Special: Constructs where the (natural) vars underneath cannot be
;;; extracted

(defun rec-var-hiding-construct? (l)
  (or (rec-expt2? l)
      (rec-div? l)
      (rec-mod? l)))

(defmacro make-cs-info (x sl)
  ``(CS-INFO ,,x ,,sl))

(defmacro rec-cs-info? (x)
  `(and (consp ,x)
	(eq (car ,x) 'CS-INFO)))

(defun is-cs-info? (x)
  (and (consp x)
       (eq (car x) 'CS-INFO)))


;;; ****************************************
;;;  SubClass: fixed-bv
;;;  Contains only bv-variables of fixed width
;;;           and  extractions  of fixed size
;;; ****************************************

(defun is-fixed-bv-equation? (eq)
  (and (consp eq)
       (eq (car eq) 'BV-EQUAL)
       (is-fixed-bv? (second eq))
       (is-fixed-bv? (third eq))))

(defun is-fixed-bv? (bv)
  (or  (is-fixed-bv-var? bv)
       (is-bv-const? bv)
       (is-fixed-bv-extraction? bv)
       (is-fixed-bv-boolop? bv)
       (is-fixed-bv-composition? bv)))

(defun is-fixed-bv-var? (var) 
  (and (consp var)
       (=  (length var) 3)
       (eq (car var) 'BV-VAR)
       (is-fixed-posnat? (caddr var))))

(defun is-fixed-bv-extraction? (l)
  (and (consp l)
       (=  (length l) 3)
       (eq (car l) 'BV-EXTRACT)
       (is-fixed-bv? (cadr l))
       (consp (caddr l))
       (= (length (caddr l)) 3)
       (eq (caaddr l) 'TUPCONS)
       (is-fixed-nat? (bv-extraction-left l))
       (is-fixed-nat? (bv-extraction-right l))
       (< (bv-extraction-left l) (bv-length (cadr l)))
       (<= (bv-extraction-right l) (bv-extraction-left l))))   

(defun is-fixed-bv-composition? (l) 
  (and (consp l)
       (> (length l) 2)
       (equal (car l) 'BV-COMPOSE)
       (every #'is-fixed-bv? (cdr l))))

(defun is-fixed-bv-boolop? (l)
  (or (and (node-p l)
           (every #'is-fixed-bv? (all-bdd-nodes l)))
      (and (consp l)
	   (or (and (= (length (cdr l)) 1)
		    (member (car l) *bvec_bool_mops*))
	       (and (= (length (cdr l)) 2)
		    (member (car l) *bvec_bool_binops*))
	       (and (= (length (cdr l)) 3)
		    (member (car l) *bvec_bool_ternops*)))
	   (every #'is-fixed-bv? (cdr l)))))

;;; ----------------------------------------------------------------------
;;;  Constructors
;;; ----------------------------------------------------------------------

(defun make-bv-var (name len)
  (ifassert (or (not (stringp name))
	      (not (string= (EXCL::substring-simple name 0 6)
			    "FRESH_"))))
  `(BV-VAR ,name ,len))

(defun make-bv-const (val len)
  `(BV-CONST ,val ,len))

(defun append-bv-const (c1 c2)
  `(BV-CONST ,(+ (bv-const-value c2)
	         (* (bv-const-value c1) (expt 2 (bv-const-length c2))))
	     ,(+ (bv-const-length c1)
		 (bv-const-length c2))))

(defun extract-bv-const (value left right)
  `(BV-CONST ,(mod (div value (expt 2 right))
		   (expt 2 (1+ (- left right))))
	     ,(1+ (- left right))))

(defun flatten-bv-constants (bv)
  ;; Turn constants into >> fills <<
  (let ((cont (bv-flat-term-content bv)))
    (make-bv-composition-from-list
     (loop for b in cont append
	   (cond
	    ((rec-bv-var? b) (list b))
	    ((rec-bv-const? b)
	     (bv-flat-term-content
	      (flatten-bv-const b)))
	    ((rec-bv-extraction? b) (list b))
	    ((rec-bv-bool? b)  (list b))
	    (t (error-misc "flatten-bv" bv "hit unexpected structure.")))))))
     

(defun flatten-bv-const (const)
  (ifassert (rec-bv-const? const))
  ;; turn into a composition of terms containing only 0s or 1s
  (let* ((bools (nat2bools (bv-const-value const) (bv-const-length const)))
	 (chunks nil)
	 (now (car bools))
	 (width 1))
    (loop for b in (append (cdr bools) '(stop)) do
	  (if (eq now b)
	      (incf width)
	    (progn
	      (push (make-bv-const (if now (1- (expt 2 width)) 0) width)
		    chunks)
	      (setf width 1
		    now b))))
    (make-bv-composition-from-list (nreverse chunks))))
  

(defun make-bv-extraction (bv left right)
  `(BV-EXTRACT ,bv (TUPCONS ,left ,right)))


(defun make-bv-composition (bv1 bv2)
  (cond
   ((rec-bv-epsilon? bv1)
    bv2)
   ((rec-bv-epsilon? bv2)
    bv1)
   ((rec-bv-composition? bv1)
    (if (rec-bv-composition? bv2)
	(append bv1 (cdr bv2))
      (append bv1 (list bv2))))
   ((rec-bv-composition? bv2)
    (cons 'BV-COMPOSE (cons bv1 (cdr bv2))))
   (t `(BV-COMPOSE ,bv1 ,bv2))))

(defun make-bv-composition-from-list (l)
  (let ((list (remove-if #'is-bv-epsilon? l)))
    (cond ((null list) 'BV-EPSILON)
	  ((null (cdr list)) (car list))
	  (t `(BV-COMPOSE ,@list)))))
  
;;; Natural Variables

(defun make-nat-var (x)
  `(nat-var ,x))

;;; Boolean Operations

(defmacro make-bv-bool-apply (op args)
  ``(,,op ,,@args))

(defmacro make-bv-and (x y)
  ``(BV-AND ,,x ,,y))

(defmacro make-bv-or (x y)
  ``(BV-OR ,,x ,,y))

(defmacro make-bv-not (x)
  ``(BV-NOT ,,x))

(defmacro make-bv-equal (x y)
  ``(BV-EQUAL ,,x ,,y))

(defmacro make-nat-between (var low up)
  ``(NAT-VAR-BETWEEN ,,var ,,low ,,up))

;;; ----------------------------------------
;;;  Arithmetic Constructors
;;; ----------------------------------------

(defmacro make-bv-addition (modulo &rest args)
  ``(bv-addition ,,modulo ,,@args))

(defun make-bv-addition-from-list (modulo list)
  (cons 'bv-addition
	(cons modulo list))) ;;!!;

(defmacro make-nat-equal (t1 t2)
  ``(NAT-EQUAL ,,t1 ,,t2))

(defmacro make-nat-leq (t1 t2)
  ``(NAT-<= ,,t1 ,,t2))

(defmacro make-nat-leq-from-list (list)
  ``(NAT-<= ,@,list))

(defmacro make-nat-less (t1 t2)
  ``(NAT-< ,,t1 ,,t2))


(defmacro make-nat-less-from-list (list)
  ``(NAT-< ,@,list))

;;; -----------------------
;;; --- Fresh Variables ---
;;; -----------------------

(defvar *bv-fresh-var-counter* 0)

(defun make-fresh-bv-var (len &key (fresh-var-call nil))
  (cond
   ((numberp len)
    (cond
     ((< len 0) (error-misc "make-fresh-bv-var" len "negative size"))
     ((= len 0) 'BV-EPSILON)
     (t (let* ((name (CLOS::string-append
		     "FRESH_"
		     (princ-to-string (incf *bv-fresh-var-counter*))))
	       (var `(BV-VAR ,name ,len)))
	  (ifuncall fresh-var-call var)
	  var))))
   (t (error-misc "make-fresh-bv-var" len "not caught."))))
	      

;;; ----------------------------------------------------------------------
;;;  Destructors
;;; ----------------------------------------------------------------------

(defun bv-length (l)
  ;; Returns a canonized Term;
  ;; if the argument is a fixed bv term, it will return a natural number
   (cond
    ((rec-bv-epsilon? l)  0)
    ((rec-bv-var? l)
     (bv-var-length l))
    ((rec-bv-const? l)
     (bv-const-length l))
    ((rec-bv-extraction? l)
     (canonize-nat-term
      `(+ 1
	  ,(bv-extraction-left l)
	  (* -1 ,(bv-extraction-right l)))))
    ((rec-bv-composition? l)
     (canonize-nat-term
      `(+ ,@(mapcar #'bv-length (bv-composition-content l)))))
    ((rec-bv-bool-apply? l)
     (bv-length (car (bv-bool-args l))))
    ((node-p l)
     (bv-length (node-variable l)))
    ((rec-bv-addition? l)
     (bv-addition-modulo l))
    
    (t (error-misc "bv-length" l "not caught."))))

;;-

(defun bv-var-name (var)
  (cadr var))

(defun bv-var-length (var)
  (caddr var))

(defun nat-var-name (var)
  (cadr var))


(defun bv-const-value (l)
  (cadr l))

(defun bv-const-length (l)
  (caddr l))

(defun bv-extraction-length (l)
  (canonize-nat-term 
   `(+ 1 ,(bv-extraction-left l) (* -1 ,(bv-extraction-right l)))))

(defun bv-extraction-bv (l)
  (cadr l))

(defun bv-extraction-left (l)
  (cadr (caddr l)))

(defun bv-extraction-right (l)
  (caddr (caddr l)))

;-

(defun bv-decompose-left (l)
  (cadr l))
    
(defun bv-decompose-right (l)
  (let* ((rest (cddr l))
	 (len (length rest)))   
  (case len
    (0 'BV-EPSILON)
    (1 (car rest))
    (t `(BV-COMPOSE ,@rest)))))

(defmacro bv-composition-content (l) "List of all bvecs in a composition"
  `(cdr ,l))

(defmacro bv-flat-term-content (l)
  `(if (rec-bv-composition? ,l)
       (bv-composition-content ,l)
     (list ,l)))

(defmacro bv-bool-args (bv)
  `(cdr ,bv))

(defmacro bv-recognizer (bv)
  `(car ,bv))


(defmacro bv-addition-args (bv)
  `(cddr ,bv))

(defmacro bv-addition-modulo (bv)
  `(cadr ,bv))


;;; ****************************************
;;;  Browse Functions
;;; ****************************************

(defun all-vars-in-bv-term-unique (bv)
  (remove-duplicates
   (all-vars-in-bv-term bv)
   :TEST 'equal))

(defun all-vars-in-bv-term (bv)
  (cond
   ((rec-bv-const? bv) nil)
   ((rec-bv-var? bv) `(,bv))
   ((rec-bv-extraction? bv) (all-vars-in-bv-term (bv-extraction-bv bv)))
   ((rec-bv-composition? bv)
    (loop for e in (bv-composition-content bv) append
	  (all-vars-in-bv-term e)))
   ((node-p bv)
    (loop for n in (all-bdd-nodes bv) append
	  (all-vars-in-bv-term n)))
   ((rec-bv-bool-apply? bv)
    (loop for n in (cdr bv) append
	  (all-vars-in-bv-term n)))
   (t (error-misc "all-vars-in-bv-term" bv "not caught."))))
   
;;; ********************
;;;  Dealing Higher-Level Macros
;;; ********************

;;; Iteration

(defmacro rec-bv-var-or-var-extract? (term)
  `(and (consp ,term)
        (or (eq   (car ,term) 'BV-VAR)
	    (and  (eq (car ,term) 'BV-EXTRACT)
		  (eq (car (bv-extraction-bv ,term)) 'BV-VAR)))))

(defmacro make-bv-iteration (times bv)
  ``(BV-ITERATE ,,times ,,bv))

(defmacro bv-iteration-times (bv)
  `(cadr ,bv))

(defmacro bv-iteration-bv (bv)
  `(caddr ,bv))

(defun is-bv-iteration? (bv)
  (and (consp bv)
       (eq (car bv) 'BV-ITERATE)
       (is-nat? (bv-iteration-times bv))
       (is-bv?  (bv-iteration-bv    bv))))

(defun is-bv-epsilon? (bv)
  (eq bv 'BV-EPSILON))

(defun rec-bv-iteration? (bv)
  `(and (consp ,bv)
	(eq (car ,bv) 'BV-ITERATE)))


(defmacro rec-bv-epsilon? (bv)
  `(eq ,bv 'BV-EPSILON))


;;; **************************************************
;;;  Canonizing Natural Terms
;;; **************************************************
;;;
;;; Bring a (linear) term to the form
;;;  <nat> |
;;;  (* <fixed-int> <nat-var>) |
;;;  (+ <(<nat> | (* <fixed-nat> <nat-var>) )+2 )
;;;
;;; 
;;; The Cardinal Variables are assumed to appear in a order given by 
;;;  nat-var-<
;;;
;;; The Canonizer assumes that any argument is canonized as well.

(defun canonize-nat-term (term)
  ;; recursively (!)
  (cond
   ((is-fixed-int? term) term)
   ((numberp term) term)
   (t 
      (let ((op  (if (consp term) (car term)))
	    (arg (if (consp term) (cdr term))))
     (cond
      ((is-fixed-int? term) term)
      ((rec-nat-var? term) term)
      ((eq op '*) (canonize-multiplication term))
      ((eq op '+) (canonize-addition term))
      ((eq op '-) (canonize-subtraction term))
      ((eq op 'expt2) (canonize-expt2-term term))
      ((eq op '/) (canonize-division-term term))
      ;; special constructs
      ((eq op 'NAT-VAR-BETWEEN)
       (make-nat-between (car arg)
			 (canonize-nat-term (cadr arg))
			 (canonize-nat-term (caddr arg))))
      ((eq op 'NAT-MAX)
       (symbolic-max (mapcar #'canonize-nat-term arg)))
      ((eq op 'NAT-MIN)
       (symbolic-min (mapcar #'canonize-nat-term arg)))
      ((eq op 'CS-LIST)
       (make-cs-list (mapcar #'canonize-nat-term arg)))

      (t (error-misc "canonize-nat-term" term "not caught.")))))))

(defun canonize-nat-equation (eq)
  (ifassert (rec-nat-equation? eq))
  (make-nat-equal
   0
   (canonize-nat-term 
    `(- ,(cadr eq) ,(caddr eq)))))

(defun canonize-nat-leq (leq)
  (ifassert (rec-nat-leq? leq))
  (let* ((less (canonize-nat-term (cadr leq)))
	 (more (canonize-nat-term (caddr leq)))
	 (new-more (canonize-subtraction `(- ,more ,less)))
	 (new-less 0))
    (if  (and (rec-addition? new-more)
	      (rec-fixed-int? (cadr new-more)))
	(setf new-less (- 0 (cadr new-more))
	      new-more (let ((nn (cddr new-more)))
			 (if (= (length nn) 1)
			     (car nn)
			   (cons '+ nn)))))
    `(NAT-<= ,new-less ,new-more)))


(defun canonize-multiplication (term)
  (let ((fac1 (cadr term))
	(fac2 (canonize-nat-term (caddr term))))
    (ifassert (numberp fac1))
  (cond
   ((rec-fixed-int? fac2) (* fac1 fac2))
   ((= 0 fac1) 0)
   ((= 1 fac1) fac2)
   ((and (consp fac2)
	 (eq (car fac2) '*))
    `(* ,(* fac1 (cadr fac2))
	 ,(caddr fac2)))
   ((and (consp fac2)
	 (eq (car fac2) '+)
	  (canonize-addition
	   `(+ ,@(mapcar #'(lambda (x) `(* ,fac1 ,x)) (cdr fac2))))))
   (t `(* ,fac1 ,fac2)))))

(defun canonize-addition (term)
  (let* ((cterm `(+ ,@(mapcar #'canonize-nat-term (cdr term))))
	 (var-occ (mapcar #'(lambda (x) `(,x . 0))
			    (sort (all-visible-vars-in-nat-term cterm) #'nat-var-<)))
	 (other-occ (mapcar #'(lambda (x) `(,x . 0))
			    (all-other-in-nat-term cterm)))
	 (var-other-occ (nconc var-occ other-occ))
	 (flat-args (loop for e in (cdr cterm) append
			  (cond
			   ((rec-addition? e) (cdr e))
			   ((rec-primitive-multiplication? e) (list (eval e)))
			   (t (list e)))))
	 (int  (apply '+ (remove-if-not #'numberp flat-args)))
	 (non-int (remove-if #'numberp flat-args))
	 (dummy
	  (loop for e in non-int do
		(cond
		 ((rec-multiplication? e)
		  (incf (cdr (assoc (caddr e) var-other-occ :TEST 'equal))
			(cadr e)))
		 (t (incf (cdr (assoc e var-other-occ :TEST 'equal)))))))
	 (var-other-occ
	  (delete-if #'(lambda (x) (= 0 (cdr x))) var-other-occ))
	 (final-args
	  (append (if (= 0 int)
		      nil
		    `(,int))
		  (mapcar #'(lambda (x)
			      (if (= 1 (cdr x))
				  (car x)
				`(* ,(cdr x) ,(car x))))
			    var-other-occ))))
    (declare (ignore dummy))
    (case (length final-args)
      (0 0)
      (1 (car final-args))
      (t `(+ ,@final-args)))))

(defun canonize-subtraction (term)
  (let ((posarg (cadr term))
	(negargs (cddr term)))
    (canonize-addition
     `(+ ,posarg
	 ,@(mapcar #'(lambda (x)
		       `(* -1 ,x))
		     negargs)))))
    

(defun canonize-mod-term (term)
  (let ((arg1 (canonize-nat-term (cadr term)))
	(arg2 (canonize-nat-term (caddr term))))
    (cond
     ((and (is-fixed-int? arg1)
	   (is-fixed-int? arg2))
      (mod arg1 arg2))
     (t `(mod ,arg1 ,arg2)))))

(defun canonize-div-term (term)
  (let ((arg1 (canonize-nat-term (cadr term)))
	(arg2 (canonize-nat-term (caddr term))))
    (cond
     ((and (is-fixed-int? arg1)
	   (is-fixed-int? arg2))
      (div arg1 arg2))
     (t `(div ,arg1 ,arg2)))))

(defun canonize-expt2-term (term)
  (let ((arg (canonize-nat-term (cadr term))))
    (if (is-fixed-posnat? arg)
	(expt 2 arg)
      `(expt2 ,arg))))

(defun canonize-division-term (term)
  (let ((args (mapcar #'canonize-nat-term (cdr term))))
    (if (every #'numberp args)
	(eval `(/ ,@args))
      `(/ ,@args))))

(defun is-int? (l)
  (or (is-fixed-int? l)
      (is-addition? l)
      (is-multiplication? l)
      (is-nat? l)))


(defun is-addition? (term)
  (and (consp term)
       (eq (car term) '+)
       (every #'is-int? (cdr term))))

(defun is-multiplication? (term)
  (and (consp term)
       (= (length term) 3)
       (eq (car term) '*)
       (is-fixed-int? (cadr term))
       (is-nat? (caddr term))))

(defun is-expt2? (term)
  (and (consp term)
       (= (length term) 2)
       (eq (car term) 'expt2)
       (is-nat? (cadr term))))


(defmacro rec-primitive-multiplication? (term)
  `(and (consp ,term)
	(eq (car ,term) '*)
	(is-fixed-int? (cadr ,term))
	(is-fixed-int? (caddr ,term))))

(defmacro rec-addition? (term)
  `(and (consp ,term)
	(eq (car ,term) '+)))

(defmacro rec-subtraction? (term)
  `(and (consp ,term)
        (eq (car ,term) '-)))

(defmacro rec-multiplication? (term)
  `(and (consp ,term)
	(eq (car ,term) '*)))

(defmacro rec-expt2? (term)
  `(and (consp ,term)
	(eq (car ,term) 'expt2)))

(defmacro rec-div? (term)
  `(and (consp ,term)
	(eq (car ,term) 'div)))

(defmacro rec-mod? (term)
  `(and (consp ,term)
	(eq (car ,term) 'mod)))

(defmacro rec-division? (term)
  `(and (consp ,term)
	(eq (car ,term) '/)))

;; BV Equation

(defmacro make-bv-equation (t1 t2)
  ``(BV-EQUAL ,,t1 ,,t2))

(defmacro rec-bv-equation? (term)
  `(and (consp ,term)
	(eq (car ,term) 'bv-equal)))

(defmacro bv-equation-args (term)
  `(cdr ,term))

(defun all-other-in-nat-term (term)
  ;; any other terms but + , *
  ;; e.g. (expt2 .) (mod . .) (div . .)
  (cond
   ((is-fixed-int? term) nil)
   ((rec-nat-var? term)  nil)
   ((rec-addition? term)
    (remove-duplicates
     (loop for e in (cdr term) append
	   (all-other-in-nat-term e))
     :TEST 'equal))
   ((rec-multiplication? term)
    (all-other-in-nat-term (caddr term)))
   (t `(,term))))

(defun all-visible-vars-in-nat-term (term)
  (cond
   ((numberp term) nil)
   ((rec-nat-var? term) `(,term))
   ((rec-addition? term)
    (remove-duplicates
     (loop for e in (cdr term) append
	   (all-visible-vars-in-nat-term e))
     :TEST 'equal))
   ((rec-multiplication? term)
    (all-visible-vars-in-nat-term (caddr term)))
   ((rec-subtraction? term)
    (remove-duplicates
     (loop for e in (cdr term) append
	   (all-visible-vars-in-nat-term e))
     :TEST #'equal))
   ;; Special Constructs
   ((rec-nat-between? term)
    (cons (cadr term)
	  (append (all-visible-vars-in-nat-term (caddr term))
		  (all-visible-vars-in-nat-term (cadddr term)))))
   ((or (rec-nat-max? term)
	(rec-nat-min? term))
    (loop for e in (cdr term) append
	   (all-visible-vars-in-nat-term e)))
   ((rec-var-hiding-construct? term)
    nil)
   (t (error-misc "all-visible-vars-in-nat-term" term "not caught."))))

;; Nat Equations

(defmacro rec-nat-max? (term)
  `(and (consp ,term)
	(eq (car ,term) 'MAX)))

(defmacro rec-nat-min? (term)
  `(and (consp ,term)
	(eq (car ,term) 'MIN)))

(defmacro rec-nat-between? (term)
  `(and (consp ,term)
	(eq (car ,term) 'NAT-VAR-BETWEEN)))

(defmacro make-nat-min (list)
  ``(min ,@,list))

(defmacro make-nat-max (list)
  ``(max ,@,list))

(defmacro make-free-list (list)
  ``(free-list ,@,list))

(defmacro rec-free-list? (list)
  `(and (consp ,list)
	(eq (car ,list) 'FREE-LIST)))

(defun is-free-list? (list)
  (and (consp list)
       (eq (car list) 'FREE-LIST)))

;;; --------------------------------------------------
;;;  Auxiliary Functions & Macros
;;; --------------------------------------------------

(defmacro ifuncall (function &rest args)
  `(if ,function
       (funcall ,function ,@args)))

(defmacro ninsert-list (seq a list)
  ;; replace destructively the element a of seq with list
  `(let ((pos (position ,a ,seq :TEST #'equal)))
     (if (null pos)
	 (error-misc "ninsert-list" a "not a member.")
       (setf ,seq
	 (append (subseq ,seq 0 pos)
		 ,list
		 (subseq ,seq (1+ pos)))))))

    
(defun nat2bools (n &optional (nbits nil))
  (let ((res nil))
    (if nbits
	(loop for i from 0 to (1- nbits) do
	      (if (= 1 (mod n 2))
		  (push t res)
		(push nil res))
	      (setf n (div n 2)))
      (loop while (> n 0) do
	    (if (= 1 (mod n 2))
		(push t res)
	      (push nil res))
	    (setf n (div n 2))))
    res))
  

;;; ****************************************
;;;  Dealing with BV-BDDs
;;; ****************************************


(defstruct node
  (variable    nil) ;; contains also leaf-values...
  (label       -1  :TYPE integer)
  (leaf-node?  nil)
  (else        nil)
  (then        nil)
  (mark        nil)
  )      

(defun is-bdd? (term)
  (node-p term))

(defmacro rec-bdd? (term)
  `(node-p ,term))


;;; Functions on BDDs

(defun all-bdd-nodes (node)
  (vars-of-node node))

(defun lift-bdd-if (bdd)
  ;; turn a BDD into a flat term, if possible
  (if (node-p bdd)
      (cond
       ((leaf-node? bdd) (node-variable bdd))
       ((and (true-node? (node-then bdd))
	     (false-node? (node-else bdd)))
	(node-variable bdd))
       (t bdd)))
  bdd)

;;; ----------------------------------------

(defmacro numposp (n) "[positive-number-predicate] Is n an integer >=0?"
  `(and ,`(integerp ,n)
        ,`(>= ,n 0)))

(defmacro numneqp (n) "[postitive-non-zero-predicate] Is n an integer >0?"
  `(and ,`(integerp ,n) 
        ,`(> ,n 0)))

(defun nat-var-< (a b)
  (if (rec-nat-var? a)
      (if (rec-nat-var? b)
	  (string< (nat-var-name a)
		   (nat-var-name b))
	nil)
    (if (rec-nat-var? b)
	t
      (< a b))))

(defun nat-term-< (a b)
  (let ((a-l (nat-term-level a))
	(b-l (nat-term-level b)))
    (cond
     ((< a-l b-l) t)
     ((> a-l b-l) nil)
     ((numberp a)
      (< a b))
     ((rec-nat-var? a)
      (nat-var-< a b))
     (t
      (some #'(lambda (x) (nat-term-< (car x) (cdr x)))
	    (reverse (pairlis-pad (cdr a) (cdr b))))))))

(defun nat-term-level (term)
  (cond
   ((null term)    0)
   ((numberp term) 1)
   ((rec-nat-var? term) 2)
   ((rec-addition? term) 3)
   ((rec-subtraction? term) 4)
   ((rec-multiplication? term) 5)
   ((rec-mod? term) 6)
   ((rec-div? term) 7)
   ((rec-expt2? term) 8)
   (t (error-misc "nat-term-level" term "not caught."))))


;;; General AUX Functions

(defun div (a b)
  (/ (- a (mod a b)) b))

(defun pairlis-pad (a b)
  (ifassert (listp a))
  (ifassert (listp b))
  ;; like pairlis, but pads missing elements with nil at the list end
  (let* ((na (length a))
	 (nb (length b))
	 (n  (max na nb))
	 (pada (loop for i from 1 to (- n na) collect nil))
	 (padb (loop for i from 1 to (- n nb) collect nil)))
    (pairlis (nconc a pada) (nconc b padb))))

(defun ziplis (args)
  ;; similar to pairlis, but turns m lists of n elements
  ;; into n lists of m elements
  (ifassert (consp args))
  (let* ((len (length (car args)))
	 (n (length args))
	 (res (make-list len)))
    (loop for i from 0 to (1- len) do
	  (loop for j downfrom (1- n) to 0 do
		(push (nth i (nth j args))
		      (nth i res))))
    res))


(defun count-down (n) "Creates a n-ary list, starting with n-1"
  (let ((erg nil))
    (dotimes (i n erg) (push i erg))))

(defun count-up (n)
  (loop for i from 0 to (1- n)
	collect i))


;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;; Error report
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(defun error-type (s1 s2)
  (progn (princ "ERROR in [")
	 (princ s1)
	 (princ "]:  Wrong argument type(s)")
	 (dolist (e s2) (progn (princ " <")
			       (princ e)
			       (princ ">")))
	 (terpri)
	 (break)))

(defun error-misc (s1 s2 s3)
  (progn (princ "ERROR in [")
	 (princ s1)
	 (princ "]:  ")
	 (dolist (e s2) (progn (princ " <")
			       (princ e)
			       (princ ">")))
	 (princ " ")
	 (princ s3)
	 (terpri)
	 (break)))
