;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; --------------------------------------------------------
;;; - File:    fm_elimination.cl
;;; - Purpose: Implement a the function int-close
;;; -          (p. 66 of Thesis)
;;; - USES:   bvec_structure.cl
;;; -         bvec_arith.cl
;;; -         bvec_slicing.cl
;;; - Method: Variant of Fourier-Motzkin Elimination
;;; --------------------------------------------------------
;;; - Oliver M"oller (moeller@ki.informatik.uni-ulm.de)   
;;; -----------------------------------------------------------
;;;
;;; Allegro Common Lisp
;;; Begun:         Dezember, 1st 1997
;;; Last Changes:  March, 16th   1998
;;; Version 2.0
;;;

(in-package user)


;;; ******************************
;;;  Loading structure
;;; ******************************

(defun ll ()
  (load "/home/hiwi/moeller/da/lisp/bvec_structure.cl")
  (load "/home/hiwi/moeller/da/lisp/bvec_arith.cl")
  (load "/home/hiwi/moeller/da/lisp/bvec_slicing.cl")
  (load "/home/hiwi/moeller/da/etc/nats/fm_elimination.cl")
  )

(defun cc ()
  (compile-file "/home/hiwi/moeller/da/lisp/bvec_structure.cl")
  (compile-file "/home/hiwi/moeller/da/lisp/bvec_arith.cl")
  (compile-file "/home/hiwi/moeller/da/lisp/bvec_slicing.cl")
  (compile-file "/home/hiwi/moeller/da/etc/nats/fm_elimination.cl")
  (load "/home/hiwi/moeller/da/lisp/bvec_structure.fasl")
  (load "/home/hiwi/moeller/da/lisp/bvec_arith.fasl")
  (load "/home/hiwi/moeller/da/lisp/bvec_slicing.fasl")
  (load "/home/hiwi/moeller/da/etc/nats/fm_elimination.fasl")
  )

(defun l1 ()
  (load "/home/hiwi/moeller/da/etc/nats/fm_elimination.cl")
  )

(defun c1 ()
  (load "/home/hiwi/moeller/da/etc/nats/fm_elimination.cl")
  (compile-file "/home/hiwi/moeller/da/etc/nats/fm_elimination.cl")
  (load "/home/hiwi/moeller/da/etc/nats/fm_elimination.fasl")
  )

;;; ******************************
;;;  Structure
;;; ******************************

(defstruct integer-constraints
  (LEQ nil)
  (BET nil)
  (MAP nil)
  (INT nil))

