module GT where
import Monad
import Monoid
import MonadState
import MonadWriter
import MonadRWS
-- Just a quick exercise in using monads.
-- Thought it'd be nice to share with the class.
data GOp
= PushVal Integer
| Push Integer
| Pop Integer
| Slide Integer
| Update Integer
| GAdd | GSub | GMul | GDiv | GMod | GPow
| GNeg | GAbs
deriving (Eq, Ord, Read, Show)
type Tmp = Integer
data ROp
= LoadImm Tmp Integer
| RAdd Tmp Tmp Tmp
| RSub Tmp Tmp Tmp
| RMul Tmp Tmp Tmp
| RDiv Tmp Tmp Tmp
| RMod Tmp Tmp Tmp
| RPow Tmp Tmp Tmp
| RNeg Tmp Tmp
| RAbs Tmp Tmp
deriving (Eq, Ord, Read, Show)
type CounterT m t = StateT Integer m t
type StackT t = State [Integer] t
type GST t = RWS () [ROp] (Integer, [Integer]) t
class Stack f where
pushVal, push, pop, update, slide :: Integral t => t -> f ()
popVal :: Integral t => f t
instance Integral t => Stack (RWS () [ROp] (t, [t])) where
pushVal n = do
(ctr, stk) <- get
put (ctr, fromIntegral n : stk)
popVal = do
(ctr, top:stk) <- get
put (ctr, stk)
return (fromIntegral top)
push n = do
(ctr, stk) <- get
put (ctr, stk!!fromIntegral n : stk)
pop n = do
(ctr, stk) <- get
put (ctr, drop (fromIntegral n) stk)
slide n = do
(ctr, top:stk) <- get
put (ctr, top : drop (fromIntegral n) stk)
update n = do
(ctr, top:stk) <- get
let (front, _:back) = splitAt (fromIntegral n) stk
put (ctr, front ++ [top] ++ back)
class Counter f where
gen :: Enum t => f t
instance Integral t => Counter (RWS () [ROp] (t, [t])) where
gen = do
(ctr, stk) <- get
put (ctr + 1, stk)
return . toEnum . fromIntegral $ ctr + 1
instance (Enum t, Monad m) => Counter (StateT t m) where
gen = do
ctr <- get
put $ succ ctr
ctr <- get
return . toEnum $ fromEnum ctr
translate gOps = snd $ evalRWS (mapM trans gOps) () (0,[])
trans :: GOp -> GST ()
trans i = case i of
PushVal n ->
do
reg <- gen
tell [LoadImm reg n]
pushVal reg
Push n -> push n
Pop n -> pop n
Slide n -> slide n
Update n -> update n
GAdd -> doBinOp RAdd
GSub -> doBinOp RSub
GMul -> doBinOp RMul
GDiv -> doBinOp RDiv
GMod -> doBinOp RMod
GPow -> doBinOp RPow
GNeg -> doUnOp RNeg
GAbs -> doUnOp RAbs
where
doUnOp op =
do
x <- popVal
y <- gen
tell [op y x]
pushVal y
doBinOp op =
do
x <- popVal
y <- popVal
z <- gen
tell [op z x y]
pushVal z
_______________________________________________
Haskell-Cafe mailing list
[EMAIL PROTECTED]
http://www.haskell.org/mailman/listinfo/haskell-cafe
