Mercurial > vba-clojure

annotate clojure/com/aurellem/run/title.clj @ 280:d5e5c73af7e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
reorginazed save corruption code
author Robert McIntyre <rlm@mit.edu>
date Tue, 27 Mar 2012 21:08:44 -0500
parents c7b002525041
children 8e63b0bb8ea3
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@256 24 (defn scroll-text
rlm@256 25 ([script]
rlm@256 26 (advance [:b] [:a :b] script))
rlm@256 27 ([n script]
rlm@256 28 (reduce (fn [script _]
rlm@256 29 (scroll-text script))
rlm@256 30 script
rlm@256 31 (range n))))
rlm@81 32
rlm@87 33 (defn start [] [[] (root)])
rlm@81 34
rlm@250 35 (defn-memo title
rlm@250 36 ([] (title (start)))
rlm@250 37 ([script]
rlm@250 38 (->> script
rlm@250 39 (advance [] [:a])
rlm@250 40 (advance [] [:start])
rlm@250 41 (advance [] [:a])
rlm@250 42 (advance [] [:start]))))
rlm@81 43
rlm@250 44 (defn-memo oak
rlm@250 45 ([] (oak (title)))
rlm@250 46 ([script]
rlm@250 47 (->> script
rlm@256 48 (scroll-text 13))))
rlm@81 49
rlm@250 50 (defn-memo name-entry-rlm
rlm@250 51 ([] (name-entry-rlm (oak)))
rlm@250 52 ([script]
rlm@250 53 (->> script
rlm@250 54 (advance [] [:a])
rlm@250 55 (advance [] [:r] DE)
rlm@250 56 (play-moves
rlm@250 57 [[]
rlm@250 58 [:r] [] [:r] [] [:r] [] [:r] []
rlm@250 59 [:r] [] [:r] [] [:r] [] [:d] [:a]
rlm@250 60 [:l] [] [:l] [] [:l] [] [:l] []
rlm@250 61 [:l] [] [:l] [:a] [] [:r] [:a]
rlm@250 62 [:r] [] [:r] [] [:r] [] [:r] []
rlm@250 63 [:r] [] [:d] [] [:d] [] [:d] [:a]]))))
rlm@91 64
rlm@250 65 (defn-memo name-entry-ash
rlm@250 66 ([] (name-entry-ash (oak)))
rlm@250 67 ([script]
rlm@250 68 (->> script
rlm@250 69 (advance [] [:d])
rlm@250 70 (advance [] [:d])
rlm@250 71 (advance [] [:a]))))
rlm@91 72
rlm@250 73 (defn-memo rival-name-entry-gary
rlm@250 74 ([] (rival-name-entry-gary (name-entry-ash)))
rlm@250 75 ([script]
rlm@250 76 (->> script
rlm@256 77 (scroll-text 5)
rlm@250 78 (advance [] [:d])
rlm@250 79 (advance [] [:d])
rlm@250 80 (advance [] [:a]))))
rlm@250 81
rlm@250 82 (defn-memo rival-name-entry-blue
rlm@250 83 ([] (rival-name-entry-blue (name-entry-ash)))
rlm@250 84 ([script]
rlm@250 85 (->> script
rlm@256 86 (scroll-text 5)
rlm@250 87 (advance [] [:d])
rlm@250 88 (advance [] [:a]))))
rlm@81 89
rlm@250 90 (defn-memo finish-title
rlm@250 91 ([] (finish-title (rival-name-entry-blue)))
rlm@250 92 ([script]
rlm@250 93 (->> script
rlm@256 94 (scroll-text 7))))
rlm@256 95
rlm@250 96 (def title-frames 2194)
rlm@89 97
rlm@89 98 (defn title-checkpoint! []
rlm@88 99 (let [[moves state] (finish-title)]
rlm@250 100 (assert (= title-frames (count moves)))
rlm@250 101 [(write-moves! moves "title-checkpoint")
rlm@250 102 (write-state! state "title-checkpoint")]))
rlm@88 103
rlm@88 104 (defn intro []
rlm@250 105 [(read-moves "title-checkpoint")
rlm@250 106 (read-state "title-checkpoint")])
rlm@88 107
rlm@88 108 (defn test-intro []
rlm@254 109 (play-vbm (moves-filename "title-checkpoint")))
rlm@88 110
rlm@87 111 ;; TODO might be able to glue these together more elegantly with monads
rlm@87 112