Mercurial > vba-clojure

     1 (ns com.aurellem.run.title

     2   (:use (com.aurellem.gb gb-driver vbm)))

     3 

     4 (defn first-difference [base alt summary root]

     5   (loop [branch-point root

     6          actions []]

     7     (let [base-branch (step branch-point base)

     8           base-val (summary base-branch)

     9           alt-branch (step branch-point alt)

    10           alt-val (summary alt-branch)]

    11       (if (not= base-val alt-val)

    12         [(conj actions alt) alt-branch]

    13         (recur base-branch (conj actions base))))))

    14 

    15 (defn advance

    16   ([base alt summary [commands state]]

    17      (let [[c s] (first-difference base alt summary state)]

    18        [(concat commands c) s]))

    19   ([base alt [commands state]]

    20      (advance base alt AF [commands state]))

    21   ([alt [commands state]]

    22      (advance [] alt [commands state])))

    23 

    24 (defn scroll-text

    25   ([script]

    26      (advance [:b] [:a :b] script))

    27   ([n script]

    28      (reduce (fn [script _]

    29                (scroll-text script))

    30              script

    31              (range n))))

    32 

    33 (defn start [] [[] (root)])

    34 

    35 (defn-memo title

    36   ([] (title (start)))

    37   ([script]

    38      (->> script

    39           (advance [] [:a])

    40           (advance [] [:start])

    41           (advance [] [:a])

    42           (advance [] [:start]))))

    43 

    44 (defn-memo oak

    45   ([] (oak (title)))

    46   ([script]

    47      (->> script

    48           (scroll-text 13))))

    49 

    50 (defn-memo name-entry-rlm

    51   ([] (name-entry-rlm (oak)))

    52   ([script]

    53      (->> script

    54           (advance [] [:a])

    55           (advance [] [:r] DE)

    56           (play-moves

    57            [[]

    58             [:r] [] [:r] [] [:r] [] [:r] []

    59             [:r] [] [:r] [] [:r] [] [:d] [:a]  

    60             [:l] [] [:l] [] [:l] [] [:l] []

    61             [:l] [] [:l] [:a] [] [:r] [:a]

    62             [:r] [] [:r] [] [:r] [] [:r] []

    63             [:r] [] [:d] [] [:d] [] [:d] [:a]]))))

    64 

    65 (defn-memo name-entry-ash

    66   ([] (name-entry-ash (oak)))

    67   ([script]

    68      (->> script

    69           (advance [] [:d])

    70           (advance [] [:d])

    71           (advance [] [:a]))))

    72        

    73 (defn-memo rival-name-entry-gary

    74   ([] (rival-name-entry-gary (name-entry-ash)))

    75   ([script]

    76      (->> script

    77           (scroll-text 5)

    78           (advance [] [:d])

    79           (advance [] [:d])

    80           (advance [] [:a]))))

    81   

    82 (defn-memo rival-name-entry-blue

    83   ([] (rival-name-entry-blue (name-entry-ash)))

    84   ([script]

    85      (->> script

    86           (scroll-text 5)

    87           (advance [] [:d])

    88           (advance [] [:a]))))

    89 

    90 (defn-memo finish-title

    91   ([] (finish-title (rival-name-entry-blue)))

    92   ([script]

    93      (->> script

    94           (scroll-text 7))))

    95           

    96 (def title-frames 2194)

    97 

    98 (defn title-checkpoint! []

    99   (let [[moves state] (finish-title)]

   100     (assert (= title-frames (count moves)))

   101     [(write-moves! moves "title-checkpoint")

   102      (write-state! state "title-checkpoint")]))

   103 

   104 (defn intro []

   105   [(read-moves "title-checkpoint")

   106    (read-state "title-checkpoint")])

   107 

   108 (defn test-intro []

   109   (play-vbm (moves-filename "title-checkpoint")))

   110 

   111 ;; TODO might be able to glue these together more elegantly with monads

   112
author	Robert McIntyre <rlm@mit.edu>
date	Mon, 26 Mar 2012 18:01:39 -0500
parents	c7b002525041
children	8e63b0bb8ea3