;;; | |
;;; 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