module MyState where

type Pos' s t a b = s -> (a, b -> t)
type Pos s a = Pos' s s a a

p2_1 :: Pos' (x, y) (z, y) x z
p2_1 = \ (x, y) -> (x, \ x1 -> (x1, y))
xP = p2_1

p2_2 :: Pos' (x, y) (x, w) y w
p2_2 = \ (x, y) -> (y, \ y1 -> (x, y1))
yP = p2_2

p3_1 :: Pos' (x, y, z) (s, y, z) x s
p3_1 = \ (x, y, z) -> (x, \ x1 -> (x1, y, z))
xT = p3_1

p3_2 :: Pos' (x, y, z) (x, t, z) y t
p3_2 = \ (x, y, z) -> (y, \ y1 -> (x, y1, z))
yT = p3_2

p3_3 :: Pos' (x, y, z) (x, y, u) z u  
p3_3 = \ (x, y, z) -> (z, \ z1 -> (x, y, z1))
zT = p3_3

p4_1 :: Pos' (x, y, z, w) (s, y, z, w) x s
p4_1 = \ (x, y, z, w) -> (x, \ x1 -> (x1, y, z, w))
xQ = p4_1

p4_2 :: Pos' (x, y, z, w) (x, t, z, w) y t
p4_2 = \ (x, y, z, w) -> (y, \ y1 -> (x, y1, z, w))
yQ = p4_2

p4_3 :: Pos' (x, y, z, w) (x, y, u, w) z u 
p4_3 = \ (x, y, z, w) -> (z, \ z1 -> (x, y, z1, w))
zQ = p4_3

p4_4 :: Pos' (x, y, z, w) (x, y, z, v) w v
p4_4 = \ (x, y, z, w) -> (w, \ w1 -> (x, y, z, w1))
wQ = p4_3

x_ :: Pos' (x, y, z, i, j, k, m, n) (p, y, z, i, j, k, m, n) x p
x_ = \ (x, y, z, i, j, k, m, n) -> (x, \ x1 -> (x1, y, z, i, j, k, m, n))

y_ :: Pos' (x, y, z, i, j, k, m, n) (x, p, z, i, j, k, m, n) y p
y_ = \ (x, y, z, i, j, k, m, n) -> (y, \ y1 -> (x, y1, z, i, j, k, m, n))

z_ :: Pos' (x, y, z, i, j, k, m, n) (x, y, p, i, j, k, m, n) z p
z_ = \ (x, y, z, i, j, k, m, n) -> (z, \ z1 -> (x, y, z1, i, j, k, m, n))

i_ :: Pos' (x, y, z, i, j, k, m, n) (x, y, z, p, j, k, m, n) i p
i_ = \ (x, y, z, i, j, k, m, n) -> (i, \ i1 -> (x, y, z, i1, j, k, m, n))

j_ :: Pos' (x, y, z, i, j, k, m, n) (x, y, z, i, p, k, m, n) j p
j_ = \ (x, y, z, i, j, k, m, n) -> (j, \ j1 -> (x, y, z, i, j1, k, m, n))

k_ :: Pos' (x, y, z, i, j, k, m, n) (x, y, z, i, j, p, m, n) k p
k_ = \ (x, y, z, i, j, k, m, n) -> (k, \ k1 -> (x, y, z, i, j, k1, m, n))

m_ :: Pos' (x, y, z, i, j, k, m, n) (x, y, z, i, j, k, p, n)  m p
m_ = \ (x, y, z, i, j, k, m, n) -> (m, \ m1 -> (x, y, z, i, j, k, m1, n))

n_ :: Pos' (x, y, z, i, j, k, m, n) (x, y, z, i, j, k, m, p) n p
n_ = \ (x, y, z, i, j, k, m, n) -> (n, \ n1 -> (x, y, z, i, j, k, m, n1))

cmpPos :: Pos' s t x y -> Pos' x y a b -> Pos' s t a b
p1 `cmpPos` p2 = \ s -> let (x, f) = p1 s -- f :: y -> t 
                            (a, g) = p2 x -- g :: b -> y
                          in (a, f . g)  

class MyState m where
  get :: Pos s a -> m s a
  set :: Pos s a -> a -> m s ()
  extend :: Pos s t -> m t a -> m s a
  shrink :: (s -> t) -> (t -> s) -> m s a -> m t a

resetLocal y m  = extend xP $ shrink (\ (x, _) -> x) (\ x -> (x, y)) m
resetGlobal x m = extend yP $ shrink (\ (_, y) -> y) (\ y -> (x, y)) m

update :: (Monad (m s), MyState m) => Pos s a -> (a -> a) ->  m s ()
update p st = do a <- get p
                 set p (st a)

-- Todo: State に Dynamic を使って、cons, nil, … を実装する
--       参考: MicroKanren.hs
data MuList s a = MuNil | MuCons (Pos s a) (Pos s (MuList s a))

data MuTree s a = MuEmpty
                 | MuBranch (Pos s (MuTree s a)) (Pos s a) (Pos s (MuTree s a))

pair x y     = (x,y)
triple x y z = (x,y,z)