[-*- Mode: emacs-lisp -*-]
[
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
]
[-----grammar
 (gz start (prog))
 (gz prog (module))
 (gz module (id language-pragma-opt exports imports topdecl-star
                ::pr("[[language-pragma-opt]]module [[id]] [[exports]] where{\n[[imports]]\n"
                     "[[topdecl-star('',';\n','\n')]]}\n\n")))
 (gz language-pragma ( :language-pragma f id-non-star j
                                        ::pr
                                        ("{-# LANGUAGE [[id-non-star('',',','')]] #-}\n")))
 (gz exports (f export-star j
                ::pr("[[export-star('(',', ',')')]]")) (:export-everything ::pr("")))
 (gz export (id)
     (f :module-export id j ::pr("module [[id]]"))
     )
 (gz imports (f import-star j
                ::pr("[[import-star('',';\n',';\n')]]")))
 (gz import(id ::pr( "import [[id]]"))
     (f :qualified (original-name ::is id) (new-name ::is id) j
        ::pr ( "import qualified [[original-name]] as [[new-name]]"))
     (f :specific id id-non-star j
        ::pr ("import [[id]][[id-non-star('(',',',')')]]"))
     )

 (gz type-class (f decl-mark (class-name ::is id) :type-class context-opt  id-non-plus f type-class-decl-star j j
                   ::pr("class [[context-opt]][[class-name]] [[id-non-plus('',' ','')]] where{\n"
                        "[[type-class-decl-star('',';\n','\n')]]}")))
 (gz topdecl (decl) (data)(type-synonym)(newtype)(instance)(type-class))
 (gz type-class-decl (type-signature)(decl))
 (gz type-signature (f :tysig name ret-type-and-params j
                       ::pr("[[name]] :: [[ret-type-and-params]]")))
 (gz instance (f :instance (type ::is id) (name ::is simpletype)  decls j
                 ::pr ("instance [[type]] ([[name]]) where [[decls]]")))
 [(gz instance (f :instance context-opt (type ::is id) simpletype-plus :x decls j
                  ::pr ("instance [[context-opt]][[type]] [[simpletype-plus('(',')(',')')]] where [[decls]]")))]
 (gz newtype (f decl-mark id :newtype type-vars-opt  constr deriving-opt j
                ::pr("newtype [[id]] [[type-vars-opt]] = [[constr]][[deriving-opt]]")))
 (gz deriving (:deriving f id-non-plus j
                         ::pr(" deriving [[id-non-plus('(',', ',')')]]")))
 (gz id-non (id))
 (gz type-synonym (f decl-mark id :type-synonym type-vars-opt type j
                     ::pr("type [[id]] [[type-vars-opt]] = [[type]]")))
 (gz data (f decl-mark id :data type-vars-opt constrs deriving-opt j ::pr("data [[id]] [[type-vars-opt]] = [[constrs]][[deriving-opt]]")))
 (gz simpletype (f id-non-plus j ::pr ("[[id-non-plus('',' ','')]]")))
 (gz type-vars (:args f id-non-star j ::pr ("[[id-non-star('',' ','')]]")))
 (gz constrs(constr-star ::pr("[[constr-star('',' | ','')]]"))

     )
 (gz field-type-and-param (f param type j
                             ::pr("[[param]] :: [[type]]")))
 (gz type-and-param ( f param type j ::pr("[[type]]")))
 (gz constr(positional-constructor) (field-label-constructor) )
 (gz field-label-constructor(f type-ctor :field field-type-and-param-star j
                               ::pr("[[type-ctor]][[field-type-and-param-star('{',', ','}')]]")))

 (gz decls (  decl-star  ::pr("{[[decl-star('\n',';\n','\n')]]}\n")))
 (gz context (:context f a-context-plus j ::pr
                       ("[[a-context-plus('(',', ',')')]] => ")))
 (gz a-context [(f (type ::is id) id-non-plus j
                   ::pr("[[type]] [[id-non-plus('',' ','')]]"))]
     (f (class ::is id) type-plus j
        ::pr("[[class]] [[type-plus('(',')(',')')]]"))
     )
 (gz forall (:forall f id-non-plus j
                     ::pr("forall [[id-non-plus('',' ','')]] . ")))
 (gz ret-type-and-params
     (type f type-and-param-star j forall-opt context-opt
           ::pr("[[forall-opt]][[context-opt]][[type-and-param-star('',' \x2d> ','')]]"
                (::c "if(my_type_and_param_star->v.size()>0)out(' \x2d> ');")
                "[[type]]")))

 (gz decl (f decl-mark name :fun ret-type-and-params  expr j
             ::pr("[[name]] :: [[ret-type-and-params]];\n"
                  "[[name]]"
                  (::c "for(many_trees::const_iterator pos = my_ret_type_and_params->my_type_and_param_star->v.begin();pos!= my_ret_type_and_params->my_type_and_param_star->v.end();++pos){"
                       "const tr_type_and_param* t=dynamic_cast<const tr_type_and_param*>(*pos);"
                       "assert(t);"
                       "out(' ');"
                       "t->my_param->print();" "}")
                  " = [[expr]]"))
     (f decl-mark name :fun :no-sig ret-type-and-params  expr j
        ::pr("[[name]]"
             (::c "for(many_trees::const_iterator pos = my_ret_type_and_params->my_type_and_param_star->v.begin();pos!= my_ret_type_and_params->my_type_and_param_star->v.end();++pos){"
                  "const tr_type_and_param* t=dynamic_cast<const tr_type_and_param*>(*pos);"
                  "assert(t);"
                  "out(' ');"
                  "t->my_param->print();" "}")
             " = [[expr]]"))
     (f decl-mark name :simple  expr j
        ::pr("[[name]] = [[expr]]"))
     )
 (gz name (id))
 (gz positional-constructor ["this one is sketchy"]
     (type-ctor ::pr("[[type-ctor]]"))
     (f   type-ctor typepls-opt j
          ::pr("[[type-ctor]][[typepls-opt]]"))
     (f :tuple type-plus j
        ::pr("[[type-plus('(',', ',')')]]"))
     )
 (gz pattern
     (id)
     (f  pattern-ctor pattern-star j
         ::pr ("([[pattern-ctor]] [[pattern-star('',' ','')]])"))

     (f pattern-ctor :fpat f fpat-star j j
        ::pr ("[[pattern-ctor]][[fpat-star('{',', ','}')]]"))

     (f :ptuple pattern-plus j [pattern-plus cuz :nil exists for empty lists]
        ::pr("[[pattern-plus('(',', ',')')]]"))

     (f :plist pattern-plus j [pattern-plus cuz :nil exists for empty lists]
        ::pr("[[pattern-plus('\x5b',', ','\x5d')]]"))

     (f :pchar astring j ::pr("(\x27[[astring]]\x27)"))

     (f :pstring astring j ::pr("\x22[[astring]]\x22"))

     (f :as id pattern j ::pr("[[id]]@[[pattern]]"))
     )
 (gz pattern-ctor (id) (:cons ::pr ("(:)")) (:nil ::pr ("[]")))

 (gz fpat (f (variable ::is id) pattern j
             ::pr("[[variable]] = [[pattern]]")))

 (gz type
     (f :fn ret-type-and-params j ::pr ("([[ret-type-and-params]])")) (:unit ::pr("()"))
     (positional-constructor))
 (gz typepls (paren-type-plus))
 (gz paren-type (type ::pr( "([[type]])"))
     (f :strict type j ::pr("!([[type]])"))
     (f :generic id j ::pr (" [[id]] ")))
 (gz type-ctor(id)(:list ::pr ("[]"))(:nondet ::pr ("[]")))
 (gz param (pattern))
 (gz qastring  (astring ::pr("\x22[[astring]]\x22")))

 (gz expr (id) (:mcons ::pr ("(:)")) [(:nil ::pr ("[]"))]
     [(f :pipe expr-plus j ::pr[("[[expr-star('(',' $ ',')')]]")]
         (
          (::c "for(many_trees::const_iterator pos = my_expr_plus->v.begin();"
               "pos!=my_expr_plus->v.end();++pos){")
          "("
          (::c "(*pos)->print();" "}")
          (::c "for(many_trees::const_iterator pos = my_expr_plus->v.begin();"
               "pos!=my_expr_plus->v.end();++pos){")
          ")"
          (::c  "}")
          )
         )]
     (f :join expr-plus j ::pr("[[expr-plus('(',' >>= ',')')]]"))

     (f :rpipe expr-plus j ::pr[("[[expr-star('(',' $ ',')')]]")]
        (["http;//gcc.gnu.org/bugzilla/show_bug.cgi?id=11729"]
         (::c "for(many_trees::reverse_iterator pos = my_expr_plus->v.rbegin();"
              "pos!=my_expr_plus->v.rend();++pos){")
         "("
         (::c "(*pos)->print();" "}")
         (::c "for(many_trees::const_iterator pos = my_expr_plus->v.begin();"
              "pos!=my_expr_plus->v.end();++pos){")
         ")"
         (::c  "}")
         )
        )
     (f :rcompose expr-plus j ::pr
        [("[[expr-plus('(',' . ',')')]]")]
        ("("
         (::c "for(many_trees::reverse_iterator pos = my_expr_plus->v.rbegin();"
              "pos!=my_expr_plus->v.rend();++pos){")
         (::c "if(pos!=my_expr_plus->v.rbegin())")
         " . "
         (::c "(*pos)->print();" "}")
         ")"
         )
        )

     (f :cc expr-star j ::pr ("[[expr-star('(',' ++ ',')')]]"))
     (qastring)
     (f :lit astring j ::pr("[[astring]]"))

     (f :ty type expr j ::pr("([[expr]] :: [[type]])"))
     (f (fun-name ::is expr) expr-star j
        ::pr ("([[fun-name]][[expr-star(' ',' ','')]])"))
     [(f :construct ctor expr-star j
         ::pr ("([[ctor]] [[expr-star('',' ','')]])"))]
     (f :do  stmt-star  j ::pr("(do{\n[[stmt-star('  ','\n  ','\n')]]})"))
     (f :case expr  alt-star  j
        ::pr("(case [[expr]] of {\n[[alt-star('  ',';\n  ','\n')]]})"))
     (f :case expr alt-star :else (underbar ::is expr) j
        ["the else is there so the grammar does not have a reduce/reduce conflict"]
        ::pr("(case [[expr]] of {\n[[alt-star('  ',';\n  ',';\n')]]"
             "  _ -> [[underbar]]\n"
             "})"))
     (f :lcase alt-star j
        ::pr("(\x5clambda_case_var ->"
             "case lambda_case_var of {\n"
             "[[alt-star('  ',';\n  ','\n')]]})"))
     (f :lcase alt-star :else (underbar ::is expr) j
        ::pr("(\x5clambda_case_var ->"
             "case lambda_case_var of {\n"
             "[[alt-star('  ',';\n  ',';\n')]]"
             "  _ -> [[underbar]]\n"
             "})"))
     
     (f :let decl-star expr j
        ::pr("(let {[[decl-star('\n',';\n','\n')]]}\n in [[expr]])"))
     (f :cfd expr assignments-star j
        ::pr("([[expr]][[assignments-star('{',', ','}')]])"))
     [(f :compose (a ::is expr) (b ::is expr) j ::pr("((.)[[a]] [[b]])"))]
     [(:compose ::pr ("(.)"))]
     [(f :compose expr-plus j ::pr ("[[expr-plus('(',' . ',')')]]"))]
     (f :mlist expr-star j ::pr("[[expr-star('\x5b',', ','\x5d')]]"))
     (f :cons-list expr-star j ::pr("[[expr-star('(',':',')')]]"))
     (f :mtuple expr-star j ::pr("[[expr-star('(',', ',')')]]"))
     (:nothing  ::pr ("()"))

     (f :lambda name ret-type-and-params expr j
        ::pr("(let {[[name]] :: [[ret-type-and-params]];\n"
             "[[name]]"
             (::c "for(many_trees::const_iterator pos = my_ret_type_and_params->my_type_and_param_star->v.begin();pos!= my_ret_type_and_params->my_type_and_param_star->v.end();++pos){"
                  "const tr_type_and_param* t=dynamic_cast<const tr_type_and_param*>(*pos);"
                  "assert(t);"
                  "out(' ');"
                  "t->my_param->print();" "}")
             " = [[expr]]} in [[name]])"))
     (f :lambda-simple id-non expr j
        [recommended only for reordering arguments to functions
                     and other simple expressions]
        [only one variable to keep it simple]
        ::pr ("(\x5c[[id-non]] -> [[expr]])"))

     )


 (gz assignments (f id expr j ::pr("[[id]] = [[expr]]")))
 (gz stmt (expr ::pr("[[expr]];"))
     (f ":=" pattern type expr j ::pr("[[pattern]] :: [[type]] <- [[expr]];"))
     (f :dlet decl-star j ::pr ("let {[[decl-star('\n',';\n','\n')]]};"))
     )
 (gz alt (f  pattern expr-or-gpat j
             ::pr("[[pattern]][[expr-or-gpat]]")))
 (gz expr-or-gpat
     (expr ::pr ("-> [[expr]]"))
     (where-opt :gpats pred-expr-star [silly lookahead limitation]
        ::pr ("\n[[pred-expr-star('','','')]] [[where-opt]]"
              )))
 (gz pred-expr ( f (pred ::is expr) (do ::is expr) j
                   ::pr ("| [[pred]]\n -> [[do]]\n")))
 (gz where (:where decls ::pr ("where [[decls]]")))

 (gz decl-mark (":"))
 ]



