Mercurial > vba-clojure

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
collect cruft, rename other files
author Robert McIntyre <rlm@mit.edu>
date Sat, 10 Mar 2012 14:48:17 -0600
parents 04d539d26bdc
children 65c2854c5875
comparison
equal deleted inserted replaced
86:9864032ef3c8 87:e8855121f413
1 (ns com.aurellem.title 1 (ns com.aurellem.title
2 (:use (com.aurellem gb-driver vbm))) 2 (:use (com.aurellem gb-driver vbm)))
3 3
4 (defn delayed-key 4 (defn first-difference [base alt summary root]
5 ([key delay total] 5 (loop [branch-point root
6 (concat (repeat delay []) [key] (repeat (- total delay 1) []))) 6 actions []]
7 ([key total] 7 (let [base-branch (step branch-point base)
8 (delayed-key key (dec total) total))) 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))))))
9 14
10 (defn no-action [length] 15 (defn advance
11 (repeat length [])) 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])))
12 23
13 (defn start-summary [] 24 (def scroll-text (partial advance [:b] [:a :b]))
14 (nth (registers) 2))
15 25
16 (defn common-initial-elements [baseline moves] 26 (defn start [] [[] (root)])
17 (loop [common 0 b baseline m moves] 27
18 (if (empty? m) common 28 (defn-memo title [start]
19 (if (= (first b) (first m)) 29 (->> start
20 (recur (inc common) (rest b) (rest m)) 30 (advance [] [:a])
21 common)))) 31 (advance [] [:start])
22 32 (advance [] [:a])
23 (defn earliest-press 33 (advance [] [:start])))
24 [start-frame 34
25 end-frame 35 (defn-memo oak [start]
26 key 36 (->> (title)
27 summary-fn] 37 scroll-text
28 (let [action-length (- end-frame start-frame) 38 scroll-text
29 baseline (no-action action-length)] 39 scroll-text
30 (print "establishing baseline...") 40 scroll-text
31 (play-moves start-frame baseline) 41 scroll-text
32 (let [bad-value (summary-fn)] 42 scroll-text
33 (println bad-value) 43 scroll-text
34 (loop [n 0] 44 scroll-text
35 (let [moves (delayed-key key n action-length) 45 scroll-text
36 header-length 46 scroll-text
37 (common-initial-elements moves baseline)] 47 scroll-text
38 (print "length" (inc n) "...") 48 scroll-text
39 (without-saves 49 scroll-text
40 (play-moves 50 (advance [] [:a])))
41 (+ start-frame header-length) 51
42 (drop header-length moves))) 52 (defn-memo name-entry []
43 (let [result (summary-fn)] 53 (->> (oak)
44 (println result) 54 (advance [] [:r] DE)
45 (if (not= result bad-value) 55 (play-moves
46 (let [keys (delayed-key key (inc n))] 56 [[]
47 (play-moves start-frame keys) 57 [:r] [] [:r] [] [:r] [] [:r] []
48 keys) 58 [:r] [] [:r] [] [:r] [] [:d] [:a]
49 (recur (inc n))))))))) 59 [:l] [] [:l] [] [:l] [] [:l] []
60 [:l] [] [:l] [:a] [] [:r] [:a]
61 [:r] [] [:r] [] [:r] [] [:r] []
62 [:r] [] [:d] [] [:d] [] [:d] [:a]
63 ])))
64
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])))
75
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))
85
86 (defn-memo intro []
87 (-> (start) title oak name-entry rival-name-entry finish-title))
50 88
51 89
52 (defn search-first 90 ;; TODO might be able to glue these together more elegantly with monads
53 [start-frame
54 baseline
55 gen-move-fn
56 summary-fn]
57 (print "establishing baseline...")
58 (play-moves start-frame baseline)
59 (let [bad-value (summary-fn)]
60 (println bad-value)
61 (loop [n 0]
62 (let [trial-moves (gen-move-fn n)
63 header-length
64 (common-initial-elements trial-moves baseline)]
65 (print "length" (inc n) "...")
66 (without-saves
67 (play-moves
68 (+ start-frame header-length)
69 (drop header-length trial-moves)))
70 (let [result (summary-fn)]
71 (println result)
72 (if (not= result bad-value)
73 (let [keys (take (inc n) trial-moves)]
74 (play-moves start-frame keys)
75 keys)
76 (recur (inc n))))))))
77 91
78 (defn title-search
79 [start-frame
80 end-frame
81 key
82 summary-fn]
83 (let [action-length (- end-frame start-frame)]
84 (search-first
85 start-frame
86 (no-action action-length)
87 (fn [n] (delayed-key key n action-length))
88 summary-fn)))
89
90 (defn gen-title []
91 (let [start0 (no-action 300)]
92 (play-moves 0 start0)
93 (let [start->first-press
94 (title-search (frame) (+ 50 (frame)) [:a] start-summary)
95 first-press->second-press
96 (title-search (frame) (+ 100 (frame)) [:start] start-summary)
97 second-press->third-press
98 (title-search (frame) (+ 151 (frame)) [:a] start-summary)
99 new-game
100 (title-search (frame) (+ 151 (frame)) [:a] start-summary)]
101 (concat
102 start0
103 start->first-press
104 first-press->second-press
105 second-press->third-press
106 new-game))))
107
108 (def title
109 [[] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
110 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
111 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
112 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
113 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
114 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
115 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
116 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
117 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
118 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
119 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
120 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
121 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
122 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
123 [] [] [] [] [] [] [] [] [] [] [] [] [] [ :a] [] [] [] [] [] [] []
124 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
125 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
126 [] [] [] [] [] [] [] [] [] [:start] [] [] [] [] [] [] [] [] [] []
127 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
128 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
129 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
130 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
131 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
132 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
133 [] [] [] [] [ :a] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
134 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
135 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
136 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
137 [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
138 [] [] [] [] [] [ :a]])
139
140
141 (require '(clojure [zip :as zip]))