;; 
;; NOTE: the Quine-McCluskey Algorithm is NP Hard and the complexity
;; grows exponentially as the number of variables increases... be
;; patient!
;;
;; If the number of prime implicants is really large, the non-optimal
;; "Espresso heuristic logic minimizer may be a better choice

;; (sb-ext:restrict-compiler-policy 'debug 3)

;; e.g. SIGMA m(one-list) + d(dont-care-list)

;; Note to self: '(0 0 0 0) and '(0 0 0 1) combine to form '(0 0 0 -)


;; boolean algebra

(defun boolean-or ()
  (multiple-value-bind (b1 b2)
      (get-eq-length-bit-strings)
    (if (and b1 b2)
	(bit-ior b1 b2))))

(defun boolean-xor ()
  (multiple-value-bind (b1 b2)
      (get-eq-length-bit-strings)
    (if (and b1 b2)
	(bit-xor b1 b2))))

(defun boolean-nor ()
  (multiple-value-bind (b1 b2)
      (get-eq-length-bit-strings)
    (if (and b1 b2)
	(bit-nor b1 b2))))

(defun boolean-not ()
  (let ((b (get-bit-string)))
    (if b
	(bit-not (read-from-string b)))))

(defun boolean-nand ()
  (multiple-value-bind (b1 b2)
      (get-eq-length-bit-strings)
    (if (and b1 b2)
	(bit-nand b1 b2))))

(defun boolean-and ()
  (multiple-value-bind (b1 b2)
      (get-eq-length-bit-strings)
    (if (and b1 b2)
	(bit-and b1 b2))))

(defun get-bit-string ()
  (format t "enter a string of 1s and 0s with no spaces: ")
  (let ((bs (read-line))
	(good-data t))
    (map nil #'(lambda (c)
		 (when (or (not (digit-char-p c))
			   (not (< (- (char-int c) 48) 2)))
		   (setf good-data nil)))
	 bs)
    (if good-data
	(concatenate 'string "#*" bs)
	())))
;(format t "Failure! I was looking for a string of all 1s and 0s~%"))))
	
(defun get-eq-length-bit-strings ()
  (let ((bs1 (get-bit-string))
	(bs2 (get-bit-string)))
    (if (and bs1 bs2)
	(if (= (length bs1)
	       (length bs2))
	    (values (read-from-string bs1) (read-from-string bs2))
	    (format t "Failure!  Bit strings must be the same length~%"))
	(format t "Failure! Invalid bit string~%"))))

;; if you would like to construct your own boolean functions, check
;; out (boole boole-and n m) etc and (bit-and bit-array-1 bit-array-2)
;; etc.

