100 lines
3.2 KiB
Clojure
100 lines
3.2 KiB
Clojure
(ns clojure-sandbox.truthtables
|
|
(:require [clojure.string :as s]
|
|
[clojure.pprint :as pprint]))
|
|
|
|
;; Definitions of the logical operators
|
|
(defn !op [expr]
|
|
(not expr))
|
|
|
|
(defn |op [e1 e2]
|
|
(not (and (not e1)
|
|
(not e2))))
|
|
|
|
(defn &op [e1 e2]
|
|
(and e1 e2))
|
|
|
|
(defn ->op [e1 e2]
|
|
(if e1
|
|
e2
|
|
true))
|
|
|
|
(def operators {"!" !op
|
|
"|" |op
|
|
"&" &op
|
|
"->" ->op})
|
|
|
|
;; The evaluations of expressions always call the value method on sub-expressions
|
|
(defn evaluate-unary [operator operand valuemap]
|
|
(let [operand-value (value operand valuemap)
|
|
operator (get operators operator)]
|
|
(operator operand-value)))
|
|
|
|
(defn evaluate-binary [o1 op o2 valuemap]
|
|
(let [op1-value (value o1 valuemap)
|
|
op2-value (value o2 valuemap)
|
|
operator (get operators op)]
|
|
(operator op1-value op2-value)))
|
|
|
|
;; Protocol to handle all kinds of expressions : unary (!x), binary (x & y), symbolic (x)
|
|
(defprotocol Expression
|
|
(value [_ valuemap] "Returns boolean value of expression")) ;; this value map specifies the variables' truth values
|
|
|
|
(defrecord UnaryExpression [operator operand]
|
|
Expression
|
|
(value [self valuemap] (evaluate-unary operator operand valuemap)))
|
|
|
|
(defrecord BinaryExpression [op1 operator op2]
|
|
Expression
|
|
(value [self valuemap] (evaluate-binary op1 operator op2 valuemap)))
|
|
|
|
(defrecord SymbolExpression [operand]
|
|
Expression
|
|
(value [self valuemap] (get valuemap operand)))
|
|
|
|
|
|
;; Recursively create the right kind of boolean expression, evaluating from the right
|
|
(defn expression [inputs]
|
|
(if (contains? operators (first inputs))
|
|
(->UnaryExpression (first inputs) (expression (rest inputs)))
|
|
(if (= 1 (count inputs))
|
|
(->SymbolExpression (first inputs))
|
|
(->BinaryExpression (->SymbolExpression (first inputs)) (nth inputs 1) (expression (nthrest inputs (- (count inputs) 1)))))))
|
|
|
|
;; This won't handle brackets, so it is all evaluated right to left
|
|
(defn parse [input-str]
|
|
(-> input-str
|
|
s/trim ;; remove leading/trailing space
|
|
(s/split #"\s+"))) ;;remove intermediate spaces
|
|
|
|
(defn extract-var-names [inputs]
|
|
"Get a list of variables that can have truth value"
|
|
(->> inputs
|
|
(filter (fn[i] (not (contains? operators i))))
|
|
set))
|
|
|
|
(defn all-var-values [inputs]
|
|
"Returns a list of all potential variable assignments"
|
|
(let [vars (extract-var-names inputs)]
|
|
(loop [vars-left vars
|
|
outputs []]
|
|
(if (empty? vars-left)
|
|
outputs
|
|
(let [this-var (first vars-left)]
|
|
(if (empty? outputs)
|
|
(recur (rest vars-left) [{this-var true} {this-var false}])
|
|
(recur (rest vars-left)
|
|
(concat (map (fn[x] (assoc x this-var true)) outputs)
|
|
(map (fn[x] (assoc x this-var false)) outputs)))))))))
|
|
|
|
(defn truth-table [input]
|
|
"Print out the truth table for an input string"
|
|
(let [input-values (parse input)
|
|
value-maps (all-var-values input-values)
|
|
expression (expression input-values)]
|
|
(value expression (first value-maps))
|
|
(->> value-maps
|
|
(map (fn [x] (assoc x input (value expression x))))
|
|
pprint/print-table)))
|
|
|
|
(truth-table "! a | b") ;; interpreted as ! (a | b)
|