view clojure/com/aurellem/title.clj @ 87:e8855121f413

collect cruft, rename other files
author Robert McIntyre <rlm@mit.edu>
date Sat, 10 Mar 2012 14:48:17 -0600
parents 04d539d26bdc
children 65c2854c5875
line wrap: on
line source
1 (ns com.aurellem.title
2 (:use (com.aurellem gb-driver vbm)))
4 (defn first-difference [base alt summary root]
5 (loop [branch-point root
6 actions []]
7 (let [base-branch (step branch-point base)
8 base-val (summary base-branch)
9 alt-branch (step branch-point alt)
10 alt-val (summary alt-branch)]
11 (if (not= base-val alt-val)
12 [(conj actions alt) alt-branch]
13 (recur base-branch (conj actions base))))))
15 (defn advance
16 ([base alt summary [commands state]]
17 (let [[c s] (first-difference base alt summary state)]
18 [(concat commands c) s]))
19 ([base alt [commands state]]
20 (advance base alt AF [commands state]))
21 ([alt [commands state]]
22 (advance [] alt [commands state])))
24 (def scroll-text (partial advance [:b] [:a :b]))
26 (defn start [] [[] (root)])
28 (defn-memo title [start]
29 (->> start
30 (advance [] [:a])
31 (advance [] [:start])
32 (advance [] [:a])
33 (advance [] [:start])))
35 (defn-memo oak [start]
36 (->> (title)
37 scroll-text
38 scroll-text
39 scroll-text
40 scroll-text
41 scroll-text
42 scroll-text
43 scroll-text
44 scroll-text
45 scroll-text
46 scroll-text
47 scroll-text
48 scroll-text
49 scroll-text
50 (advance [] [:a])))
52 (defn-memo name-entry []
53 (->> (oak)
54 (advance [] [:r] DE)
55 (play-moves
56 [[]
57 [:r] [] [:r] [] [:r] [] [:r] []
58 [:r] [] [:r] [] [:r] [] [:d] [:a]
59 [:l] [] [:l] [] [:l] [] [:l] []
60 [:l] [] [:l] [:a] [] [:r] [:a]
61 [:r] [] [:r] [] [:r] [] [:r] []
62 [:r] [] [:d] [] [:d] [] [:d] [:a]
63 ])))
65 (defn-memo rival-name-entry []
66 (->> (name-entry)
67 scroll-text
68 scroll-text
69 scroll-text
70 scroll-text
71 scroll-text
72 (advance [] [:d])
73 (advance [] [:d])
74 (advance [] [:a])))
76 (defn-memo finish-title []
77 (->> (rival-name-entry)
78 scroll-text
79 scroll-text
80 scroll-text
81 scroll-text
82 scroll-text
83 scroll-text
84 scroll-text))
86 (defn-memo intro []
87 (-> (start) title oak name-entry rival-name-entry finish-title))
90 ;; TODO might be able to glue these together more elegantly with monads