Improve output and implement infix-to-prefix

This allows truth-infix macros being written and now we can entry
infix expressions!

There is no precedence evaluation of operators yet, but this works
fine.

Author: ryukinix

src/package.lisp

@@ -32,6 +32,7 @@
    :prefix-to-infix
    :print-truth-table
    :truth
+   :truth-infix
    :lookup-internal-operators
    :intern-symbol
    :main

src/parser.lisp

@@ -109,3 +109,11 @@
                (a (first-operand exp)))
            (cons op (list (prefix-to-infix a)))))
         (t (swap-operand-operator exp))))
+
+
+(defun infix-to-prefix (exp)
+    (cond ((atom exp) exp)
+          ((null (cdr exp)) (infix-to-prefix (car exp)))
+          (t (list (cadr exp)
+                   (infix-to-prefix (car exp))
+                   (infix-to-prefix (cddr exp))))))

src/truth-table.lisp

@@ -134,7 +134,11 @@
 (defun princ-n (string n)
   "Just print the STRING by N times"
   (dotimes (_ n) (princ string)))
-
+(defun print-bar (spaces)
+  (princ "+")
+  (princ-n "-" (1- (reduce #'+ spaces)))
+  (princ "+")
+  (princ #\newline))
 
 (defun print-truth-table (exp)
   "Given a EXP with prefixed notation generate
@@ -147,31 +151,36 @@
                                  for p = (princ-to-string x)
                                  collect (concatenate 'string "  " p "  |")))
          (spaces (mapcar #'length printable-header)))
-    (princ-n "-" (reduce #'+ spaces))
-    (princ #\newline)
+    (print-bar spaces)
+    (princ "|")
     (loop for exp in printable-header do (princ exp))
     (princ #\newline)
-    (princ-n "-" (reduce #'+ spaces))
-    (princ #\newline)
+    (print-bar spaces)
     (loop for n-value from 1 below n-values
-          do (progn (loop for n-exp from 0 below (length header)
-                          do (let* ((space (nth n-exp spaces))
-                                    (half-space (floor (- space 2) 2))
-                                    (val (nth n-value (nth n-exp truth-table))))
-                               (princ-n " " half-space)
-                               (princ val)
-                               (princ-n " " half-space)
-                               (if (oddp space)
-                                   (princ " |")
-                                   (princ "|"))))
-                    (princ #\newline)))
-    (princ-n "-" (reduce #'+ spaces))
-    (princ #\newline)))
+          do (progn
+               (princ "|")
+               (loop for n-exp from 0 below (length header)
+                     do (let* ((space (nth n-exp spaces))
+                               (half-space (floor (- space 2) 2))
+                               (val (nth n-value (nth n-exp truth-table))))
+                          (princ-n " " half-space)
+                          (princ val)
+                          (princ-n " " half-space)
+                          (if (oddp space)
+                              (princ " |")
+                              (princ "|"))))
+               (princ #\newline)))
+    (print-bar spaces)))
 
 (defmacro truth (exp)
   "A easy way to generate a truth table"
   `(print-truth-table (quote ,exp)))
 
+(defmacro truth-infix (exp)
+  "A easy and infix way of EXP generate a truth table.
+   Ex.: (truth-infix (p ^ q)) "
+  `(print-truth-table (infix-to-prefix (quote , exp))))
+
 (defun main ()
   (truth (=> (v p (~ q)) (=> p q)))
   (truth (^ p q))