rlm@170: (ns com.aurellem.run.title
rlm@170:   (:use (com.aurellem.gb gb-driver vbm)))
rlm@81: 
rlm@87: (defn first-difference [base alt summary root]
rlm@87:   (loop [branch-point root
rlm@87:          actions []]
rlm@87:     (let [base-branch (step branch-point base)
rlm@87:           base-val (summary base-branch)
rlm@87:           alt-branch (step branch-point alt)
rlm@87:           alt-val (summary alt-branch)]
rlm@87:       (if (not= base-val alt-val)
rlm@87:         [(conj actions alt) alt-branch]
rlm@87:         (recur base-branch (conj actions base))))))
rlm@81: 
rlm@87: (defn advance
rlm@87:   ([base alt summary [commands state]]
rlm@87:      (let [[c s] (first-difference base alt summary state)]
rlm@87:        [(concat commands c) s]))
rlm@87:   ([base alt [commands state]]
rlm@87:      (advance base alt AF [commands state]))
rlm@87:   ([alt [commands state]]
rlm@87:      (advance [] alt [commands state])))
rlm@81: 
rlm@87: (def scroll-text (partial advance [:b] [:a :b]))
rlm@81: 
rlm@87: (defn start [] [[] (root)])
rlm@81: 
rlm@250: (defn-memo title
rlm@250:   ([] (title (start)))
rlm@250:   ([script]
rlm@250:      (->> script
rlm@250:           (advance [] [:a])
rlm@250:           (advance [] [:start])
rlm@250:           (advance [] [:a])
rlm@250:           (advance [] [:start]))))
rlm@81: 
rlm@250: (defn-memo oak
rlm@250:   ([] (oak (title)))
rlm@250:   ([script]
rlm@250:      (->> script
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text)))
rlm@81: 
rlm@250: (defn-memo name-entry-rlm
rlm@250:   ([] (name-entry-rlm (oak)))
rlm@250:   ([script]
rlm@250:      (->> script
rlm@250:           (advance [] [:a])
rlm@250:           (advance [] [:r] DE)
rlm@250:           (play-moves
rlm@250:            [[]
rlm@250:             [:r] [] [:r] [] [:r] [] [:r] []
rlm@250:             [:r] [] [:r] [] [:r] [] [:d] [:a]  
rlm@250:             [:l] [] [:l] [] [:l] [] [:l] []
rlm@250:             [:l] [] [:l] [:a] [] [:r] [:a]
rlm@250:             [:r] [] [:r] [] [:r] [] [:r] []
rlm@250:             [:r] [] [:d] [] [:d] [] [:d] [:a]]))))
rlm@91: 
rlm@250: (defn-memo name-entry-ash
rlm@250:   ([] (name-entry-ash (oak)))
rlm@250:   ([script]
rlm@250:      (->> script
rlm@250:           (advance [] [:d])
rlm@250:           (advance [] [:d])
rlm@250:           (advance [] [:a]))))
rlm@91:        
rlm@250: (defn-memo rival-name-entry-gary
rlm@250:   ([] (rival-name-entry-gary (name-entry-ash)))
rlm@250:   ([script]
rlm@250:      (->> script
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           (advance [] [:d])
rlm@250:           (advance [] [:d])
rlm@250:           (advance [] [:a]))))
rlm@250:   
rlm@250: (defn-memo rival-name-entry-blue
rlm@250:   ([] (rival-name-entry-blue (name-entry-ash)))
rlm@250:   ([script]
rlm@250:      (->> script
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           (advance [] [:d])
rlm@250:           (advance [] [:a]))))
rlm@81: 
rlm@250: (defn-memo finish-title
rlm@250:   ([] (finish-title (rival-name-entry-blue)))
rlm@250:   ([script]
rlm@250:      (->> script
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text
rlm@250:           scroll-text)))
rlm@91: 
rlm@250: (def title-frames 2194)
rlm@89: 
rlm@89: (defn title-checkpoint! []
rlm@88:   (let [[moves state] (finish-title)]
rlm@250:     (assert (= title-frames (count moves)))
rlm@250:     [(write-moves! moves "title-checkpoint")
rlm@250:      (write-state! state "title-checkpoint")]))
rlm@88: 
rlm@88: (defn intro []
rlm@250:   [(read-moves "title-checkpoint")
rlm@250:    (read-state "title-checkpoint")])
rlm@88: 
rlm@88: (defn test-intro []
rlm@88:   (play-vbm (moves->filename title-frames)))
rlm@88: 
rlm@87: ;; TODO might be able to glue these together more elegantly with monads
rlm@87: