[-*- Mode: lispcc -*-]
[
 Game values for the game of Chomp

 Copyright 2017 Ken Takusagawa

 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 (f decl-mark id :class language-pragma-opt exports imports topdecl-star j
             ::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))
 (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]]")))

(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  type deriving-opt j
              ::pr("newtype [[id]] [[type-vars]] = [[type]][[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 type j
                   ::pr("type [[id]] [[type-vars]] = [[type]]")))
 (gz data (f decl-mark id :data type-vars constrs deriving-opt j ::pr("data [[id]] [[type-vars]] = [[constrs]][[deriving-opt]]")))
 (gz simpletype (f id-non-plus j ::pr ("[[id-non-plus('',' ','')]]")))
 (gz type-vars (f id-non-star j ::pr ("[[id-non-star('',' ','')]]")))
 (gz constrs(f constr-star j ::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 f field-type-and-param-star j 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
  (forall-opt context-opt type f type-and-param-star j
   ::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
    (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
  (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 (id))
 (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 :lcase alt-star j
     ::pr("(\x5clambda_case_var ->"
	  "case lambda_case_var of {\n"
	  "[[alt-star('  ',';\n  ','\n')]]})"))
  (f :let decl-star expr j
     ::pr("(let {[[decl-star('\n',';\n','\n')]]}\n in [[expr]])"))
  (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 :cfd (type ::is id) assignments-star j
   ::pr("[[type]][[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 id f pattern-star j expr j
      ::pr("(\x5c[[pattern-star('',' ','')]] -> [[expr]])"))]


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

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


(: Main :class
   :language-pragma
   (ScopedTypeVariables)
   :export-everything
   (  Control.Exception
      [Ratio]
      [Foreign.C.Types]
      [IO]
      System.IO.Unsafe
      [List]
      [Monad]
      Control.Monad
      Control.Monad.ST
      [Control.Monad.Error]
      [(:qualified Control.Monad.State State)]
      [Array]
      [(:qualified Data.Set Set)]
      [Data.Set]
      [System.Directory]
      (:qualified Data.Map Map)
      Data.Array.ST
      Data.Maybe
      System.Random
      [Char]
      System.Environment
      [Data.Bits]
      Data.STRef
      [Numeric]
      Data.Array.IArray
      Data.Ord
      Control.Parallel.Strategies
      Data.List
      [(:qualified Data.ByteString B)]
      [(:qualified Data.Sequence Seq)]
      [Data.IORef]
      System.IO
      [Data.Word]
      [SHA1]

      )


   (: main :fun (IO :unit)()
      (:do
       (hPutStrLn stderr rcs-code)
       (:join
	getArgs
	(:lcase
         ((:plist(:pstring "nothing"))(return :nothing))
         ((:plist(:pstring "go")(num))(go (read num)))
         ((:plist(:pstring "pnumslow")(num))(:rpipe num read positions-with-n-pieces-slow length print))
         ((:plist(:pstring "pnumfast")(num))(:rpipe num read positions-with-n-pieces-fast length print))
         ))
       ))

   (: show-list :fun :context ((Show(a)))(String)((l(:list(a))))
     (unlines (map show l))
     )

   (: quiet :fun(Bool)() False)

   (: cerr :fun(a)((message (:list(String)))(x(a)))
      (:case quiet
        ((True)x)
        ((_)(unsafePerformIO
             (:do
              (hPutStrLn stderr (concat message))
              (return x))))))
   (: cerr0 :fun(a)((message(String))(x(a)))
      (:case quiet
        ((True)x)
        ((_)(unsafePerformIO
             (:do
              (hPutStrLn stderr message )
              (return x))))))

   (: cerr-x :fun(a)((_(:list(String)))(x(a)))x)

   (: peek :fun :context((Show(a)))(a)((x(a)))
     (seq x (cerr (:mlist(show x)) x)))

   [(: peek-more :fun(a)((f(:fn(:list(String))((x(a)))))(x(a)))
     (:case quiet
       ((True)x)
       ((_)(seq x (cerr  (f x) x)))))]
   (: peek-more-x :fun(a)((_(:fn(:list(String))((x(a)))))(x(a)))x)

   (: zip-map :fun(:list(:tuple(a)(b)))
     ((f(:fn(b)((x(a)))))(l(:list(a))))
     (zip l (map f l)))

   (: zip-map-parallel :fun(:list(:tuple(a)(b)))
     ((strat(Strategy b))(f(:fn(b)((x(a)))))(l(:list(a))))
     (zip l (using (map f l)
		   (parList strat)
		   )))

   (: show-and :fun :context ((Show(a))(Show(b)))
     (IO :unit)((f(:fn(b)((x(a)))))(l(:list(a))))
     (:rpipe (zip-map f l) show-list putStr))

   (: ntakes :fun(:list(:list(a)))((n(Int))(l(:list(a))))
     (:mcons(take n l)(ntakes n (tail l)))
     )

   (: enum-from-count :fun :context ((Enum(a))) (:list(a))
     ((start(a))(count(Int)))
     (take count (enumFrom start)))

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



   [(: sort-by-extractor :fun :context ((Ord(b)))(:list(a))
     ((extract(:fn(b)((x(a)))))(l(:list(a))))
     (:let
      (sortBy (compare-by-extractor extract) l)
      ))
    (use sortBy (comparing extract))
    ]
   [(: compare-by-extractor :fun :context ((Ord(b)))(Ordering)
     ((extract(:fn(b)((x(a)))))(x(a))(y(a)))
     (compare (extract x)(extract y))) == comparing]

   (: reverse-comparison :fun (Ordering) ((o(Ordering)))
      (:case o
	     ((LT)GT)
	     ((EQ)EQ)
	     ((GT)LT)
	     ))
   (: reverse-comparison-function :fun
      (:fn(Ordering)((x(a))(y(a))))
      ((f(:fn(Ordering)((x(a))(y(a))))))
      (:rpipe
       (:rcompose (uncurry f) reverse-comparison)
       curry))

   (: n-chunk :fun(:list(:list(a)))((n(Int))(l(:list(a))))
     (:case l
       ((:nil)(:mlist) )
       ((_)(:mcons (take-enough n l) (n-chunk n (drop n l))))
       ))
   (: take-enough :fun (:list a) ((n Int)(l(:list a)))
      (:case (compare 0 n)
	     ((EQ)(:mlist))
	     ((LT)(:case l
			 ((:cons(head)(tail))
			  (:mcons head (take-enough (pred n)(tail))))))))

   [(: zip-check-same-length :fun(:list(:tuple(a)(b)))
     ((x1(:list(a)))(x2(:list(b))))
     (assert (==(length x1)(length x2))
             (zip x1 x2))
     )]
   (: 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)))))

   (: powers-of-two :fun :no-sig(:list(a))()
     (:mcons 1 (map (* 2) powers-of-two)))

   (: binary-to-decimal :fun :no-sig (Int) ((bits(:list(Int))))
     (sum (zipWith * (reverse bits) powers-of-two)))

   [(: compress-rle :fun :context ((Eq a))
     (:tuple(:list(a))(:list(Int)))((l(:list(a))))
     (:let
      (:mtuple (map head g) (map length g))
      (: g :fun :no-sig(:list(:list(a)))()
        (group l)
        ))
     )]
   [(: uncompress-rle :fun(:list(a))((rle(RLE(a)))
                                  )
     (:pipe
      (assert (== (length (fst rle))(length (snd rle))))
      (concatMap (uncurry (flip replicate)) ((uncurry zip-check-same-length)
                                             rle))
      ))]


   (: 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))))

   (: RLE :type-synonym (a)(:tuple(:list(a))(:list(Int))))

   (: diffs :fun :no-sig (Maybe(:list(Int))) ((l(:list(Int))))
     (:case l
       ((:nil)Nothing)
       ((:cons(h)(t))
        (Just(:mcons h (zipWith - t l))))))
   (: undiff :fun :no-sig (:list(Int))((l(Maybe(:list(Int)))))
     (:case l
       ((Nothing)(:mlist))
       ((Just(l))(scanl1 + l))
       ))

   (: every-n :fun(:list(a))((n(Int))(l(:list(a))))
     (:let
      (: is-mult :fun  (Bool)((i(Int)))
        (== 0 (mod i n)))
      (map snd (filter(:rcompose fst is-mult) (zip (enumFrom 0)l)))
      ))
   (: tab-split :fun(:list(String))((s(String)))
     (:let(: br :fun(:tuple(String)(String))()(break (== (:lit "'\t'"))s))
            (:mcons (fst br)
                    (:case (snd br)
                      ((:nil)(:mlist))
                      ((:cons(:pchar "\t")(rest))(tab-split rest)))
                    )
            ))
   (: second-is-longer :fun(Bool)((small(:list(a)))(big(:list(a))))
     (:case (:mtuple small big)
       ((:ptuple(:nil)(_))True)
       ((:ptuple(_)(:nil))False)
       ((:ptuple(:cons(_)(r1))(:cons(_)(r2)))(second-is-longer r1 r2))
       ))
   (: is-prefix :fun :context ((Eq(a))) (Bool) ((prefix(:list(a)))(l(:list(a))))
     (&&(second-is-longer prefix l)
        (and (zipWith == prefix l))))

   (: is-suffix :fun :context ((Eq(a))) (Bool) ((suffix(:list(a)))(l(:list(a))))
     (is-prefix (reverse suffix) (reverse l)))

   (: concatenate-many-files :fun(IO(String))((files(:list(String))))
     (:join
      (mapM readFile files) (:rcompose concat return))
     )

   [(: glob-directory :fun(IO(:list(FilePath)))
     ((dir(FilePath))(prefix(FilePath))(suffix(FilePath)))
     (:do
      (:= files (getDirectoryContents dir))
      (:pipe
       return
       (map (++ (++ dir "/")))
       (filter (is-suffix suffix))
       (filter (is-prefix prefix))
       files)
      ))]

   [(: concatenate-glob :fun(IO(String))
     ((dir(FilePath))(prefix(FilePath))(suffix(FilePath)))
     (:do
      (:= files (glob-directory dir prefix suffix))
      (concatenate-many-files files)
      ))]

   ["sort-tuple"]
   (: put-in-order :fun :context((Ord(a)))(:tuple(a)(a))((x(:tuple(a)(a))))
     (:case (> (fst x)(snd x))
       ((True)(:mtuple (snd x)(fst x)))
       ((_)x)))

   (: punch-array :fun :context((Ix(a))) (Array(a)(Bool))
      ((bounds(:tuple(a)(a)))
       (l(:list(a))))
      (:let
       (: set-true :fun (Bool)((_(Bool))(_(Bool)))
          True
          )
       (accumArray set-true False bounds
		  (zip l (repeat (error "fnord"))))
       ))

   (: build-array-from-list :fun :context((Ix(a))) (Array(a)(:list(b)))
      ((bounds(:tuple(a)(a)))
       (l(:list(:tuple(a)(b)))))
      (accumArray snoc (:mlist) bounds l))

   (: snoc :fun (:list(a)) ((rest(:list(a)))(h(a)))
      (:mcons h rest))

   (: filter-trues :fun (:list(a))((xb(:list(:tuple(a)(Bool)))))
      (:rpipe
       xb (filter snd) (map fst)))

   (: compare-length-lists :fun (Ordering) ((x(:list(a)))(y(:list(a))))
      (:case (:mtuple x y)
        ((:ptuple(:nil)(:nil))EQ)
        ((:ptuple(:nil)(_))LT)
        ((:ptuple(_)(:nil))GT)
        ((_)(compare-length-lists (tail x)(tail y)))))

   (: ordering-to-equality :fun :forall (a)
      (:fn(Bool)((x(a))(y(a))))
      ((compare-function(:fn(Ordering)((x(a))(y(a))))))
      (:let
       (: ret-val :fun (Bool) ((x(a))(y(a)))
	  (:case (compare-function x y)
		 ((EQ)True)
		 ((_)False)
		 ))
       ret-val))
   (: sort-and-group-by :fun (:list(:list(a)))
      ((compare-function(:fn(Ordering)((x(a))(y(a)))))
       (l(:list(a))))
      (:rpipe
       l
       (sortBy compare-function)
       (groupBy ( ordering-to-equality compare-function))
       ))
   (: compare-list-length-with-unity :fun (Ordering) ((l(:list(a))))
      (:case l
        ((:nil)LT)
        ((:cons(_)(:nil))EQ)
        ((_)GT)
        ))

   (: choose-from-list-randomly :fun (IO(a)) ((l(:list(a))))
      (:case l
	     ((:nil)(error "choose-from-list-randomly called on empty list"))
	     ((_)
	      (:join
	       (randomRIO (:mtuple 0 (pred (length l))))
	       (:rcompose (!! l) return)
	       )
	      )))
   (: uniform-random-IO :fun (IO(Float)) ()
      (randomRIO (:mtuple 0 1)))
   (: random-permutation-IO :fun (IO(:list(a))) ((l(:list(a))))
      (:join
       (sequence (replicate (length l) uniform-random-IO))
       (:rcompose
	(zip-check-same-length l)
	(sortBy (comparing snd))
	(map fst)
	return))
      )

   (: combine-maybes-in-io :fun :context((Monad(io)))
      (io(Maybe(a))) ((l-to-do(:list(io(Maybe(a))))))
      (:case l-to-do
	     ((:nil)(return Nothing))
	     ((:cons(h)(rest))
	      (:join
	       h
	       (:lcase ["there's no generic way to test for failure?"]
		      ((Just(_))h)
		      ((_)(combine-maybes-in-io rest))
		      ))
	      )
	     )
      )

   (: is-singleton-list :fun (Bool)((l(:list(a))))
      (:case l
	     ((:cons(_)(:nil))True)
	     ((_)False)
	     ))
   (: first-last :fun (:tuple(a)(a))((l(:list(a))))
      (:mtuple (head l)(last l)))

   (: list-change-at-index :fun (:list(a))((l(:list(a)))(n(Int))(new-value(a)))
      (:case l
	     ((:cons(head)(tail))
	      (:case (compare 0 n)
		 ((EQ)(:mcons new-value tail))
		 ((LT)
		  (:mcons head
			  (list-change-at-index tail (pred n) new-value))))))
      [(:cc (take n l) (:mlist new-value) (drop (+ 1 n) l))
       does not fail for out of index
       ]
      )
   (: backwards-tuple :fun (:tuple(b)(a))((x(:tuple(a)(b))))
      (:case x
	     ((:ptuple(i)(j))(:mtuple j i))))

   (: mk-1-map-array :fun (Array(Int)(b))
      ((fn(:fn(b)((x(a)))))
       (la(:list(a))))
      (listArray (:mtuple 1 (length la))
		 (map fn la)))
   (: filter-justs :fun (:fn(:list a) ((ll(:list(Maybe a)))))()
      (:rcompose
       (filter isJust)
       (map fromJust)))

   (: head-only :fun a ((l(:list a)))
      (:case l
	     ((:plist(x))x)
	     ))
   (: tail-assert :fun :context ((Eq a))(:list a)
      ((x(a))(l(:list a)))
      (assert
       (== x (head l))
       (tail l)))

   [(: continue-through :fun b ((pred(Bool))(x(b)))
      (:case pred
	     ((True)x)))]

   (: singleton :fun (:list a) ((x a))
      (:mlist x))
   (: rcs-code :fun(String)()
      "$Id: chomp-trainer.ll,v 1.86 2017/12/05 23:27:00 kenta Exp $")

   (: Table :type-synonym () (Map.Map Key-position Gamevalue))
   (: Gamevalue :data () ((Lose-in(Int))(Win-in(Int))):deriving(Eq Show))
   (: table-lookup :fun (Maybe Gamevalue) ((t Table)(p Position))
      (Map.lookup p t))

   (: Position :newtype () (Position (:list Int)):deriving (Eq Ord Show))
   (: Key-position :type-synonym () Position)

   (: best :fun Gamevalue ((_direction Bool)(vals(:list Gamevalue)))
      (flip-gamevalue(minimum vals)))
   (: flip-gamevalue :fun Gamevalue ((g Gamevalue))
      (:case g
        ((Lose-in(i))(Win-in(succ i)))
        ((Win-in(i))(Lose-in(succ i)))))

   (: game-value-generate :fun (ST s Bool)
      ((ptable(STRef s Table))(direction Bool)(position Position))
      (:do
       (:= table (Table) (readSTRef ptable))
       (:case (table-lookup table position)
         ((Just(_))(return True))
         ((_)(:let
              (: moves :fun (:list Position)()
                 (moves-from position))
              (:case (sequence (map (table-lookup table) moves))
                ((Just(vals))
                 (:do
                  (write ptable position(best direction vals))
                  (return True)))
                ((Nothing)
                 (:do
                  (mapM- (game-value-generate
                          ptable (not direction))
                         moves)
                  (return False)
                  ))))))))

   (:instance Ord (Gamevalue)
              (: compare :fun :no-sig Bool ((x Gamevalue)(y Gamevalue))
                 (:case x
                   ((Lose-in(xx))(:case y
                                  ((Lose-in(yy))(compare xx yy))
                                  ((Win-in(_))LT)))
                   ((Win-in(xx))(:case y
                                 ((Lose-in(_))GT)
                                 ((Win-in(yy))(compare yy xx))))))
              )

   (: extract-Position :fun (:list Int) ((p Position))
      (:case p
        ((Position(x))x)))
   (: moves-from :fun (:list Position) ((p Position))
      (:rpipe p extract-Position
              bit-create-position
              clean-m2 (map canonicalize)
              (map count-position)
              one-only
              (map Position)))
   (: count-line :fun Int ((l(:list Bool)))
      (:rpipe l (takeWhile id) length))
   (: count-position :fun (:list Int) ((l(:list(:list Bool))))
      (takeWhile (< 0) (map count-line l)))
   (: bit-create-position-padded :fun (:list Bool)
      ((width Int)(this Int))
      (take width (++(replicate this True)(repeat False))))

   (: bit-create-position :fun (:list(:list Bool)) ((l(:list Int)))
      (:case l
        ((:cons(h)(t))
         (:mcons (replicate h True)
                 (map (bit-create-position-padded h)t)))))

   (: canonicalize :fun (:list(:list Bool)) ((p(:list(:list Bool))))
      (max p (transpose p)))
   (: m1 :fun (:list(:list Bool)) ((x(:list Bool)))
      (:case x
        ((:nil)(:mlist))
        ((:cons(True)(rest))
         (:mcons
          (map (const False) x)
          (:do
           (:= m2 (:list Bool) (m1 rest))
           (return (:mcons True m2))
           )))
        ((:cons(False)(rest))
         (:do
           (:= m2 (:list Bool) (m1 rest))
           (return (:mcons (error "True after False") m2))
           ))))
   (: m2 :fun (:list(:list(:list Bool))) ((x(:list(:list Bool))))
      (:case x
        ((:nil)(:mlist))
        ((:cons(line)(rest))
         (++
          (:do
           (:= mask (:list Bool)(m1 line))
           (return (map (zipWith && mask) x)))
          (:do
           (:= do-rest (:list(:list Bool)) (m2 rest))
           (return (:mcons line do-rest))
           )))))
   (: clean-m2 :fun (:list(:list(:list Bool))) ((x(:list(:list Bool))))
      (:do
       (:= r (:list (:list Bool)) (m2 x))
       (guard (head (head r)))
       (return r)))

   (: show-position :fun String ((x(Position)))
      (:rpipe x extract-Position bit-create-position(map (map show-pos-char)) unlines))
   (: show-pos-char :fun Char ((x Bool))
      ((:case x
         ((True)(head "X"))
         ((_)(head ".")))))

   (: one-only :fun :context ((Ord a))(:list a) ((x(:list a)))
      (:rpipe x
              sort
              group
              (map head)
              ))
   (: l-positions :fun (:list Position) ()
      (map Position
           (:do
            (:= x Int (enumFrom 1))
            (return (:mcons (+ 1 x) (replicate x 1))))))

   (: two-positions :fun (:list Position) ()
      (map Position
           (:do
            (:= x Int (enumFrom 3))
            [skipping 2 because it is also an L position]
            (return (:mlist x (pred x))))))

   [Proposition 2 from Doron Zeilberger, "Three-Rowed Chomp"]
   (: three-positions :fun (:list Position)()
      (map Position
           (:do
            (:= x Int (enumFrom 4))
            (return (:mlist x (- x 2) 2))
            )))

   (: lost-positions :fun (:list Position) ((limit Int))
      (:let
       (: within-size :fun Bool ((p Position))
          (:case p
            ((Position(:cons(s)(_)))(<= s limit))))
       (concat
        (:mlist
         (takeWhile within-size l-positions)
         (takeWhile within-size two-positions)
         [possibly omit these, as the winning strategy from the position is not well known]
         (takeWhile within-size three-positions)
         ))))

   (: initial-scores :fun Table ((limit Int))
      (Map.fromList
       (:mcons
        (:mtuple (Position (:mlist 1)) (Lose-in 0))
        (:do
         (:= p Position (lost-positions limit))
         (return (:mtuple p (Lose-in 0)))))))

   (: write :fun (ST s :unit) ((ptable(STRef s Table))(p Position)(v Gamevalue))
      (modifySTRef ptable (:lambda modify Table ((t Table))
                                   (Map.insert p v t))))

   (: untilST :fun (ST s :unit) ((body(:fn (ST s Bool)())))
      (:do
       (:= done Bool body)
       (:case done
         ((True)(return :nothing))
         ((_)(untilST body)))))

   (: solve-game-st :fun (ST s Table) ((limit Int))
      (:do
        (:= ptable (STRef s Table) (newSTRef (initial-scores limit)))
        (untilST (game-value-generate ptable True (Position (replicate limit limit))))
        (readSTRef ptable))
      )
   (: solve-game :fun Table ((limit Int))
      (runST (solve-game-st limit))
      )
   (: go :fun (IO :unit) ((limit Int))
      (:rpipe
       limit solve-game
       (Map.toList)
       show-list
       putStr))
   (: find-move :fun (IO :unit) ((t Table)(f(:list Int)))
      (:rpipe f Position
              moves-from
              (zip-map (table-lookup t))
              (sortBy (comparing snd))
              show-list
              putStrLn))

   (: positions-with-n-pieces-1 :fun (:list(:list Int)) ((maxwidth Int)(n Int))
      (:mcons
       (:mlist)
       (:case (|| (== 0 n) (== 0 maxwidth))
         ((True)mzero)
         ((_)
          (:do
           (:= x Int (enumFromTo 1 (min maxwidth n)))
           (:= l (:list Int) (positions-with-n-pieces-1 x (- n x)))
           (return (:mcons x l))
           )))))

   (: positions-with-n-pieces-slow :fun (:list Position) ((n Int))
      (:rpipe
       (positions-with-n-pieces-1 n n)
       tail [omit the empty position]
       (map Position)
       (filter is-canonical)
       ))

   (: is-canonical :fun Bool ((p Position))
      (:rpipe
       p
       extract-Position
       bit-create-position
       canonicalize
       count-position
       Position
       (== p)
       ))

   (: positions-with-n-pieces :fun (:list(:list Int)) ((maxwidth Int)(maxheight Int)(n Int))
      (:mcons
       (:mlist)
       (:case (or (:mlist (== 0 n) (== 0 maxwidth) (== 0 maxheight)))
         ((True)mzero)
         ((_)
          (:do
           (:= x Int (enumFromTo 1 (min maxwidth n)))
           (:= l (:list Int) (positions-with-n-pieces x (pred maxheight) (- n x)))
           (return (:mcons x l))
           )))))

   (: positions-with-n-pieces-fast :fun (:list Position) ((n Int))
      (:do
       (:= x Int (enumFromTo 1 n))
       (:= l (:list Int) (positions-with-n-pieces x (pred x) (- n x)))
       (:let
        (: p :fun Position () (Position (:mcons x l)))
        (:do
         (guard (is-canonical p))
         (return p)
         ))))
   [https;//oeis.org/A046682 gives numbers with exactly N pieces ( not up to N pieces as we have calculated here)]
    [n=120 answer=8635240371, 9 hours]
   )