--

import ST

---------------------------------------------

data Id x = Id x
data Exception x = Ok x | Fail
data Env e x = Env (e -> x)
data Mult x = Mult [x]
data Store s x = St(s -> (x,s))
data Output x = OP(x,String)

-- Some Instance declarations

return x = Id x
(>>=) (Id x) f = f x

return x = Ok x
(>>=) (Ok x) f = f x
(>>=) Fail f = Fail

return x = Env(\ e -> x)
(>>=) x yf = let Env f = x
h e = let x = f e
Env g = yf x
in g e
in Env h

return x = St(\ s -> (x,s))
(>>=) x yf = let St f = x
h s1 = let (x,s2) = f s1
St g = yf x
(y,s3) = g s2
in (y,s3)
in St h

return x = Mult[x]
(>>=) x yf = let Mult xs = x
ys = map yf xs
in Mult (concat[ z | Mult z <- ys ])

return x = OP(x,"")
(>>=) (OP(x,s1)) f = let OP(y,s2) = f x in OP(y,s1 ++ s2)

--- A few non-standard morphisms (the interface of the ADT)

type Map = [(String,Value)]

getEnv :: String -> (Env Map Value)
getEnv nm = Env(\ s -> find s)
find ((s,n):m) = if s==nm then n else find m

runInNewEnv :: String -> Int -> (Env Map Value) -> (Env Map Value)
runInNewEnv s n (Env g) = Env(\ m -> g ((s,n):m))

getStore :: String -> (Store Map Value)
getStore nm = St(\ s -> find s s)
where find w [] = (0,w)
find w ((s,n):m) = if s==nm then (n,w) else find w m

putStore :: String -> Value -> (Store Map ())
putStore nm n = (St(\ s -> ((),build s)))
where build [] = [(nm,n)]
build ((s,v):zs) =
if s==nm then (s,n):zs else (s,v):(build zs)

printOutput:: String -> Output ()
printOutput s = OP((),s)

-------------------------------------------------------------------
-- A much richer monad combining many of the elements of the above

type Value = Int
type Maps x = [(String,x)]
data M v x = M(Maps v -> Maps v -> (Maybe x,String,Maps v))

return x = M(\ st env -> (Just x,[],st))
(>>=) (M f) g = M h
where h st env = compare env (f st env)
compare env (Nothing,op1,st1)  = (Nothing,op1,st1)
compare env (Just x, op1,st1)  = next env op1 st1 (g x)
next env op1 st1 (M f2)        = compare2 op1 (f2 st1 env)
compare2 op1 (Nothing,op2,st2) = (Nothing,op1++op2,st2)
compare2 op1 (Just y, op2,st2) = (Just y, op1++op2,st2)

--- Sub classes of Monad for generic evaluation

class Monad m => Eval e v m where
eval :: e -> m v

class Monad m => Failure m where
fails :: m a

class Monad m => HasEnv m v where
inNewEnv :: String -> v -> m v -> m v
getfromEnv :: String -> m v

class Monad m => HasStore m v where
getfromStore :: String -> m v
putinStore :: String -> v -> m v

class (Monad m,Show v) => Prints m v where
write :: String -> v -> m v

---------------------------------------------------------------
-- Instance declarations for the rich monad

instance Failure (M v) where
fails = M(\ st env -> (Nothing,[],st))

get name ((a,b):m) = if a==name then b else get name m

instance HasEnv (M v) v where
inNewEnv name v (M f) = M(\ st env -> f st ((name,v):env))
getfromEnv name = M h
where h st env = (Just(get name env),[],st)

instance HasStore (M v) v where
getfromStore name = M h
where h st env = (Just(get name st),[],st)
putinStore name v = M h
where h st env = (Just v,[],(name,v):st)

instance Show v => Prints (M v) v where
write message v = M h
where h st env = (Just v,message++(show v),st)

--------------------------------------------------------------
-- A state based algorithm