Main :language-pragma
(
 ScopedTypeVariables
 [PatternSignatures]
 GeneralizedNewtypeDeriving
 )
(main)
(
 Array
 System
 Char
 IO
 Control.Monad.State
 Control.Exception
 Monad
 Random
 Data.List
 (:qualified Data.Set Set)
 (:qualified Data.Map Map)
 Maybe
 Data.Array.ST
 Control.Monad.ST
 )


(: main :fun (IO :unit)()
  (:do
   [(hPutStrLn stderr rcs-code)]
   (setStdGen(mkStdGen 1))
   (:join
    getArgs
    (:lcase
     ((:plist(:pstring "nothing"))(return :nothing))
     ((:plist(:pstring "show-chords")(num-actions))(show-chords(read num-actions)))
     ))))


(: map-tuple :fun(:tuple(b)(b))((fn(:fn(b)((x(a)))))
                                (x(:tuple(a)(a))))
  (:mtuple (fn (fst x))(fn (snd x))))

(: apply-first :fun(:tuple(b)(c))((fn(:fn(b)((_(a)))))
                                  (x(:tuple(a)(c))))
  (:mtuple (fn (fst x))(snd x)))

(: apply-second :fun(:tuple(c)(b))
  ((fn(:fn(b)((_(a)))))(x(:tuple(c)(a))))
  (:mtuple (fst x)(fn (snd x))))

