Mercurial > vba-clojure

comparison clojure/com/aurellem/run/title.clj @ 145:412ca096a9ba

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
major refactoring complete.
author Robert McIntyre <rlm@mit.edu>
date Mon, 19 Mar 2012 21:23:46 -0500
parents clojure/com/aurellem/title.clj@613353b7e012
children 09caf6a5bbf4
comparison
equal deleted inserted replaced
144:ec477931f077 145:412ca096a9ba
1 (ns com.aurellem.title
2 (:use (com.aurellem gb-driver vbm)))
3
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))))))
14
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])))
23
24 (def scroll-text (partial advance [:b] [:a :b]))
25
26 (defn start [] [[] (root)])
27
28 (defn-memo title []
29 (->> (start)
30 (advance [] [:a])
31 (advance [] [:start])
32 (advance [] [:a])
33 (advance [] [:start])))
34
35 (defn-memo oak []
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 ))
51
52 (defn-memo name-entry-rlm []
53 (->> (oak)
54 (advance [] [:a])
55 (advance [] [:r] DE)
56 (play-moves
57 [[]
58 [:r] [] [:r] [] [:r] [] [:r] []
59 [:r] [] [:r] [] [:r] [] [:d] [:a]
60 [:l] [] [:l] [] [:l] [] [:l] []
61 [:l] [] [:l] [:a] [] [:r] [:a]
62 [:r] [] [:r] [] [:r] [] [:r] []
63 [:r] [] [:d] [] [:d] [] [:d] [:a]
64 ])))
65
66 (defn-memo name-entry-ash []
67 (->> (oak)
68 (advance [] [:d])
69 (advance [] [:d])
70 (advance [] [:a])))
71
72 (defn-memo rival-name-entry-gary []
73 (->> (name-entry-ash)
74 scroll-text
75 scroll-text
76 scroll-text
77 scroll-text
78 scroll-text
79 (advance [] [:d])
80 (advance [] [:d])
81 (advance [] [:a])))
82
83 (defn-memo rival-name-entry-blue []
84 (->> (name-entry-ash)
85 scroll-text
86 scroll-text
87 scroll-text
88 scroll-text
89 scroll-text
90 (advance [] [:d])
91 (advance [] [:a])))
92
93 (defn-memo finish-title []
94 (->> (rival-name-entry-blue)
95 scroll-text
96 scroll-text
97 scroll-text
98 scroll-text
99 scroll-text
100 scroll-text
101 scroll-text))
102
103 (def title-frames 2323)
104
105 (defn title-checkpoint! []
106 (let [[moves state] (finish-title)]
107 (assert (= title-frames (:frame state)))
108 [(write-moves! moves) (write-state! state)]))
109
110 (defn intro []
111 [(read-moves title-frames)
112 (read-state title-frames)])
113
114 (defn test-intro []
115 (play-vbm (moves->filename title-frames)))
116
117 ;; TODO might be able to glue these together more elegantly with monads
118