logic-puzzle-demo.clj

(ns logic-puzzle-demo.core
  (:require [clojure.math.combinatorics :as combo]))

;; Playing around with some stuff to make logic puzzles easier

;; Inspired by http://blog.jenkster.com/2013/02/solving-logic-puzzles-with-clojures-corelogic.html
;; but then really http://programming-puzzler.blogspot.com/2013/03/logic-programming-is-overrated.html
;; Also see http://rosettacode.org/wiki/Zebra_puzzle

;;
;; A "web" is basically a hashmap with metainfo that allows easy accessing via any element.
;;
;; Given something like
;;
;;     { :bob { :name :bob :location :kitchen } :tom { :name :tom :location :living-room } }
;;
;; this means you can use (get-> the-map :kitchen) to get the :bob record.
;;

;; new-web
;;
;; Adds an empty web with the invariant keys.
;;
;; i.e.
;;
;;     (new-web :name [:bob :tom :joe]) =>
;;     { :bob { :name :bob }  :tom { :name :tom } :joe { :name :joe } }
;;
;; ... with additional metainfo 

(defn new-web [key iv]
  (with-meta 
    (into {} 
          (map #(vector %1 {key %1}) iv))
    { :iv iv :ix {} })
  )

;;
;; add-web-layer
;;
;; Given a webbed hashmap, add the vector of data elements
;;
;; (add-web-layer
;;     (new-web :name [:bob :tom])
;;     :location
;;     [:kitchen :living-room])
;;
;; This will put bob in the :kitchen and tom in the :living-room, with appropriate indexes added.
;;

(defn add-web-layer [hm key v]
  (let [new-index (into (:ix (meta hm)) (map vector v (:iv (meta hm))))]
    (loop [hm hm iv (:iv (meta hm)) v v]
      (cond
        (empty? v) (vary-meta hm assoc :ix new-index)
        :default   (let [ivk (first iv)
                         vk  (first v)
                         hm' (assoc-in hm [ivk key] vk)
                         ]
                     (recur hm' (rest iv) (rest v))
                     )
        )
      ))
  )

;;
;; get->
;;
;; Same as -> for hashmaps but uses index if not found
;;

(defn get->
  ([hm key] (or (hm key) (hm (((meta hm) :ix) key))))
  ([hm key & keys] (apply get-> (get-> hm key) keys))
  )

;;
;; eval-stream
;;
;; Runs the logic problem.  See the examples.
;;

(defn- eval-stream' [hm s]
  (if-let [[k v] (first s)]
    (cond
      (= k :when) (cond
                    (v hm) (eval-stream' hm (rest s))
                    :default nil
                    )
      :default (let [permutes (combo/permutations v)]
                 (flatten (map #(eval-stream' (add-web-layer hm k %1) (rest s)) permutes))
                 )
      )
    hm
    )
  )

(defn eval-stream [& s]
  (let [s (partition 2 s)
        [k v] (first s)]
    (remove nil? 
            (eval-stream' (new-web k v) (rest s)))
    )
  )

;;
;; Set up a logic puzzle
;;
;; The Templars were all taken out for the day during the second week of their visit, and one Templar, (Antimatter) had the good fortune to be taken out twice. Where did the Templars choose to go (in Antimatter's case, there were two choices) and when was each outing?

;; Personnel:
;;     Hexagon
;;     Jasmine
;;     Antimatter
;;     Cygnus

;; Locations:
;;     Globe Theatre
;;     London Eye
;;     Monument
;;     Tower of London
;;     Buckingham Palace

;; Days:
;;     Monday Tuesday Thursday Friday Saturday

;; Data:
;;     1. The Templar taken to the Globe Theatre isn't Cygnus, who went out the day before Hexagon.
;;     2. Antimatter's trip to the London Eye was later in the week than his visit to the Tower of London.
;;     3. Cygnus isn't the Templar who visited Buckingham Palace on Monday.
;;     4. No Templar was taken to see the Monument on Friday.

(defn logic-problem []
  (eval-stream
   :name [:hexagon :jasmine :cygnus :antimatter :antimatter2]
   :day [1 2 4 5 6]

   ;; Since Antimatter visits twice, don't permute based on him
   :when (fn [x] (< (get-> x :antimatter :day) (get-> x :antimatter2 :day)))
   
   :location [:globe-theater :london-eye :monument :tower-of-london :buckingham-palace]
   
   ;; Antimatter's trip to the London Eye was later in the week than his visit to the Tower of London.
   :when (fn [x] (= (get-> x :antimatter :location) :tower-of-london))
   :when (fn [x] (= (get-> x :antimatter2 :location) :london-eye))

   ;; The Templar taken to the Globe Theatre isn't Cygnus, who went out the day before Hexagon
   :when (fn [x] (not= (get-> x :cygnus :location) :globe-theater))
   :when (fn [x] (== (+ 1 (get-> x :cygnus :day)) (get-> x :hexagon :day)))
   
   ;; Cygnus isn't the Templar who visited Buckingham Palace on Monday.
   :when (fn [x] (= (get-> x :buckingham-palace :day) 1))
   :when (fn [x] (not= (get-> x :cygnus :day) 1))

   ;; No Templar was taken to see the Monument on Friday.
   :when (fn [x] (not= (get-> x :monument :day) 5))
   )
  )

;; see http://rosettacode.org/wiki/Zebra_puzzle for problem statement

(defn zebra-problem []
  (let [next-to (fn [a b] (= 1 (Math/abs (- (:house a) (:house b)))))]
    (eval-stream
     ;; 1. There are five houses.
     :house  [1 2 3 4 5]
     :man    [:english :swede :dane :german :norwegian]
     
     ;; 3. The Norwegian lives in the first house.
     :when (fn [ans] (= (get-> ans :norwegian :house) 1))
     
     :color  [:red :green :white :yellow :blue]

     ;; 5. The green house is immediately to the left of the white house.
     :when (fn [ans] (= (+ 1 (get-> ans :green :house)) (get-> ans :white :house)))
     
     ;; 2. The English man lives in the red house.
     :when (fn [ans] (= (get-> ans :english :color) :red))

     ;; 15. The Norwegian lives next to the blue house.
     :when (fn [ans] (next-to (get-> ans :norwegian) (get-> ans :blue)))
     
     :drink  [:tea :coffee :milk :beer :water]

     ;; 4. The Dane drinks tea.
     :when (fn [ans] (=  (get-> ans :dane :drink) :tea))

     ;; 6. They drink coffee in the green house.
     :when (fn [ans] (= (get-> ans :green :drink) :coffee))
     
     ;; 9. In the middle house they drink milk.
     :when (fn [ans] (= (get-> ans :milk :house) 3))

     :smoke  [:pallmall :dunhill :blend :bluemaster :prince]

     ;; 8. In the yellow house they smoke Dunhill.
     :when (fn [ans] (= (get-> ans :yellow :smoke) :dunhill))

     ;; 13. The man who smokes Blue Master drinks beer.
     :when (fn [ans] (= (get-> ans :bluemaster :drink) :beer))

     ;; 14. The German smokes Prince.
     :when (fn [ans] (= (get-> ans :german :smoke) :prince))
     
     ;; 16. They drink water in a house next to the house where they smoke Blend.
     :when (fn [ans] (next-to (get-> ans :blend) (get-> ans :water)))
     
     :animal [:dog :birds :cats :horse :zebra]

     ;; 3. The Swede has a dog.
     :when (fn [ans] (= (get-> ans :swede :animal) :dog))

     ;; 7. The man who smokes Pall Mall has birds.
     :when (fn [ans] (= (get-> ans :pallmall :animal) :birds))

     ;; 11. The man who smokes Blend lives in the house next to the house with cats.
     :when (fn [ans] (next-to (get-> ans :blend) (get-> ans :cats)))

     ;; 12. In a house next to the house where they have a horse, they smoke Dunhill.
     :when (fn [ans] (next-to (get-> ans :horse) (get-> ans :dunhill)))
     ))
)