(: zip-check-same-length :fun (:list(:tuple(a)(b)))
  ((x1(:list(a)))(x2(:list(b))))
  (:case
    (:mtuple x1 x2)
    ((:ptuple(:nil)(:nil))(:mlist))
    ((:ptuple(:cons(a)(arest))
             (:cons(b)(brest)))
     (:mcons(:mtuple a b)
            (zip-check-same-length arest brest)))))

(: zipWith-check-same-length :fun (:list(c))
  ((f(:fn(c)((x1(a))(x2(b)))))(x1(:list(a)))
   (x2(:list(b))))
  (:case
    (:mtuple x1 x2)
    ((:ptuple(:nil)(:nil))(:mlist))
    ((:ptuple(:cons(a)(arest))
             (:cons(b)(brest)))
     (:mcons
      (f a b)
      (zipWith-check-same-length f arest brest)))))
(: zip-map :fun (:list(:tuple a b))
  ((f(:fn  b ((x a)))) (l(:list a)))
  (zip l (map f l)))
(: flip-tuple :fun (:tuple b a) ((x(:tuple a b)))
  (:mtuple (snd x)(fst x)))
(: show-list :fun (IO :unit)((l(:list a))):context ((Show a))
  (:rpipe l (map show) unlines putStr))
(: compare-zipped :fun (:fn Ordering ((x(:tuple a b))(y(:tuple a b)))) () :context ((Ord b))
   (curry(:rcompose (map_tuple snd)(uncurry compare))))
