summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJed Barber <jjbarber@y7mail.com>2014-08-31 20:43:51 +1000
committerJed Barber <jjbarber@y7mail.com>2014-08-31 20:43:51 +1000
commite9a61167bfe3ed15f747bd973117fb1a0f9fed4a (patch)
treec52cee5ce0d8d8c136fbe2312e98d5d02025ba43
parent5826e8e9b69e0e299765c6691f22e27dfe3213f4 (diff)
Added pop instruction
-rw-r--r--src/Grasp/Interpreter.hs34
1 files changed, 30 insertions, 4 deletions
diff --git a/src/Grasp/Interpreter.hs b/src/Grasp/Interpreter.hs
index 2d04226..e009e5e 100644
--- a/src/Grasp/Interpreter.hs
+++ b/src/Grasp/Interpreter.hs
@@ -79,7 +79,7 @@ execute g (cur:rest) out =
"new" -> newI g node
"del" -> delI g node
"push" -> pushI g node
- "pop" -> popI g node
+ "pop" -> popI g node >>= (\x -> return (garbageCollect x ((cur:rest) ++ out)))
"pick" -> pickI g node
"add" -> addI g node
"mul" -> mulI g node
@@ -252,11 +252,37 @@ popI :: GraspProgram -> Node -> IO GraspProgram
popI g node =
let edges = Graph.out g node
- stackN = targetNodes (getByLabel "stack" edges)
- outL = targetLabels g (getByLabel "out" edges)
+ stackNs = targetNodes (getByLabel "stack" edges)
+ outN = targetNodes (getByLabel "out" edges)
emptyL = targetLabels g (getByLabel "empty" edges)
- in return g
+ in if (length stackNs /= 1) then error ("Instruction " ++ (show node) ++
+ " should have one stack argument")
+
+ else let stackN = head stackNs
+ nextN = targetNodes (getByLabel "next" (Graph.out g stackN))
+
+ in case nextN of
+ x | length x > 1 -> error ("Stack node " ++ (show node) ++
+ " should only have one next edge")
+
+ x | length x == 1 ->
+ let label = fromJust (Graph.lab g stackN)
+ g' = foldl' (\gr n -> reLabel gr n label) g outN
+
+ s = head x
+ edgesToDel = Graph.inn g' s
+ edgesToAdd = map (\(x,y,z) -> (x,s,z)) edgesToDel
+
+ g'' = foldl' (flip Graph.delLEdge) g' edgesToDel
+ g''' = Graph.insEdges edgesToAdd g''
+ in return g'''
+
+ x ->
+ if (emptyL == []) then return g
+ else (getStdRandom (randomR (0,length emptyL - 1))) >>=
+ (\x -> return (foldl' (\gr n -> reLabel gr n (emptyL !! x)) g outN))
+