module a8

/*
  Advanced Progrmming 2018, Assignment 8
  Pieter Koopman, pieter@cs.ru.nl
*/
import StdEnv

import iTasks => qualified return, >>=, >>|, sequence, forever, :: Set

import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans
import Data.Func
import Data.Functor
import Data.Either
import Data.Maybe

import Text => qualified join

import qualified Data.List as List
import qualified Data.Map as Map

:: Expression
  = New      [Int]
  | Elem     Int
  | Variable Ident
  | Size     Set
  | (+.) infixl 6 Expression Expression
  | (-.) infixl 6 Expression Expression
  | (*.) infixl 7 Expression Expression
  | (=.) infixl 2 Ident Expression

:: Logical
  = TRUE | FALSE
  | (In) infix 4 Elem Set
  | (==.) infix 4 Expression Expression
  | (<=.) infix 4 Expression Expression
  | Not Logical
  | (||.) infixr 2 Logical Logical
  | (&&.) infixr 3 Logical Logical

:: Stmt
  = Expression Expression
  | Logical Logical
  | For Ident Set Stmt
  | If Logical Stmt Stmt

:: Set    :== Expression
:: Elem   :== Expression
:: Ident  :== String

// === State
:: Val :== Either Int [Int]
:: SemState :== 'Map'.Map String Val
:: Sem a :== StateT SemState (Either String) a

store :: Ident Val -> Sem Val
store k v = modify ('Map'.put k v) *> pure v

read :: Ident -> Sem Val
read k = gets ('Map'.get k) >>= maybe (fail "Unknown ident") pure

fail :: String -> Sem a
fail s = liftT (Left s)

// === semantics
isset :: (Sem Val) -> Sem [Int]
isset s = s >>= either (\_->fail "Expected Set, got Elem") pure

iselem :: (Sem Val) -> Sem Int
iselem s = s >>= either pure (\_->fail "Expected Elem, got Set")

class eval t ~v :: t -> Sem v

instance eval Expression Val
where
	eval :: Expression -> Sem Val
	eval (New s)      = pure $ Right s
	eval (Elem i)     = pure $ Left i
	eval (Variable i) = read i
	eval (Size s)     = isset (eval s) >>= pure o Left o length
	eval (l +. r)     = eval l >>= \x->eval r >>= \y->case (x, y) of
		(Left  x, Left  y) = pure $ Left (x + y)
		(Left  x, Right y) = pure $ Right $ 'List'.union [x] y
		(Right x, Left  y) = pure $ Right $ 'List'.union x [y]
		(Right x, Right y) = pure $ Right $ 'List'.union x y
	eval (l -. r)     = eval l >>= \x->eval r >>= \y->case (x, y) of
		(Left  x, Left  y) = pure $ Left (x - y)
		(Left  x, Right y) = fail "Elem -. Set is illegal"
		(Right x, Left  y) = pure $ Right $ 'List'.intersect x [y]
		(Right x, Right y) = pure $ Right $ 'List'.intersect x y
	eval (l *. r)     = eval l >>= \x->eval r >>= \y->case (x, y) of
		(Left  x, Left  y) = pure $ Left (x * y)
		(Left  x, Right y) = pure $ Right [x*y\\y<-y]
		(Right x, Left  y) = fail "Set *. Elem is illegal"
		(Right x, Right y) = pure $ Right $ 'List'.intersect x y
	eval (v =. b)    = eval b >>= store v

instance eval Logical Bool
where
	eval TRUE        = pure True
	eval FALSE       = pure False
	eval (e In s)    = liftM2 'List'.elem (iselem (eval e)) (isset (eval s))
	eval (e1 ==. e2) = liftM2 (===) (eval e1) (eval e2)
	eval (e1 <=. e2) = evalExpr e1 >>= \x->evalExpr e2 >>= \y->case (x, y) of
		(Left e1, Left e2) = pure $ e1 < e2
		(Left e1, Right e2) = pure $ True
		(Right e1, Left e2) = pure $ False
		(Right e1, Right e2) = pure $ length e1 < length e2
	where
		evalExpr :: (Expression -> Sem Val)
		evalExpr = eval
	eval (Not l)     = not <$> eval l
	eval (l1 ||. l2) = liftM2 (||) (eval l1) (eval l2)
	eval (l1 &&. l2) = liftM2 (&&) (eval l1) (eval l2)

instance eval Stmt ()
where
	eval (Expression e) = eval e >>| pure ()
	eval (Logical l)    = eval l >>| pure ()
	eval (For i e s)    = (eval e >>= store i) *> eval s
	eval (If l s1 s2)   = eval l >>= \b->if b (eval s1) (eval s2)

class print t :: t [String] -> [String]
instance print Expression
where
	print (New s)      c = ["[":'List'.intersperse "," $ map toString s] ++ ["]":c]
	print (Elem i)     c = [toString i:c]
	print (Variable i) c = [i:c]
	print (Size s)     c = ["size(":print s [")":c]]
	print (l +. r)     c = ["(":print l ["+.":print r [")":c]]]
	print (l -. r)     c = ["(":print l ["-.":print r [")":c]]]
	print (l *. r)     c = ["(":print l ["*.":print r [")":c]]]
	print (l =. r)     c = [l,"=.":print r c]

instance print Logical
where
	print TRUE        c = ["True":c]
	print FALSE       c = ["False":c]
	print (e In s)    c = print e [" in ":print s c]
	print (e1 ==. e2) c = ["(":print e1 ["==.":print e2 [")":c]]]
	print (e1 <=. e2) c = ["(":print e1 ["<=.":print e2 [")":c]]]
	print (Not l)     c = ["not (":print l [")":c]]
	print (l1 ||. l2) c = ["(":print l1 ["||.":print l2 [")":c]]]
	print (l1 &&. l2) c = ["(":print l1 ["&&.":print l2 [")":c]]]

instance print Stmt
where
	print (Expression e) c = print e c
	print (Logical l)    c = print l c
	print (For i e s)    c = ["For ",i,"=":print e ["in":print s ["Rof":c]]]
	print (If l s1 s2)   c = ["If":print l ["then":print s1 ["else":print s2 ["Fi":c]]]]

// === simulation
stateShared :: Shared SemState
stateShared = sharedStore "sharedSemState" 'Map'.newMap

derive class iTask Expression, Logical, Stmt

main :: Task SemState
main = 'iTasks'.forever $
	    enterInformation "Enter a statement" []
	-|| viewSharedInformation "Old state" [ViewAs printer] stateShared
	>&^ viewSharedInformation "Print" [ViewAs viewer]
	>&> viewSharedInformation "New state" [ViewAs $ fmap printer] o mapRead evaler o ((>*<) stateShared)
	>>* [OnAction (Action "Execute") $ ifValue (\e->e=:(Right _)) $ \(Right s)->set s stateShared]
where
	viewer = maybe
		"No expression selected"
		('Text'.join " " o flip print [])
	evaler :: (SemState, Maybe Stmt) -> Either String SemState
	evaler (s, t) = maybe
		(Left "No expression selected")
		(\e->execStateT (eval e) s) t
	printer m = [k +++ "=" +++ toSingleLineText v\\(k,v)<-'Map'.toList m]

Start w = doTasks main w