summaryrefslogtreecommitdiff
path: root/src/Grasp
diff options
context:
space:
mode:
Diffstat (limited to 'src/Grasp')
-rw-r--r--src/Grasp/Interpreter.hs127
1 files changed, 79 insertions, 48 deletions
diff --git a/src/Grasp/Interpreter.hs b/src/Grasp/Interpreter.hs
index 965aa13..e8896cf 100644
--- a/src/Grasp/Interpreter.hs
+++ b/src/Grasp/Interpreter.hs
@@ -3,6 +3,7 @@ module Grasp.Interpreter (
) where
+import System.Random
import Text.Read( readMaybe )
import Data.Graph.Inductive.Graph( Node, LNode, LEdge, (&) )
import qualified Data.Graph.Inductive.Graph as Graph
@@ -20,32 +21,32 @@ type IP = [LNode String]
grasp :: GraspProgram -> IO ()
grasp g =
- let ips = map (:[]) (nodesWithName g "grasp:main")
- in interpret g ips
+ let ips = map (:[]) (nodesWithName g "grasp:main")
+ in interpret g ips
reachable :: GraspProgram -> [IP] -> [Node]
reachable g ips =
- let startNodes = nub . (map fst) $ (namedNodes g) ++ (concat ips)
- in reach g startNodes []
+ let startNodes = nub . (map fst) $ (namedNodes g) ++ (concat ips)
+ in reach g startNodes []
reach :: GraspProgram -> [Node] -> [Node] -> [Node]
reach _ [] f = f
reach g s@(x:xs) f =
- let f' = nub (x:f)
- s' = nub (xs ++ (Graph.suc g x))
- g' = Graph.delNode x g
- in reach g' s' f'
+ let f' = nub (x:f)
+ s' = nub (xs ++ (Graph.suc g x))
+ g' = Graph.delNode x g
+ in reach g' s' f'
garbageCollect :: GraspProgram -> [IP] -> GraspProgram
garbageCollect g ips =
- let unreachable = (Graph.nodes g) \\ (reachable g ips)
- in Graph.delNodes unreachable g
+ let unreachable = (Graph.nodes g) \\ (reachable g ips)
+ in Graph.delNodes unreachable g
@@ -58,29 +59,29 @@ execute :: GraspProgram -> [IP] -> [IP] -> IO ()
execute g [] out = interpret g (reverse out)
execute g ([]:ips) out = execute g ips out
execute g (cur:rest) out = do
- (g', cur') <-
- case (snd . head $ cur) of
- "set" -> setI g cur
- "new" -> newI g cur
- "del" -> delI g cur
- "push" -> pushI g cur
- "pop" -> popI g cur
- "pick" -> pickI g cur
- "call" -> callI g cur
- "ret" -> retI g cur
- "add" -> addI g cur
- "mul" -> mulI g cur
- "sub" -> subI g cur
- "div" -> divI g cur
- "mod" -> modI g cur
- "getc" -> getcI g cur
- "putc" -> putcI g cur
- "gets" -> getsI g cur
- "puts" -> putsI g cur
-
- x | isInteger x -> implicitPushI g cur
-
- x -> error ("Unknown instruction at " ++ (show x))
+ (g', cur') <-
+ case (snd . head $ cur) of
+ "set" -> setI g cur
+ "new" -> newI g cur
+ "del" -> delI g cur
+ "push" -> pushI g cur
+ "pop" -> popI g cur
+ "pick" -> pickI g cur
+ "call" -> callI g cur
+ "ret" -> retI g cur
+ "add" -> addI g cur
+ "mul" -> mulI g cur
+ "sub" -> subI g cur
+ "div" -> divI g cur
+ "mod" -> modI g cur
+ "getc" -> getcI g cur
+ "putc" -> putcI g cur
+ "gets" -> getsI g cur
+ "puts" -> putsI g cur
+
+ x | isInteger x -> implicitPushI g cur
+
+ x -> error ("Unknown instruction at " ++ (show x))
execute g' rest (cur':out)
@@ -88,17 +89,24 @@ execute g (cur:rest) out = do
isInteger :: String -> Bool
isInteger x =
- let check = readMaybe x :: Maybe Int
- in if (isJust check) then True else False
+ let check = readMaybe x :: Maybe Int
+ in if (isJust check) then True else False
+
+
+
+isFloat :: String -> Bool
+isFloat x =
+ let check = readMaybe x :: Maybe Float
+ in if (isJust check) then True else False
reLabel :: GraspProgram -> Node -> String -> GraspProgram
reLabel g n s =
- let (mc,d) = Graph.match n g
- c = fromJust mc
- c' = (\(w,x,y,z) -> (w,x,s,z)) $ c
- in if (isNothing mc) then g else c' & d
+ let (mc,d) = Graph.match n g
+ c = fromJust mc
+ c' = (\(w,x,y,z) -> (w,x,s,z)) $ c
+ in if (isNothing mc) then g else c' & d
@@ -121,23 +129,23 @@ targetLNodes g = map (\(_,x,_) -> (x, fromJust (Graph.lab g x)) )
updateIP :: IP -> [LNode String] -> IO IP
updateIP _ [] = return []
updateIP ip next =
- getStdRandom (randomR (0,length next)) >>=
- (\x -> return ((next !! x):(tail ip)) )
+ getStdRandom (randomR (0,length next)) >>=
+ (\x -> return ((next !! x):(tail ip)) )
setI :: GraspProgram -> IP -> IO (GraspProgram, IP)
setI g ip = do
- let edges = Graph.out g (fst . head $ ip)
+ let edges = Graph.out g (fst . head $ ip)
inL = targetLabels g (getByLabel "in" edges)
outN = targetNodes (getByLabel "out" edges)
nextLN = targetLNodes g (getByLabel "next" edges)
-
- g' <- case inL of
- [] -> return g
- _ -> (getStdRandom (randomR (0,length inL))) >>=
- (\x -> foldl' (\g n -> reLabel g n (inL !! x)) (return g) outN)
+
+ g' <- case inL of
+ [] -> return g
+ _ -> (getStdRandom (randomR (0,length inL))) >>=
+ (\x -> return (foldl' (\g n -> reLabel g n (inL !! x)) g outN) )
ip' <- updateIP ip nextLN
@@ -146,7 +154,30 @@ setI g ip = do
newI :: GraspProgram -> IP -> IO (GraspProgram, IP)
-newI g ip = return (g,ip)
+newI g ip = do
+ let node = fst . head $ ip
+ edges = Graph.out g node
+
+ tailN = targetNodes (getByLabel "tail" edges)
+ headN = targetNodes (getByLabel "head" edges)
+ labelL = targetLabels g (getByLabel "label" edges)
+
+ g' <- case (tailN, headN, labelL) of
+ (x,_,_) | length x /= 1 -> error ("Instruction " ++ (show node) ++
+ " should only have one tail argument")
+ (_,y,_) | length y /= 1 -> error ("Instruction " ++ (show node) ++
+ " should only have one head argument")
+ (_,_,z) | length z /= 1 -> error ("Instruction " ++ (show node) ++
+ " should only have one label argument")
+ (_,_,z) | isFloat (head z) -> error ("Instruction " ++ (show node) ++
+ " should have non-numeric label argument")
+ (x,y,z) -> return (Graph.insEdge (head x, head y, head z) g)
+
+ ip' <- updateIP ip (targetLNodes g' (getByLabel "next" (Graph.out g' node)))
+
+ return (g',ip')
+
+
delI :: GraspProgram -> IP -> IO (GraspProgram, IP)
delI g ip = return (g,ip)