Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
;;;
;;; 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment