Mercurial > vba-clojure

     1 (ns com.aurellem.title

     2   (:use (com.aurellem 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 (def scroll-text (partial advance [:b] [:a :b]))

    25 

    26 (defn start [] [[] (root)])

    27 

    28 (defn-memo title []

    29   (->> (start)

    30        (advance [] [:a])

    31        (advance [] [:start])

    32        (advance [] [:a])

    33        (advance [] [:start])))

    34 

    35 (defn-memo oak []

    36   (->> (title)

    37        scroll-text

    38        scroll-text

    39        scroll-text

    40        scroll-text

    41        scroll-text

    42        scroll-text

    43        scroll-text

    44        scroll-text

    45        scroll-text

    46        scroll-text

    47        scroll-text

    48        scroll-text

    49        scroll-text

    50        ))

    51 

    52 (defn-memo name-entry-rlm []

    53   (->> (oak)

    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 

    66 (defn-memo name-entry-ash []

    67   (->> (oak)

    68        (advance [] [:d])

    69        (advance [] [:d])

    70        (advance [] [:a])))

    71        

    72 (defn-memo rival-name-entry-gary []

    73   (->> (name-entry-ash)

    74        scroll-text

    75        scroll-text

    76        scroll-text

    77        scroll-text

    78        scroll-text

    79        (advance [] [:d])

    80        (advance [] [:d])

    81        (advance [] [:a])))

    82 

    83 (defn-memo rival-name-entry-blue []

    84   (->> (name-entry-ash)

    85        scroll-text

    86        scroll-text

    87        scroll-text

    88        scroll-text

    89        scroll-text

    90        (advance [] [:d])

    91        (advance [] [:a])))

    92 

    93 (defn-memo finish-title []

    94   (->> (rival-name-entry-blue)

    95        scroll-text

    96        scroll-text

    97        scroll-text

    98        scroll-text

    99        scroll-text

   100        scroll-text

   101        scroll-text))

   102 

   103 (def title-frames 2323)

   104 

   105 (defn title-checkpoint! []

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

   107     (assert (= title-frames (:frame state)))

   108     [(write-moves! moves) (write-state! state)]))

   109 

   110 (defn intro []

   111   [(read-moves title-frames)

   112    (read-state title-frames)])

   113 

   114 (defn test-intro []

   115   (play-vbm (moves->filename title-frames)))

   116 

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

   118
author	Robert McIntyre <rlm@mit.edu>
date	Tue, 20 Mar 2012 05:18:31 -0500
parents	412ca096a9ba
children	09caf6a5bbf4