;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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:  check_via_mona.cl
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; HOW TO USE:  [Allegro Common Lisp Version]
;; ~~~~~~~~~~~
;;  (1) Install Mona Version 1.1
;;      [ to optain eg. at  http://www.brics.dk/~mona/index.html ]
;;  (2) Fetch also the files  bvec_structures.cl  and  bvec_arith.cl
;;      [ to optain eg. at  
;;        http://www.informatik.uni-ulm.de/ki/Bitvector  ]
;;  (3) Create a local directory, where Mona can store the
;;      input-and output files (e.g. mona/)
;;  (4) Modify the constants
;;        *home-directory*  *mona-local-directory-path*  *mona-call-exe*
;;      according to your local settings
;;  (5) Load common lisp files in this order
;;        bvec_structure.cl
;;        bvec_arith.cl
;;        check_via_mona.cl
;;      [compilation recommended]
;;  (6) Start >> Solver << with
;;        (solve-via-mona '(bv-equal <term-1> <term-2>))
;;      <term-1> and <term-2> are assumed to be canonized(!)
;;      An example for term structure is given in section * Examples *
;;      NOTES: 
;;        (a) The 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)
;;        (b) The finite automaton is not put out as a default;
;;            if the directive  "-w" is added to the call to the mona-program
;;            (cf. function call-mona-program ), the automaton is put to file
;;              mona_output_file.txt
;;      The function  solve-via-mona  returns one of the symbols
;;        TAUTOLOGY        iff the equation is a tautology
;;        UNSATISFIABLE    iff the equation is unsatisfiable
;;        COUNTEREXAMPLE   if there is a model,
;;                             but the formula is not a tautology
;;        ERROR            if an error occurred
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; General Remarks:   This implementation realizes
;; 'Solving' fixed bv equations via a transformation to S1S
;; And creating an output which can be processed with MONA 1.1
;; Strictly speaking, this is not an implementation of a solver
;; but a test for TAUTOLOGY or UNSATISFIABILITY;
;; This can be used to generate a solving algorithm, by means of
;; Repeatedly replace bits of variables with constants;
;; [See Diploma Thesis for detailed description]
;;
;; The big revenue of this approach is, that it allows to check
;; FIXED SIZE BITVECTOR EQUATIONS WITH LINEAR ARITHMETIC 
;;  AND LOGIC
;; for validity (which is the most common usage of decision procedures)
;; The big drawback is the sometimes horrendous run-time
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; BEGUN:         October, 4th 1997
;;; Last Changes:  March, 14th  1998
;;; Version 2.0    [as printed in Appendix C of the Diploma Thesis]

(in-package user)

;;; ****************************************
;;;  Constants to Customize
;;; ****************************************

(defconstant *home-directory* "/home/hiwi/moeller/")

(defconstant *mona-local-directory-path*
    (CLOS::string-append *home-directory* "da/etc/mona/"))

(defconstant *mona-call-exe* "/usr/local/share/ai-systems/mona/mona-1.1/mona")

;;; ************************************************************

(defconstant *mona-input-file*
    (CLOS::string-append *mona-local-directory-path*
			 "mona_input_file.mona"))
(defconstant *mona-output-file*
    (CLOS::string-append *mona-local-directory-path*
			 "mona_output_file.txt"))
(defconstant *mona-result-file*
    (CLOS::string-append *mona-local-directory-path*
			 "mona_result_file.txt"))
(defconstant *full-adder-file*
    (CLOS::string-append *mona-local-directory-path*
			 "fulladder.mona"))

(defconstant *allow-complement* nil)

(defconstant *negate* nil)
;;; *negate* = nil -> If the equation is a tautology,
;;;                          Mona will reply 'valid'
;;;                   Else   Mona will present a counterexample
;;;                          [Here, the automaton is a encoding
;;;                           of the SOLUTION] 
;;; ------------------
;;; *negate* = t   -> If the equation is unsatisfiable
;;;                          Mona will reply 'valid'
;;;                   Else   Mona will present a counterexample
;;; ------------------


(defun solve-via-mona (bv-eq &optional (trigger-mona-on nil)
				       (trigger-mona-off nil))
  ;; Returns  'tautology      iff the equation is a tautology
  ;;          'unsatisfiable  iff the equation is unsatisfiable
  ;;          'counterexample if there is a model,
  ;;                             but the formula is not a tautology
  ;;          'errir          if the mona-output-file is not as expected
  (ifassert (and (consp bv-eq)
	       (eq (car bv-eq) 'bv-equal)))
  (ifassert (is-fixed-arith-bool-bv? (cadr bv-eq)))
  (ifassert (is-fixed-arith-bool-bv? (cadr bv-eq)))
  (let* ((term1 (rewrite-boolean-logic-AON (cadr bv-eq)))
	 (term2 (rewrite-boolean-logic-AON (caddr bv-eq)))
	 (width (arith-bool-bv-length term1)))
    ;; !!! Assume canonized terms !!!
    (labels ((get-sub-structures (recog?)
	       (remove-duplicates
		(append (all-recognized-in-arith-bool-bv-term term1 recog?)
			(all-recognized-in-arith-bool-bv-term term2 recog?))
		:TEST #'equal)))
      (let* ((vars (sort
		    (get-sub-structures #'(lambda (x) (rec-bv-var? x)))
		    #'(lambda (x y)
			(string< (bv-var-name x)
				 (bv-var-name y)))))
	     ;;; (var-names (mapcar #'bv-var-name vars))
	     (var-alen (mapcar #'(lambda (x)
				   `(,(bv-var-name x) . ,(bv-var-length x)))
				 vars))
	     (var-len (loop for pair in var-alen collect (cdr pair)))
	     (var-fnames (mapcar #'(lambda (x)
				     (CLOS::string-append
				      "VAR_"
				      (princ-to-string (bv-var-name x))
				      "_"
				      (princ-to-string (bv-var-length x))))
				   vars))
	     ;;; (var-assoc (pairlis var-len var-fnames))
	     (constants (get-sub-structures
			 #'(lambda (x) (rec-bv-const? x))))
	     (additions (get-sub-structures
			 #'(lambda (x) (rec-bv-addition? x))))
	     (negations (get-sub-structures
			 #'(lambda (x) (rec-bv-negation? x))))
;;! Compl does not work in Mona (early version)
	     (complements (get-sub-structures
			   #'(lambda (x) (rec-bv-negation? x))))
	     (complement-fnames
	      (loop for i from 1 to (length complements) collect
		    (CLOS::string-append "Compl_"
					 (princ-to-string i))))
	     (complement-alist
	      (if *allow-complement*
		  nil
		(pairlis complements complement-fnames)))
;;!	     
	     (filter-lengths
	      (remove-duplicates
	       (append var-len
		       (mapcar #'(lambda (x) (bv-addition-modulo x))
				 additions)
		       (mapcar #'(lambda (x) (arith-bool-bv-length x))
				 negations)
		       (mapcar #'bv-extraction-length
				 (get-sub-structures #'(lambda (x) (rec-bv-extraction? x)))))))
	     (filter-fnames
	      (loop for e in filter-lengths collect
		    (CLOS::string-append "Filter_"
					 (princ-to-string e))))
	     (filter-assoc (pairlis filter-lengths filter-fnames))
	     (addition-fnames
	      (loop for i from 1 to (length additions) collect
		    (CLOS::string-append "RES_"
					 (princ-to-string i))))
	     (constant-fnames
	      (loop for e in constants collect
		    (CLOS::string-append "CONST_"
					 (princ-to-string (bv-const-length e))
					 "_"
					 (princ-to-string (bv-const-value e)))))
	     (addition-alist (pairlis additions addition-fnames))
	     (constant-alist (pairlis constants constant-fnames))
	     (replace-alist (append (mapcar #'(lambda (x)
						(cons (car x)
						      (CLOS::string-append
						       "("
						       (cdr x)
							" inter "
							(dassoc (bv-addition-modulo (car x)) filter-assoc)
							 ")")))
					      addition-alist)
				    (mapcar #'(lambda (x)
						(cons (car x)
						      (CLOS::string-append
						       "("
						       (cdr x)
							" inter "
							(dassoc (bv-var-length (car x)) filter-assoc)
							 ")")))
							(pairlis vars var-fnames))
				    constant-alist
				    (mapcar #'(lambda (x)
						(cons (car x)
						      (CLOS::string-append
						       "("
						       (cdr x)
							" inter "
							(dassoc (arith-bool-bv-length (car x)) filter-assoc)
							 ")")))
					      complement-alist)))

	     ;;; ---  Create Axioms ---
	     (filter-axioms
	      (loop for e in filter-assoc collect
		    (let ((len (car e))
			  (name (cdr e)))
		      `(all1 "p" (and (=> (< "p" ,len)
					  (in "p" ,name))
				      (=> (<= ,len "p")
					  (notin "p" ,name)))))))
	     (constant-axioms
	      (loop for e in constant-alist append
		    (let* ((con (car e))
			   (len (bv-const-length con))
			   (val (bv-const-value con))
			   (bits (reverse (nat2bools val len)))
			   (name (cdr e)))
		      `((all1 "p" (=> (<= ,len "p")
				      (notin "p" ,name)))
			,@(loop for i from 0 to (1- len) collect
				(if (nth i bits)
				    `(in ,i ,name)
				  `(notin ,i ,name)))))))
	     (addition-axioms-strings
	      (loop for e in addition-alist collect
		    (let* ((ad     (car e))
			   ;; (modulo (cadr ad))
			   (args   (cddr ad))
			   (len    (length args))
			   (name   (cdr e)))
		      (eval `(CLOS::string-append
		       "add" ,(princ-to-string len) "("
		       ,@(loop for e in args append
			       `(,(translate-form-to-string-with-replace e replace-alist) ","))
		       ,name ")")))))
	     ;!;
	     (complement-axioms-strings
	      (loop for e in complement-alist collect
		    (CLOS::string-append
		     "Complement( "
		     (translate-form-to-string-with-replace (car (bv-bool-args (car e))) replace-alist)
		     " , "
		     (cdr e)
		     " )")))
	     )
	(labels ((check-via-mona (negate width trigger-on trigger-off)
		   ;; Ouptut the created Terms
		   (new-mona-file)
		   (output-var2-and-addition-defs
		    var-fnames
		    (apply #'max
			   (cons 0
				 (mapcar #'(lambda (x)
					     (length (bv-addition-args x)))
					 additions)))
		    width)
		   (output-main-implication
		    (append (mapcar #'(lambda (x) (translate-form-to-string-with-replace x replace-alist))
				    (append filter-axioms
					    constant-axioms))
			    addition-axioms-strings
			    complement-axioms-strings ;!;
			    )
		    (translate-form-to-string-with-replace term1 replace-alist)
		    (translate-form-to-string-with-replace term2 replace-alist)
		    (append constant-fnames
			    addition-fnames
			    filter-fnames
			    complement-fnames ;!;
			    )
		    negate)
		   (ifuncall trigger-on)
		   (call-mona-program)
		   (ifuncall trigger-off)
		   (scan-mona-output)))
	  ;;; -- THE ONLY ONE CALL TO MONA --
	  (check-via-mona nil width trigger-mona-on trigger-mona-off))))))
	 

(defun translate-form-to-string-with-replace (form alist)
  (flet ((make-bracket-string (op list)
	   (eval `(CLOS::string-append
		   "("
		   ,@(loop for e in (butlast list) collect
			   (CLOS::string-append
			    (translate-form-to-string-with-replace e alist)
			    " " op " "))
		    ,(translate-form-to-string-with-replace (car (last list)) alist)
		    ")")))	 
	 (make-intermediate-string (op arg1 arg2)
	   (CLOS::string-append
	    "("
	    (translate-form-to-string-with-replace arg1 alist)
	    " " op " "
	    (translate-form-to-string-with-replace arg2 alist)
	    ")"))
	 (make-quantified-string (quan var body)
	   (CLOS::string-append
	    "("
	    quan
	    " "
	    var
	    ": "
	    (translate-form-to-string-with-replace body alist)
	    ")")))    
    (cond
     ((assoc form alist :TEST #'equal)
      (cdr (assoc form alist :TEST #'equal)))
     ((stringp form) form)
     ((integerp form) (princ-to-string form))
     ((consp form)
      (case (car form)
	(<=> (make-bracket-string "<=>" (cdr form)))
	(=   (make-bracket-string "=" (cdr form)))
	(and (make-bracket-string "&" (cdr form)))
	(or  (make-bracket-string "|" (cdr form)))
	(<=  (make-bracket-string "<=" (cdr form)))
	(=>  (make-bracket-string "=>" (cdr form)))
	(<   (make-bracket-string "<" (cdr form)))
	(>   (make-bracket-string ">" (cdr form)))
	(not (CLOS::string-append
	      "~"
	      (translate-form-to-string-with-replace (cadr form) alist)
	      ))
	(in  (make-intermediate-string "in" (princ-to-string (cadr form)) (caddr form)))
	(notin (make-intermediate-string "notin" (princ-to-string (cadr form)) (caddr form)))
	(all0 (make-quantified-string "all0" (cadr form) (caddr form)))
	(all1 (make-quantified-string "all1" (cadr form) (caddr form)))
	(all2 (make-quantified-string "all2" (cadr form) (caddr form)))
	(exist0 (make-quantified-string "exist0" (cadr form) (caddr form)))
	(exist1 (make-quantified-string "exist1" (cadr form) (caddr form)))
	(exist2 (make-quantified-string "exist2" (cadr form) (caddr form)))
	(union (make-bracket-string "union" (cdr form)))
	(inter (make-bracket-string "inter" (cdr form)))
	(compl (CLOS::string-append
		"(compl "
		(translate-form-to-string-with-replace (cadr form) alist)
		")"))
	(+ (translate-offset-to-string-with-replace (cadr form) (caddr form) alist))
	(- (translate-offset-to-string-with-replace (cadr form) (-  0 (caddr form)) alist))
	(bv-compose (translate-composition-to-string-with-replace form alist))
	(bv-extract (translate-extraction-to-string-with-replace form alist))
	;; -- boolean --
	(bv-and (translate-form-to-string-with-replace
		 `(inter ,@(bv-bool-args form)) alist))
	(bv-or (translate-form-to-string-with-replace
		`(union ,@(bv-bool-args form)) alist))
       	(bv-not (translate-form-to-string-with-replace
		 `(inter (compl ,@(bv-bool-args form))
			 ,(CLOS::string-append
			   "Filter_"
			   (princ-to-string (arith-bool-bv-length form))))
		  alist))
	(t (error-misc "translate-form-to-string-with-replace" form "not caught.")))))))


(defun translate-composition-to-string-with-replace (cmp alist)
  (let* ((args (reverse (bv-composition-content cmp)))
	 (offset 0)
	 (offsets (loop for e in args collect
			(let ((old offset))
			  (incf offset (arith-bool-bv-length e))
			  old))))
    (translate-form-to-string-with-replace
     `(union ,@(loop for e in (pairlis args offsets) collect
		     `(+ ,(translate-form-to-string-with-replace (car e) alist)
			 ,(cdr e))))
     alist)))
    
(defun translate-offset-to-string-with-replace (term offset alist)
  (let ((str (translate-form-to-string-with-replace term alist)))
    (cond
     ((= offset 0)
      str)
     ((< offset 0)
      (CLOS::string-append "(" str " - " (princ-to-string (-  0 offset)) ")"))
     (t
      (CLOS::string-append "(" str " + " (princ-to-string offset) ")")))))

(defun translate-extraction-to-string-with-replace (extr alist)
  (let ((len (bv-extraction-length extr))
	(bv  (bv-extraction-bv extr))
	(off (bv-extraction-right extr)))
    (translate-form-to-string-with-replace
     `(inter (- ,bv ,off)
	     ,(CLOS::string-append "Filter_" (princ-to-string len)))
     alist)))
			    
	 
;;; ****************************************
;;;  AUXillary Functions
;;; ****************************************


(defun create-filter-names (n)
  (loop for i from 1 to n collect
	(CLOS::string-append "Filter"
			     (princ-to-string i))))

(defun dassoc (a alist)
  (cdr (assoc a alist :TEST 'equal)))


(defun rewrite-boolean-logic-AON (term)
  ;; Replace boolean operations: XOR
  ;; By AND OR NOT
  (cond
   ((rec-bv-var? term) 
    term)
   ((rec-bv-const? term)
    term)
   ((rec-bv-extraction? term)
    (make-bv-extraction
     (rewrite-boolean-logic-AON (bv-extraction-bv term))
     (bv-extraction-left term)
     (bv-extraction-right term)))
   ((rec-bv-composition? term)
    (make-bv-composition-from-list
     (mapcar #'rewrite-boolean-logic-AON
	     (bv-composition-content term))))
   ((rec-bv-addition? term)
    (make-bv-addition-from-list
     (bv-addition-modulo term)
	(mapcar #'rewrite-boolean-logic-AON
		  (bv-addition-args term))))
   ((rec-bv-bool? term)
    (case (bv-recognizer term)
      (bv-and term)
      (bv-or  term)
      (bv-not term)
      (bv-xor (let ((x (rewrite-boolean-logic-AON
			(car (bv-bool-args term))))
		    (y (rewrite-boolean-logic-AON
			(cadr (bv-bool-args term)))))
		(make-bv-or (make-bv-and (make-bv-not x) y)
			    (make-bv-and x (make-bv-not y)))))
      (t (error-misc "rewrite-boolean-logic-AON [bool]" term "not caught."))))
   (t (error-misc "rewrite-boolean-logic-AON" term "not caught."))))


;;; **************************************************
;;;  File Handling
;;; **************************************************

(defun new-mona-file ()
  (with-open-file (stream *mona-input-file*
		   :direction :output
		   :if-exists :supersede
		   :if-does-not-exist :create)
    (format stream "## Check Fixed Sized Bit Vector Equations via Mona 1.1~%")
    (format stream "## part of Diploma Thesis~%")
    (format stream "## M. Oliver Moeller 1997~%")
    (format stream "linear;~%")
    ))

(defun output-var2-and-addition-defs (names add-upto width)
  (with-open-file (stream *mona-input-file*
		   :direction :output
		   :if-does-not-exist :error
		   :if-exists :append)
    (loop for n in names do
	  (format stream "var2 ~a;~%" n))
    (if (> add-upto 1)
	(progn
	  (with-open-file (include *full-adder-file*
			   :direction :input
			   :if-does-not-exist :error)
	    (loop for i from 1 to (file-length include) do
		  (princ (read-char include) stream)))
	  (create-addition-predicates add-upto stream)))
    (unless *allow-complement*
      (format stream "~%pred Complement(var2 X,Y) = all1 p : (p < ~d) => ( (p in X) <=> (p notin Y));~%~%" width))))

(defun output-main-implication (axiom-stringlist str1 str2 existential-quantified negate)
  (with-open-file (stream *mona-input-file*
		   :direction :output
		   :if-does-not-exist :error
		   :if-exists :append)
    (flet ((conjunction-output-if (list)
	     (if (null list)
		 (format stream " true ")
	       (progn
		 (format stream " (")
		 (loop for a in (butlast list) do
		       (format stream "~a & ~%  " a))
		 (format stream "~a )" (car (last list)))))))
      (format stream "~%## Check the following ~a Implication:~%~a("
	      (if negate "(negated)" "")
	      (if (consp existential-quantified)
		  (eval
		   `(CLOS::string-append
		     ,(if negate "~(" "(")
		     "ex2 "
		     ,@(loop for e in (butlast existential-quantified) append
			     `(,e ","))
		      ,(car (last existential-quantified))
		       ": "))
		""))
      (conjunction-output-if axiom-stringlist)
      (format stream   " &~%    ( ~a~%   =  ~a ) )   );~%" str1 str2))))
    

(defun call-mona-program ()
  (shell
    (CLOS::string-append
	  *mona-call-exe*
	  " -c -u "
	  *mona-input-file*
	  " 2> "
	  *mona-output-file*
	  " 1> "
	  *mona-output-file*
	  )))

(defun scan-mona-output ()
  (let ((res 'error))
    (flet ((testfor (string)
	     (shell (CLOS::string-append
		     "egrep "
		     " '" string "' "
		     *mona-output-file* " > "
		     *mona-result-file*))
	     (with-open-file (stream *mona-result-file*
			      :direction :input
			      :if-does-not-exist :error)
	       (if (> (file-length stream)
		      0)
		   t
		 nil))))
      (cond
       ((testfor "Formula is valid")
	(setf res 'tautology))
       ((testfor "Counter-example")
	(setf res 'counterexample))
       ((testfor "Formula is unsatisfiable")
	(setf res 'unsatisfiable)))
      res)))    
  
;;; ******************************
;;;  Creating Formulae
;;; ******************************

(defun create-addition-predicates (n stream)
  ;; from binary to n-ary terms
  (flet ((add-pred (i)
	   (let ((vars (loop for j from 1 to i collect
			     (CLOS::string-append "S"
						  (princ-to-string j)))))
	     (eval
	      `(CLOS::string-append
		"pred add" ,(princ-to-string i) "(var2 "
		,@(loop for e in vars append
		      `(,e ","))
		"Result) = ~%   ex2 Z: add"
		,(princ-to-string (1- i))
		"("
		,@(loop for e in (butlast vars) append
			`(,e ","))
		"Z) & ~%          add2(Z,"
		,(car (last vars))
		",Result);~%~%")))))
    (loop for i from 3 to n do
	  (format stream (add-pred i)))))
	
;;; ************
;;; * Examples *
;;; ************

(defun ex-1 () ;;; TAUTOLOGY
  (solve-via-mona
   '(bv-equal
     (bv-addition 4
      (bv-compose
       (bv-extract (bv-var x 4) (tupcons 2 0))
       (bv-const 0 1))
      (bv-const 1 4)
      (bv-const 0 4)
      (bv-const 0 4))
     (bv-compose (bv-extract (bv-var x 4) (tupcons 2 0))
      (bv-const 1 1)))))

(defun ex-2 () ;;; UNSATISFIABLE
  (solve-via-mona
   '(bv-equal
     (bv-compose (bv-var x 5) (bv-const 1 1))
     (bv-compose (bv-const 0 1) (bv-var x 5)))))

(defun ex-3 () ;;; COUNTEREXAMPLE
  (solve-via-mona
   '(bv-equal
     (bv-addition 3 (bv-var x 3) (bv-var y 3))
     (bv-const 3 3))))
