Mercurial > vba-clojure

annotate clojure/com/aurellem/title.clj @ 113:0831da75d2c5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
completed frame-counting machine language program with dylan's help
author Robert McIntyre <rlm@mit.edu>
date Fri, 16 Mar 2012 00:43:28 -0500
parents 613353b7e012
children
rev   line source
rlm@81 1 (ns com.aurellem.title
rlm@81 2 (:use (com.aurellem 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@88 28 (defn-memo title []
rlm@88 29 (->> (start)
rlm@87 30 (advance [] [:a])
rlm@87 31 (advance [] [:start])
rlm@87 32 (advance [] [:a])
rlm@87 33 (advance [] [:start])))
rlm@81 34
rlm@88 35 (defn-memo oak []
rlm@87 36 (->> (title)
rlm@87 37 scroll-text
rlm@87 38 scroll-text
rlm@87 39 scroll-text
rlm@87 40 scroll-text
rlm@87 41 scroll-text
rlm@87 42 scroll-text
rlm@87 43 scroll-text
rlm@87 44 scroll-text
rlm@87 45 scroll-text
rlm@87 46 scroll-text
rlm@87 47 scroll-text
rlm@87 48 scroll-text
rlm@87 49 scroll-text
rlm@91 50 ))
rlm@81 51
rlm@91 52 (defn-memo name-entry-rlm []
rlm@87 53 (->> (oak)
rlm@91 54 (advance [] [:a])
rlm@87 55 (advance [] [:r] DE)
rlm@87 56 (play-moves
rlm@87 57 [[]
rlm@87 58 [:r] [] [:r] [] [:r] [] [:r] []
rlm@87 59 [:r] [] [:r] [] [:r] [] [:d] [:a]
rlm@87 60 [:l] [] [:l] [] [:l] [] [:l] []
rlm@87 61 [:l] [] [:l] [:a] [] [:r] [:a]
rlm@87 62 [:r] [] [:r] [] [:r] [] [:r] []
rlm@87 63 [:r] [] [:d] [] [:d] [] [:d] [:a]
rlm@87 64 ])))
rlm@91 65
rlm@91 66 (defn-memo name-entry-ash []
rlm@91 67 (->> (oak)
rlm@91 68 (advance [] [:d])
rlm@91 69 (advance [] [:d])
rlm@91 70 (advance [] [:a])))
rlm@91 71
rlm@91 72 (defn-memo rival-name-entry-gary []
rlm@91 73 (->> (name-entry-ash)
rlm@87 74 scroll-text
rlm@87 75 scroll-text
rlm@87 76 scroll-text
rlm@87 77 scroll-text
rlm@87 78 scroll-text
rlm@87 79 (advance [] [:d])
rlm@87 80 (advance [] [:d])
rlm@87 81 (advance [] [:a])))
rlm@81 82
rlm@91 83 (defn-memo rival-name-entry-blue []
rlm@91 84 (->> (name-entry-ash)
rlm@91 85 scroll-text
rlm@91 86 scroll-text
rlm@91 87 scroll-text
rlm@91 88 scroll-text
rlm@91 89 scroll-text
rlm@91 90 (advance [] [:d])
rlm@91 91 (advance [] [:a])))
rlm@91 92
rlm@87 93 (defn-memo finish-title []
rlm@91 94 (->> (rival-name-entry-blue)
rlm@87 95 scroll-text
rlm@87 96 scroll-text
rlm@87 97 scroll-text
rlm@87 98 scroll-text
rlm@87 99 scroll-text
rlm@87 100 scroll-text
rlm@87 101 scroll-text))
rlm@81 102
rlm@89 103 (def title-frames 2323)
rlm@89 104
rlm@89 105 (defn title-checkpoint! []
rlm@88 106 (let [[moves state] (finish-title)]
rlm@89 107 (assert (= title-frames (:frame state)))
rlm@88 108 [(write-moves! moves) (write-state! state)]))
rlm@88 109
rlm@88 110 (defn intro []
rlm@88 111 [(read-moves title-frames)
rlm@88 112 (read-state title-frames)])
rlm@88 113
rlm@88 114 (defn test-intro []
rlm@88 115 (play-vbm (moves->filename title-frames)))
rlm@88 116
rlm@87 117 ;; TODO might be able to glue these together more elegantly with monads
rlm@87 118