(: take-while-plus :fun (:tuple(:list a)(Maybe a))
      ((p(:fn Bool ((x a))))
       (l(:list a)))
      (:case l
        ((:nil)(:mtuple(:mlist)Nothing))
        ((:cons(h)(t))
         (:case(p h)
           ((False)(:mtuple(:mlist)(Just h)))
           ((_)(:let
                (: answer :simple
                   (take-while-plus p t))
                (:mtuple
                 (:mcons h (:rpipe answer fst))
                 (snd answer))))))))
(: random-from-list :fun (IO a) ((l (:list a)))
   (:join
    (:rpipe
     (:mtuple 0
              (:rpipe l length pred)
              )
     randomR
     getStdRandom
     )
    (:rcompose
     (!! l)
     return)))
(: rcs-code :fun String ()
  "$Id: chords.ll,v 1.10 2010/12/05 11:58:07 kenta Exp kenta $")

(: Button :data (Thumb Tposition)(Finger Fnumber):deriving (Show Eq))
(: Direction :data Up Down :deriving(Show Eq))
(: Command :data (Key Hand Button Direction) Beat :deriving(Show Eq))
(: Tposition :newtype (Tposition Int):deriving(Show Eq Ord Ix))
(: Hstate :data (Hstate Tstate Fstate):deriving (Show Eq))
(: Tstate :type-synonym (Array Hand (Maybe Tposition)))
(: Hand :newtype (Hand Int):deriving(Eq Ord Show Ix))
(: Hand-finger :type-synonym (:tuple Hand Fnumber))
(: Fstate :type-synonym (Array Hand-finger Direction))
(: Fnumber :newtype (Fnumber Int):deriving(Eq Ord Show Ix))



