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 [start]

    29   (->> start

    30        (advance [] [:a])

    31        (advance [] [:start])

    32        (advance [] [:a])

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

    34 

    35 (defn-memo oak [start]

    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        (advance [] [:a])))

    51 

    52 (defn-memo name-entry []

    53   (->> (oak)

    54        (advance [] [:r] DE)

    55        (play-moves

    56         [[]

    57          [:r] [] [:r] [] [:r] [] [:r] []

    58          [:r] [] [:r] [] [:r] [] [:d] [:a]  

    59          [:l] [] [:l] [] [:l] [] [:l] []

    60          [:l] [] [:l] [:a] [] [:r] [:a]

    61          [:r] [] [:r] [] [:r] [] [:r] []

    62          [:r] [] [:d] [] [:d] [] [:d] [:a]

    63          ])))

    64           

    65 (defn-memo rival-name-entry []

    66   (->> (name-entry)

    67        scroll-text

    68        scroll-text

    69        scroll-text

    70        scroll-text

    71        scroll-text

    72        (advance [] [:d])

    73        (advance [] [:d])

    74        (advance [] [:a])))

    75 

    76 (defn-memo finish-title []

    77   (->> (rival-name-entry)

    78        scroll-text

    79        scroll-text

    80        scroll-text

    81        scroll-text

    82        scroll-text

    83        scroll-text

    84        scroll-text))

    85 

    86 (defn-memo intro []

    87   (-> (start) title oak name-entry rival-name-entry finish-title))

    88 

    89 

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

    91
author	Robert McIntyre <rlm@mit.edu>
date	Sat, 10 Mar 2012 14:48:17 -0600
parents	04d539d26bdc
children	65c2854c5875