Boolean Algebra

https://github.com/natefusion/boolean
This project has some experiments with parsing of mathematical expressions, executing boolean algebra, and term rewriting.

Expression parsing

Expression parsing is handled by the following functions:
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
(defun notation (exp &optional vars)
  (let (variables)
    (labels ((infix-binding-power (op)
               (case op
                 (or (values 1 2))
                 ((and xor) (values 3 4))
                 (|)| (values nil nil '|)|))
                 (t (values 3 4 'implicit-*))))
             (postfix-binding-power (op)
               (case op
                 (not 10)
                 (t nil)))
             (infix->prefix (min-bp)
               (loop with lhs = (let ((lhs (pop exp)))
                                  (case lhs
                                    (|(| (prog1 (infix->prefix 0)
                                           (unless (eq (pop exp) '|)|)
                                             (error "No closing parenthesis somewhere lol"))))
                                    ((or and xor) (list lhs (infix->prefix lhs)))
                                    (t lhs)))
                     for op = (car exp)
                     do (unless op (loop-finish))
                        (block thing
                          (multiple-value-bind (lhs-bp) (postfix-binding-power op)
                            (when lhs-bp
                              (when (< lhs-bp min-bp)
                                (loop-finish))
                              (pop exp)
                              (setf lhs (list op lhs))
                              (return-from thing)))
                          (multiple-value-bind (lhs-bp rhs-bp special) (infix-binding-power op)
                            (cond ((or (eq special '|)|) (< lhs-bp min-bp))
                                   (loop-finish))
                                  ((eq special 'implicit-*)
                                   (setf op 'and))
                                  (t
                                   (pop exp)))
                            (setf lhs (list op lhs (infix->prefix rhs-bp)))))
                     finally (return lhs)))
             (lex (exp)
               (loop for x across exp
                     append (if (alpha-char-p x)
                                (let ((a (read-from-string (string x))))
                                  (pushnew a variables)
                                  (list a))
                                (case x
                                  ((#\') '(not))
                                  ((#\+) '(or))
                                  ((#\*) '(and))
                                  ((#\^) '(xor))
                                  ((#\() '(|(|))
                                  ((#\)) '(|)|))
                                  ((#\0) '(nil))
                                  ((#\1) '(t))
                                  ((#\space))
                                  (t (error "wot in tarnation is '~a' doing here" x)))))))
      (setf exp (lex exp))
      (list (mapcar (lambda (x) (read-from-string (string x)))
                    (sort (union vars variables) #'var<=))
                                                   (infix->prefix 0)))))

Execution

Term rewriting