(: t-bounds :fun (:tuple Tposition Tposition)()
   (:mtuple (Tposition 1)(Tposition 2)))
(: f-bounds :fun (:tuple Hand-finger Hand-finger)()
   (:mtuple (:mtuple (fst h-bounds) (Fnumber 1))
            (:mtuple (snd h-bounds) (Fnumber 2))))
(: h-bounds :fun (:tuple Hand Hand)()
   (:mtuple (Hand 1)
            (Hand 2)))


(: tmoves-one-hand :fun (:list Command) ((hand Hand)(old(Maybe Tposition)))
   (:case old
          ((Just p)(:mlist(Key hand (Thumb p) Up)))
          :else
          (:do
           (:= t Tposition all-thumbs)
           (return (Key hand (Thumb t) Down))
           )))

(: all-thumbs :fun (:list Tposition)()
   (range t-bounds))

(: flip-dir :fun Direction ((d Direction))
   (:case d
          (Up Down)
          (Down Up)))
(: finger-moves :fun (:list Command) ((fs Fstate))
   (:do
    (:= (:ptuple (:ptuple hand finger) dir)
        (:tuple Hand-finger Direction)(assocs fs))
    (return (Key hand (Finger finger) (flip-dir dir)))
    ))
(: thumb-moves :fun(:list Command)((ts Tstate))
   (:do
    (:= (:ptuple hand thumb)
        (:tuple Hand (Maybe Tposition))
        (assocs ts))
    (tmoves-one-hand hand thumb)))
