diff options
| -rw-r--r-- | src/Grasp/Interpreter.hs | 92 | ||||
| -rw-r--r-- | src/Grasp/Monad.hs | 26 |
2 files changed, 88 insertions, 30 deletions
diff --git a/src/Grasp/Interpreter.hs b/src/Grasp/Interpreter.hs index d6c1f80..40bc028 100644 --- a/src/Grasp/Interpreter.hs +++ b/src/Grasp/Interpreter.hs @@ -5,10 +5,17 @@ module Grasp.Interpreter ( +import qualified System.Random as Random + import qualified Control.Monad as Monad +import Control.Monad.IO.Class( liftIO ) + import qualified Data.Maybe as Maybe +import Data.List( (!!) ) +import qualified Data.List as List + import Grasp.Monad( GraspM ) import qualified Grasp.Monad as GMonad @@ -21,6 +28,9 @@ import qualified Grasp.Types.GEdge as GE import Grasp.Types.Instruction( Instruction ) import qualified Grasp.Types.Instruction as IN +import Grasp.Types.EdgeLabel( EdgeLabel ) +import qualified Grasp.Types.EdgeLabel as EL + @@ -31,42 +41,68 @@ grasp input = GMonad.finalise $ GMonad.construct input >> interpret interpret :: GraspM () interpret = do - n <- GMonad.peekIP - - if (Maybe.isNothing n) then return () else do - case (IN.toString . GN.toInst . Maybe.fromJust $ n) of - "set" -> setI - "new" -> newI - "del" -> delI - "push" -> pushI - "pop" -> popI - "pick" -> pickI - "call" -> callI - "ret" -> retI - "add" -> addI - "mul" -> mulI - "sub" -> subI - "div" -> divI - "mod" -> modI - "getc" -> getcI - "putc" -> putcI - "gets" -> getsI - "puts" -> putsI - inst | Maybe.isJust . IN.toInt . IN.mk $ inst -> implicitPushI - x -> error ("Unknown instruction " ++ x) - - GMonad.nextIP - interpret + n <- GMonad.peekIP + + if (Maybe.isNothing n) then return () else do + case (IN.toString . GN.toInst . Maybe.fromJust $ n) of + "set" -> setI + "new" -> newI + "del" -> delI + "push" -> pushI + "pop" -> popI + "pick" -> pickI + "call" -> callI + "ret" -> retI + "add" -> addI + "mul" -> mulI + "sub" -> subI + "div" -> divI + "mod" -> modI + "getc" -> getcI + "putc" -> putcI + "gets" -> getsI + "puts" -> putsI + inst | Maybe.isJust . IN.toInt . IN.mk $ inst -> implicitPushI + x -> error ("Unknown instruction " ++ x) + + GMonad.nextIP + interpret setI :: GraspM () -setI = GMonad.updateIP +setI = do + curNode <- GMonad.peekIP >>= return . Maybe.fromJust + + inNodes <- GMonad.nodesOut (EL.mk "in") curNode + outNodes <- GMonad.nodesOut (EL.mk "out") curNode + + Monad.when (length inNodes /= 0) (do + r <- liftIO (Random.getStdRandom (Random.randomR (0, length inNodes - 1))) + mapM_ (GMonad.reLabel (GN.toInst (inNodes !! r))) outNodes ) + + GMonad.updateIP newI :: GraspM () -newI = GMonad.updateIP +newI = do + curNode <- GMonad.peekIP >>= return . Maybe.fromJust + + tailNodes <- GMonad.nodesOut (EL.mk "tail") curNode + headNodes <- GMonad.nodesOut (EL.mk "head") curNode + labelNodes <- GMonad.nodesOut (EL.mk "label") curNode + + Monad.when (length tailNodes /= 1) (error "Instruction new should have one tail argument") + Monad.when (length headNodes /= 1) (error "Instruction new should have one head argument") + Monad.when (length labelNodes /= 1) (error "Instruction new should have one label argument") + Monad.when (Maybe.isJust . IN.toFloat . GN.toInst $ (head labelNodes)) + (error "Label argument to instruction new should not be a number") + + let edgeLabel = EL.mk . IN.toString . GN.toInst $ (head labelNodes) + GMonad.insEdge (GE.mk (GN.toNode (head tailNodes), GN.toNode (head headNodes), edgeLabel)) + + GMonad.updateIP diff --git a/src/Grasp/Monad.hs b/src/Grasp/Monad.hs index b49b53d..e58aa74 100644 --- a/src/Grasp/Monad.hs +++ b/src/Grasp/Monad.hs @@ -13,7 +13,9 @@ module Grasp.Monad ( peekIP, nextIP, - nodesOut + nodesOut, + reLabel, + insEdge ) where @@ -39,7 +41,7 @@ import qualified Data.List as List import Data.Map( Map ) import qualified Data.Map as Map -import Grasp.Graph( Node, LNode, LEdge, Gr ) +import Grasp.Graph( Node, LNode, LEdge, Gr, (&) ) import qualified Grasp.Graph as Graph import Grasp.Types.IP( IP ) @@ -309,3 +311,23 @@ nodesOut s n = do if (Maybe.isNothing curNode) then return [] else return result + + +reLabel :: Instruction -> GNode -> GraspM () +reLabel i n = do + (gr, ips, fh) <- State.get + + let (mc, d) = Graph.match (GN.toNode n) gr + c = Maybe.fromJust mc + c' = (\(w,x,y,z) -> (w,x,i,z)) $ c + + Monad.when (Maybe.isJust mc) (State.put ((c' & d) ,ips, fh)) + + + +insEdge :: GEdge -> GraspM () +insEdge e = do + (gr, ips, fh) <- State.get + let gr' = Graph.insEdge (GE.toLEdge e) gr + State.put (gr', ips, fh) + |