module a10

import StdEnv

import Data.Functor
import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.Error
import Text => qualified join

:: BM a b =
	{ t :: a->b
	, f :: b->a
	, t2 :: A.c t:(t c a)->t c b
	, f2 :: A.c t:(t b c)->t a c
	}
bm = {t = id, f = id, t2 = id, f2 = id}

:: Action b a
	= MoveToShip (BM b High) (BM a High)
	| MoveToQuay (BM b High) (BM a High)
	| MoveUp     (BM b Low)  (BM a High)
	| MoveDown   (BM b High) (BM a Low)
	| Lock       (BM b Low)  (BM a Low)
	| Unlock     (BM b Low)  (BM a Low)
	| Wait       (BM b a)
	| E.i: (:.) infixl 1 (Action b i) (Action i a)
	| WhileContainerBelow (BM b a) (Action a a)
:: High = High
:: Low = Low

moveToShip = MoveToShip bm bm
moveToQuay = MoveToQuay bm bm
moveUp     = MoveUp     bm bm
moveDown   = MoveDown   bm bm
lock       = Lock       bm bm
unlock     = Unlock     bm bm
wait       = Wait       bm
whileContainerBelow = WhileContainerBelow bm

:: State =
	{ onShip      :: [String]
	, onQuay      :: [String]
	, craneUp     :: Bool
	, craneOnQuay :: Bool
	, locked      :: Maybe String
	}

state0 =
	{ onShip = []
	, onQuay = ["apples","beer","camera's"]
	, craneUp = True
	, craneOnQuay = True
	, locked = Nothing
	}

// ================
eval :: (Action i f) State -> MaybeErrorString State
eval (MoveToShip _ _) s = pure {s & craneOnQuay = False}
eval (MoveToQuay _ _) s = pure {s & craneOnQuay = True}
eval (MoveUp _ _)     s = pure {s & craneUp = True}
eval (MoveDown _ _)   s = pure {s & craneUp = False}
eval (Lock _ _)       s=:{locked=Nothing}
	| s.craneOnQuay
		= case s.onQuay of
			[c:r] = pure {s & onQuay = r, locked = Just c}
			[]    = Error "Cannot lock container on empty quay"
		= case s.onShip of
			[c:r] = pure {s & onShip = r, locked = Just c}
			[]    = Error "Cannot lock container on empty ship"
eval (Lock _ _)       s=:{locked=(Just c)}
	= Error ("Cannot lock new container, craner contains " +++ c)
eval (Unlock _ _)     s=:{locked=(Just c)}
	| s.craneOnQuay = pure {s & onQuay = [c:s.onQuay], locked = Nothing}
	                = pure {s & onShip = [c:s.onShip], locked = Nothing}
eval (Unlock b1 b2)   s=:{locked=Nothing}
	= Error "Cannot unlock container, crane contains nothing"
eval (Wait _)       s = Ok s
eval (a :. b)       s = eval a s >>= eval b
eval (WhileContainerBelow _ action) s
	| s.craneOnQuay && not (isEmpty s.onQuay) || not s.craneOnQuay && not (isEmpty s.onShip)
		= eval (action :. whileContainerBelow action) s
	= pure s

opt :: (Action a b) -> Action a b
opt (WhileContainerBelow b a) = WhileContainerBelow b (opt a)
opt (Wait bm :. b) = opt (bm.f2 b)
opt (a :. Wait bm) = opt (bm.t2 a)
opt (a :. b) = opt a :. opt b
opt x = x

Start = opt (moveToShip :. wait :. moveDown)
//print :: (Action i f) [String] -> [String]
//print (MoveToShip _ _) s = ["Move to ship":s]
//print (MoveToQuay _ _) s = ["Move to quay":s]
//print (MoveUp _ _)     s = ["Move up":s]
//print (MoveDown _ _)   s = ["Move down":s]
//print (Lock _ _)       s = ["Lock":s]
//print (Unlock _ _)     s = ["Unlock":s]
//print (Wait _)         s = ["Wait":s]
//print (a :. b)         s = print a ["\n":print b s]
//print (WhileContainerBelow _ a) s
//	= ["While container below (":indent ["\n":print a [")":s]]]
//where
//	indent s = map (\s->if (s.[0] == '\n') (s +++ "\t") s)
//

print :: (Action i f) String [String] -> [String]
print (MoveToShip _ _) i s = [i,"Move to ship":s]
print (MoveToQuay _ _) i s = [i,"Move to quay":s]
print (MoveUp _ _)     i s = [i,"Move up":s]
print (MoveDown _ _)   i s = [i,"Move down":s]
print (Lock _ _)       i s = [i,"Lock":s]
print (Unlock _ _)     i s = [i,"Unlock":s]
print (Wait _)         i s = [i,"Wait":s]
print (a :. b)         i s = print a i ["\n":print b i s]
print (WhileContainerBelow _ a) i s
	= [i,"While container below (\n":print a ("\t"+++i) ["\n",i,")":s]]

Start = print loadShip "" []

p1 = moveToShip :. moveDown

//p2 = moveToShip :. wait :. lock // the required type error

loadShip =
	whileContainerBelow (
		moveDown:.
		lock:.
		moveUp:.
		moveToShip:.
		wait:.
		moveDown:.
		wait:.
		unlock:.
		moveUp:.
		moveToQuay
	) :. wait