catsdogshanoi.clj

;;;
;;; Blog post at http://wp.me/p12FcK-3
;;;
;;; Loom: http://github.com/jkk/loom
;;; GraphViz: http://graphviz.org
;;; Ubigraph: http://ubietylab.net/ubigraph/
;;;

(ns user
  (:use [clojure.string :only [lower-case split-lines join]]
        [loom.graph :only [graph fly-graph neighbors]]
        [loom.attr :only [hilite-path add-attrs-to-all]]
        [loom.io :only [view]])
  (:require [loom.io.ubigraph :as ubi]))

;;;
;;; Kata from http://codekata.pragprog.com/2007/01/kata_nineteen_w.html
;;;

(def dictionary
  (->> (slurp "/usr/share/dict/words")
       split-lines
       (map lower-case)
       (into #{})))

(def alphabet "abcdefghijklmnopqrstuvwxyz")

(defn edits [^String word]
  "Returns words that differ from word by one letter. E.g.,
  cat => fat, cut, can, etc."
  (->> word
       (map-indexed (fn [i c]
                      (let [sb (StringBuilder. word)]
                        (for [altc alphabet :when (not= altc c)]
                          (str (doto sb (.setCharAt i altc)))))))
       (apply concat)
       (filter dictionary)))

;; non-lazy
(defn find-path1 [neighbors start end]
  "Return a path from start to end with the fewest hops (i.e. irrespective
  of edge weights), neighbors being a function that returns adjacent nodes"
  (loop [queue (conj clojure.lang.PersistentQueue/EMPTY start)
         preds {start nil}]
    (when-let [node (peek queue)]
      (let [nbrs (remove #(contains? preds %) (neighbors node))]
        (if (some #{end} nbrs)
          (reverse (cons end (take-while identity (iterate preds node))))
          (recur (into (pop queue) nbrs)
                 (reduce #(assoc %1 %2 node) preds nbrs)))))))

;; generalized, lazy
(defn traverse
  "Traverses a graph breadth-first from start, neighbors being a
  function that returns adjacent nodes. When f is provided, returns
  a lazy seq of (f node predecessor-map) for each node traversed. Otherwise,
  returns a lazy seq of the nodes."
  ([neighbors start]
     (traverse neighbors start (fn [n p] n)))
  ([neighbors start f]
     (letfn [(step [queue preds]
               (when-let [node (peek queue)]
                 (cons (f node preds)
                       (lazy-seq
                        (let [nbrs (remove #(contains? preds %) (neighbors node))]
                          (step (into (pop queue) nbrs)
                                (reduce #(assoc %1 %2 node) preds nbrs)))))))]
       (step (conj clojure.lang.PersistentQueue/EMPTY start)
             {start nil}))))

;; makes use of lazy traverse
(defn find-path
  "Return a path from start to end with the fewest hops (i.e. irrespective
  of edge weights), neighbors being a function that returns adjacent nodes"
  [neighbors start end]
  (when-let [preds (some (fn [[n p]] (when (p end) p))
                         (traverse neighbors start vector))]
    (reverse (take-while identity (iterate preds end)))))

;;;
;;; Visualization -- requires Loom + GraphViz
;;;

(def word-chains (fly-graph :nodes dictionary :neighbors edits))

(defn path-sample
  [g path]
  (apply graph (mapcat #(for [nbr (neighbors g %)] [% nbr]) path)))

(defn pretty-path-sample
  [g start end]
  (let [path (find-path (neighbors g) start end)]
    (-> g
        (path-sample path)
        (add-attrs-to-all
         :color "#00000055"
         :fontcolor "#000000aa"
         :fontname :arial)
        (hilite-path path))))

#_(view
   (pretty-path-sample word-chains "cat" "dog")
   :alg :sfdp
   :graph {:smoothing :triangle :K 1})

;;;
;;; Towers of Hanoi solver
;;;

(defn moves
  [state]
  (for [[from-peg disk] (map-indexed #(vector %1 (first %2)) state)
        to-peg (range (count state))
        :when (and disk
                   (not= from-peg to-peg)
                   (or (empty? (state to-peg))
                       (< disk (first (state to-peg)))))]
    (-> state
        (update-in [from-peg] disj disk)
        (update-in [to-peg] conj disk))))

(defn solve
  [num-disks num-pegs]
  (let [start (into [(apply sorted-set (range num-disks))]
                    (repeat (dec num-pegs) (sorted-set)))
        end (-> start
                (assoc (dec num-pegs) (first start))
                (assoc 0 (sorted-set)))]
    (find-path moves start end)))

(defn draw
  [num-disks bchar state]
  (str
   (join "\n"
         (for [row (range num-disks)]
           (join " "
                 (for [peg (range (count state))]
                   (let [pad (- num-disks (count (state peg)))
                         bsize (first (keep-indexed
                                       #(when (= row (+ pad %1)) %2)
                                       (state peg)))
                         bsize (inc (or bsize -1))]
                     (format (str \% num-disks \s)
                             (join (repeat bsize bchar))))))))
   "\n"
   (join (repeat (+ 2 (dec num-disks) (* (count state) num-disks)) \'))))

#_(doseq [step (solve 3 3)]
    (println (draw 3 \# step)))

;; requires Loom + GraphViz
(defn view-hanoi
  [num-disks num-pegs]
  (let [start (into [(apply sorted-set (range num-disks))]
                    (repeat (dec num-pegs) (sorted-set)))
        end (-> start
                (assoc (dec num-pegs) (first start))
                (assoc 0 (sorted-set)))
        hg (fly-graph :neighbors moves :start start)]
    (view (-> hg
              (hilite-path (find-path (neighbors hg) start end))
              (add-attrs-to-all :fontname "menlo" :fontsize 6 :margin 0))
          :alg :neato
          :node-label (partial draw num-disks \u25a0))))

#_(view-hanoi 3 3)

;;
;; Realtime-ish visualization w/ Ubigraph
;;

(defn ubi-find-path
  [neighbors start end & [labels?]]
  (let [node->id (atom {})
        edge->id (atom {})]
    (ubi/clear)
    (some
     (fn [[_ preds]]
       (doseq [[v u] preds]
         (when (and u (not (@node->id v)))
           (let [uid (Integer. (or (@node->id u) (ubi/call :new_vertex)))
                 vid (Integer. (ubi/call :new_vertex))]
             (when (= u start)
               (when labels?
                 (ubi/call :set_vertex_attribute uid "label" (str u)))
               (ubi/call :set_vertex_attribute uid "fontcolor" "#ffffff")
               (ubi/call :set_vertex_attribute uid "fontsize" "14"))
             (swap! node->id assoc u uid v vid)
             (let [edge-id (ubi/call :new_edge uid vid)]
               (swap! edge->id assoc [u v] (Integer. edge-id))))))
       (when (preds end)
         (doseq [[v u] (partition 2 1 (take-while identity (iterate preds end)))]
           (let [vid (@node->id v)]
             (when labels?
               (ubi/call :set_vertex_attribute vid "label" (str v)))
             (ubi/call :set_edge_attribute (@edge->id [u v]) "color" "#ffffff")
             (ubi/call :set_vertex_attribute vid "color" "#ff0000")
             (ubi/call :set_vertex_attribute vid "fontcolor" "#ff0000")
             (ubi/call :set_vertex_attribute vid "fontsize" "14")))
         true))
     (traverse neighbors start vector))))

#_(ubi-find-path edits "cat" "dog" true)


#_(def start (into [(apply sorted-set (range 6))]
                    (repeat (dec 3) (sorted-set))))
#_(def end (-> start
                (assoc (dec 3) (first start))
                (assoc 0 (sorted-set))))
#_(ubi-find-path moves start end)