diff options
Diffstat (limited to 'src/Grasp')
| -rw-r--r-- | src/Grasp/Interpreter.hs | 127 |
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) |