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