(defconstant *fail-constr*
  (make-integer-constraints
   :LEQ '(FAIL)))


;;; ******************************
;;;  Definitions
;;; ******************************

(defconstant *observe-int-close* t)

(defmacro obs-ic (x)
  (if *observe-int-close* x))

;;; ******************************
;;;  Functions
;;; ******************************

(defun int-close-log (leq int &key (name "int-close-log.txt"))
  ;;; writes output to File
  (with-open-file (stream name
		   :DIRECTION :OUTPUT
		   :IF-DOES-NOT-EXIST :CREATE
		   :IF-EXISTS :SUPERSEDE)
    (int-close leq int :STREAM stream)))

(defun int-close-ic (integer-constraints
		     &key (stream nil))
  ;;; computes int-close
  ;;; but is called with a structure [integer-constraint] as an argument
  (let* ((res (int-close
	       (mapcar #'canonize-nat-leq
		       (integer-constraints-LEQ integer-constraints))
	       (integer-constraints-INT integer-constraints)
	       :STREAM stream))
	 (BET (integer-constraints-BET res))
	 (BET-vars (loop for b in BET collect (second b))))
    (make-integer-constraints
     :LEQ (integer-constraints-LEQ res)
     :BET (append (remove-if #'(lambda (x) (member (second x) BET-vars :TEST #'EQUAL))
			     (integer-constraints-BET integer-constraints))
		  BET)
     :MAP (append (integer-constraints-MAP integer-constraints)
		  (integer-constraints-MAP res))
     :INT (append (integer-constraints-INT integer-constraints)
		  (integer-constraints-INT res)))))
		   

(defun int-close (leq int &key (stream nil))
  (ifassert (every #'is-canonical-leq? leq))
  (let* ((vars (sort
		(remove-duplicates
		 (loop for e in leq append
		       (all-recognized-in-nat-term
			(caddr e) #'is-nat-var?))
		 :TEST #'equal)
		#'nat-var-<)))
    (obs-ic (progn
	      (princ (format nil "~%------------------------------~%Starting INT-CLOSE with~%") stream)
	      (create-output-from-list (mapcar #'bv-term-to-ASCII leq) :FIRST-WORD "LEQ: " :STREAM stream)
	      (create-output-from-list (mapcar #'bv-term-to-ASCII int) :FIRST-WORD "INT: " :STREAM stream)
	      (princ (format nil "------------------------------~%") stream)))
    (let ((res (int-close-process leq int vars :STREAM stream)))
      (obs-ic (progn
		(princ (format nil "------------------------------~%") stream)
		(princ (format nil "Results in:~%") stream)
		(create-output-from-list (mapcar #'bv-term-to-ascii (integer-constraints-LEQ res)) :FIRST-WORD "LEQ: " :STREAM stream)
		(create-output-from-list (mapcar #'bv-term-to-ascii (integer-constraints-BET res)) :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 res))
					 :FIRST-WORD "MAP: " :STREAM stream)
		(create-output-from-list (mapcar #'bv-term-to-ascii (integer-constraints-INT res)) :FIRST-WORD "INT: " :STREAM stream)
		(princ (format nil "------------------------------~%") stream)))
      res)))
  
(defun int-close-process (leq int vars &key (stream nil))
  ;; Returns a structure integer-constraints:
  ;;  LEQ   A list of linear constraints [or, a list '(FAIL) ]
  ;;  BET   A list of lower-upper bounds for variables, like
  ;;         '( (NAT-VAR-BETWEEN (nat-var n) 1 (MIN (NAT-VAR m) 17)) )
  ;;  MAP   An assoc-list of variable replacements
  ;;  INT   A list of terms that are required to evaluate to integers
  ;;
  (if (null vars)
      (if (impossible? leq int)
	  *fail-constr*
	(make-integer-constraints
	 :LEQ nil
	 :BET nil
	 :MAP nil
	 :INT nil))
    (let ((actual (car vars))
	  (rest (cdr vars))
	  (list+ nil)
	  (list- nil)
	  (list-rest nil))
      (loop for leq in leq do
	    (let ((f (get-nat-var-coefficient actual (caddr leq))))
	      (cond
	       ((= f 0) (push leq list-rest))
	       ((< f 0) (push (remove-linear-component-in-leq
			       actual
			       (multiply-leq (/ 1 (- 0 f)) leq))
			      list+))
	       (t (push (remove-linear-component-in-leq
			 actual
			 (multiply-leq (/ 1 f) leq))
			list-)))))
      (let* ((new-leq
	      (remove-trivial-assumptions
	       (loop for e1 in list+ append
		     (loop for e2 in list- collect
			   (canonize-nat-leq
			    (make-nat-leq `(+ ,(cadr  e1) ,(cadr e2))
					  `(+ ,(caddr e1) ,(caddr e2))))))))
	     (new-enclose
	      (make-nat-between actual
				(symbolic-max
				 (loop for e in list- collect
				       (canonize-nat-term `(- ,(cadr e) ,(caddr e)))))
				(symbolic-min
				 (loop for e in list+ collect
				       (canonize-nat-term `(- ,(caddr e) ,(cadr e)))))))
	     (dummy
	      (obs-ic
	       (progn (create-output-from-list (mapcar #'bv-term-to-ascii new-leq) :FIRST-WORD "New LEQs: " :STREAM stream)
		      (princ (format nil "New Between: ~a~%" (bv-term-to-ascii new-enclose)) stream)
		      (princ (format nil "** Recursive call to  INT-CLOSE ** [eliminated variable: ~a ]~%" (bv-term-to-ASCII actual)) stream))))
	     
	     (rec-call (int-close-process (append list-rest new-leq) INT rest :STREAM stream))
	     (dummy
	      (obs-ic (princ (format nil "** RETURN from recursive call with:~%") stream)))
	     
	     (LEQ (integer-constraints-LEQ rec-call))
	     (BET (cons new-enclose
			(integer-constraints-BET rec-call)))
	     (MAP (integer-constraints-MAP rec-call))
	     (INT (cons actual (integer-constraints-INT rec-call)))
	     (hit nil)
	     (fail nil)
	     (prop-LEQ nil)
	     (prop-BET nil)
	     )
      (obs-ic (progn
		 (create-output-from-list (mapcar #'bv-term-to-ascii LEQ) :FIRST-WORD "LEQ: " :STREAM stream)
		 (create-output-from-list (mapcar #'bv-term-to-ascii BET) :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)))) MAP)
		     :FIRST-WORD "MAP: " :STREAM stream)
		 (create-output-from-list (mapcar #'bv-term-to-ascii INT) :FIRST-WORD "INT: " :STREAM stream)))		 
      (labels ((propagate-BET ()
		 (obs-ic (princ (format nil "Propagating in BET...") stream))
		 (setf BET
		   (mapcar #'propagate-one-enclose BET))
		 (obs-ic (princ (format nil "done.~%") stream))
	         (obs-ic (create-output-from-list (mapcar #'bv-term-to-ascii BET) :FIRST-WORD " -> BET: " :STREAM stream)))
	       
	       (propagate-one-enclose (enc)
		 (make-nat-between (cadr enc)
				   (propagate-enc-part (caddr enc))
				   (propagate-enc-part (cadddr enc))))
	       
	       (propagate-enc-part (part)
		 (cond
		  ((rec-nat-max? part)
		   (symbolic-max (mapcar #'enc-replace-if (cdr part))))
		  ((rec-nat-min? part)
		   (symbolic-min (mapcar #'enc-replace-if (cdr part))))
		  (t (enc-replace-if part))))
	       
	       (enc-replace-if (term)
		 (canonize-nat-term
		  (replace-in-term-via-assoc term MAP)))
	       (make-bet-to-leq ()
		 ;;; create list of LEQs from BET
		 (loop for b in BET append
		       (append
			(if (rec-nat-max? (third b))
			    (loop for less in (cdr (third b)) collect
				  `(NAT-<= ,less ,(second b)))
			  `((NAT-<= ,(third b) ,(second b))))
			(if (rec-nat-min? (fourth b))
			    (loop for more in (cdr (fourth b)) collect
				  `(NAT-<= ,(second b) ,more))
			  `((NAT-<= ,(second b) ,(fourth b)))))))
		       
	       (propagate-LEQ ()
		 (obs-ic (princ (format nil "Propagating in constraint-list...") stream))
		 (setf LEQ
		   (remove-trivial-assumptions
		    (mapcar #'propagate-one-constr (append LEQ (make-bet-to-leq)))))
		 (obs-ic (princ (format nil "done.~%") stream))
		 (obs-ic (create-output-from-list (mapcar #'bv-term-to-ascii LEQ :FIRST-WORD "LEQ: " :STREAM stream))))
	       
	       (propagate-one-constr (co)
		  (canonize-nat-leq
		   (make-nat-leq (second co)
				 (con-replace-if (third co)))))
	       
	       (con-replace-if (term)
		   (cond
		    ((numberp term) term)
		    ((rec-nat-var? term)
		     (let ((res (cdr (assoc term MAP :TEST #'equal))))
		       (if res
			   (progn (setf prop-LEQ t)
				  res)
			 term)))
		    (t (canonize-nat-term
			`(,(car term)
			  ,@(mapcar #'con-replace-if (cdr term)))))))
	       
	       (check-for-fail-constr ()
		 (setf prop-LEQ nil
		       LEQ
		       (remove-trivial-assumptions LEQ))
		 (setf fail (some #'is-trivially-false-leq LEQ)))
	       
	       (check-for-fail-enclose ()
		 (setf prop-BET nil
		       fail (some #'is-trivially-empty? BET)))
	       
	       (find-enclose-hit ()
		 (setf prop-BET nil)
		 (obs-ic (princ (format nil "Trying to find hit in BET~%") stream))
		 (let ((hit t)
		       (check-BET nil)
		       (check-BET-anew (remove-if #'(lambda (x) (assoc (second x) MAP :TEST #'equal)) (copy-list BET))))
		   (loop while hit do
			 (setf hit nil)
			 (psetf check-BET check-BET-anew
				check-BET-anew nil)
		      (loop for e in check-BET do
			    (obs-ic (princ (format nil " -> Checking ~a~%" (bv-term-to-ASCII e)) stream))
			    (let ((ehit (upper-and-lower e)))
			      (obs-ic (if ehit (princ (format nil " => MATCHES ~a~%" (bv-term-to-ASCII ehit)) stream)
					(princ (format nil " .. No match.~%") stream)))
			   (if ehit
			    (progn
			     (insert-in-MAP (second e) ehit)
			     (setf hit t
				   prop-LEQ t
				   LEQ
				   (mapcar #'(lambda (x)
					       (canonize-nat-leq
						(replace-in-term (second e) ehit x)))
					   LEQ)
				BET
				(mapcar #'(lambda (x)
				  (make-nat-between (second x)
				   (replace-in-term (second e) ehit (third x))
				   (replace-in-term (second e) ehit (fourth x))))
					BET)
				check-BET-anew
				(mapcar #'(lambda (x)
				  (make-nat-between (second x)
				   (replace-in-term (second e) ehit (third x))
				   (replace-in-term (second e) ehit (fourth x))))
					check-BET-anew)
				INT
				(mapcar #'(lambda (x)
					    (replace-in-term (second e) ehit x))
					INT)))
			   (push e check-BET-anew)))))))
	       
	       (find-constr-hit ()
		 (obs-ic (princ (format nil "Trying to find hit in LEQ~%") stream))
		 (setf prop-LEQ nil)
		 (let ((superflous nil))
		   (loop for c1 in LEQ do
			 (if (has-leq-two-vars? c1)
			     (loop for c2 in LEQ do
				   (if (and (has-leq-two-vars? c2)
					    (build-an-equation? c1 c2))
				       (progn
					 (let* ((var (car (all-vars-in-nat-term c1)))
						(rhs (solve-nat-equation-to-var
						      (make-nat-equal (cadr c1) (caddr c1))
						     var)))
					   (insert-in-MAP var rhs)
					   (setf hit t)
					   (push c1 superflous)
					   (push c2 superflous)))))))
		   (unless (not hit)
		     (setf prop-BET t))
		   ))
		   ;;(unless (not hit)
		   ;;  (setf constr-list
		   ;;    (remove-if #'(lambda (x) (member x superflous)) constr-list))
		   ;;  (propagate-LEQ)
		   ;;  (propagate-BET))))
	       
	       (insert-in-MAP (var term)
		 (obs-ic (princ (format nil "Inserting in MAP: ~a |-> ~a~%" (bv-term-to-ASCII var) (bv-term-to-ASCII term)) stream))
		 (setf MAP
		   (cons (cons var term)
			 (replace-in-alist var term MAP))))
	       )
	       
	;;???;(setf prop-LEQ (propagate-BET))
      ;;;; ---- process work ----
      (if (member 'FAIL LEQ)
	  *fail-constr*
	(progn
	  (propagate-BET)
	  (find-enclose-hit)
	  (loop while (or prop-BET prop-LEQ) do
		(if prop-LEQ (check-for-fail-enclose))
		(if fail (return *fail-constr*))
		(find-enclose-hit)
		(if fail (return *fail-constr*))
		(find-constr-hit)
		(if fail (return *fail-constr*))
		FINALLY (return (make-integer-constraints
				 :LEQ LEQ
				 :BET BET
				 :MAP MAP
				 :INT INT))))))))))
      
	      

;;; ****************************************
;;;  Structure
;;; ****************************************
    
(defun is-canonical-leq? (list)
  (and (consp list)
       (= (length list) 3)
       (eq (car list) 'NAT-<=)
       (is-fixed-int? (cadr list))
       (and (rec-nat-term? (caddr list))
	    (or (not (rec-addition? (caddr list)))
		(not (is-fixed-int? (cadr (caddr list))))))))
	     
;;; ****************************************
;;;  Propagation
;;; ****************************************

(defun propagate-nat-var-alist (nat alist)
  (cond
   ((numberp nat) nat)
   ((rec-nat-var? nat) (find-via-assoc nat alist :TEST #'equal))
   ((consp nat)
    `(,(car nat) ,@(mapcar #'(lambda (x) (propagate-nat-var-alist x alist))
			   (cdr nat))))
   (t (error-misc "propagate-nat-var-alist" nat "not caught."))))
		 

(defun impossible? (leq int)
  ;;; try to entail FALSE from {leq} and {int}
  (or (member 'FAIL leq)
      (some #'is-trivially-false-leq? LEQ)
      (some #'is-no-integer? INT)))


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

(defun find-via-assoc (el alist &key (test #'equal))
  (let ((res (assoc el alist :TEST test)))
    (if (null res)
	el
      (find-via-assoc (cdr res) alist))))

(defun replace-in-alist (old new alist)
  (loop for e in alist collect
	(if (occurs? old (cdr e))
	    (cons (car e) (replace-in-term old new (cdr e)))
	  e)))

(defun occurs? (term bigterm)
  (cond
   ((equal term bigterm) t)
   ((numberp bigterm) nil)
   ((rec-nat-var? bigterm) nil)
   ((rec-addition? bigterm)
    (some #'(lambda (x) (occurs? term x)) (cdr bigterm)))
   ((rec-multiplication? bigterm)
    (some #'(lambda (x) (occurs? term x)) (cdr bigterm)))
   ((rec-nat-min? bigterm)
    (some #'(lambda (x) (occurs? term x)) (cdr bigterm)))
   ((rec-nat-max? bigterm)
    (some #'(lambda (x) (occurs? term x)) (cdr bigterm)))
   (t nil)))

(defun replace-in-term (old new term)
  (cond
   ((equal old term) new)
   ((numberp term) term)
   ((eq term EXCL::*INFINITY-DOUBLE*) term)
   ((rec-nat-var? term) term)
   ((rec-addition? term)
    `(+ ,@(mapcar #'(lambda (x) (replace-in-term old new x))
		  (cdr term))))
   ((rec-multiplication? term)
    `(* ,@(mapcar #'(lambda (x) (replace-in-term old new x))
		  (cdr term))))
   ((rec-nat-min? term)
    (make-nat-min (mapcar
		   #'(lambda (x) (replace-in-term old new x))
		   (cdr term))))
   ((rec-nat-max? term)
    (make-nat-max (mapcar
		   #'(lambda (x) (replace-in-term old new x))
		   (cdr term))))
   ((rec-nat-leq? term)
    (make-nat-leq (replace-in-term old new (second term))
		  (replace-in-term old new (third term))))
   (t (error-misc "replace-in-term" (list term) "not caught."))))

(defun replace-in-term-via-assoc (term alist)
  (cond
   ((numberp term) term)
   ((assoc term alist :TEST #'equal)
    (cdr (assoc term alist :TEST #'equal)))
   ((rec-nat-var? term) term)
   ((rec-addition? term)
    `(+ ,@(mapcar #'(lambda (x) (replace-in-term-via-assoc x alist))
		  (cdr term))))
   ((rec-multiplication? term)
    `(* ,@(mapcar #'(lambda (x) (replace-in-term-via-assoc x alist))
		  (cdr term))))
   ((rec-nat-min? term)
    (make-nat-min (mapcar
		   #'(lambda (x) (replace-in-term-via-assoc x alist))
		   (cdr term))))
   ((rec-nat-max? term)
    (make-nat-max (mapcar
		   #'(lambda (x) (replace-in-term-via-alist x alist))
		   (cdr term))))
   ((rec-nat-leq? term)
    (make-nat-leq (replace-in-term-via-assoc (second term) alist)
		  (replace-in-term-via-assoc (third term) alist)))
   (t (error-misc "replace-in-term-via-assoc" (list term) "not caught."))))


(defun close-assumptions (list assoc)
  ;; Returns a list of 'purified' assumptions
  ;; Replace Variables with assoc-if
  ;; Delete trivial assumptions
  ;; Check for unsatisfiability and return a '(FAIL), if so
  (let ((new-list (remove-trivial-assumptions
		   (mapcar #'(lambda (x) (propagate-nat-var-alist x assoc))
			   list))))
    (if (some #'is-trivially-false-leq? new-list)
	'(FAIL)
      new-list)))

(defun replace-nat-via-alist (term alist)
  (or (cdr (assoc term alist :TEST #'equal))
      (cond
       ((or (numberp term)
	    (rec-nat-var? term))
	term)
       ((consp term)
	`(,(car term)
	    ,@(mapcar #'(lambda (x) (replace-nat-via-alist x alist)) (cdr term))))
       (t (error-misc "replace-nat-via-alist" term "not caught.")))))
				     
(defun solve-nat-equation-to-var (eq var)
  (ifassert (rec-nat-equation? eq))
  (let* ((rhs (canonize-nat-term `(- ,(third eq) ,(second eq))))
	 (co  (get-nat-var-coefficient var rhs)))
    (canonize-nat-term `(* ,(/ -1 co)  (- ,rhs (* ,co ,var))))))


(defun min-max-content (term)
  ;; returns a list of things that are in a (possible) min/max symbolic structure
     (if (or (rec-nat-max? term)
	     (rec-nat-min? term))
	 (cdr term)
       (list term)))

(defun has-leq-two-vars? (nat-term)
  (let ((nvars (length (all-vars-in-nat-term nat-term))))
    (and (>= nvars 1)
	 (<= nvars 2))))

(defun build-an-equation? (leq1 leq2)
  ;;; Assume canonized LEQs
  (equal
   (canonize-nat-leq
     (make-nat-leq `(* -1 ,(cadr leq1))
		    `(* -1 ,(caddr leq1))))
   leq2))
      

(defun get-nat-var-coefficient (var add)
  ;; assume: canonized terms only
  (cond
   ((rec-nat-var? add)
    (if (equal var add) 1 0))
   ((rec-addition? add)
    (let ((res 0))
      (loop for e in (cdr add) do
	    (cond
	     ((equal e var) (setf res 1))
	     ((and (rec-multiplication? e)
		   (equal (caddr e) var))
	      (setf res (cadr e)))))
      res))
   ((and (rec-multiplication? add)
	 (equal (caddr add) var))
    (cadr add))
   (t 0)))

(defun get-nat-constant (add)
   ;; assume: canonized terms only
  (cond
   ((numberp add) add)
   ((rec-addition? add)
    (loop for e in (cdr add) do
	  (if (numberp e) (return e))
	  finally (return 0)))
   (t 0)))

(defun multiply-leq (fac leq)
  (ifassert (numberp fac))
  (cond
   ((= 0 fac)
    `(NAT-<= 0 0))
   ((> fac 0)
    `(NAT-<= ,(* fac (cadr leq))
	     ,(canonize-multiplication `(* ,fac ,(caddr leq)))))
   (t
    (canonize-nat-leq
     (make-nat-leq
      `(* ,fac ,(caddr leq))
      `(* ,fac ,(cadr leq)))))))

(defun remove-linear-component-in-leq (var leq)
  (make-nat-leq
   (remove-linear-component var (cadr leq))
   (remove-linear-component var (caddr leq))))
   

(defun remove-linear-component (var term)
  ;; Removes a variable (possibly with coefficient) from a
  ;; canonized linear term
  (cond
   ((numberp term) term)
   ((rec-nat-var? term)
    (if (equal var term) 0 term))
   ((rec-multiplication? term)
    (if (equal var (caddr term)) 0 term))
   ((rec-addition? term)
    (let ((args (remove-if #'(lambda (x) (or (equal var x)
					     (and (rec-multiplication? x)
						  (equal var (caddr x)))))
			   (cdr term))))
      (case (length args)
	(0 0)
	(1 (car args))
	(t `(+ ,@args)))))
   (t (error-misc "remove-linear-component" term "not caught."))))

(defun symbolic-max (list)
  ;;either a single term [if possible]
  ;;or a list beginning with recognizer 'MAX
  ;;The MAX of the empty list is defined 0 [here, for it is applied to nats]
  (let ((symbolmax nil))
    (loop for e in list do
	  (unless
	      (some #'(lambda (x) (is-trivially-leq? e x)) symbolmax)
	    (setf symbolmax
	      (nconc `(,e)
		     (remove-if #'(lambda (x) (is-trivially-leq? x e)) symbolmax)))))
    (cond
     ((null symbolmax) 0)
     ((= 1 (length symbolmax)) (first symbolmax))
     (t `(MAX ,@(sort symbolmax #'nat-term-<))))))

(defun symbolic-min (list)
  ;;either a single term [if possible]
  ;;or a list beginning with recognizer 'MIN
  ;;the MIN of a empty list is defined *INF* (infinity)
  (let ((symbolmin nil))
    (loop for e in list do
	  (unless
	      (some #'(lambda (x) (is-trivially-leq? x e)) symbolmin)
	    (setf symbolmin
	      (nconc `(,e)
		     (remove-if #'(lambda (x) (is-trivially-leq? e x)) symbolmin)))))
    (cond
     ((null symbolmin) *INF*)
     ((= 1 (length symbolmin)) (first symbolmin))
     (t `(MIN ,@(sort symbolmin #'nat-term-<))))))



(defun is-trivially-leq? (t1 t2)
  ;; assumes that there are only NATURAL NUMBER VARS >= 0 !
  (cond
   ((or (not (is-linear-term? t1))
	(not (is-linear-term? t2)))
    nil)
   ((equal t2 *INF*)
    t)
   (t
    (let* ((vars (remove-duplicates
		  (append (all-vars-in-nat-term t1)
			  (all-vars-in-nat-term t2))
		  :TEST #'equal))
	   (n (length vars))
	   (co1 (mapcar #'(lambda (x) (get-nat-var-coefficient x t1)) vars))
	   (co2 (mapcar #'(lambda (x) (get-nat-var-coefficient x t2)) vars))
	   (fix1 (get-nat-constant t1))
	   (fix2 (get-nat-constant t2)))
      (and (<= fix1 fix2)
	   (loop for i from 0 to (1- n) do
		 (if (> (nth i co1) (nth i co2))
		     (return nil))
	       finally (return t)))))))

(defun is-trivially-empty? (between)
  ;; Takes a nat-var-between-form and checks if it
  ;; fails for some reason
  (let* ((lower  (caddr between))
	 (upper  (cadddr between))
	 (llist (if (rec-nat-max? lower)
		   (cdr lower)
		 (list lower)))
	(ulist (if (rec-nat-min? upper)
		   (cdr upper)
		 (list upper)))
	(itis nil))
    (loop for e1 in llist do
	  (if itis (return))
	  (loop for e2 in ulist do
		(if (is-trivially-less? e2 e1)
		    (progn (setf itis t)
			   (return)))))
    itis))

(defun is-trivially-less? (t1 t2)
  ;; assumes that there are only NATURAL NUMBER VARS >= 0 !
  ;; canonized Terms!
  ;; possibly MAX/MIN-Constructs
  (if (or (not (is-linear-term? t1))
	  (not (is-linear-term? t2)))
      nil
    (and (is-trivially-leq? t1 t2)
	 (not (equal t1 t2)))))

(defun is-trivially-false-leq? (leq)
  (is-trivially-less? (caddr leq) (cadr leq)))

(defun remove-trivial-assumptions (list)
  (remove-if #'is-trivial-assumption? list))

(defun is-no-integer? (term)
  (and (numberp term)
       (not (integerp term))))


(defun is-linear-term? (term)
  (or
   (numberp term)
   (rec-nat-var? term)
   (and (rec-addition? term)
	(every #'is-linear-term? (cdr term)))
   (and (rec-multiplication? term)
	(numberp (cadr term))
	(is-linear-term? (caddr term)))))
     
(defun upper-and-lower (encl)
  (ifassert (rec-nat-between? encl))
  (let ((hit nil)
	(e1 (if (rec-nat-max? (caddr encl))
		(cdaddr encl)
	      (list (caddr encl))))
	(e2 (if (rec-nat-min? (cadddr encl))
		(cdr (cadddr encl))
	      (list (cadddr encl)))))
    (loop for t1 in e1 do
	  (if hit (return hit))
	  (loop for t2 in e2 do
		(if (equal t1 t2)
		    (return (setf hit t1)))))
    hit))
    


;;; ****************************************
;;;  Processing the natural terms
;;; ****************************************

(defun process-assumptions (as-list)
  ;; returns either a list of (minimal) assumptions
  ;; or a 'FAIL if the assumptions are not consistent
  (let ((res (remove-subsumptions
	      (remove-if #'is-trivial-assumption? as-list))))
    (if (check-for-impossible res)
	'FAIL
      res)))

(defun is-trivial-assumption? (na)
  ;; the assumtion is canonized
  (let ((op (car na))
	(arg1 (cadr na))
	(arg2 (caddr na)))
    (case op
      (NAT-EQUAL
       (equal arg1 arg2))
      (NAT-<=
       (is-trivially-leq? arg1 arg2))
      (NAT-<
       (and (numberp arg2)
	    (< arg1 arg2)))
      (t (error-misc "is-trivial-assumption?" na "not caught.")))
    ))

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

;;; ************************************************************
;;;  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-less? 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))))
     ((rec-free-list? term)
      (eval `(CLOS::string-append "("
				  ,@(loop for x in (cdr term) collect
					(CLOS::string-append " "  (bv-term-to-ASCII x)))
				  " )")))
     ((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
;;; ********************

(defun ex-ic-1 () "FAILS"
  (int-close
   '((NAT-<= 2  (NAT-VAR n))
     (NAT-<= 0  (+ (* -1 (NAT-VAR n)) (NAT-VAR m)))
     (NAT-<= -1 (* -1 (NAT-VAR m)))
     )
   nil))

(defun ex-ic-2 () "FAILS"
  (int-close
   '((NAT-<= 13 (+ (NAT-VAR n) (NAT-VAR m) (NAT-VAR l)))
     (NAT-<= -3 (* -1  (NAT-VAR n)))
     (NAT-<= -4 (* -1  (NAT-VAR m)))
     (NAT-<= -5 (* -1  (NAT-VAR l))))
   nil))

(defun ex-ic-3 () "Restricts n, but not m"
  (int-close
   `( (NAT-<= 1 (NAT-VAR n))
      (NAT-<= -1 (* -1 (NAT-VAR n)))
      (NAT-<= 0  (+ (* -1 (NAT-VAR n)) (NAT-VAR m))))
   nil))

(defun ex-ic-4 () "Restricts n to be even"
  (int-close
   '((NAT-<= 0 (+  (NAT-VAR n) (* -2  (NAT-VAR m))))
     (NAT-<= 0 (+ (* -1 (NAT-VAR n)) (*  2 (NAT-VAR m)))))
   nil))