(setf m '(4 8 10 11 12 15))
(setf dc '(9 14))

(defun print-sigma-expression (min-term-list dc-list)
  (format t "   _____~%")
  (format t "   \\ ~%")
  (format t "    \\     M(")
  (dolist (o min-term-list)
    (if (= (position o min-term-list)
	   (- (length min-term-list) 1))
	(format t "~A" o)
	(format t "~A, " o)))
  (format t ") +  D(")
  (dolist (d dc-list)
    (if (= (position d dc-list)
	   (- (length dc-list) 1))
	(format t "~A" d)
	(format t "~A, " d)))
  (format t ")~%")
  (format t "    /~%")
  (format t "   /____~%"))

;; transforms m(min-term-list) + d(dont-care-list) to standard SOP string
(defun to-sop-form (min-term-list dc-list)
  (let ((max (car (sort (append min-term-list dc-list) #'>))))
    (let ((num-bits (ceiling (log max 2.0)))
	  (prime-implicants nil))
      (dolist (m min-term-list)
	(let ((nl (natural->bit-list m)))
	  (if (= (length nl) num-bits)
	      (push nl prime-implicants)
	      (let ((fixed (push-zeros nl num-bits)))
		(push fixed prime-implicants)))))
      (let ((result ""))
	(dolist (p (reverse prime-implicants))
	  (do ((bit-pos 0 (incf bit-pos))
	       (expression "")
	       (variable #\A (code-char (1+ (char-code variable)))))
	      ((>= bit-pos num-bits)
	       (setf result
		  (concatenate 'string (reverse expression) " + " result)))
	    (if (zerop (elt p bit-pos))
		(setf expression
		      (concatenate 'string
				   (list variable #\~ )
				   expression))
		(setf expression
		      (concatenate 'string
				   (list variable)
				   expression)))))

	(subseq result 0 (- (length result) 3))))))

(defun quine-mccluskey (min-terms dont-cares)
  (let* ((lst (append min-terms dont-cares))
	 (groups (group-by-ones lst
			       (get-num-bits lst))))))

(defun group-by-ones (lon num-bits)
  (let ((raw-list nil))
    (dolist (l lon)
      (let ((bits (natural->bit-list l)))
	(if (= (length bits) num-bits)
	    (push  bits raw-list)
	    (push (push-zeros bits num-bits) raw-list))))
    (let ((num-groups (+ 1 (length (car raw-list))))
	  (groups nil))
      (dotimes (i num-groups)
	(push nil groups))
      ;; now the (elt groups i) where i=number-of-ones will hold all
      ;; bit-lists with that many ones
      (dolist (r raw-list)
	(let ((pos (count-ones r)))
	  (push r (elt groups (count-ones r)))))
      groups)))

(defun count-ones (bit-list)
  (let ((cnt 0))
    (dolist (b bit-list)
      (if (= b 1)
	  (incf cnt)))
    cnt))

(defun get-num-bits (l)
  (let* ((lst l)
	 (m (max (car (sort (copy-list lst) #'>)))))
    (ceiling (log m 2.0))))

(defun push-zeros (lon len)
  (if (= (length lon) len)
      lon
      (push-zeros (cons 0 lon)
		  len)))

(defun natural->bit-list (n)
  (let ((res nil))
    (do* ((q n (truncate (/ q 2.0)))
	  (r (mod q 2) (mod q 2)))
	 ((<= q 0) res)
      (push r res))))

;; truth tables
(defun print-truth-table (op)
  (case op
    ('and (print-tt-and))
    ('or (print-tt-or))
    ('not (print-tt-not))
    ('nand (print-tt-nand))
    ('nor (print-tt-nor))
    (t (progn
	 (format t "unrecognized argument to print-truth-table~%")
	 (format t "acceptable values: 'and, 'or, 'not, 'nand, 'nor.")))))

(defun print-tt-and ()
  (format t "|___|___|_______|~%")
  (format t "| x | y | x * y |~%")
  (format t "|___|___|_______|~%")
  (format t "| 0 | 0 |   0   |~%")
  (format t "| 0 | 1 |   0   |~%")
  (format t "| 1 | 0 |   0   |~%")
  (format t "| 1 | 1 |   1   |~%")
  (format t "|___|___|_______|~%"))


(defun print-tt-or ()
  (format t "|___|___|_______|~%")
  (format t "| x | y | x V y |~%")
  (format t "|___|___|_______|~%")
  (format t "| 0 | 0 |   0   |~%")
  (format t "| 0 | 1 |   1   |~%")
  (format t "| 1 | 0 |   1   |~%")
  (format t "| 1 | 1 |   1   |~%")
  (format t "|___|___|_______|~%"))

(defun print-tt-not ()
  (format t "|___|_______|~%")
  (format t "| x |  ~~x   |~%")
  (format t "|___|_______|~%")
  (format t "| 0 |   1   |~%")
  (format t "| 1 |   0   |~%")
  (format t "|___|_______|~%"))


(defun print-tt-nand ()
  (format t "|___|___|___________|~%")
  (format t "| x | y | x NAND y  |~%")
  (format t "|___|___|___________|~%")
  (format t "| 0 | 0 |    1      |~%")
  (format t "| 0 | 1 |    1      |~%")
  (format t "| 1 | 0 |    1      |~%")
  (format t "| 1 | 1 |    0      |~%")
  (format t "|___|___|___________|~%"))

(defun print-tt-nor ()
  (format t "|___|___|___________|~%")
  (format t "| x | y | x NOR y   |~%")
  (format t "|___|___|___________|~%")
  (format t "| 0 | 0 |    1      |~%")
  (format t "| 0 | 1 |    0      |~%")
  (format t "| 1 | 0 |    0      |~%")
  (format t "| 1 | 1 |    0      |~%")
  (format t "|___|___|___________|~%"))