From 1d1e603683e63a59734adf57b3500217945b17c6 Mon Sep 17 00:00:00 2001
From: Jed Barber <jjbarber@y7mail.com>
Date: Sat, 6 Dec 2014 23:00:03 +1100
Subject: set and del instructions added

---
 src/Grasp/Interpreter.hs | 92 +++++++++++++++++++++++++++++++++---------------
 src/Grasp/Monad.hs       | 26 ++++++++++++--
 2 files changed, 88 insertions(+), 30 deletions(-)

(limited to 'src/Grasp')

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)
+
-- 
cgit