Commit bab00d3b authored by Mart Lubbers's avatar Mart Lubbers

Fix funcmayfail buggery

parent 36c17fcd
Pipeline #15385 passed with stage
in 1 minute and 36 seconds
...@@ -37,7 +37,7 @@ instance < (LPath a) | gLexOrd{|*|} a where ...@@ -37,7 +37,7 @@ instance < (LPath a) | gLexOrd{|*|} a where
// and the remaining 'Graph'. // and the remaining 'Graph'.
defMatchAny :: (gr a b) -> GDecomp gr a b | Graph gr defMatchAny :: (gr a b) -> GDecomp gr a b | Graph gr
defMatchAny g = case labNodes g of defMatchAny g = case labNodes g of
[] -> abort "Match Exception, Empty Graph" _ -> abort "Match Exception, Empty Graph"
[(v,_):_] -> (c,g`) [(v,_):_] -> (c,g`)
where where
(Just c,g`) = match v g (Just c,g`) = match v g
......
...@@ -22,7 +22,7 @@ findP v [LP (p=:[(w,_):_]):ps] | v==w = p ...@@ -22,7 +22,7 @@ findP v [LP (p=:[(w,_):_]):ps] | v==w = p
| otherwise = findP v ps | otherwise = findP v ps
getPath :: Node RTree -> Path getPath :: Node RTree -> Path
getPath v t = (reverse o first (\[w:_]->w==v)) t getPath v t = (reverse o first (\w->hd w==v)) t
getLPath :: Node (LRTree a) -> LPath a getLPath :: Node (LRTree a) -> LPath a
getLPath v t = (LP o reverse o findP v) t getLPath v t = (LP o reverse o findP v) t
......
...@@ -37,7 +37,9 @@ defMatchAnyM :: (m (gr a b)) -> m (GDecomp gr a b) | GraphM m gr ...@@ -37,7 +37,9 @@ defMatchAnyM :: (m (gr a b)) -> m (GDecomp gr a b) | GraphM m gr
defMatchAnyM g = labNodesM g >>= \vs -> defMatchAnyM g = labNodesM g >>= \vs ->
case vs of case vs of
[] -> abort "Match Exception, Empty Graph" [] -> abort "Match Exception, Empty Graph"
[(v,_):_] -> matchM v g >>= \(Just c,g`) -> pure (c,g`) [(v,_):_] -> matchM v g >>= \t->case t of
(Just c,g`) -> pure (c,g`)
_ -> abort "No Match"
defNoNodesM :: (m (gr a b)) -> m Int | GraphM m gr defNoNodesM :: (m (gr a b)) -> m Int | GraphM m gr
defNoNodesM m = (labNodesM >>. length) m defNoNodesM m = (labNodesM >>. length) m
......
...@@ -5,7 +5,6 @@ implementation module Data.Graph.Inductive.NodeMap ...@@ -5,7 +5,6 @@ implementation module Data.Graph.Inductive.NodeMap
//import Control.Monad.Trans.State // TODO Implement monadic interface //import Control.Monad.Trans.State // TODO Implement monadic interface
import Control.Monad, Control.Applicative, Data.Functor import Control.Monad, Control.Applicative, Data.Functor
import StdOverloaded, StdBool, StdClass, StdTuple, StdInt import StdOverloaded, StdBool, StdClass, StdTuple, StdInt
from StdFunc import o
import Data.Maybe import Data.Maybe
//import Data.Graph.Inductive.Graph //import Data.Graph.Inductive.Graph
from Data.Graph.Inductive.Graph import class Graph, class DynGraph, :: LNode, :: Node, :: LEdge, :: Edge from Data.Graph.Inductive.Graph import class Graph, class DynGraph, :: LNode, :: Node, :: LEdge, :: Edge
...@@ -13,6 +12,8 @@ import qualified Data.Graph.Inductive.Graph ...@@ -13,6 +12,8 @@ import qualified Data.Graph.Inductive.Graph
from Data.Map import :: Map, instance == (Map k v) from Data.Map import :: Map, instance == (Map k v)
import qualified Data.Map import qualified Data.Map
import qualified Data.List import qualified Data.List
import Data.Func
import StdEnv
:: NodeMap a = :: NodeMap a =
{ map :: Map a Node { map :: Map a Node
...@@ -85,7 +86,7 @@ insMapNode_ m a g = ...@@ -85,7 +86,7 @@ insMapNode_ m a g =
insMapEdge :: (NodeMap a) (a, a, b) (g a b) -> g a b | Ord a & DynGraph g insMapEdge :: (NodeMap a) (a, a, b) (g a b) -> g a b | Ord a & DynGraph g
insMapEdge m e g = insMapEdge m e g =
let (Just e`) = mkEdge m e let e` = maybe (abort "shouldn't happen") id $ mkEdge m e
in 'Data.Graph.Inductive.Graph'.insEdge e` g in 'Data.Graph.Inductive.Graph'.insEdge e` g
delMapNode :: (NodeMap a) a (g a b) -> g a b | Ord a & DynGraph g delMapNode :: (NodeMap a) a (g a b) -> g a b | Ord a & DynGraph g
...@@ -95,7 +96,7 @@ delMapNode m a g = ...@@ -95,7 +96,7 @@ delMapNode m a g =
delMapEdge :: (NodeMap a) (a, a) (g a b) -> g a b | Ord a & DynGraph g delMapEdge :: (NodeMap a) (a, a) (g a b) -> g a b | Ord a & DynGraph g
delMapEdge m (n1, n2) g = delMapEdge m (n1, n2) g =
let (Just (n1`, n2`, _)) = mkEdge m (n1, n2, ()) let (n1`, n2`, _) = maybe (abort "shouldn't happen") id $ mkEdge m (n1, n2, ())
in 'Data.Graph.Inductive.Graph'.delEdge (n1`, n2`) g in 'Data.Graph.Inductive.Graph'.delEdge (n1`, n2`) g
insMapNodes :: (NodeMap a) [a] (g a b) -> (g a b, NodeMap a, [LNode a]) | Ord a & DynGraph g insMapNodes :: (NodeMap a) [a] (g a b) -> (g a b, NodeMap a, [LNode a]) | Ord a & DynGraph g
...@@ -110,7 +111,7 @@ insMapNodes_ m as g = ...@@ -110,7 +111,7 @@ insMapNodes_ m as g =
insMapEdges :: (NodeMap a) [(a, a, b)] (g a b) -> g a b | Ord a & DynGraph g insMapEdges :: (NodeMap a) [(a, a, b)] (g a b) -> g a b | Ord a & DynGraph g
insMapEdges m es g = insMapEdges m es g =
let (Just es`) = mkEdges m es let es` = maybe (abort "Shouldn't happen") id $ mkEdges m es
in 'Data.Graph.Inductive.Graph'.insEdges es` g in 'Data.Graph.Inductive.Graph'.insEdges es` g
delMapNodes :: (NodeMap a) [a] (g a b) -> g a b | Ord a & DynGraph g delMapNodes :: (NodeMap a) [a] (g a b) -> g a b | Ord a & DynGraph g
...@@ -120,14 +121,14 @@ delMapNodes m as g = ...@@ -120,14 +121,14 @@ delMapNodes m as g =
delMapEdges :: (NodeMap a) [(a, a)] (g a b) -> g a b | Ord a & DynGraph g delMapEdges :: (NodeMap a) [(a, a)] (g a b) -> g a b | Ord a & DynGraph g
delMapEdges m ns g = delMapEdges m ns g =
let (Just ns`) = mkEdges m ('Data.List'.map (\(a, b) -> (a, b, ())) ns) let ns` = maybe (abort "shouldn't happen") id $ mkEdges m ('Data.List'.map (\(a, b) -> (a, b, ())) ns)
ns`` = 'Data.List'.map (\(a, b, _) -> (a, b)) ns` ns`` = 'Data.List'.map (\(a, b, _) -> (a, b)) ns`
in 'Data.Graph.Inductive.Graph'.delEdges ns`` g in 'Data.Graph.Inductive.Graph'.delEdges ns`` g
mkMapGraph :: [a] [(a, a, b)] -> (g a b, NodeMap a) | Ord a & DynGraph g mkMapGraph :: [a] [(a, a, b)] -> (g a b, NodeMap a) | Ord a & DynGraph g
mkMapGraph ns es = mkMapGraph ns es =
let (ns`, m`) = mkNodes new ns let (ns`, m`) = mkNodes new ns
(Just es`) = mkEdges m` es es` = maybe (abort "shouldn't happen") id $ mkEdges m` es
in ('Data.Graph.Inductive.Graph'.mkGraph ns` es`, m`) in ('Data.Graph.Inductive.Graph'.mkGraph ns` es`, m`)
// | Graph construction monad; handles passing both the `NodeMap` and the // | Graph construction monad; handles passing both the `NodeMap` and the
......
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
implementation module Data.Graph.Inductive.Query.BFS implementation module Data.Graph.Inductive.Query.BFS
import StdBool, StdFunc import StdMisc,StdBool, StdFunc
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Graph
...@@ -47,7 +47,7 @@ leveln _ g | isEmptyGraph g = [] ...@@ -47,7 +47,7 @@ leveln _ g | isEmptyGraph g = []
leveln [(v,j):vs] g = case match v g of leveln [(v,j):vs] g = case match v g of
(Just c,g`) -> [(v,j):leveln (vs++suci c (j+1)) g`] (Just c,g`) -> [(v,j):leveln (vs++suci c (j+1)) g`]
(Nothing,g`) -> leveln vs g` (Nothing,g`) -> leveln vs g`
leveln _ _ = abort "Shouldn't happen"
// bfe (breadth first edges) // bfe (breadth first edges)
// remembers predecessor information // remembers predecessor information
...@@ -90,17 +90,17 @@ bft :: Node (gr a b) -> RTree | Graph gr ...@@ -90,17 +90,17 @@ bft :: Node (gr a b) -> RTree | Graph gr
bft v g = bf (queuePut [v] mkQueue) g bft v g = bf (queuePut [v] mkQueue) g
bf :: (Queue Path) (gr a b) -> RTree | Graph gr bf :: (Queue Path) (gr a b) -> RTree | Graph gr
bf q g | queueEmpty q || isEmptyGraph g = [] bf q g
| otherwise = | queueEmpty q || isEmptyGraph g = []
let (p=:[v:_],q`) = queueGet q in = case queueGet q of
case match v g of (p=:[v:_],q`) = case match v g of
(Just c, g`) -> [p:bf (queuePutList (map (\x -> [x:p]) (suc` c)) q`) g`] (Just c, g`) = [p:bf (queuePutList (map (\x -> [x:p]) (suc` c)) q`) g`]
(Nothing, g`) -> bf q` g` (Nothing, g`) = bf q` g`
(_,_) = abort "shouldn't happen"
esp :: Node Node (gr a b) -> Path | Graph gr esp :: Node Node (gr a b) -> Path | Graph gr
esp s t g = (getPath t o bft s) g esp s t g = (getPath t o bft s) g
// lesp is a version of esp that returns labeled paths // lesp is a version of esp that returns labeled paths
// Note that the label of the first node in a returned path is meaningless; // Note that the label of the first node in a returned path is meaningless;
// all other nodes are paired with the label of their incoming edge. // all other nodes are paired with the label of their incoming edge.
...@@ -112,13 +112,14 @@ lbft v g = case out g v of ...@@ -112,13 +112,14 @@ lbft v g = case out g v of
lbf :: (Queue (LPath b)) (gr a b) -> LRTree b | Graph gr lbf :: (Queue (LPath b)) (gr a b) -> LRTree b | Graph gr
lbf q g | queueEmpty q || isEmptyGraph g = [] lbf q g
| otherwise = | queueEmpty q || isEmptyGraph g = []
let (LP (p=:[(v,_):_]),q`) = queueGet q in = case queueGet q of
case match v g of (LP (p=:[(v,_):_]),q`) = case match v g of
(Just c, g`) -> (Just c, g`) =
[LP p:lbf (queuePutList (map (\v` -> LP [v`:p]) (lsuc` c)) q`) g`] [LP p:lbf (queuePutList (map (\v` -> LP [v`:p]) (lsuc` c)) q`) g`]
(Nothing, g`) -> lbf q` g` (Nothing, g`) = lbf q` g`
_ = abort "Shouldn't happen"
lesp :: Node Node (gr a b) -> LPath b | Graph gr lesp :: Node Node (gr a b) -> LPath b | Graph gr
lesp s t g = (getLPath t o lbft s) g lesp s t g = (getLPath t o lbft s) g
...@@ -44,6 +44,7 @@ instance == (Heap a) where ...@@ -44,6 +44,7 @@ instance == (Heap a) where
go f [x:xs] [y:ys] = f x y && f y x && go f xs ys go f [x:xs] [y:ys] = f x y && f y x && go f xs ys
go _ [] [] = True go _ [] [] = True
go _ _ _ = False go _ _ _ = False
(==) _ _ = False
instance < (Heap a) where instance < (Heap a) where
< Empty Empty = False < Empty Empty = False
...@@ -60,6 +61,7 @@ instance < (Heap a) where ...@@ -60,6 +61,7 @@ instance < (Heap a) where
go f [] [] = False go f [] [] = False
go f [] [_:_] = True go f [] [_:_] = True
go f [_:_] [] = False go f [_:_] [] = False
< _ _ = False
// /O(1)/. Is the heap empty? // /O(1)/. Is the heap empty?
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment