[-*- Mode: emacs-lisp -*-]

[
Copyright 2010 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 (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 "many-moves"))(many-moves initial-game-state))
     ((:plist(:pstring "counter")n)
      (:do
       (:rpipe n read mkStdGen setStdGen)
       (many-moves-counter 0 initial-game-state)))
     ))
   ))


(: 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: crazyhouseannihilation.ll,v 1.29 2010/11/15 09:35:03 kenta Exp kenta $")

(: test :fun Int ((xy(:tuple Int Int)))
   (:case xy
          ((:ptuple v z) z)))

(: pparam :fun Int (((:ptuple q r)(:tuple Int Int)))
   q)

(: iopat :fun (IO Int) ()
   (:do
    (:= (:ptuple x y) (:tuple Int Int) undefined)
    (return x)
    ))
(: ray :fun (:list Coord)((origin Coord)
                          (delta(:tuple Int Int)))
   (:let
    (: nc :fun Coord ()
       (add-coord origin delta)
       )
    (:mcons nc (ray nc delta))
    ))
(: add-coord :fun Coord (((Coord(:ptuple ox oy))Coord)
                         ((:ptuple dx dy)Delta))
   (Coord(:mtuple
    (+ ox dx)
    (+ oy dy)
    )))
[(: Coord :type-synonym (:tuple Int Int))]
(: Coord :newtype (Coord (:tuple Int Int)) :deriving (Eq Ord Ix))
(: board-range :fun (:tuple Coord Coord)()
   (:mtuple (Coord(:mtuple 0 0))
			 (Coord(:mtuple bmax bmax)))
)
(: Board :type-synonym (Array Coord (Maybe Piece)))
(: Promotion-state :data Original Was-a-pawn :deriving (Eq Show))
(: Piece :type-synonym (:tuple Color (:tuple Type-piece Promotion-state)))
(: Color :data White Black :deriving (Show Eq Ord))
(: Type-piece :data Pawn Night Bishop Rook Queen King :deriving ( Eq Show Ord))
(: random-piece :fun (IO Type-piece) ()
   (random-from-list all-pieces))

(: random-mpiece :fun (IO (Maybe Piece)) ()
   (:join
    (random-from-list (:mlist False True))
    (:lcase
     (True (return Nothing))
     :else
     (:do
      (:= color Color (random-from-list (:mlist Black White)))
      (:= p Type-piece random-piece)
      (:= promoted Promotion-state
          (:case p
                 ((Pawn)(return Original))
                 :else
                 (random-from-list (:mlist Original Was-a-pawn))))
      (:rpipe
       (Just (:mtuple color (:mtuple p promoted)))return)
      ))))

(: show-type-piece :fun String ((p Type-piece))
   (:mlist
    (:rpipe
     p show head)))
(: show-color :fun String ((c Color))
   (:case c
          (White "w")
          (Black "b")))
(: show-piece :fun String ((p (Maybe Piece)))
   (:case p
          (Nothing " .")
          ((Just(:ptuple c (:ptuple t promoted)))
           (++ (show-color c)
               (map
                (:case promoted
                       (Was-a-pawn toLower)
		       (Original toUpper))
                (show-type-piece t))
               ))))

(: show-row :fun String ((lp(:list(Maybe Piece))))
   (:rpipe lp
           (map show-piece)
           (intersperse " ")
           concat))
(: bmax :fun Int () 7)
(: sixty-four :fun Int () (*
                           (+ 1 bmax)
                           (+ 1 bmax)))
(: board-row :fun (:list(Maybe Piece)) ((b Board)(r Int))
   (:do
    (:= i Int (enumFromTo 0 bmax))
    (return (! b (Coord(:mtuple r i))))))
(: random-board :fun (IO Board) ()
   (:join
    (:rpipe
     random-mpiece
     (replicate sixty-four)
     sequence)
    (:rcompose
     (listArray board-range)
     return)))
(: show-board :fun String ((b Board))
   (:rpipe
    (:do
     (:= r String
         (:rpipe
          (enumFromThenTo bmax (- bmax 1) 0)
          (map (board-row b))
          (map show-row)))
     (return (++ r "\n")))
    concat))


(: ray-possibilities :fun (:list Coord)
   ((b Board)(origin Coord)(delta Delta))
   (:case
    (:rpipe
     (ray origin delta)
     (takeWhile (inRange (bounds b)))
     (take-while-plus (:lambda-simple xy (== Nothing (! b xy))))
     )
    ((:ptuple empties old-capture)
     (++ empties
              (:case old-capture
                     ((Just(xy))
                      (:case (== (:rpipe (! b xy) fromJust fst)
                                 (:rpipe (! b origin)fromJust fst))
                             (False(:mlist xy))
                             :else
                             (:mlist)))
                     :else (:mlist))))))
(: many-ray-possibilities :fun (:list Coord)
   ((b Board)(origin Coord)(delta (:list Delta)))
   (:rpipe delta
           (concatMap (ray-possibilities b origin))
           ))
(: Delta :type-synonym (:tuple Int Int))
(: queen-rays :fun (:list Delta) ()
   (:let
    (: p :fun Int () 1)
    (: z :fun Int () 0)
    (: n :fun Int () (negate 1))
    (:do
     (:= x Int (:mlist p z n))
     (:= y Int (:mlist p z n))
     (guard (|| (/= x 0) (/= y 0)))
     (return (:mtuple x y))
     )))
(: rook-rays :fun (:list Delta) ()
   (:do
    (:= (:ptuple x y) Delta queen-rays)
    (guard (== 0 (* x y)))
    (return (:mtuple x y))
    ))
(: bishop-rays :fun (:list Delta) ()
   (:do
    (:= (:ptuple x y) Delta queen-rays)
    (guard (/= 0 (* x y)))
    (return (:mtuple x y))
    ))
[(: white-pawn :fun (:tuple (:list Coord)(:list Coord))
   ((b Board)(enpassant(Maybe Coord))(origin Coord))
   (:mtuple
    (white-pawn-advance b origin)
    (white-pawn-capture b enpassant origin)
    ))]

(: get-promotion :fun (:list (Maybe Type-piece)) ((do-promotion Bool))
   (:case do-promotion
	  (False (return Nothing))
	  :else
	  (map Just (:mlist Night Bishop Rook Queen))))
    
(: white-pawn-advance :fun (:list Move-dest) ((b Board)((Coord(:ptuple row col)) Coord))
   (:let
    (: one :fun Coord () (Coord(:mtuple (+ row 1)col)))
    (: two :fun Coord () (Coord(:mtuple (+ row 2)col)))
   (++
    (:do
     (guard (inRange (bounds b) one)) [should not be necessary as no pawns on 8th rank]
     (guard (== Nothing (! b one)))
     (:= promotion (Maybe Type-piece) (get-promotion (== (+ row 1) bmax)))
     (return (Regular-move one promotion))
     )
    (:do
     (guard (== row 1)) [only second rank pawns may advance 2]
     (guard (== Nothing (! b one)))
     (guard (== Nothing (! b two)))
     (:rpipe (Double-pawn (Empty-square-ep one) 
			  (Killed-piece-ep two)) 
	     return)
     )
   )))
(: black-pawn-advance :fun (:list Move-dest) ((b Board)((Coord(:ptuple row col)) Coord))
   (:let
    (: one :fun Coord () (Coord(:mtuple (- row 1)col)))
    (: two :fun Coord () (Coord(:mtuple (- row 2)col)))
   (++
    (:do
     (guard (inRange (bounds b) one)) [should not be necessary as no pawns on 8th rank]
     (guard (== Nothing (! b one)))
     (:= promotion (Maybe Type-piece) (get-promotion (== row 1)))     
     (return (Regular-move one promotion))
     )
    (:do
     (guard (== row (- bmax 1))) [only second rank pawns may advance 2]
     (guard (== Nothing (! b one)))
     (guard (== Nothing (! b two)))
     (:rpipe (Double-pawn (Empty-square-ep one) 
			  (Killed-piece-ep two)) 
	     return)
     
     )
    )))

(: pawn-attack-dir :fun (:list Coord) ((direction Int)(b Board) ((Coord(:ptuple row col)) Coord))
   [not checked whether there is a piece there or enpassant]
   (:do
    (:= ncol Int (:mlist (- col 1)(+ col 1)))
    (:dlet
     (: advance :fun Coord () (Coord(:mtuple (+ row direction)ncol))))
    (guard (inRange (bounds b) advance))
    (return advance)
    )
   )

(: night-steps :fun (:list Delta) ()
   (:let
    (: sign :fun (:list Int) () (:mlist 1 (negate 1)))
    (: onetwo :fun (:list Int) () (:mlist 1 2))
    (:do
     (:= x Int onetwo)
     (:= y Int onetwo)
     (guard (/= x y))
     (:= sx Int sign)
     (:= sy Int sign)
     (:rpipe(:mtuple (* sx x)(* sy y)) return))))
                          

(: classify-pawn-capture :fun (:list Move-dest) ((mycolor Color)(b Board)(enpassant Enpassant)(c Coord))

   (:case enpassant
          ((Enpassant (Empty-square-ep empty)
		      killed)
           :where
           :gpats ((== c empty)
                   (return (Enpassant-capture (Empty-square-ep empty) killed))))
          :else
          (:case (! b c)
                 (Nothing mzero)
                 :else
                 (:do
                  (guard (/= mycolor (get-color b c)))
		  (:= promotion (Maybe Type-piece)
		      (get-promotion
		       (is-promotion mycolor c)))
                  (return (Regular-move c promotion))))))

(: is-promotion :fun Bool ((mycolor Color)((Coord(:ptuple row _))Coord))
   (|| (&& (== mycolor White)
	   (== row bmax))
       (&& (== mycolor Black)
	   (== row 0))))
(: Move-dest :data
   (Double-pawn Empty-square-ep Killed-piece-ep)
   (Enpassant-capture Empty-square-ep Killed-piece-ep)
   (Regular-move Coord (Maybe Type-piece) [second is promotion])
   :deriving (Show))

(: pawn-advance :fun (:fn (:list Move-dest) ((b Board)((:ptuple row col) Coord))) ((color Color))
   (:case color
          (Black black-pawn-advance)
          (White white-pawn-advance)))
[XXX detect color automatically]
(: pawn-attack :fun (:fn (:list Coord) ((b Board) ((:ptuple row col) Coord))) ((color Color))
   (:case color
          (White (pawn-attack-dir 1))
          (Black (pawn-attack-dir (negate 1)))))

(: get-pawn-moves :fun (:list Move-dest) ((b Board)(enpassant Enpassant)(start Coord))
   (:let
    (: color :fun Color () (:rpipe start (! b) fromJust fst))
    (++ (pawn-advance color b start)
        (:rpipe
         (pawn-attack color b start)
         (concatMap (classify-pawn-capture color b enpassant))
         ))))

(: ok-to-move :fun Bool ((b Board)(start Coord)(destination Coord))
   (:case (! b destination)
          (Nothing True)
          ((Just (:ptuple othercolor _))
           (/= (get-color b start) othercolor))))

(: get-piece-moves :fun (:list Move-dest)
   ((b Board)(enpassant Enpassant)(start Coord))
   (:case
    (:rpipe start (! b) fromJust snd fst)
    (Pawn (get-pawn-moves b enpassant start))
    :else
    (:do
     (:= c Coord (regular-moves b start))
     (return (Regular-move c Nothing)))
    ))

(: regular-moves :fun (:list Coord) ((b Board)(start Coord))
   (:case
    (:rpipe start (! b) fromJust snd fst)
    (night-or-king
     :where
     :gpats ( (|| (== night-or-king Night)
                  (== night-or-king King))
              (:rpipe
               (:case night-or-king
                      (Night night-steps)
                      (King queen-rays))
               (map (add-coord start))
               (filter (inRange (bounds b)))
               (filter (ok-to-move  b start))
               )))
     (ray-piece
      (:rpipe
       (:case ray-piece
              (Queen queen-rays)
              (Bishop bishop-rays)
              (Rook rook-rays))
       (many-ray-possibilities b start)
       ))
     ))
(: get-color :fun Color ((b Board)(start Coord))
   (:rpipe start (! b) fromJust fst))

(: get-attacked-squares :fun (:list Coord) ((b Board) (start Coord))
   (:do
    (:= s Coord
        (:case
         (:rpipe start (! b) fromJust snd fst)
         (Pawn (pawn-attack (get-color b start) b start))
         :else
         (regular-moves b start)
         ))
    (guard (== Nothing (! b s)))
    (return s)))

(: board-my-pieces :fun (:list Coord) ((b Board)(mycolor Color))
   (:do
    (:= (:ptuple xy mp) (:tuple Coord (Maybe Piece))(assocs b))
    (guard (isJust mp))
    (:rpipe mp fromJust fst (== mycolor) guard)
    (return xy)
    ))

(: all-attacked-squares :fun (:list Coord) ((b Board)(mycolor Color))
   (:rpipe
    (board-my-pieces b mycolor)
    (map (get-attacked-squares b))
    concat
    Set.fromList
    Set.toList
    ))

(: In-hand :type-synonym (Map.Map Type-piece Int))

(: foo :fun Int ((a Both-pieces-in-hand))
   (fromJust(Map.lookup King 
(:rpipe a (Map.lookup White) fromJust)
)))

(:instance Show (Coord)
   (: show :fun :no-sig String (((Coord (:ptuple rank file)) Coord))
      (++(:mlist (chr (+ (ord (head "a")) file)))
	 (show (+ rank 1))))
)
(: initial-board :fun Board ()
   (:let
    (: w :fun (Maybe Piece) ((color Color)(t Type-piece))
       (Just (:mtuple color (:mtuple t Original))))
    (: first-rank :fun (:list Type-piece) ()
       (:mlist Rook Night Bishop Queen King Bishop Night Rook))
    (: pawns :fun (:list Type-piece) ()
       (replicate 8 Pawn))
    (listArray board-range
	      (:cc
	       (map (w White) first-rank )
	       (map (w White) pawns )
	       (replicate 32 Nothing)
	       (map (w Black) pawns )
	       (map (w Black) first-rank )
	       ))))
(: Both-pieces-in-hand :type-synonym (Map.Map Color In-hand))
(: Game-state :data (Game-state Board Enpassant Color Both-pieces-in-hand)
   :deriving (Show))
(: Dmove :data Pass
   (Rmove Coord Move-dest)
   (Drop Type-piece Coord)
   :deriving (Show)
   )
(: Enpassant :data No-enpassant
   (Enpassant Empty-square-ep
	      Killed-piece-ep)
   :deriving(Show)
   )
(: Empty-square-ep :newtype (Empty-square-ep Coord) :deriving (Show Eq))
(: Killed-piece-ep :newtype (Killed-piece-ep Coord) :deriving (Show Eq))

(: all-pieces :fun (:list Type-piece) ()
   (:mlist Pawn Rook Night Bishop Queen King))
[(: null-pieces :fun Both-pieces-in-hand ()
[xxx delete this]
   (:let
    (: nothing :fun In-hand ()
       [(Map.fromList
	(:do
	 (:= ty Type-piece all-pieces)
	 (return (:mtuple ty 0))))]
       Map.empty
       )
    (Map.fromList
    (:mlist
     (:mtuple White nothing)
     (:mtuple Black nothing)
     )
    )))]

(: othercolor :fun Color ((c Color))
   (:case c
	  (Black White)
	  (White Black)))
(: execute-regular-move :fun Game-state 
   (((:as g(Game-state oldboard _ color oldhand)) Game-state)
    (origin Coord)
    ((Regular-move dest mpromote) Move-dest))
   (:let
    (: newboard :fun Board ()
       (// oldboard 
	   (:mlist
	    (:mtuple origin Nothing)
	    (:mtuple 
	     dest
	     (:case 
	      mpromote
	      (Nothing (! oldboard origin))
	      ((Just ty) (Just(:mtuple color (:mtuple ty Was-a-pawn))))))))
       )
    (: newhand :fun Both-pieces-in-hand ()
       (:case (! oldboard dest)
	      (Nothing oldhand)
	      ((Just(:ptuple _ (:ptuple ty Original)))
	       (increment-both-hand g ty))
	      ((Just(:ptuple _ (:ptuple _ Was-a-pawn)))
	       (increment-both-hand g Pawn))
	      ))
    (: theothercolor :fun Color () (othercolor color))
    (:rpipe
     (Game-state newboard No-enpassant theothercolor newhand)
     (assert (== color (:rpipe (! oldboard origin) fromJust fst)))
     (assert (:case (! oldboard dest)
		    (Nothing True)
		    ((Just (:ptuple oc _))(== oc theothercolor))))
     )
    ))
(: execute-enpassant :fun Game-state 
   (((:as g(Game-state oldboard (Enpassant old-e old-k) color _)) Game-state)
    (origin Coord)
    ((Enpassant-capture (:as e(Empty-square-ep empty))
			(:as k(Killed-piece-ep killed))) Move-dest))
   (:let
    (: newboard :fun Board ()
       (// oldboard 
	   (:mlist
	    (:mtuple origin Nothing)
	    (:mtuple empty (! oldboard origin))
	    (:mtuple killed Nothing))))
    (: theothercolor :fun Color () (othercolor color))
    (:rpipe
     (Game-state newboard No-enpassant theothercolor
		 (increment-both-hand g Pawn))
     [enps match]
     (assert (&& (== e old-e) (== k old-k)))
     [moving piece was a pawn]
     (assert (== (Just (:mtuple color (:mtuple Pawn Original)))
		 (! oldboard origin)))
     [empty square is empty]
     (:rpipe empty (! oldboard) isNothing assert)
     [killed piece was a pawn]
     (assert (== (Just (:mtuple theothercolor (:mtuple Pawn Original)))
		 (! oldboard killed)))
     )))

(: execute-double-pawn :fun Game-state 
   (((Game-state oldboard _ color oldpieces) Game-state)
    (origin Coord)
    ((Double-pawn (:as e(Empty-square-ep empty))
		  (:as k (Killed-piece-ep killed))) Move-dest))
   (:let
    (: newboard :fun Board ()
       (// oldboard 
	   (:mlist
	    (:mtuple origin Nothing)
	    (:mtuple killed (! oldboard origin) ))))
    (: theothercolor :fun Color () (othercolor color))
    (:rpipe
     (Game-state newboard (Enpassant e k)
		 theothercolor oldpieces)
     [moving piece was a pawn]
     (assert (== (Just (:mtuple color (:mtuple Pawn Original)))
		 (! oldboard origin)))
     [empty square is empty]
     (:rpipe empty (! oldboard) isNothing assert)
     [killed square is empty]
     (:rpipe killed (! oldboard) isNothing assert))
     ))

(: execute-drop :fun Game-state 
   (((:as g(Game-state oldboard _ color _)) Game-state)
    (ty Type-piece)
    (location Coord)
   )
   (:let
    (: newboard :fun Board ()
       (// oldboard 
	   (:mlist
	    (:mtuple location (Just(:mtuple color
				       (:mtuple ty Original))))
	    )))
    (: theothercolor :fun Color () (othercolor color))
    (:rpipe
     (Game-state newboard No-enpassant
		 theothercolor (decrement-both-hand g ty))
     [empty square is empty]
     (:rpipe location (! oldboard) isNothing assert)
     )))

(: execute-pass :fun Game-state 
   (((Game-state oldboard _ color oldhand) Game-state))
   (:let
    (: theothercolor :fun Color () (othercolor color))
    (Game-state oldboard No-enpassant
		 theothercolor oldhand)
    ))

(: execute-move :fun Game-state
   ((g Game-state)
    (dm Dmove))
   (:case dm
	  ((Rmove origin (:as m (Regular-move _ _)))
	   (execute-regular-move g origin m))
	  ((Rmove origin (:as m (Enpassant-capture _ _)))
	   (execute-enpassant g origin m))
	  ((Rmove origin (:as m (Double-pawn _ _)))
	   (execute-double-pawn g origin m))
	  ((Drop ty loc)
	   (execute-drop g ty loc))
	  (Pass (execute-pass g))
	  ))

(: initial-game-state :fun Game-state ()
   (Game-state initial-board No-enpassant White 
	       (Map.fromList
		(:mlist
		 (:mtuple White Map.empty)
		 (:mtuple Black Map.empty)))
	       ))

(: get-moves :fun (:list Dmove) ((g Game-state))
   (:mcons 
    Pass
    (++ (get-drops g)
	(get-rmoves g))))
(: get-drops :fun (:list Dmove) (((Game-state board enpassant color hand)Game-state))
   (:do
    (:= empty Coord (all-attacked-squares board color))
    (:rpipe
     (return :nothing)
     (:rpipe
      (! board empty)
      isNothing
      assert))
    (:= dropper Type-piece (available-pieces-in-hand ((Map.!) hand color)))
    (guard (:case dropper
		  (Pawn (pawn-drop-ok empty))
		  :else True))
    (return (Drop dropper empty)))
   )
(: get-rmoves :fun (:list Dmove) (((Game-state board enpassant color hand)Game-state))
   (:do
    (:= p Coord (board-my-pieces board color))
    (:= m Move-dest (get-piece-moves board enpassant p))
    (return (Rmove p m))
    )
   )
    
(: print-game-state :fun (IO :unit) (((Game-state b _ _ hand)Game-state))
   (:do
    (:rpipe b show-board putStrLn)
    (:rpipe hand Map.toList show-list)
    ))
(: move-number :fun Game-state ((g Game-state)(n Int))
   (execute-move g (!! (get-moves g) n)))
[useful with foldl: 
print_game_state$foldl move_number initial_game_state [11,9,27,6,29]
]
(: st-execute-double-pawn :fun (ST s :unit)((oldgame (STArray s Coord (Maybe Piece))))
   undefined)
(: increment-in-hand :fun In-hand ((old In-hand)(t Type-piece))
   (Map.insertWith + t 1 old))
(: increment-both-hand :fun Both-pieces-in-hand 
   (((Game-state _ _ color hand)Game-state)(t Type-piece))
   (:let
    (: old :fun In-hand ()
       ((Map.!) hand color)
       [parentheses required... sigh]
       )
    
    (Map.insert color (increment-in-hand old t) hand)))
(: decrement-both-hand :fun Both-pieces-in-hand
   (((Game-state _ _ color hand)Game-state)(t Type-piece))
   (:rpipe
    (Map.insert color
		(Map.insertWith + t (negate 1) ((Map.!)hand color))
		hand)
    (assert
     (< 0 ((Map.!)((Map.!)hand color) t)))
    ))

(: available-pieces-in-hand :fun (:list Type-piece)
   ((hand In-hand))
   (:do
    (:= pc Type-piece all-pieces)
    (guard (:case (Map.lookup pc hand)
		  (Nothing False)
		  ((Just(n))(< 0 n))))
    (return pc)))
(: numbered-move-list :fun (IO :unit) ((g Game-state))
   (:rpipe
    g get-moves (zip (enumFrom 0)) show-list))
(: pawn-drop-ok :fun Bool (((Coord(:ptuple row _))Coord))
   (&& ( < 0 row)
       ( < row bmax)))
(: state-and-moves :fun (IO :unit) ((g Game-state))
   (:do
    (numbered-move-list g)
    (:join(:rpipe(:mtuple 0
			  (:rpipe g get-moves length pred))
	   randomR getStdRandom)print)
    (print-game-state g)
    ))

(: do-random-move :fun (IO (Maybe (:tuple Dmove Game-state)))((g Game-state))
   (:case
    (is-position-lost g)
    (True (return Nothing))
    :else
    (:do
     (:dlet
      (: moves :fun (:list Dmove)()
	 (get-moves g)))
     (putStrLn (:cc (show(length moves)) " moves"))
     (:= m Dmove (random-from-list moves))
     (return (Just (:mtuple
		    m
		    (execute-move g m)))))))

(: decer :fun (IO Integer) ((x Integer))
   (:do
    (return ( - x 2))))

(: manydecer :fun (IO :unit) ((start Integer))
   (:do
    (:= once Integer (decer start))
    (:case once 
	   (0 (:do
		  (putStrLn "done")))
	   :else
	   (manydecer once))))

[the above, works]

(: many-moves :fun (IO :unit) ((start Game-state))
   (:do
    (:= mmove (Maybe (:tuple Dmove Game-state)) (depth-one-search start))
    (:case mmove
	   (Nothing (return :nothing))
	   ((Just(:ptuple move newstate))
	    (:do
	     (putStrLn(show move))
	     (print-game-state newstate)
	     (putStrLn "=====")
	     (many-moves newstate))))))
(: is-position-lost :fun Bool (((Game-state board _ color _)Game-state))
   (null (board-my-pieces board color)))

(: depth-one-search :fun (IO (Maybe (:tuple Dmove Game-state)))((g Game-state))
   (:case
    (is-position-lost g)
    (True (return Nothing))
    :else
    (:let
     (: moves2 :fun (:list Dmove)()
	(depth-one-moves g))
     (:do
      [(putStrLn (:cc (show(length moves2)) " moves"))]
      (:= m Dmove (random-from-list moves2))
      (return (Just (:mtuple
		     m
		     (execute-move g m))))))))
(: capturing-rmove :fun Bool (((Game-state board _ _ _)Game-state)
			      (m Dmove))
   (:case m
	  ((Rmove _ (Double-pawn _ _))False)
	  ((Rmove _ (Enpassant-capture _ _))True)
	  ((Rmove _ (Regular-move dest _))(isJust (! board dest)))
	  ))

(: depth-one-moves :fun (:list Dmove) ((g Game-state))
   (:case (:rpipe g get-rmoves [only rmoves can kill]
		  (filter (:rcompose (execute-move g) is-position-lost)))
	  ((:nil)(get-moves g))
	  (x x)))

(: many-moves-counter :fun (IO :unit) ((counter Int)(start Game-state))
   (:do
    (:= mmove (Maybe (:tuple Dmove Game-state)) (depth-one-search start))
    (:case mmove
	   (Nothing (print counter))
	   ((Just(:ptuple move newstate))
	    (:do
	     [(putStrLn(show move))
	     (print-game-state newstate)
	     (putStrLn "=====")]
             (:let
              [(: next-counter :fun Int ()
                 (succ counter))]
              (seq counter (many-moves-counter (succ counter) newstate))))))))