module Control.Monad.MultiPass.Example.CFG ( Node(..), emitCFG )
where
import Control.Monad.ST2
import Control.Monad.MultiPass
import Control.Monad.MultiPass.Instrument.EmitST2Array
import Control.Monad.MultiPass.Instrument.Knot3
import Control.Monad.MultiPass.Instrument.Delay
import Control.Monad.MultiPass.Utils
import Data.Array
type CFG = Array Node [Node]
newtype Node
= Node Int
deriving (Eq, Ord, Ix)
newtype Position
= Position Int
deriving (Eq, Ord, Ix)
instance Num Position where
(Position x) + (Position y) = Position (x + y)
(Position x) (Position y) = Position (x y)
(Position x) * (Position y) = Position (x * y)
negate (Position x) = Position (negate x)
abs (Position x) = Position (abs x)
signum (Position x) = Position (signum x)
fromInteger x = Position (fromInteger x)
type EmitCFGType r w p1 p2 p3 tc
= Knot3 (Array Node Position) r w p1 p2 p3 tc
-> EmitST2Array Position Int r w p1 p2 p3 tc
-> Delay p2 p3 tc
-> MultiPassMain r w tc (p3 (ST2Array r w Position Int))
newtype EmitCFG r w p1 p2 p3 tc =
EmitCFG (EmitCFGType r w p1 p2 p3 tc)
instance MultiPassAlgorithm
(EmitCFG r w p1 p2 p3 tc)
(EmitCFGType r w p1 p2 p3 tc)
where
unwrapMultiPassAlgorithm (EmitCFG f) = f
emitCFG :: CFG -> ST2 r w (ST2Array r w Position Int)
emitCFG g =
run $ PassS $ PassS $ PassS $ PassZ $ EmitCFG $
emitMain g
emitMain
:: (Monad p1, Monad p2, Monad p3)
=> CFG
-> EmitCFGType r w p1 p2 p3 tc
emitMain g kn emitter delay12 =
mkMultiPassMain
(return ())
(\() -> knot3 kn (emitNodes emitter delay12 g))
(\() -> getResult emitter)
emitNodes
:: (Monad p1, Monad p2, Monad p3)
=> EmitST2Array Position Int r w p1 p2 p3 tc
-> Delay p2 p3 tc
-> CFG
-> p3 (Array Node Position)
-> MultiPass r w tc (p2 (Array Node Position), ())
emitNodes emitter delay12 g offsets =
do g' <- pmapM g (emitNode emitter delay12 offsets)
return (g', ())
emitNode
:: (Monad p1, Monad p2, Monad p3)
=> EmitST2Array Position Int r w p1 p2 p3 tc
-> Delay p2 p3 tc
-> p3 (Array Node Position)
-> [Node]
-> MultiPass r w tc (p2 Position)
emitNode emitter delay12 offsets ys =
do
emit emitter (return (length ys))
sequence_
[ do
pos <- getIndex emitter
emit emitter $
do pos' <- delay delay12 pos
offsets' <- offsets
let offset = offsets' ! y
return (positionDiff offset pos')
| y <- ys
]
getIndex emitter
positionDiff :: Position -> Position -> Int
positionDiff (Position a) (Position b) =
a b