Mercurial > vba-clojure

annotate clojure/com/aurellem/run/title.clj @ 250:b7f682bb3090

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
updated title and save_corruption to work with all the recent updates
author Robert McIntyre <rlm@mit.edu>
date Mon, 26 Mar 2012 03:49:33 -0500
parents 09caf6a5bbf4
children 5dafe6188ca5
rev   line source
rlm@170 1 (ns com.aurellem.run.title
rlm@170 2 (:use (com.aurellem.gb gb-driver vbm)))
rlm@81 3
rlm@87 4 (defn first-difference [base alt summary root]
rlm@87 5 (loop [branch-point root
rlm@87 6 actions []]
rlm@87 7 (let [base-branch (step branch-point base)
rlm@87 8 base-val (summary base-branch)
rlm@87 9 alt-branch (step branch-point alt)
rlm@87 10 alt-val (summary alt-branch)]
rlm@87 11 (if (not= base-val alt-val)
rlm@87 12 [(conj actions alt) alt-branch]
rlm@87 13 (recur base-branch (conj actions base))))))
rlm@81 14
rlm@87 15 (defn advance
rlm@87 16 ([base alt summary [commands state]]
rlm@87 17 (let [[c s] (first-difference base alt summary state)]
rlm@87 18 [(concat commands c) s]))
rlm@87 19 ([base alt [commands state]]
rlm@87 20 (advance base alt AF [commands state]))
rlm@87 21 ([alt [commands state]]
rlm@87 22 (advance [] alt [commands state])))
rlm@81 23
rlm@87 24 (def scroll-text (partial advance [:b] [:a :b]))
rlm@81 25
rlm@87 26 (defn start [] [[] (root)])
rlm@81 27
rlm@250 28 (defn-memo title
rlm@250 29 ([] (title (start)))
rlm@250 30 ([script]
rlm@250 31 (->> script
rlm@250 32 (advance [] [:a])
rlm@250 33 (advance [] [:start])
rlm@250 34 (advance [] [:a])
rlm@250 35 (advance [] [:start]))))
rlm@81 36
rlm@250 37 (defn-memo oak
rlm@250 38 ([] (oak (title)))
rlm@250 39 ([script]
rlm@250 40 (->> script
rlm@250 41 scroll-text
rlm@250 42 scroll-text
rlm@250 43 scroll-text
rlm@250 44 scroll-text
rlm@250 45 scroll-text
rlm@250 46 scroll-text
rlm@250 47 scroll-text
rlm@250 48 scroll-text
rlm@250 49 scroll-text
rlm@250 50 scroll-text
rlm@250 51 scroll-text
rlm@250 52 scroll-text
rlm@250 53 scroll-text)))
rlm@81 54
rlm@250 55 (defn-memo name-entry-rlm
rlm@250 56 ([] (name-entry-rlm (oak)))
rlm@250 57 ([script]
rlm@250 58 (->> script
rlm@250 59 (advance [] [:a])
rlm@250 60 (advance [] [:r] DE)
rlm@250 61 (play-moves
rlm@250 62 [[]
rlm@250 63 [:r] [] [:r] [] [:r] [] [:r] []
rlm@250 64 [:r] [] [:r] [] [:r] [] [:d] [:a]
rlm@250 65 [:l] [] [:l] [] [:l] [] [:l] []
rlm@250 66 [:l] [] [:l] [:a] [] [:r] [:a]
rlm@250 67 [:r] [] [:r] [] [:r] [] [:r] []
rlm@250 68 [:r] [] [:d] [] [:d] [] [:d] [:a]]))))
rlm@91 69
rlm@250 70 (defn-memo name-entry-ash
rlm@250 71 ([] (name-entry-ash (oak)))
rlm@250 72 ([script]
rlm@250 73 (->> script
rlm@250 74 (advance [] [:d])
rlm@250 75 (advance [] [:d])
rlm@250 76 (advance [] [:a]))))
rlm@91 77
rlm@250 78 (defn-memo rival-name-entry-gary
rlm@250 79 ([] (rival-name-entry-gary (name-entry-ash)))
rlm@250 80 ([script]
rlm@250 81 (->> script
rlm@250 82 scroll-text
rlm@250 83 scroll-text
rlm@250 84 scroll-text
rlm@250 85 scroll-text
rlm@250 86 scroll-text
rlm@250 87 (advance [] [:d])
rlm@250 88 (advance [] [:d])
rlm@250 89 (advance [] [:a]))))
rlm@250 90
rlm@250 91 (defn-memo rival-name-entry-blue
rlm@250 92 ([] (rival-name-entry-blue (name-entry-ash)))
rlm@250 93 ([script]
rlm@250 94 (->> script
rlm@250 95 scroll-text
rlm@250 96 scroll-text
rlm@250 97 scroll-text
rlm@250 98 scroll-text
rlm@250 99 scroll-text
rlm@250 100 (advance [] [:d])
rlm@250 101 (advance [] [:a]))))
rlm@81 102
rlm@250 103 (defn-memo finish-title
rlm@250 104 ([] (finish-title (rival-name-entry-blue)))
rlm@250 105 ([script]
rlm@250 106 (->> script
rlm@250 107 scroll-text
rlm@250 108 scroll-text
rlm@250 109 scroll-text
rlm@250 110 scroll-text
rlm@250 111 scroll-text
rlm@250 112 scroll-text
rlm@250 113 scroll-text)))
rlm@91 114
rlm@250 115 (def title-frames 2194)
rlm@89 116
rlm@89 117 (defn title-checkpoint! []
rlm@88 118 (let [[moves state] (finish-title)]
rlm@250 119 (assert (= title-frames (count moves)))
rlm@250 120 [(write-moves! moves "title-checkpoint")
rlm@250 121 (write-state! state "title-checkpoint")]))
rlm@88 122
rlm@88 123 (defn intro []
rlm@250 124 [(read-moves "title-checkpoint")
rlm@250 125 (read-state "title-checkpoint")])
rlm@88 126
rlm@88 127 (defn test-intro []
rlm@88 128 (play-vbm (moves->filename title-frames)))
rlm@88 129
rlm@87 130 ;; TODO might be able to glue these together more elegantly with monads
rlm@87 131