module peg

import StdEnv

from Text import class Text, instance Text String
import qualified Text
from Data.Func import $
import Data.Tuple
import Data.List
import Data.Functor
import Data.Monoid
import Control.Monad
import Control.Monad.RWST
import Control.Applicative
import Data.Maybe
import Data.Functor

:: Coord :== (Int, Int)
:: Position = Inv | Emp | Peg
:: PegBoard :== {{Position}}
:: Move :== (Coord, Direction)
:: Direction = N | E | S | W
:: Solver a :== RWST () [PegBoard] PegBoard Maybe a

european :: PegBoard
european = 
	{{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
	,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
	,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
	,{Peg, Peg, Peg, Emp, Peg, Peg, Peg}
	,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
	,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
	,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
	}

empty = RWST \_ _->Nothing
(<|>) (RWST fa) (RWST fb) = RWST \r s->maybe (fb r s) Just (fa r s)

instance toChar Position where
	toChar p = case p of Inv = ' '; Emp = '.'; Peg = 'o'

transform :: Coord Direction -> Coord
transform (x, y) d = case d of N = (x, y+1); S = (x, y-1); W = (x+1, y); E = (x-1, y)

getPos :: Coord -> Solver Position
getPos (x, y) = get >>= \b->if (valid b) empty (pure b.[y].[x])
where 
	valid b = y<0 || x<0 || y >= size b || x >= size b.[0] || b.[y].[x] =: Inv

move :: Move -> Solver ()
move (tc=:(tx, ty), d)
# sc=:(sx, sy) = transform tc d
# fc=:(fx, fy) = transform sc d
= get >>= \b->liftM3 tuple3 (getPos fc) (getPos sc) (getPos tc) >>= \f->case f of
	(Peg, Peg, Emp)
		# b = {{{c\\c<-:r}\\r<-:b} & [fy,fx]=Emp, [sy,sx]=Emp, [ty,tx]=Peg}
		= tell [b] >>| put b
	_ = empty

getCoords :: (Position -> Bool) PegBoard -> [Coord]
getCoords f b = [(x, y)\\r<-:b & y<-[0..] , c<-:r & x<-[0..] | f c]

win :: (PegBoard -> Bool)
win = (==) 1 o length o getCoords (\c->c=:Peg)

printPegBoard :: PegBoard -> String
printPegBoard b = 'Text'.join "\n" [{#toChar x\\x<-:r}\\r <-: b]

moves :: Solver [Move]
moves = gets $ \b->[(c,d)\\c<-getCoords (\c->c=:Emp) b, d<-[N,E,S,W]]

solve :: PegBoard -> Maybe [PegBoard]
solve b = snd <$> evalRWST (tell [b] >>| solver) () b
where
	solver = get >>= \board->if (win board)
		(get >>= tell o pure)
		(moves >>= foldr (<|>) empty o map (\m->move m >>| solver))

Start = 'Text'.join "\n" o map printPegBoard <$> solve european