Clojure implementation of the Blocks World Keyboard Exercise from Common Lisp: A Gentle Introduction to Symbolic Computing

core.clj

(ns blocks-world.core)

(def ^:private database
  "The blocks database."
  [[:b1 :shape :brick]
   [:b1 :color :green]
   [:b1 :size :small]
   [:b1 :supported-by :b2]
   [:b1 :supported-by :b3]
   [:b2 :shape :brick]
   [:b2 :color :red]
   [:b2 :size :small]
   [:b2 :supports :b1]
   [:b2 :left-of :b3]
   [:b3 :shape :brick]
   [:b3 :color :red]
   [:b3 :size :small]
   [:b3 :supports :b1]
   [:b3 :right-of :b2]
   [:b4 :shape :pyramid]
   [:b4 :color :blue]
   [:b4 :size :large]
   [:b4 :supported-by :b5]
   [:b5 :shape :cube]
   [:b5 :color :green]
   [:b5 :size :large]
   [:b5 :supports :b4]
   [:b6 :shape :brick]
   [:b6 :color :purple]
   [:b6 :size :large]])

(defn- match-element
  "Return true if two elements match (including if the second is :?)."
  [e1 e2]
  (or (= e1 e2)
      (= e2 :?)))

(defn- match-triple
  "Return true if ASSERTION matches PATTERN."
  [assertion pattern]
  (every? true? (map match-element assertion pattern)))

(defn- fetch
  "Return all the assertions in the database that match PATTERN."
  [pattern]
  (filter #(match-triple % pattern) database))

(defn- color-pattern-for-block
  "Return the pattern that will match the color of BLOCK."
  [block]
  [block :color :?])

(defn supporters
  "Return the blocks that support BLOCK."
  [block]
  (map first
       (fetch [:? :supports block])))

(defn supported-by-cube?
  "Is BLOCK supported by a cube?"
  [block]
  (not-every? empty?
              (map #(fetch [% :shape :cube])
                   (supporters block))))

(defn- desc-1
  [block]
  (fetch [block :? :?]))

(defn- desc-2
  [block]
  (map rest
       (desc-1 block)))

(defn description
  "BLOCK's description."
  [block]
  (apply concat
         (desc-2 block)))