data Tree a = Tip | Node (Tree a) a (Tree a)

number :: Tree a -> Int -> (Tree (a,Int), Int)
number Tip n = (Tip, n)
number (Node l x r) n = (Node l' (x,n) r', n'')
where (l',n')  = number l (n+1)
(r',n'') = number r n'

---------------------------------------------------------------
-- Another example

data Aop = Multiply | Add | Sub

data Exp
= Num Int
| Var String
| Oper (Exp, Aop, Exp )
| Let (String, Exp, Exp)

e2 = Let("x",Num 5,
Oper(Num 4,Multiply,Num 2)))

-- free variables

freeV :: Exp -> [ String]
freeV term = freevars [] term []
where
freevars bound x free = case x of
Num(i) -> free
Var(s) ->  if any (==s) bound
then free else add s free
Oper(x,y,z) ->freevars bound x (freevars bound z free)
Let(s,e,body) ->
freevars (s:bound) body (freevars bound e free)

add x xs = if any (==x) xs then xs else x:xs

rename n x = x ++ (show n)

find s [] = s
find s ((t,v):xs) = if s==t then v else find s xs

renameE x = snd(rnE [] 0 x)
where rnE bnd n x = case x of
Num(i) ->(n,Num i)
Var(s) -> (n,Var(find s bnd))
Oper(x,y,z) -> let (n1,x') = rnE bnd n x
(n2,z') = rnE bnd n1 z
in (n2,Oper(x',y,z'))
Let(s,e,b) ->
let s' = rename n s
(n1,b') = rnE ((s,s'):bnd) (n+1) b
(n2,e') = rnE bnd n1 e
in (n2,Let(s',e',b'))

e3 =
Let("x", Oper(Var "z",Multiply,Num 2),
Let("q",
Oper(Var "x",Sub,
Oper(Var "q",
Multiply,Var "v"))))

e4 = renameE e3
{-
Let ("x0", Oper (Var "z",Multiply,Num 2),
Let ("q1",
Oper (Var "x0",Sub,
Oper (Var "q1",
Multiply,Var "v"))))
-}

------------------------------------------------------

swap :: STRef s a -> STRef s a -> ST s ()
swap v w = do { x <- readSTRef v
; writeSTRef w x
; writeSTRef v y
}

rn bnd (Num i) v = return(Num i)
rn bnd (Var s)v  = return(Var(find s bnd))
rn bnd (Oper(x,y,z)) v =
do { x' <- rn bnd x v
; z' <- rn bnd z v
; return(Oper(x',y,z')) }
rn bnd (Let(s,e,b)) v =
do { n <- readSTRef v
; writeSTRef v (n+1)
; s' <- return(rename n s)
; b' <- rn ((s,s'):bnd) b v
; e' <- rn bnd e v
; return(Let(s',e',b')) }

re x = runST(do { v <- newSTRef 0; rn [] x v })

e5 =  Let("x", Oper(Var "z",Multiply,Num 2),
Oper(Var "x", Sub,
Oper(Var "q",Multiply,Var"v"))))
e6 = re e5

----------------------------------------------------------

type UpdList s a = STRef s (ListVar s a, ListVar s a)

type ListVar s a = STRef s (ListElt s a)
data ListElt s a = Nil
| Cons a (ListVar s a)
newList :: ST s (UpdList s a)
newList = do {f <- newSTRef Nil; newSTRef (f,f)}

frontList :: UpdList s a -> ST s a
frontList l = do {(f,b) <- readSTRef l;
Cons x f' <- readSTRef f;
writeSTRef l (f',b);
return x}

backList :: UpdList s a -> a -> ST s ()
backList l x = do {(f,b) <- readSTRef l;
b' <- newSTRef Nil;
writeSTRef b (Cons x b');
writeSTRef l (f,b')}

emptyList :: UpdList s a -> ST s Bool
emptyList l = do {(f,b) <- readSTRef l; return (f == b)}
--