1.1 --- a/clojure/com/aurellem/title.clj	Sat Mar 10 14:24:10 2012 -0600
     1.2 +++ b/clojure/com/aurellem/title.clj	Sat Mar 10 14:48:17 2012 -0600
     1.3 @@ -1,141 +1,91 @@
     1.4  (ns com.aurellem.title
     1.5    (:use (com.aurellem gb-driver vbm)))
     1.6  
     1.7 -(defn delayed-key
     1.8 -  ([key delay total]
     1.9 -     (concat (repeat delay []) [key] (repeat (- total delay 1) [])))
    1.10 -  ([key total]
    1.11 -     (delayed-key key (dec total) total)))
    1.12 +(defn first-difference [base alt summary root]
    1.13 +  (loop [branch-point root
    1.14 +         actions []]
    1.15 +    (let [base-branch (step branch-point base)
    1.16 +          base-val (summary base-branch)
    1.17 +          alt-branch (step branch-point alt)
    1.18 +          alt-val (summary alt-branch)]
    1.19 +      (if (not= base-val alt-val)
    1.20 +        [(conj actions alt) alt-branch]
    1.21 +        (recur base-branch (conj actions base))))))
    1.22  
    1.23 -(defn no-action [length]
    1.24 -  (repeat length []))
    1.25 +(defn advance
    1.26 +  ([base alt summary [commands state]]
    1.27 +     (let [[c s] (first-difference base alt summary state)]
    1.28 +       [(concat commands c) s]))
    1.29 +  ([base alt [commands state]]
    1.30 +     (advance base alt AF [commands state]))
    1.31 +  ([alt [commands state]]
    1.32 +     (advance [] alt [commands state])))
    1.33  
    1.34 -(defn start-summary []
    1.35 -  (nth (registers) 2))
    1.36 +(def scroll-text (partial advance [:b] [:a :b]))
    1.37  
    1.38 -(defn common-initial-elements [baseline moves]
    1.39 -  (loop [common 0 b baseline m moves]
    1.40 -    (if (empty? m) common
    1.41 -        (if (= (first b) (first m))
    1.42 -          (recur (inc common) (rest b) (rest m))
    1.43 -          common))))
    1.44 -    
    1.45 -(defn earliest-press
    1.46 -  [start-frame
    1.47 -   end-frame
    1.48 -   key
    1.49 -   summary-fn]
    1.50 -  (let [action-length (- end-frame start-frame)
    1.51 -        baseline (no-action action-length)]
    1.52 -    (print "establishing baseline...")
    1.53 -    (play-moves start-frame baseline)
    1.54 -    (let [bad-value (summary-fn)]
    1.55 -      (println bad-value)
    1.56 -      (loop [n 0]
    1.57 -        (let [moves (delayed-key key n action-length)
    1.58 -              header-length
    1.59 -              (common-initial-elements moves baseline)]
    1.60 -          (print "length" (inc n) "...")
    1.61 -          (without-saves
    1.62 -           (play-moves
    1.63 -            (+ start-frame header-length)
    1.64 -            (drop header-length moves)))
    1.65 -          (let [result (summary-fn)]
    1.66 -            (println result)
    1.67 -            (if (not= result bad-value)
    1.68 -              (let [keys (delayed-key key (inc n))]
    1.69 -                  (play-moves start-frame keys)
    1.70 -                  keys)
    1.71 -              (recur (inc n)))))))))
    1.72 +(defn start [] [[] (root)])
    1.73  
    1.74 +(defn-memo title [start]
    1.75 +  (->> start
    1.76 +       (advance [] [:a])
    1.77 +       (advance [] [:start])
    1.78 +       (advance [] [:a])
    1.79 +       (advance [] [:start])))
    1.80  
    1.81 -(defn search-first
    1.82 -  [start-frame
    1.83 -   baseline
    1.84 -   gen-move-fn
    1.85 -   summary-fn]
    1.86 -  (print "establishing baseline...")
    1.87 -  (play-moves start-frame baseline)
    1.88 -  (let [bad-value (summary-fn)]
    1.89 -    (println bad-value)
    1.90 -    (loop [n 0]
    1.91 -      (let [trial-moves (gen-move-fn n)
    1.92 -            header-length
    1.93 -            (common-initial-elements trial-moves baseline)]
    1.94 -        (print "length" (inc n) "...")
    1.95 -        (without-saves
    1.96 -         (play-moves
    1.97 -          (+ start-frame header-length)
    1.98 -          (drop header-length trial-moves)))
    1.99 -        (let [result (summary-fn)]
   1.100 -          (println result)
   1.101 -          (if (not= result bad-value)
   1.102 -            (let [keys (take (inc n) trial-moves)]
   1.103 -              (play-moves start-frame keys)
   1.104 -              keys)
   1.105 -            (recur (inc n))))))))
   1.106 +(defn-memo oak [start]
   1.107 +  (->> (title)
   1.108 +       scroll-text
   1.109 +       scroll-text
   1.110 +       scroll-text
   1.111 +       scroll-text
   1.112 +       scroll-text
   1.113 +       scroll-text
   1.114 +       scroll-text
   1.115 +       scroll-text
   1.116 +       scroll-text
   1.117 +       scroll-text
   1.118 +       scroll-text
   1.119 +       scroll-text
   1.120 +       scroll-text
   1.121 +       (advance [] [:a])))
   1.122  
   1.123 -(defn title-search
   1.124 -  [start-frame
   1.125 -   end-frame
   1.126 -   key
   1.127 -   summary-fn]
   1.128 -  (let [action-length (- end-frame start-frame)]
   1.129 -    (search-first
   1.130 -     start-frame
   1.131 -     (no-action action-length)
   1.132 -     (fn [n] (delayed-key key n action-length))
   1.133 -     summary-fn)))
   1.134 +(defn-memo name-entry []
   1.135 +  (->> (oak)
   1.136 +       (advance [] [:r] DE)
   1.137 +       (play-moves
   1.138 +        [[]
   1.139 +         [:r] [] [:r] [] [:r] [] [:r] []
   1.140 +         [:r] [] [:r] [] [:r] [] [:d] [:a]  
   1.141 +         [:l] [] [:l] [] [:l] [] [:l] []
   1.142 +         [:l] [] [:l] [:a] [] [:r] [:a]
   1.143 +         [:r] [] [:r] [] [:r] [] [:r] []
   1.144 +         [:r] [] [:d] [] [:d] [] [:d] [:a]
   1.145 +         ])))
   1.146 +          
   1.147 +(defn-memo rival-name-entry []
   1.148 +  (->> (name-entry)
   1.149 +       scroll-text
   1.150 +       scroll-text
   1.151 +       scroll-text
   1.152 +       scroll-text
   1.153 +       scroll-text
   1.154 +       (advance [] [:d])
   1.155 +       (advance [] [:d])
   1.156 +       (advance [] [:a])))
   1.157  
   1.158 -(defn gen-title []
   1.159 -  (let [start0 (no-action 300)]
   1.160 -    (play-moves 0 start0)
   1.161 -    (let [start->first-press
   1.162 -          (title-search (frame) (+ 50 (frame)) [:a] start-summary)
   1.163 -          first-press->second-press
   1.164 -          (title-search (frame) (+ 100 (frame)) [:start] start-summary)
   1.165 -          second-press->third-press
   1.166 -          (title-search (frame) (+ 151 (frame)) [:a] start-summary)
   1.167 -          new-game
   1.168 -          (title-search (frame) (+ 151 (frame)) [:a] start-summary)]
   1.169 -      (concat
   1.170 -       start0
   1.171 -       start->first-press
   1.172 -       first-press->second-press
   1.173 -       second-press->third-press
   1.174 -       new-game))))
   1.175 -  
   1.176 -(def title
   1.177 -  [[] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.178 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.179 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.180 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.181 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.182 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.183 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.184 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.185 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.186 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.187 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.188 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.189 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.190 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.191 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [ :a] [] [] [] [] [] [] []
   1.192 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.193 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.194 -   [] [] [] [] [] [] [] [] [] [:start] [] [] [] [] [] [] [] [] [] []
   1.195 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.196 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.197 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.198 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.199 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.200 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.201 -   [] [] [] [] [ :a] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.202 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.203 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.204 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.205 -   [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
   1.206 -   [] [] [] [] [] [ :a]])
   1.207 +(defn-memo finish-title []
   1.208 +  (->> (rival-name-entry)
   1.209 +       scroll-text
   1.210 +       scroll-text
   1.211 +       scroll-text
   1.212 +       scroll-text
   1.213 +       scroll-text
   1.214 +       scroll-text
   1.215 +       scroll-text))
   1.216  
   1.217 +(defn-memo intro []
   1.218 +  (-> (start) title oak name-entry rival-name-entry finish-title))
   1.219  
   1.220 -(require '(clojure [zip :as zip]))
   1.221 \ No newline at end of file
   1.222 +
   1.223 +;; TODO might be able to glue these together more elegantly with monads
   1.224 +