egison-4.0.0: sample/chopsticks.egi

assocMultiset a := matcher
  | [] as () with
    | [] -> [()]
    | _  -> []
  | #$x :: $ as assocMultiset a with
    | $tgt -> match tgt as list (a, integer) with
              | $hs ++ (#x, #1) :: $ts -> hs ++ ts
              | $hs ++ (#x, $n) :: $ts -> hs ++ (x, n - 1) :: ts
  | $ :: $ as (a, assocMultiset a) with
    | $tgt -> matchAll tgt as list (a, integer) with
              | $hs ++ ($x, #1) :: $ts -> (x, hs ++ ts)
              | $hs ++ ($x, !#1 & $n) :: $ts -> (x, hs ++ (x, n - 1) :: ts)
  | $ as something with
    | $tgt -> [tgt]

assertEqual "assocMultiset"
  (matchAll [(1,2),(2,1),(3,3)] as assocMultiset integer with
   | #1 :: $rs -> rs)
  [(1, 1), (2, 1), (3, 3)]

assertEqual "assocMultiset"
  (matchAll [(1,2),(2,1),(3,3)] as assocMultiset integer with
   | #2 :: $rs -> rs)
  [(1, 2), (3, 3)]

assertEqual "assocMultiset"
  (matchAll [(1,2),(2,1),(3,3)] as assocMultiset integer with
   | $x :: $rs -> (x,rs))
  [(2, [(1, 2), (3, 3)]), (1, [(1, 1), (2, 1), (3, 3)]), (3, [(1, 2), (2, 1), (3, 2)])]

assocToList xs := concat (matchAllDFS xs as list (something, integer) with
  | _ ++ ($x, $n) :: _ -> take n (repeat1 x))

assertEqual "assocToList"
  (assocToList [(1,2),(2,1),(3,3)])
  [1, 1, 2, 3, 3, 3]

N := 5

tree a := matcher
  | node $ $ as (a, multiset (tree a)) with
    | Node $x $ts -> [(x, ts)]
  | $ as something with
    | $tgt -> [tgt]

state := (integer, assocMultiset integer, assocMultiset integer)

fOrS s := match s as state with
  | ($h, _, _) -> h

transformState s := match s as state with
  | ($h, $x, $y) -> (h, assocToList x, assocToList y)

move s := matchAllDFS s as state with
  -- equal or less than N
  | (#1, ($s1 & $x :: _), (?(\y -> x + y < N + 1) & $y) :: $rs')
    -> (2, s1, add (x + y) rs')
  -- the single hand becomes more than N
  | (#1, ($s1 & $x :: _), ?(\y -> x + y > N) :: [])
    -> (-1, s1, [])
  -- a hand becomes more than N
  | (#1, ($s1 & $x :: _), (?(\y -> x + y > N) & $y) :: (![] & $rs'))
    -> (2, s1, rs')
  -- equal or less than N
  | (#2, $x :: $rs', (?(\y -> x + y < N + 1) & $y) :: _ & $s2)
    -> (1, add (x + y) rs', s2)
  -- the single hand becomes more than N
  | (#2, $x :: [], (?(\y -> x + y > N) :: _) & $s2)
    -> (-2, [], s2)
  -- a hand becomes more than N
  | (#2, $x :: (![] & $rs'), (?(\y -> x + y > N) :: _) & $s2)
    -> (1, rs', s2)

add x xs := matchDFS xs as list (integer, integer) with
  | $hs ++ (#x, $n) :: $ts -> hs ++ (x, n + 1) :: ts
  | $hs ++ (!((?(\y -> x > y), _) :: _) & $ts) -> hs ++ (x, 1) :: ts
  | _ -> (x, 1) :: xs


"move"
move (1, [(2,1)], [(1,1), (5,1)]) -- [(2, [(2, 1)], [(3, 1), (5, 1)]), (2, [(2, 1)], [(1, 1)])]
move (2, [(1,1), (5,1)], [(2,1)]) -- [(1, [(3, 1), (5, 1)], [(2, 1)])]


assertEqual "add"
  (add 1 [(1,3),(3,1)])
  [(1, 4), (3, 1)]

assertEqual "add"
  (add 2 [(1,3),(3,1)])
  [(1, 3), (2, 1), (3, 1)]

init := (1, [(1,2)], [(1,2)])

assertEqual "move"
  (move init)
  [(2, [(1, 2)], [(1, 1), (2, 1)])]

makeTree x := Node x (map makeTree (move x))

assertEqual "makeTree"
  (makeTree (1, [(2, 1)], [(1, 1)]))
  (Node (1, [(2, 1)], [(1, 1)])
    [Node (2, [(2, 1)], [(3, 1)])
       [Node (1, [(5, 1)], [(3, 1)])
          [Node (-1, [(5, 1)], [])
             []]]])

topTree s n :=
  matchAllDFS makeTree s as tree state with
  | loop $i (1, [1..n], $m)
      (node $x_i (... :: _))
      _
  -> map (\i -> x_i) [1..m]


paths :=
  matchAllDFS makeTree init as tree state with
  | loop $i (1, $n)
      (node $x_i (... :: _))
      (node $x_(n + 1) [])
  -> map (\i -> x_i) [1..(n + 1)]

--io (each (compose show print) (head paths))

winningRec s :=
  matchAll makeTree s as tree state with
  | (node ($h, _, _)
         ((node ($t & ((#(neg h), _, _)
                    | ?(\t -> (empty? (winningRec t))))) _)
          :: _))
  -> t

winningNot s :=
  matchAllDFS makeTree s as tree state with
  | node ($h, _, _)
      (loop $i (1, [1..], _)
         (node $t !(node _ !... :: _) :: _)
         (node (#(neg h), _, _) _ :: _))
  -> t

winning c :=
  matchAllDFS makeTree c as tree state with
  | node ($h, _, _)
      (loop $i (1, $n)
         (node $f_i (forall (@ :: _)
                            (node $s_i ...)) :: _)
         (node ((#(neg h), _, _) & $l) _ :: _))
  -> c :: concat (map (\i -> [f_i, s_i]) [1..n]) ++ [l]

"winning (first)"
io (each (compose (\l -> (map transformState l)) (compose show print)) (winning init))

"winning (second)"
winning (2, [(1, 2)], [(2, 1), (1, 1)])

"winning"
winning (1, [(5, 2)], [(5, 1)])

"winning"
winning (1, [(2, 1)], [(1, 1)])

assertEqual "winningNot (first)"
  (winningNot init)
  [(2, [(1, 2)], [(2, 1), (1, 1)])]

assertEqual "winningNot (second)"
  (winningNot (2, [(1, 2)], [(2, 1), (1, 1)]))
  []