From ef7ed9cc9292554a90e644c92533cfc0e2a50896 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Sat, 6 Dec 2014 01:05:25 +1100 Subject: Moving old code out of the way; to be deleted after rewrite --- src/Grasp/Interpreter.hs | 532 ------------------------------------------- src/Grasp/Interpreter.hs.old | 532 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 532 insertions(+), 532 deletions(-) delete mode 100644 src/Grasp/Interpreter.hs create mode 100644 src/Grasp/Interpreter.hs.old (limited to 'src/Grasp') diff --git a/src/Grasp/Interpreter.hs b/src/Grasp/Interpreter.hs deleted file mode 100644 index e7a36c9..0000000 --- a/src/Grasp/Interpreter.hs +++ /dev/null @@ -1,532 +0,0 @@ -module Grasp.Interpreter ( - grasp - ) where - - -import Control.Monad -import Control.Exception -import System.Random -import System.IO -import System.IO.Error -import Text.Read( readMaybe ) -import Data.Graph.Inductive.Graph( Node, LNode, LEdge, (&) ) -import qualified Data.Graph.Inductive.Graph as Graph -import Data.Map( (!) ) -import qualified Data.Map as Map -import Data.List -import Data.Maybe -import Data.Char -import Grasp.Types -import Grasp.Parser - - - -type IP = [LNode String] - - - --- this is a disgusting, disgusting way to implement this - --- I blame the inelegance of manipulating graphs, and I strongly suspect --- it would be better for all concerned if I created a DSL for that purpose --- and refactored all the instructions into that form - - - -grasp :: GraspProgram -> IO () -grasp g = - 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 [] - - - -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' - - - -garbageCollect :: GraspProgram -> [IP] -> GraspProgram -garbageCollect g ips = - let unreachable = (Graph.nodes g) \\ (reachable g ips) - in Graph.delNodes unreachable g - - - -interpret :: GraspProgram -> [IP] -> IO () -interpret g ips = if (ips == []) then return () else execute g ips [] - - - -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 = - let (node,instruction) = head cur - condL = targetLabels g (getByLabel "cond" (Graph.out g node)) - goAhead = all (\x -> isFloat x && (read :: String -> Float) x /= 0.0) condL - - in case (goAhead, instruction) of - (False,_) -> do - cur' <- updateIP cur (targetLNodes g (getByLabel "next" (Graph.out g node))) - execute g rest (cur':out) - - (True,x) | x /= "call" && x /= "ret" -> do - g' <- case x of - "set" -> setI g node - "new" -> newI g node - "del" -> delI g node - "push" -> pushI 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 - "sub" -> subI g node - "div" -> divI g node - "mod" -> modI g node - "getc" -> getcI g node - "putc" -> putcI g node - "gets" -> getsI g node - "puts" -> putsI g node - inst | isInteger inst -> implicitPushI g node - _ -> error ("Unknown instruction at " ++ (show x)) - cur' <- updateIP cur (targetLNodes g' (getByLabel "next" (Graph.out g' node))) - execute g' rest (cur':out) - - (_,x) -> do - (g',cur') <- case x of - "call" -> callI g cur - "ret" -> retI g cur >>= (\(x,y) -> return (garbageCollect x ((y:rest) ++ out), y)) - _ -> error ("Execute function reached impossible branch") - execute g' rest (cur':out) - - - -isInteger :: String -> Bool -isInteger x = - 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 :: String -> GraspProgram -> Node -> GraspProgram -reLabel s g n = - 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 - - - -getByLabel :: String -> [LEdge String] -> [LEdge String] -getByLabel name = filter (\(_,_,x) -> x == name) - - - -targetLabels :: GraspProgram -> [LEdge String] -> [String] -targetLabels g = map (\(_,x,_) -> fromJust (Graph.lab g x)) - -targetNodes :: [LEdge String] -> [Node] -targetNodes = map (\(_,x,_) -> x) - -targetLNodes :: GraspProgram -> [LEdge String] -> [LNode String] -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 - 1)) >>= - (\x -> return ((next !! x):(tail ip)) ) - - - -setI :: GraspProgram -> Node -> IO GraspProgram -setI g node = - let edges = Graph.out g node - - inL = targetLabels g (getByLabel "in" edges) - outN = targetNodes (getByLabel "out" edges) - - in case inL of - [] -> return g - _ -> (getStdRandom (randomR (0,length inL - 1))) >>= - (\x -> return (foldl' (reLabel (inL !! x)) g outN) ) - - - -newI :: GraspProgram -> Node -> IO GraspProgram -newI g node = - let edges = Graph.out g node - - tailN = targetNodes (getByLabel "tail" edges) - headN = targetNodes (getByLabel "head" edges) - labelL = targetLabels g (getByLabel "label" edges) - - in 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) - - - -delI :: GraspProgram -> Node -> IO GraspProgram -delI g node = - let edges = Graph.out g node - - tailN = targetNodes (getByLabel "tail" edges) - headN = targetNodes (getByLabel "head" edges) - labelL = targetLabels g (getByLabel "label" edges) - - edgesToDel = filter (\(x,y,z) -> x `elem` tailN && - (headN == [] || y `elem` headN) && - (labelL == [] || z `elem` labelL)) (Graph.labEdges g) - - in return (foldl' (flip Graph.delLEdge) g edgesToDel) - - - -pushI :: GraspProgram -> Node -> IO GraspProgram -pushI g node = do - let edges = Graph.out g node - - stackN = targetNodes (getByLabel "stack" edges) - inL = targetLabels g (getByLabel "in" edges) - - rnd <- getStdRandom (randomR (0,length inL -1)) - let label = if (inL == []) then "" else inL !! rnd - - if (length stackN /= 1) - then error ("Instruction " ++ (show node) ++ " should have one stack argument") - else doPushI g (head stackN) label - - - -implicitPushI :: GraspProgram -> Node -> IO GraspProgram -implicitPushI g node = - let edges = Graph.out g node - - stackN = targetNodes (getByLabel "stack" edges) - label = fromJust $ Graph.lab g node - - in if (length stackN /= 1) - then error ("Instruction " ++ (show node) ++ " should have one stack argument") - else doPushI g (head stackN) label - - - -doPushI :: GraspProgram -> Node -> String -> IO GraspProgram -doPushI g s l = - let newN = head (Graph.newNodes 1 g) - - edgesToDel = Graph.inn g s - edgesToAdd = map (\(x,y,z) -> (x,newN,z)) edgesToDel - - nextE = (newN,s,"next") - - g' = Graph.insNode (newN,l) g - g'' = foldl' (flip Graph.delLEdge) g' edgesToDel - g''' = Graph.insEdges (nextE:edgesToAdd) g'' - - in return g''' - - - -popI :: GraspProgram -> Node -> IO GraspProgram -popI g node = - let edges = Graph.out g node - - stackNs = targetNodes (getByLabel "stack" edges) - outN = targetNodes (getByLabel "out" edges) - emptyL = targetLabels g (getByLabel "empty" edges) - - 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' (reLabel 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' (reLabel (emptyL !! x)) g outN)) - - - -pickI :: GraspProgram -> Node -> IO GraspProgram -pickI g node = - let edges = Graph.out g node - - stackN = targetNodes (getByLabel "stack" edges) - depthL = targetLabels g (getByLabel "depth" edges) - outN = targetNodes (getByLabel "out" edges) - emptyL = targetLabels g (getByLabel "empty" edges) - - in case (stackN, depthL) of - (x,_) | length x /= 1 -> error ("Instruction " ++ (show node) ++ - " should have one stack argument") - - (_,y) | length y /= 1 -> error ("Instruction " ++ (show node) ++ - " should have one depth argument") - - (_,y) | not (isInteger (head y)) -> error ("Instruction " ++ (show node) ++ - " should have integer depth argument") - - (x,y) -> doPickI g (head x) (read (head y)) outN emptyL - - - -doPickI :: GraspProgram -> Node -> Int -> [Node] -> [String] -> IO GraspProgram -doPickI g stackN depth outN emptyL = - let nextN = targetNodes (getByLabel "next" (Graph.out g stackN)) - - in case nextN of - x | length x > 1 -> error ("Stack has too many next edges at node " ++ (show stackN)) - - x | length x == 0 -> - if (emptyL == []) then return g - else (getStdRandom (randomR (0,length emptyL - 1))) >>= - (\x -> return (foldl' (reLabel (emptyL !! x)) g outN)) - - x -> - if (depth > 0) then doPickI g (head nextN) (depth - 1) outN emptyL - else let label = fromJust (Graph.lab g stackN) - in return (foldl' (reLabel label) g outN) - - - -callI :: GraspProgram -> IP -> IO (GraspProgram, IP) -callI g ip = - let node = fst . head $ ip - edges = Graph.out g node - - funcL = targetLabels g (getByLabel "func" edges) - arguments = filter (\(x,y,z) -> z /= "func" && z /= "name" && z /= "cond" && z /= "next") edges - - possibleFuncs = concatMap (nodesWithName g) funcL - - in if (possibleFuncs == []) then error ("Call from " ++ (show node) ++ " has no candidates") - else do - r <- getStdRandom (randomR (0,length possibleFuncs - 1)) - - let oldNodes = reachable g [[possibleFuncs !! r]] - oldEdges = filter (\(x,y,z) -> x `elem` oldNodes && y `elem` oldNodes) (Graph.labEdges g) - - nodeMap = Map.fromList (zip oldNodes (Graph.newNodes (length oldNodes) g)) - - labels = map (fromJust . (Graph.lab g)) oldNodes - newNodes = map (nodeMap !) oldNodes - - newLNodes = zip newNodes labels - newEdges = map (\(x,y,z) -> (nodeMap ! x, nodeMap ! y, z)) oldEdges - - mainNode = (\(x,y) -> (nodeMap ! x, y)) (possibleFuncs !! r) - argEdges = map (\(x,y,z) -> (nodeMap ! (fst (possibleFuncs !! r)), y, z)) arguments - - g' = (Graph.insEdges (newEdges ++ argEdges)) . (Graph.insNodes newLNodes) $ g - ip' = mainNode : ip - - return (g', ip') - - - -retI :: GraspProgram -> IP -> IO (GraspProgram, IP) -retI g (n:[]) = return (g,[]) -retI g ip = - let oldEdges = Graph.out g (fst . head $ ip) - returnValues = filter (\(x,y,z) -> z /= "name" && z /= "cond" && z /= "next") oldEdges - - node = fst . head $ (tail ip) - edges = Graph.out g node - - nextLN = targetLNodes g (getByLabel "next" edges) - - in if (nextLN == []) then return (g,[]) - else do - ip' <- updateIP (tail ip) nextLN - - let node' = fst . head $ ip' - returnEdges = map (\(x,y,z) -> (node',y,z)) returnValues - - g' = Graph.insEdges returnEdges g - - return (g',ip') - - - -addI :: GraspProgram -> Node -> IO GraspProgram -addI = addmulI sum - -mulI :: GraspProgram -> Node -> IO GraspProgram -mulI = addmulI product - -addmulI :: ([Float] -> Float) -> GraspProgram -> Node -> IO GraspProgram -addmulI f g node = - let edges = Graph.out g node - - argL = targetLabels g (getByLabel "arg" edges) - outN = targetNodes (getByLabel "out" edges) - - in case argL of - x | not (all isFloat x) -> error ("Instruction " ++ (show node) ++ - " has non numeric arguments") - x -> let s = f . (map read) $ x - in return (foldl' (reLabel (show s)) g outN) - - - -subI :: GraspProgram -> Node -> IO GraspProgram -subI = subdivI (\a b -> a - (sum b)) - -divI :: GraspProgram -> Node -> IO GraspProgram -divI = subdivI (\a b -> a / (product b)) - -subdivI :: (Float -> [Float] -> Float) -> GraspProgram -> Node -> IO GraspProgram -subdivI f g node = - let edges = Graph.out g node - - leftL = targetLabels g (getByLabel "left" edges) - rightL = targetLabels g (getByLabel "right" edges) - outN = targetNodes (getByLabel "out" edges) - - in case (leftL, rightL) of - (x,_) | length x /= 1 -> error ("Instruction " ++ (show node) ++ - " lacks a left edge") - (x,y) | not (all isFloat x && all isFloat y) -> - error ("Instruction " ++ (show node) ++ - " has non numeric arguments") - (x,y) -> let s = f (read . head $ x) (map read y) - in return (foldl' (reLabel (show s)) g outN) - - - -modI :: GraspProgram -> Node -> IO GraspProgram -modI g node = - let edges = Graph.out g node - - leftL = targetLabels g (getByLabel "left" edges) - rightL = targetLabels g (getByLabel "right" edges) - outN = targetNodes (getByLabel "out" edges) - - in case (leftL, rightL) of - (x,y) | length x /= 1 || length y /= 1 -> - error ("Instruction " ++ (show node) ++ " requires " ++ - "a single left edge and a single right edge") - - (x,y) | not (all isInteger x && all isInteger y) -> - error ("Instruction " ++ (show node) ++ - " has non integer arguments") - - (x,y) -> let s = (read . head $ x) `mod` (read . head $ y) - in return (foldl' (reLabel (show s)) g outN) - - - -getcI :: GraspProgram -> Node -> IO GraspProgram -getcI g node = do - let edges = Graph.out g node - - outN = targetNodes (getByLabel "out" edges) - fhL = targetLabels g (getByLabel "fh" edges) - - c <- case fhL of - x | length x == 0 || length x == 1 -> getChar >>= - (\x -> if (x == '\EOT') then return (-1) else return (ord x)) - - --x | length x == 1 -> do - -- h <- openFile (head fhL) ReadMode - -- input <- try (hGetChar h) - -- hClose h - -- case input of - -- Left e -> if (isEOFError e) then return (-1) else ioError e - -- Right inpChr -> return (ord inpChr) - - x -> error ("Instruction " ++ (show node) ++ - " may only have one file handle") - - return (foldl' (reLabel (show c)) g outN) - - - -putcI :: GraspProgram -> Node -> IO GraspProgram -putcI g node = do - let edges = Graph.out g node - - inL = targetLabels g (getByLabel "in" edges) - fhL = targetLabels g (getByLabel "fh" edges) - - r <- getStdRandom (randomR (0, length inL - 1)) - - c <- case inL of - x | length x == 0 -> - error ("Instruction " ++ (show node) ++ - " must have at least one in edge") - - x | not (isInteger $ inL!!r) -> - error ("Randomly chosen in edge to " ++ (show node) ++ - " does not contain an integer") - - x -> return . chr . read $ inL!!r - - fh <- case fhL of - x | length x == 0 || length x == 1 -> return stdout - - --x | length x == 1 -> openFile (head fhL) AppendMode - - x -> error ("Instruction " ++ (show node) ++ - " may only have one file handle") - - hPutChar fh c - when (fh /= stdout) (hClose fh) - - return g - - - -getsI :: GraspProgram -> Node -> IO GraspProgram -getsI g node = return g - -putsI :: GraspProgram -> Node -> IO GraspProgram -putsI g node = return g - diff --git a/src/Grasp/Interpreter.hs.old b/src/Grasp/Interpreter.hs.old new file mode 100644 index 0000000..e7a36c9 --- /dev/null +++ b/src/Grasp/Interpreter.hs.old @@ -0,0 +1,532 @@ +module Grasp.Interpreter ( + grasp + ) where + + +import Control.Monad +import Control.Exception +import System.Random +import System.IO +import System.IO.Error +import Text.Read( readMaybe ) +import Data.Graph.Inductive.Graph( Node, LNode, LEdge, (&) ) +import qualified Data.Graph.Inductive.Graph as Graph +import Data.Map( (!) ) +import qualified Data.Map as Map +import Data.List +import Data.Maybe +import Data.Char +import Grasp.Types +import Grasp.Parser + + + +type IP = [LNode String] + + + +-- this is a disgusting, disgusting way to implement this + +-- I blame the inelegance of manipulating graphs, and I strongly suspect +-- it would be better for all concerned if I created a DSL for that purpose +-- and refactored all the instructions into that form + + + +grasp :: GraspProgram -> IO () +grasp g = + 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 [] + + + +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' + + + +garbageCollect :: GraspProgram -> [IP] -> GraspProgram +garbageCollect g ips = + let unreachable = (Graph.nodes g) \\ (reachable g ips) + in Graph.delNodes unreachable g + + + +interpret :: GraspProgram -> [IP] -> IO () +interpret g ips = if (ips == []) then return () else execute g ips [] + + + +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 = + let (node,instruction) = head cur + condL = targetLabels g (getByLabel "cond" (Graph.out g node)) + goAhead = all (\x -> isFloat x && (read :: String -> Float) x /= 0.0) condL + + in case (goAhead, instruction) of + (False,_) -> do + cur' <- updateIP cur (targetLNodes g (getByLabel "next" (Graph.out g node))) + execute g rest (cur':out) + + (True,x) | x /= "call" && x /= "ret" -> do + g' <- case x of + "set" -> setI g node + "new" -> newI g node + "del" -> delI g node + "push" -> pushI 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 + "sub" -> subI g node + "div" -> divI g node + "mod" -> modI g node + "getc" -> getcI g node + "putc" -> putcI g node + "gets" -> getsI g node + "puts" -> putsI g node + inst | isInteger inst -> implicitPushI g node + _ -> error ("Unknown instruction at " ++ (show x)) + cur' <- updateIP cur (targetLNodes g' (getByLabel "next" (Graph.out g' node))) + execute g' rest (cur':out) + + (_,x) -> do + (g',cur') <- case x of + "call" -> callI g cur + "ret" -> retI g cur >>= (\(x,y) -> return (garbageCollect x ((y:rest) ++ out), y)) + _ -> error ("Execute function reached impossible branch") + execute g' rest (cur':out) + + + +isInteger :: String -> Bool +isInteger x = + 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 :: String -> GraspProgram -> Node -> GraspProgram +reLabel s g n = + 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 + + + +getByLabel :: String -> [LEdge String] -> [LEdge String] +getByLabel name = filter (\(_,_,x) -> x == name) + + + +targetLabels :: GraspProgram -> [LEdge String] -> [String] +targetLabels g = map (\(_,x,_) -> fromJust (Graph.lab g x)) + +targetNodes :: [LEdge String] -> [Node] +targetNodes = map (\(_,x,_) -> x) + +targetLNodes :: GraspProgram -> [LEdge String] -> [LNode String] +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 - 1)) >>= + (\x -> return ((next !! x):(tail ip)) ) + + + +setI :: GraspProgram -> Node -> IO GraspProgram +setI g node = + let edges = Graph.out g node + + inL = targetLabels g (getByLabel "in" edges) + outN = targetNodes (getByLabel "out" edges) + + in case inL of + [] -> return g + _ -> (getStdRandom (randomR (0,length inL - 1))) >>= + (\x -> return (foldl' (reLabel (inL !! x)) g outN) ) + + + +newI :: GraspProgram -> Node -> IO GraspProgram +newI g node = + let edges = Graph.out g node + + tailN = targetNodes (getByLabel "tail" edges) + headN = targetNodes (getByLabel "head" edges) + labelL = targetLabels g (getByLabel "label" edges) + + in 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) + + + +delI :: GraspProgram -> Node -> IO GraspProgram +delI g node = + let edges = Graph.out g node + + tailN = targetNodes (getByLabel "tail" edges) + headN = targetNodes (getByLabel "head" edges) + labelL = targetLabels g (getByLabel "label" edges) + + edgesToDel = filter (\(x,y,z) -> x `elem` tailN && + (headN == [] || y `elem` headN) && + (labelL == [] || z `elem` labelL)) (Graph.labEdges g) + + in return (foldl' (flip Graph.delLEdge) g edgesToDel) + + + +pushI :: GraspProgram -> Node -> IO GraspProgram +pushI g node = do + let edges = Graph.out g node + + stackN = targetNodes (getByLabel "stack" edges) + inL = targetLabels g (getByLabel "in" edges) + + rnd <- getStdRandom (randomR (0,length inL -1)) + let label = if (inL == []) then "" else inL !! rnd + + if (length stackN /= 1) + then error ("Instruction " ++ (show node) ++ " should have one stack argument") + else doPushI g (head stackN) label + + + +implicitPushI :: GraspProgram -> Node -> IO GraspProgram +implicitPushI g node = + let edges = Graph.out g node + + stackN = targetNodes (getByLabel "stack" edges) + label = fromJust $ Graph.lab g node + + in if (length stackN /= 1) + then error ("Instruction " ++ (show node) ++ " should have one stack argument") + else doPushI g (head stackN) label + + + +doPushI :: GraspProgram -> Node -> String -> IO GraspProgram +doPushI g s l = + let newN = head (Graph.newNodes 1 g) + + edgesToDel = Graph.inn g s + edgesToAdd = map (\(x,y,z) -> (x,newN,z)) edgesToDel + + nextE = (newN,s,"next") + + g' = Graph.insNode (newN,l) g + g'' = foldl' (flip Graph.delLEdge) g' edgesToDel + g''' = Graph.insEdges (nextE:edgesToAdd) g'' + + in return g''' + + + +popI :: GraspProgram -> Node -> IO GraspProgram +popI g node = + let edges = Graph.out g node + + stackNs = targetNodes (getByLabel "stack" edges) + outN = targetNodes (getByLabel "out" edges) + emptyL = targetLabels g (getByLabel "empty" edges) + + 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' (reLabel 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' (reLabel (emptyL !! x)) g outN)) + + + +pickI :: GraspProgram -> Node -> IO GraspProgram +pickI g node = + let edges = Graph.out g node + + stackN = targetNodes (getByLabel "stack" edges) + depthL = targetLabels g (getByLabel "depth" edges) + outN = targetNodes (getByLabel "out" edges) + emptyL = targetLabels g (getByLabel "empty" edges) + + in case (stackN, depthL) of + (x,_) | length x /= 1 -> error ("Instruction " ++ (show node) ++ + " should have one stack argument") + + (_,y) | length y /= 1 -> error ("Instruction " ++ (show node) ++ + " should have one depth argument") + + (_,y) | not (isInteger (head y)) -> error ("Instruction " ++ (show node) ++ + " should have integer depth argument") + + (x,y) -> doPickI g (head x) (read (head y)) outN emptyL + + + +doPickI :: GraspProgram -> Node -> Int -> [Node] -> [String] -> IO GraspProgram +doPickI g stackN depth outN emptyL = + let nextN = targetNodes (getByLabel "next" (Graph.out g stackN)) + + in case nextN of + x | length x > 1 -> error ("Stack has too many next edges at node " ++ (show stackN)) + + x | length x == 0 -> + if (emptyL == []) then return g + else (getStdRandom (randomR (0,length emptyL - 1))) >>= + (\x -> return (foldl' (reLabel (emptyL !! x)) g outN)) + + x -> + if (depth > 0) then doPickI g (head nextN) (depth - 1) outN emptyL + else let label = fromJust (Graph.lab g stackN) + in return (foldl' (reLabel label) g outN) + + + +callI :: GraspProgram -> IP -> IO (GraspProgram, IP) +callI g ip = + let node = fst . head $ ip + edges = Graph.out g node + + funcL = targetLabels g (getByLabel "func" edges) + arguments = filter (\(x,y,z) -> z /= "func" && z /= "name" && z /= "cond" && z /= "next") edges + + possibleFuncs = concatMap (nodesWithName g) funcL + + in if (possibleFuncs == []) then error ("Call from " ++ (show node) ++ " has no candidates") + else do + r <- getStdRandom (randomR (0,length possibleFuncs - 1)) + + let oldNodes = reachable g [[possibleFuncs !! r]] + oldEdges = filter (\(x,y,z) -> x `elem` oldNodes && y `elem` oldNodes) (Graph.labEdges g) + + nodeMap = Map.fromList (zip oldNodes (Graph.newNodes (length oldNodes) g)) + + labels = map (fromJust . (Graph.lab g)) oldNodes + newNodes = map (nodeMap !) oldNodes + + newLNodes = zip newNodes labels + newEdges = map (\(x,y,z) -> (nodeMap ! x, nodeMap ! y, z)) oldEdges + + mainNode = (\(x,y) -> (nodeMap ! x, y)) (possibleFuncs !! r) + argEdges = map (\(x,y,z) -> (nodeMap ! (fst (possibleFuncs !! r)), y, z)) arguments + + g' = (Graph.insEdges (newEdges ++ argEdges)) . (Graph.insNodes newLNodes) $ g + ip' = mainNode : ip + + return (g', ip') + + + +retI :: GraspProgram -> IP -> IO (GraspProgram, IP) +retI g (n:[]) = return (g,[]) +retI g ip = + let oldEdges = Graph.out g (fst . head $ ip) + returnValues = filter (\(x,y,z) -> z /= "name" && z /= "cond" && z /= "next") oldEdges + + node = fst . head $ (tail ip) + edges = Graph.out g node + + nextLN = targetLNodes g (getByLabel "next" edges) + + in if (nextLN == []) then return (g,[]) + else do + ip' <- updateIP (tail ip) nextLN + + let node' = fst . head $ ip' + returnEdges = map (\(x,y,z) -> (node',y,z)) returnValues + + g' = Graph.insEdges returnEdges g + + return (g',ip') + + + +addI :: GraspProgram -> Node -> IO GraspProgram +addI = addmulI sum + +mulI :: GraspProgram -> Node -> IO GraspProgram +mulI = addmulI product + +addmulI :: ([Float] -> Float) -> GraspProgram -> Node -> IO GraspProgram +addmulI f g node = + let edges = Graph.out g node + + argL = targetLabels g (getByLabel "arg" edges) + outN = targetNodes (getByLabel "out" edges) + + in case argL of + x | not (all isFloat x) -> error ("Instruction " ++ (show node) ++ + " has non numeric arguments") + x -> let s = f . (map read) $ x + in return (foldl' (reLabel (show s)) g outN) + + + +subI :: GraspProgram -> Node -> IO GraspProgram +subI = subdivI (\a b -> a - (sum b)) + +divI :: GraspProgram -> Node -> IO GraspProgram +divI = subdivI (\a b -> a / (product b)) + +subdivI :: (Float -> [Float] -> Float) -> GraspProgram -> Node -> IO GraspProgram +subdivI f g node = + let edges = Graph.out g node + + leftL = targetLabels g (getByLabel "left" edges) + rightL = targetLabels g (getByLabel "right" edges) + outN = targetNodes (getByLabel "out" edges) + + in case (leftL, rightL) of + (x,_) | length x /= 1 -> error ("Instruction " ++ (show node) ++ + " lacks a left edge") + (x,y) | not (all isFloat x && all isFloat y) -> + error ("Instruction " ++ (show node) ++ + " has non numeric arguments") + (x,y) -> let s = f (read . head $ x) (map read y) + in return (foldl' (reLabel (show s)) g outN) + + + +modI :: GraspProgram -> Node -> IO GraspProgram +modI g node = + let edges = Graph.out g node + + leftL = targetLabels g (getByLabel "left" edges) + rightL = targetLabels g (getByLabel "right" edges) + outN = targetNodes (getByLabel "out" edges) + + in case (leftL, rightL) of + (x,y) | length x /= 1 || length y /= 1 -> + error ("Instruction " ++ (show node) ++ " requires " ++ + "a single left edge and a single right edge") + + (x,y) | not (all isInteger x && all isInteger y) -> + error ("Instruction " ++ (show node) ++ + " has non integer arguments") + + (x,y) -> let s = (read . head $ x) `mod` (read . head $ y) + in return (foldl' (reLabel (show s)) g outN) + + + +getcI :: GraspProgram -> Node -> IO GraspProgram +getcI g node = do + let edges = Graph.out g node + + outN = targetNodes (getByLabel "out" edges) + fhL = targetLabels g (getByLabel "fh" edges) + + c <- case fhL of + x | length x == 0 || length x == 1 -> getChar >>= + (\x -> if (x == '\EOT') then return (-1) else return (ord x)) + + --x | length x == 1 -> do + -- h <- openFile (head fhL) ReadMode + -- input <- try (hGetChar h) + -- hClose h + -- case input of + -- Left e -> if (isEOFError e) then return (-1) else ioError e + -- Right inpChr -> return (ord inpChr) + + x -> error ("Instruction " ++ (show node) ++ + " may only have one file handle") + + return (foldl' (reLabel (show c)) g outN) + + + +putcI :: GraspProgram -> Node -> IO GraspProgram +putcI g node = do + let edges = Graph.out g node + + inL = targetLabels g (getByLabel "in" edges) + fhL = targetLabels g (getByLabel "fh" edges) + + r <- getStdRandom (randomR (0, length inL - 1)) + + c <- case inL of + x | length x == 0 -> + error ("Instruction " ++ (show node) ++ + " must have at least one in edge") + + x | not (isInteger $ inL!!r) -> + error ("Randomly chosen in edge to " ++ (show node) ++ + " does not contain an integer") + + x -> return . chr . read $ inL!!r + + fh <- case fhL of + x | length x == 0 || length x == 1 -> return stdout + + --x | length x == 1 -> openFile (head fhL) AppendMode + + x -> error ("Instruction " ++ (show node) ++ + " may only have one file handle") + + hPutChar fh c + when (fh /= stdout) (hClose fh) + + return g + + + +getsI :: GraspProgram -> Node -> IO GraspProgram +getsI g node = return g + +putsI :: GraspProgram -> Node -> IO GraspProgram +putsI g node = return g + -- cgit