(: empty-thumb :fun Tstate ()
   (listArray h-bounds (repeat Nothing)))
(: empty-fingers :fun Fstate ()
   (listArray f-bounds (repeat Up)))
(: empty-hand :fun Hstate ()
   (Hstate empty-thumb empty-fingers))
(: ma :fun (Array i v)((a(Array i v))(x i)(y v))
   :context((Ix i))
   (// a (:mlist(:mtuple x y))))
(: fguard :fun (m :unit) ((pred Bool))
   :context ((Monad m))
   (:case pred
          (True (return :nothing))
          (False (fail "fail"))))
(: execute :fun (m Hstate) ((c Command)((Hstate thumb finger)Hstate))
   :context((Monad m))
   (:case c
          (Beat (return(Hstate thumb finger)))
          ((Key hand button dir)
           (:case (:mtuple button dir)
                  ((:ptuple(Thumb t)Down)(:do
                                          (:rpipe hand (! thumb) isNothing fguard)
                                          (return
                                           (Hstate (ma thumb hand (Just t)) finger))
                                          ))
                  ((:ptuple(Thumb t)Up)(:do
                                          (:rpipe hand (! thumb) isJust fguard)
                                          (return
                                           (Hstate (ma thumb hand Nothing) finger))
                                          ))
                  ((:ptuple(Finger f)newstate)(:do
                                               (:dlet
                                                (: hf :fun Hand-finger ()(:mtuple hand f)))
                                               (:rpipe hf (! finger) (/= newstate) fguard)
                                               (return(Hstate thumb
                                                             (ma finger hf newstate)))
                                          ))
                  
                  ))
          
          
          ))
(: all-moves :fun (:list Command) (((Hstate t f)Hstate))
   (:mcons Beat(++ (finger-moves f)(thumb-moves t))))

(: Mstate :type-synonym :args (a) (State (Maybe Hstate) a))
(: execute-in-monad :fun (Mstate :unit) ((c Command))
   (:join get (:rcompose (execute-out-monad c) put)))
(: execute-out-monad :fun (m Hstate) ((c Command)
                                      (oldm(m Hstate)))
   :context((Monad m))
   (:join oldm (execute c)))

(: run-through :fun (Maybe Hstate) ((c (:list Command)))
   (execState (mapM- execute-in-monad c) (Just empty-hand)))
(: do-one :fun (:list(:tuple Hstate Command))((x Hstate))
   (:do
    (:= move Command (all-moves x))
    (return (:mtuple (fromJust(execute move x)) move))
    ))
(: do-several :fun (:list(:list Command))
   ((n Int)(x Hstate))
   (:case (compare n 0)
          (EQ (return (:mlist)))
          (GT
           (:do
            (:= (:ptuple new-state did-move)(:tuple Hstate Command)
                (do-one x))
            (:= rest (:list Command)(do-several (pred n) new-state))
            (return (:mcons  did-move rest))))))

(: good-end-state :fun Bool ((c(:list Command)))
   ["all fingers up at the end"]
   (== (Just empty-hand) (run-through c)))
(: state-tuples :fun (:list (Maybe Hstate)) ((c(:list Command)))
   (:rpipe
    (scanl  (flip execute-out-monad) (Just empty-hand) c)
    tail
    init))

(: no-beats :fun Filter ()
   (:rcompose (map (/= Beat)) and))
    
(: and-preds :fun Bool ((fs(:list(:fn Bool ((x a)))))(x a))
   :forall(a)
   (and
    (:do
     (:= f (:fn Bool((x a))) fs)
     (return (f x)))))
(: in-state :fun Bool ((p(:fn Bool ((s Hstate))))
                       (c(:list Command)))
   (:rpipe c state-tuples
           (map (:rcompose fromJust p))
           and))
(: Filter :type-synonym (:fn Bool ((c (:list Command)))))
(: always-down-1 :fun Filter () ["there is always at least one finger down"]
   (in-state (/= empty-hand) ))
(: always-down :fun Bool ((c(:list Command)))
   (&&(/= c (:mlist Beat))
      (always-down-1 c)))
(: one-finger :fun Bool (((Hstate _ fingers)Hstate))
   ["avoid both the index and middle finger both down on one hand"]
   (and (map (one-finger-per-hand fingers) (range h-bounds))))
(: one-finger-per-hand :fun Bool ((finger Fstate)(target Hand))
   (:case
    (:do
     (:= (:ptuple(:ptuple hand _)Down)
         (:tuple Hand-finger Direction)(assocs finger))
     (guard (== hand target))
     (return :nothing)
     )
    ((:nil) True)
    ((:cons(_)(:nil))True)
    :else False))

(: Thumb-command :data Thumb-beat (Thumb-specific Tposition Direction):deriving (Show))
(: Thumb-state :data Thumb-down (Thumb-up (Maybe Tposition)) :deriving (Show))
(: filter-thumb :fun (:list Thumb-command)((target Hand)(c Command))
   (:case c
          (Beat(return Thumb-beat))
          ((Key hand (Thumb i) dir)
           :gpats ((== hand target)(return (Thumb-specific i dir))))
          :else (:mlist)
          ))
(: move-thumb :fun (m Thumb-state) ((oldm (m Thumb-state))(next Thumb-command))
   :context((Monad m))
   (:do
    (:= old Thumb-state oldm)
    (:case (:mtuple old next)
           ((:ptuple Thumb-down Thumb-beat)(return Thumb-down))
           ((:ptuple Thumb-down (Thumb-specific i Up))(:rpipe i Just Thumb-up return))
           ((:ptuple Thumb-down (Thumb-specific _ Down))(error "more down on down"))
           ((:ptuple (Thumb-up Nothing) Thumb-beat)(return (Thumb-up Nothing)))
           ((:ptuple (Thumb-up Nothing) (Thumb-specific _ Down))(return Thumb-down))
           ((:ptuple (Thumb-up(Just _)) Thumb-beat)(return (Thumb-up Nothing)))
           ((:ptuple (Thumb-up _)(Thumb-specific _ Up))(error "more up on up"))
           ((:ptuple (Thumb-up(Just i)) (Thumb-specific j Down))
            (:case (== i j)
                   (True(return Thumb-down))
                   :else
                   (fail "moving thumb too fast"))))))
                                            
(: test-thumb-minor :fun (Maybe Thumb-state)((c(:list Thumb-command)))
   (foldl move-thumb (Just(Thumb-up Nothing)) c))
(: from-empty :fun (:list(:list Command))((n Int))
   (do-several n empty-hand))
(: test-thumb-one-hand :fun (Maybe Thumb-state)((c(:list Command))(h Hand))
   (:rpipe
    c
    (map (filter-thumb h))
    concat
    test-thumb-minor))
(: test-thumb :fun Bool ((c(:list Command)))
   (and (map (:rcompose(test-thumb-one-hand c)isJust) (range h-bounds))))
(: show-chords :fun (IO :unit)((num-actions Int))
   (:rpipe
    [(enumFromTo 1 num-actions)
     (concatMap from-empty)]
    num-actions from-empty
    (filter (and-preds
             (:mlist
              always-down
              [(in-state one-finger)]
              test-thumb
              one-beat-at-a-time
              good-end-state)))
    length print
    [show-list]))
(: head-one-beat-at-a-time :fun Bool ((c(:list Command)))
   (/= (:mlist Beat Beat)(take 2 c)))
(: one-beat-at-a-time :fun Bool ((c(:list Command)))
   (:rpipe
    c
    tails
    (map head-one-beat-at-a-time)
    and))