...
 
Commits (30)
definition module Control.Arrow
import Control.Category
from Control.Monad import class Monad
from Control.Applicative import class Applicative, class Alternative
from Data.Functor import class Functor
from Data.Either import :: Either
// | The basic arrow class.
//
// Instances should satisfy the following laws:
//
// * @'arr' cid = 'id'@
//
// * @'arr' (f >>> g) = 'arr' f >>> 'arr' g@
//
// * @'first' ('arr' f) = 'arr' ('first' f)@
//
// * @'first' (f >>> g) = 'first' f >>> 'first' g@
//
// * @'first' f >>> 'arr' 'fst' = 'arr' 'fst' >>> f@
//
// * @'first' f >>> 'arr' ('id' *** g) = 'arr' ('id' *** g) >>> 'first' f@
//
// * @'first' ('first' f) >>> 'arr' 'assoc' = 'arr' 'assoc' >>> 'first' f@
//
// where
//
// > assoc ((a,b),c) = (a,(b,c))
//
// The other combinators have sensible default definitions,
// which may be overridden for efficiency.
class Arrow a | Category a where
// | Lift a function to an arrow.
arr :: (b -> c) -> a b c
// | Send the first component of the input through the argument
// arrow, and copy the rest unchanged to the output.
first :: (a b c) -> a (b,d) (c,d)
// | A mirror image of 'first'.
//
// The default definition may be overridden with a more efficient
// version if desired.
second :: (a b c) -> a (d,b) (d,c)
// | Split the input between the two argument arrows and combine
// their output. Note that this is in general not a functor.
//
// The default definition may be overridden with a more efficient
// version if desired.
(***) infixr 3 :: (a b c) (a b` c`) -> a (b,b`) (c,c`)
// | Fanout: send the input to both argument arrows and combine
// their output.
//
// The default definition may be overridden with a more efficient
// version if desired.
(&&&) infixr 3 :: (a b c) (a b c`) -> a b (c,c`)
// Ordinary functions are arrows.
instance Arrow (->)
// | Kleisli arrows of a monad.
:: Kleisli m a b = Kleisli (a -> m b)
runKleisli :: (Kleisli m a b) -> (a -> m b)
instance Category (Kleisli m) | Monad m
instance Arrow (Kleisli m) | Monad m
// | The identity arrow, which plays the role of 'pure' in arrow notation.
pureA :: a b b | Arrow a
// | Precomposition with a pure function.
(^>>) infixr 1 :: (b -> c) (a c d) -> a b d | Arrow a
// | Postcomposition with a pure function.
(>>^) infixr 1 :: (a b c) (c -> d) -> a b d | Arrow a
// | Precomposition with a pure function (right-to-left variant).
(<<^) infixr 1 :: (a c d) (b -> c) -> a b d | Arrow a
// | Postcomposition with a pure function (right-to-left variant).
(^<<) infixr 1 :: (c -> d) (a b c) -> a b d | Arrow a
class ArrowZero a | Arrow a where
zeroArrow :: a b c
// TODO
//instance ArrowZero (Kleisli m) | MonadPlus m
// | A monoid on arrows.
class ArrowPlus a | ArrowZero a where
// | An associative operation with identity 'zeroArrow'.
(<+>) infixr 5 :: (a b c) (a b c) -> a b c
// TODO
//instance ArrowPlus (Kleisli m) | MonadPlus m
// | Choice, for arrows that support it. This class underlies the
// @if@ and @case@ constructs in arrow notation.
//
// Instances should satisfy the following laws:
//
// * @'left' ('arr' f) = 'arr' ('left' f)@
//
// * @'left' (f >>> g) = 'left' f >>> 'left' g@
//
// * @f >>> 'arr' 'Left' = 'arr' 'Left' >>> 'left' f@
//
// * @'left' f >>> 'arr' ('id' <+++> g) = 'arr' ('id' <+++> g) >>> 'left' f@
//
// * @'left' ('left' f) >>> 'arr' 'assocsum' = 'arr' 'assocsum' >>> 'left' f@
//
// where
//
// > assocsum (Left (Left x)) = Left x
// > assocsum (Left (Right y)) = Right (Left y)
// > assocsum (Right z) = Right (Right z)
//
// The other combinators have sensible default definitions, which may
// be overridden for efficiency.
class ArrowChoice a | Arrow a where
// | Feed marked inputs through the argument arrow, passing the
// rest through unchanged to the output.
left :: (a b c) -> a (Either b d) (Either c d)
// | A mirror image of 'left'.
//
// The default definition may be overridden with a more efficient
// version if desired.
right :: (a b c) -> a (Either d b) (Either d c)
// | Split the input between the two argument arrows, retagging
// and merging their outputs.
// Note that this is in general not a functor.
//
// The default definition may be overridden with a more efficient
// version if desired.
(<+++>) infixr 2 :: (a b c) (a b` c`) -> a (Either b b`) (Either c c`)
// | Fanin: Split the input between the two argument arrows and
// merge their outputs.
//
// The default definition may be overridden with a more efficient
// version if desired.
(|||) infixr 2 :: (a b d) (a c d) -> a (Either b c) d
instance ArrowChoice (->)
instance ArrowChoice (Kleisli m) | Monad m
// | Some arrows allow application of arrow inputs to other inputs.
// Instances should satisfy the following laws:
//
// * @'first' ('arr' (\\x -> 'arr' (\\y -> (x,y)))) >>> 'app' = 'id'@
//
// * @'first' ('arr' (g >>>)) >>> 'app' = 'second' g >>> 'app'@
//
// * @'first' ('arr' (>>> h)) >>> 'app' = 'app' >>> h@
//
// Such arrows are equivalent to monads (see 'ArrowMonad').
class ArrowApply a | Arrow a where
app :: a (a b c, b) c
instance ArrowApply (->)
instance ArrowApply (Kleisli m) | Monad m
// | The 'ArrowApply' class is equivalent to 'Monad': any monad gives rise
// to a 'Kleisli' arrow, and any instance of 'ArrowApply' defines a monad.
:: ArrowMonad a b = ArrowMonad (a () b)
instance Functor (ArrowMonad a) | Arrow a
instance Applicative (ArrowMonad a) | Arrow a
instance Monad (ArrowMonad a) | ArrowApply a
instance Alternative (ArrowMonad a) | ArrowPlus a
// TODO
//instance MonadPlus (ArrowMonad a) | ArrowApply a & ArrowPlus a
// | Any instance of 'ArrowApply' can be made into an instance of
// 'ArrowChoice' by defining 'left' = 'leftApp'.
leftApp :: (a b c) -> a (Either b d) (Either c d) | ArrowApply a
// | The 'loop' operator expresses computations in which an output value
// is fed back as input, although the computation occurs only once.
// It underlies the @rec@ value recursion construct in arrow notation.
// 'loop' should satisfy the following laws:
//
// [/extension/]
// @'loop' ('arr' f) = 'arr' (\\ b -> 'fst' ('fix' (\\ (c,d) -> f (b,d))))@
//
// [/left tightening/]
// @'loop' ('first' h >>> f) = h >>> 'loop' f@
//
// [/right tightening/]
// @'loop' (f >>> 'first' h) = 'loop' f >>> h@
//
// [/sliding/]
// @'loop' (f >>> 'arr' ('id' *** k)) = 'loop' ('arr' ('id' *** k) >>> f)@
//
// [/vanishing/]
// @'loop' ('loop' f) = 'loop' ('arr' unassoc >>> f >>> 'arr' assoc)@
//
// [/superposing/]
// @'second' ('loop' f) = 'loop' ('arr' assoc >>> 'second' f >>> 'arr' unassoc)@
//
// where
//
// > assoc ((a,b),c) = (a,(b,c))
// > unassoc (a,(b,c)) = ((a,b),c)
//
//class ArrowLoop a | Arrow a where
//loop :: a (b,d) (c,d) -> a b c
//instance ArrowLoop (->)
// | Beware that for many monads (those for which the '>>=' operation
// is strict) this instance will /not/ satisfy the right-tightening law
// required by the 'ArrowLoop' class.
// TODO
//instance ArrowLoop (Kleisli m) | MonadFix m
// --------------------------------------------------------------------------
// |
// Module : Control.Arrow
// Copyright : (c) Ross Paterson 2002
// License : BSD-style (see the LICENSE file in the distribution)
//
// Maintainer : libraries@haskell.org
// Stability : provisional
// Portability : portable
//
// Basic arrow definitions, based on
//
// * /Generalising Monads to Arrows/, by John Hughes,
// /Science of Computer Programming/ 37, pp67-111, May 2000.
//
// plus a couple of definitions ('pureA' and 'loop') from
//
// * /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,
// Firenze, Italy, pp229-240.
//
// These papers and more information on arrows can be found at
// <http://www.haskell.org/arrows/>.
implementation module Control.Arrow
import StdTuple
from StdFunc import o, const
import Data.Either
import Control.Monad.Fix
import Control.Category
import Control.Monad
import Control.Applicative
// Ordinary functions are arrows.
instance Arrow (->) where
arr f = f
first x = x *** cid
second x = cid *** x
(***) f g = \t -> let (x,y) = t in (f x, g y)
(&&&) f g = arr (\b -> (b,b)) >>> f *** g
// | Kleisli arrows of a monad.
:: Kleisli m a b = Kleisli (a -> m b)
runKleisli :: (Kleisli m a b) -> (a -> m b)
runKleisli (Kleisli f) = f
instance Category (Kleisli m) | Monad m where
cid = Kleisli pure
(O) (Kleisli f) (Kleisli g) = Kleisli (\b -> g b >>= f)
instance Arrow (Kleisli m) | Monad m where
arr f = Kleisli (pure o f)
first (Kleisli f) = Kleisli (\t -> let (b, d) = t in f b >>= \c -> pure (c,d))
second (Kleisli f) = Kleisli (\t -> let (d,b) = t in f b >>= \c -> pure (d,c))
(***) f g = first f >>> arr swap >>> first g >>> arr swap
where swap t = let (x,y) = t in (y,x)
(&&&) f g = arr (\b -> (b,b)) >>> f *** g
// | The identity arrow, which plays the role of 'pure' in arrow notation.
pureA :: a b b | Arrow a
pureA = arr cid
// | Precomposition with a pure function.
(^>>) infixr 1 :: (b -> c) (a c d) -> a b d | Arrow a
(^>>) f a = arr f >>> a
// | Postcomposition with a pure function.
(>>^) infixr 1 :: (a b c) (c -> d) -> a b d | Arrow a
(>>^) a f = a >>> arr f
// | Precomposition with a pure function (right-to-left variant).
(<<^) infixr 1 :: (a c d) (b -> c) -> a b d | Arrow a
(<<^) a f = a <<< arr f
// | Postcomposition with a pure function (right-to-left variant).
(^<<) infixr 1 :: (c -> d) (a b c) -> a b d | Arrow a
(^<<) f a = arr f <<< a
// TODO
//instance ArrowZero (Kleisli m) | MonadPlus m where
//zeroArrow = Kleisli (\_ -> mzero)
// TODO
//instance ArrowPlus (Kleisli m) | MonadPlus m where
//Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x)
instance ArrowChoice (->) where
left f = f <+++> cid
right f = cid <+++> f
(<+++>) f g = (Left o f) ||| (Right o g)
(|||) x y = either x y
instance ArrowChoice (Kleisli m) | Monad m where
left f = f <+++> arr cid
right f = arr cid <+++> f
(<+++>) f g = (f >>> arr Left) ||| (g >>> arr Right)
(|||) (Kleisli f) (Kleisli g) = Kleisli (either f g)
instance ArrowApply (->) where
app = \(f,x) -> f x
instance ArrowApply (Kleisli m) | Monad m where
app = Kleisli (\(Kleisli f, x) -> f x)
instance Functor (ArrowMonad a) | Arrow a where
fmap f (ArrowMonad m) = ArrowMonad (m >>> arr f)
instance Applicative (ArrowMonad a) | Arrow a where
pure x = ArrowMonad (arr (const x))
(<*>) (ArrowMonad f) (ArrowMonad x) = ArrowMonad (f &&& x >>> arr (uncurry cid))
instance Monad (ArrowMonad a) | ArrowApply a where
bind (ArrowMonad m) f = ArrowMonad (
m >>> arr (\x -> let (ArrowMonad h) = f x in (h, ())) >>> app)
instance Alternative (ArrowMonad a) | ArrowPlus a where
empty = ArrowMonad zeroArrow
(<|>) (ArrowMonad x) (ArrowMonad y) = ArrowMonad (x <+> y)
// TODO
//instance MonadPlus (ArrowMonad a) | ArrowApply a & ArrowPlus a where
//mzero = ArrowMonad zeroArrow
//ArrowMonad x `mplus` ArrowMonad y = ArrowMonad (x <+> y)
// | Any instance of 'ArrowApply' can be made into an instance of
// 'ArrowChoice' by defining 'left' = 'leftApp'.
leftApp :: (a b c) -> a (Either b d) (Either c d) | ArrowApply a
leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) |||
(\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app
//instance ArrowLoop (->) where
//loop f b = let (c,d) = f (b,d) in c
// | Beware that for many monads (those for which the '>>=' operation
// is strict) this instance will /not/ satisfy the right-tightening law
// required by the 'ArrowLoop' class.
// TODO
//instance MonadFix m => ArrowLoop (Kleisli m) where
//loop (Kleisli f) = Kleisli (liftM fst . mfix . f')
//where f' x y = f (x, snd y)
//---------------------------------------------------------------------------
// |
// Module : Control.Category
// Copyright : (c) Ashley Yakeley 2007
// License : BSD-style (see the LICENSE file in the distribution)
//
// Maintainer : ashley@semantic.org
// Stability : experimental
// Portability : portable
// http://ghc.haskell.org/trac/ghc/ticket/1773
definition module Control.Category
// | A class for categories.
// cid and (O) must form a monoid.
class Category cat where
// | the identity morphism
cid :: cat a a
// | morphism composition
(O) infixr 9 :: (cat b c) (cat a b) -> cat a c
instance Category (->)
// | Right-to-left composition
(<<<) infixr 1 :: (cat b c) (cat a b) -> cat a c | Category cat
// | Left-to-right composition
(>>>) infixr 1 :: (cat a b) (cat b c) -> cat a c | Category cat
//---------------------------------------------------------------------------
// |
// Module : Control.Category
// Copyright : (c) Ashley Yakeley 2007
// License : BSD-style (see the LICENSE file in the distribution)
//
// Maintainer : ashley@semantic.org
// Stability : experimental
// Portability : portable
// http://ghc.haskell.org/trac/ghc/ticket/1773
implementation module Control.Category
import StdFunc
instance Category (->) where
cid = \x -> x
(O) f g = f o g
// | Right-to-left composition
(<<<) infixr 1 :: (cat b c) (cat a b) -> cat a c | Category cat
(<<<) f g = f O g
// | Left-to-right composition
(>>>) infixr 1 :: (cat a b) (cat b c) -> cat a c | Category cat
(>>>) f g = g O f
......@@ -21,7 +21,6 @@ instance MonadPlus []
instance MonadPlus Maybe
return :: a -> m a | Monad m
(>>=) infixl 1 :: (m a) (a -> m b) -> m b | Monad m
(`b`) infixl 1 :: (m a) (a -> m b) -> m b | Monad m
(>>|) infixl 1 :: (m a) (m b) -> m b | Monad m
......
......@@ -28,9 +28,6 @@ instance MonadPlus Maybe where
mplus Nothing ys = ys
mplus xs _ = xs
return :: a -> m a | Monad m
return x = pure x
(>>=) infixl 1 :: (m a) (a -> m b) -> m b | Monad m
(>>=) ma a2mb = bind ma a2mb
......
......@@ -29,7 +29,9 @@ where
//Determine the number of full zero bytes we need to end up with a multiple of 64 bytes
numzerobytes = if (rembytes + 9 > 64) (119 - rembytes) (55 - rembytes)
//Encode size IN BITS as 64-bit big-endian in 8 bytes (size in bits == size in bytes times 8 (or << 3))
sizeAs64bit n = {toChar (if (b == 0) (n << 3) (n >> ((b * 8) - 3))) \\ b <- [7,6,5,4,3,2,1,0]}
sizeAs64bit n = IF_INT_64_OR_32
{toChar (if (b == 0) (n << 3) (n >> ((b * 8) - 3))) \\ b <- [7,6,5,4,3,2,1,0]}
{toChar (if (b > 3) 0 (if (b == 0) (n << 3) (n >> ((b * 8) - 3)))) \\ b <- [7,6,5,4,3,2,1,0]}
//Split the message into a list of 512-bit blocks (assumes a padded input)
chunk :: String -> [String]
......
definition module Data.Eq
from StdOverloaded import class ==
(/=) infix 4 :: !a !a -> Bool | == a
implementation module Data.Eq
import StdOverloaded, StdBool
(/=) infix 4 :: !a !a -> Bool | == a
(/=) x y = not (x == y)
......@@ -10,3 +10,8 @@ instance Functor ((,) a)
(<$>) infixl 4 :: (a -> b) (f a) -> f b | Functor f
(<$) infixl 4 :: a (f b) -> f a | Functor f
($>) infixl 4 :: (f b) a -> f a | Functor f
void :: (f a) -> f () | Functor f
implementation module Data.Functor
from StdFunc import o
from StdFunc import o, const
import Control.Applicative
import Control.Monad
......@@ -12,3 +12,12 @@ instance Functor ((,) a) where
(<$>) infixl 4 :: (a -> b) (f a) -> (f b) | Functor f
(<$>) f fa = fmap f fa
(<$) infixl 4 :: a (f b) -> f a | Functor f
(<$) x fa = fmap (const x) fa
($>) infixl 4 :: (f b) a -> f a | Functor f
($>) fa x = x <$ fa
void :: (f a) -> f () | Functor f
void x = () <$ x
//----------------------------------------------------------------------------
//
// Inductive.dcl -- Functional Graph Library
//
// (c) 1999-2007 by Martin Erwig [see file COPYRIGHT]
//
//----------------------------------------------------------------------------
definition module Data.Graph.Inductive
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Monad
import Data.Graph.Inductive.NodeMap
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.Query
//----------------------------------------------------------------------------
//
// Inductive.dcl -- Functional Graph Library
//
// (c) 1999-2007 by Martin Erwig [see file COPYRIGHT]
//
//----------------------------------------------------------------------------
implementation module Data.Graph.Inductive
// (c) 1999 - 2002 by Martin Erwig [see file COPYRIGHT]
// | Basic Graph Algorithms
definition module Data.Graph.Inductive.Basic
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Internal.Thread
// | Reverse the direction of all edges.
grev :: (gr a b) -> gr a b | DynGraph gr
// | Make the graph undirected, i.e. for every edge from A to B, there
// exists an edge from B to A.
undir :: (gr a b) -> gr a b | DynGraph gr & Eq b
// | Remove all labels.
unlab :: (gr a b) -> gr () () | DynGraph gr
// | Return all 'Context's for which the given function returns 'True'.
gsel :: ((Context a b) -> Bool) (gr a b) -> [Context a b] | Graph gr
// filter operations
//
// efilter : filter based on edge property
// elfilter : filter based on edge label property
//
// | Filter based on edge property.
efilter :: ((LEdge b) -> Bool) (gr a b) -> gr a b | DynGraph gr
// | Filter based on edge label property.
elfilter :: (b -> Bool) (gr a b) -> gr a b | DynGraph gr
// some predicates and classifications
//
// | 'True' if the graph has any edges of the form (A, A).
hasLoop :: (gr a b) -> Bool | Graph gr
// | The inverse of 'hasLoop'.
isSimple :: (gr a b) -> Bool | Graph gr
threadGraph :: ((Context a b) r -> t)
(Split (gr a b) (Context a b) r)
-> SplitM (gr a b) Node t | Graph gr
// gfold1 f d b u = threadGraph (\c->d (labNode' c)) (\c->gfoldn f d b u (f c))
gfold1 :: (((Context a b) -> [Node])) ((Context a b) r -> t) (Collect (Maybe t) r)
-> SplitM (gr a b) Node t | Graph gr
gfoldn :: ((Context a b) -> [Node]) ((Context a b) r -> t)
(Collect (Maybe t) r) [Node] (gr a b) -> (r, gr a b) | Graph gr
// gfold :: ((Context a b) -> [Node]) -> ((Node,a) -> c -> d) ->
// (Maybe d -> c -> c) -> c -> [Node] -> Graph a b -> c
// gfold f d b u l g = fst (gfoldn f d b u l g)
// type Dir a b = (Context a b) -> [Node] -- direction of fold
// type Dagg a b c = (Node,a) -> b -> c -- depth aggregation
// type Bagg a b = (Maybe a -> b -> b,b) -- breadth/level aggregation
//
// gfold :: (Dir a b) -> (Dagg a c d) -> (Bagg d c) -> [Node] -> Graph a b -> c
// gfold f d (b,u) l g = fst (gfoldn f d b u l g)
// | Directed graph fold.
gfold :: ((Context a b) -> [Node]) // ^ direction of fold
((Context a b) c -> d) // ^ depth aggregation
((Maybe d) c -> c, c) // ^ breadth\/level aggregation
[Node]
(gr a b)
-> c | Graph gr
// not finished yet ...
//
// undirBy :: (b -> b -> b) -> Graph a b -> Graph a b
// undirBy = gmap (\(p,v,l,s)->let ps = nub (p++s) in (ps,v,l,ps))
// (c) 1999 - 2002 by Martin Erwig [see file COPYRIGHT]
// | Basic Graph Algorithms
implementation module Data.Graph.Inductive.Basic
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Internal.Thread
import Data.List
from StdFunc import o
import StdTuple
// | Reverse the direction of all edges.
grev :: (gr a b) -> gr a b | DynGraph gr
grev gr = gmap (\(p,v,l,s)->(s,v,l,p)) gr
// | Make the graph undirected, i.e. for every edge from A to B, there
// exists an edge from B to A.
undir :: (gr a b) -> gr a b | DynGraph gr & Eq b
undir g = gmap (\(p,v,l,s)->let ps = nub (p++s) in (ps,v,l,ps)) g
// this version of undir considers edge lables and keeps edges with
// different labels, an alternative is the definition below:
// undir = gmap (\(p,v,l,s)->
// let ps = nubBy (\x y->snd x==snd y) (p++s) in (ps,v,l,ps))
// | Remove all labels.
unlab :: (gr a b) -> gr () () | DynGraph gr
unlab g = gmap (\(p,v,_,s)->(unlabAdj p,v,(),unlabAdj s)) g
where unlabAdj = map (\(_,v)->((),v))
// alternative:
// unlab = nmap (\_->()) o emap (\_->())
// | Return all 'Context's for which the given function returns 'True'.
gsel :: ((Context a b) -> Bool) (gr a b) -> [Context a b] | Graph gr
gsel p g = ufold (\c cs->if (p c) [c:cs] cs) [] g
// filter operations
//
// efilter : filter based on edge property
// elfilter : filter based on edge label property
//
// | Filter based on edge property.
efilter :: ((LEdge b) -> Bool) (gr a b) -> gr a b | DynGraph gr
efilter f g = ufold cfilter emptyGraph g
where cfilter (p,v,l,s) g = (p`,v,l,s`) <&> g
where p` = filter (\(b,u)->f (u,v,b)) p
s` = filter (\(b,w)->f (v,w,b)) s
// | Filter based on edge label property.
elfilter :: (b -> Bool) (gr a b) -> gr a b | DynGraph gr
elfilter f g = efilter (\(_,_,b)->f b) g
// some predicates and classifications
//
// | 'True' if the graph has any edges of the form (A, A).
hasLoop :: (gr a b) -> Bool | Graph gr
hasLoop gr = (not o isEmpty o gsel (\c-> elem (node` c) (suc` c))) gr
// | The inverse of 'hasLoop'.
isSimple :: (gr a b) -> Bool | Graph gr
isSimple g = (not o hasLoop) g
threadGraph :: ((Context a b) r -> t)
(Split (gr a b) (Context a b) r)
-> SplitM (gr a b) Node t | Graph gr
threadGraph f c = threadMaybe f c match
// gfold1 f d b u = threadGraph (\c->d (labNode' c)) (\c->gfoldn f d b u (f c))
gfold1 :: (((Context a b) -> [Node])) ((Context a b) r -> t) (Collect (Maybe t) r)
-> SplitM (gr a b) Node t | Graph gr
gfold1 f d b = threadGraph d (gfoldn f d b o f)
gfoldn :: ((Context a b) -> [Node]) ((Context a b) r -> t)
(Collect (Maybe t) r) [Node] (gr a b) -> (r, gr a b) | Graph gr
gfoldn f d b xs g = threadList b (gfold1 f d b) xs g
// gfold :: ((Context a b) -> [Node]) -> ((Node,a) -> c -> d) ->
// (Maybe d -> c -> c) -> c -> [Node] -> Graph a b -> c
// gfold f d b u l g = fst (gfoldn f d b u l g)
// type Dir a b = (Context a b) -> [Node] -- direction of fold
// type Dagg a b c = (Node,a) -> b -> c -- depth aggregation
// type Bagg a b = (Maybe a -> b -> b,b) -- breadth/level aggregation
//
// gfold :: (Dir a b) -> (Dagg a c d) -> (Bagg d c) -> [Node] -> Graph a b -> c
// gfold f d (b,u) l g = fst (gfoldn f d b u l g)
// | Directed graph fold.
gfold :: ((Context a b) -> [Node]) // ^ direction of fold
((Context a b) c -> d) // ^ depth aggregation
((Maybe d) c -> c, c) // ^ breadth\/level aggregation
[Node]
(gr a b)
-> c | Graph gr
gfold f d b l g = fst (gfoldn f d b l g)
// not finished yet ...
//
// undirBy :: (b -> b -> b) -> Graph a b -> Graph a b
// undirBy = gmap (\(p,v,l,s)->let ps = nub (p++s) in (ps,v,l,ps))
// (c) 1999-2005 by Martin Erwig [see file COPYRIGHT]
// | Static and Dynamic Inductive Graphs
definition module Data.Graph.Inductive.Graph
from Data.Maybe import :: Maybe
from StdOverloaded import class <
from StdClass import class Eq
from GenLexOrd import generic gLexOrd, :: LexOrd
// | Unlabeled node
:: Node :== Int
// | Labeled node
:: LNode a :== (Node,a)
// | Quasi-unlabeled node
:: UNode :== LNode ()
// | Unlabeled edge
:: Edge :== (Node,Node)
// | Labeled edge
:: LEdge b :== (Node,Node,b)
// | Quasi-unlabeled edge
:: UEdge :== LEdge ()
// | Unlabeled path
:: Path :== [Node]
// | Labeled path
:: LPath a = LP [LNode a]
unLPath :: (LPath a) -> [LNode a]
//instance toString (LPath a) | toString a
instance == (LPath a) | == a
instance < (LPath a) | gLexOrd{|*|} a
// TODO gLexOrd?
//instance (Ord a) => Ord (LPath a) where
//compare (LP []) (LP []) = EQ
//compare (LP ((_,x):_)) (LP ((_,y):_)) = compare x y
//compare _ _ = abort "LPath: cannot compare two empty paths"
// | Quasi-unlabeled path
:: UPath :== [UNode]
// | Labeled links to or from a 'Node'.
:: Adj b :== [(b,Node)]
// | Links to the 'Node', the 'Node' itself, a label, links from the 'Node'.
:: Context a b :== (Adj b,Node,a,Adj b) // Context a b "=" Context' a b "+" Node
:: MContext a b :== Maybe (Context a b)
// | 'Graph' decomposition - the context removed from a 'Graph', and the rest
// of the 'Graph'.
:: Decomp g a b :== (MContext a b,g a b)
// | The same as 'Decomp', only more sure of itself.
:: GDecomp g a b :== (Context a b,g a b)
// | Unlabeled context.
:: UContext :== ([Node],Node,[Node])
// | Unlabeled decomposition.
:: UDecomp g :== (Maybe UContext,g)
// | Minimum implementation: 'empty', 'isEmptyGraph', 'match', 'mkGraph', 'labNodes'
class Graph gr where
// | An empty 'Graph'.
emptyGraph :: gr a b
// | True if the given 'Graph' is empty.
isEmptyGraph :: (gr a b) -> Bool
// | Decompose a 'Graph' into the 'MContext' found for the given node and the
// remaining 'Graph'.
match :: Node (gr a b) -> Decomp gr a b
// | Create a 'Graph' from the list of 'LNode's and 'LEdge's.
//
// For graphs that are also instances of 'DynGraph', @mkGraph ns
// es@ should be equivalent to @('insEdges' es . 'insNodes' ns)
// 'empty'@.
mkGraph :: [LNode a] [LEdge b] -> gr a b
// | A list of all 'LNode's in the 'Graph'.
labNodes :: (gr a b) -> [LNode a]
// | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node'
// and the remaining 'Graph'.
matchAny :: (gr a b) -> GDecomp gr a b
// | The number of 'Node's in a 'Graph'.
noNodes :: (gr a b) -> Int
// | The minimum and maximum 'Node' in a 'Graph'.
nodeRange :: (gr a b) -> (Node,Node)
// | A list of all 'LEdge's in the 'Graph'.
labEdges :: (gr a b) -> [LEdge b]
class DynGraph gr | Graph gr where
// | Merge the 'Context' into the 'DynGraph'.
//
// Contexts should only refer to either a Node already in a graph
// or the node in the Context itself (for loops).
(<&>) :: (Context a b) (gr a b) -> gr a b
// | The number of nodes in the graph. An alias for 'noNodes'.
order :: (gr a b) -> Int | Graph gr
// | The number of edges in the graph.
//
// Note that this counts every edge found, so if you are
// representing an unordered graph by having each edge mirrored this
// will be incorrect.
//
// If you created an unordered graph by either mirroring every edge
// (including loops!) or using the @undir@ function in
// "Data.Graph.Inductive.Basic" then you can safely halve the value
// returned by this.
size :: (gr a b) -> Int | Graph gr
// | Fold a function over the graph.
ufold :: ((Context a b) c -> c) c (gr a b) -> c | Graph gr
// | Map a function over the graph.
gmap :: ((Context a b) -> Context c d) (gr a b) -> gr c d | DynGraph gr
// | Map a function over the 'Node' labels in a graph.
nmap :: (a -> c) (gr a b) -> gr c b | DynGraph gr
// | Map a function over the 'Edge' labels in a graph.
emap :: (b -> c) (gr a b) -> gr a c | DynGraph gr
// | Map functions over both the 'Node' and 'Edge' labels in a graph.
nemap :: (a -> c) (b -> d) (gr a b) -> gr c d | DynGraph gr
// | List all 'Node's in the 'Graph'.
nodes :: (gr a b) -> [Node] | Graph gr
// | List all 'Edge's in the 'Graph'.
edges :: (gr a b) -> [Edge] | Graph gr
// | Drop the label component of an edge.
toEdge :: (LEdge b) -> Edge
// | Add a label to an edge.
toLEdge :: Edge b -> LEdge b
// | The label in an edge.
edgeLabel :: (LEdge b) -> b
// | List N available 'Node's, i.e. 'Node's that are not used in the 'Graph'.
newNodes :: Int (gr a b) -> [Node] | Graph gr
// | 'True' if the 'Node' is present in the 'Graph'.
gelem :: Node (gr a b) -> Bool | Graph gr
// | Insert a 'LNode' into the 'Graph'.
insNode :: (LNode a) (gr a b) -> gr a b | DynGraph gr
// | Insert a 'LEdge' into the 'Graph'.
insEdge :: (LEdge b) (gr a b) -> gr a b | DynGraph gr
// | Remove a 'Node' from the 'Graph'.
delNode :: Node (gr a b) -> gr a b | Graph gr
// | Remove an 'Edge' from the 'Graph'.
//
// NOTE: in the case of multiple edges, this will delete /all/ such
// edges from the graph as there is no way to distinguish between
// them. If you need to delete only a single such edge, please use
// 'delLEdge'.
delEdge :: Edge (gr a b) -> gr a b | DynGraph gr
// | Remove an 'LEdge' from the 'Graph'.
//
// NOTE: in the case of multiple edges with the same label, this
// will only delete the /first/ such edge. To delete all such
// edges, please use 'delAllLedge'.
delLEdge :: (LEdge b) (gr a b) -> gr a b | DynGraph gr & Eq b
// | Remove all edges equal to the one specified.
delAllLEdge :: (LEdge b) (gr a b) -> gr a b | DynGraph gr & Eq b
delLEdgeBy :: ((b,Node) (Adj b) -> Adj b) (LEdge b) (gr a b) -> gr a b | DynGraph gr
// | Insert multiple 'LNode's into the 'Graph'.
insNodes :: [LNode a] (gr a b) -> gr a b | DynGraph gr
// | Insert multiple 'LEdge's into the 'Graph'.
insEdges :: [LEdge b] (gr a b) -> gr a b | DynGraph gr
// | Remove multiple 'Node's from the 'Graph'.
delNodes :: [Node] (gr a b) -> gr a b | Graph gr
// | Remove multiple 'Edge's from the 'Graph'.
delEdges :: [Edge] (gr a b) -> gr a b | DynGraph gr
// | Build a 'Graph' from a list of 'Context's.
//
// The list should be in the order such that earlier 'Context's
// depend upon later ones (i.e. as produced by @'ufold' (:) []@).
buildGr :: [Context a b] -> gr a b | DynGraph gr
// | Build a quasi-unlabeled 'Graph'.
mkUGraph :: [Node] [Edge] -> gr () () | Graph gr
// | Build a graph out of the contexts for which the predicate is
// true.
gfiltermap :: ((Context a b) -> MContext c d) (gr a b) -> gr c d | DynGraph gr
// | Returns the subgraph only containing the labelled nodes which
// satisfy the given predicate.
labnfilter :: ((LNode a) -> Bool) (gr a b) -> gr a b | Graph gr
// | Returns the subgraph only containing the nodes which satisfy the
// given predicate.
nfilter :: (Node -> Bool) (gr a b) -> gr a b | DynGraph gr
// | Returns the subgraph only containing the nodes whose labels
// satisfy the given predicate.
labfilter :: (a -> Bool) (gr a b) -> gr a b | DynGraph gr
// | Returns the subgraph induced by the supplied nodes.
subgraph :: [Node] (gr a b) -> gr a b | DynGraph gr
// | Find the context for the given 'Node'. Causes an error if the 'Node' is
// not present in the 'Graph'.
context :: (gr a b) Node -> Context a b | Graph gr
// | Find the label for a 'Node'.
lab :: (gr a b) Node -> Maybe a | Graph gr
// | Find the neighbors for a 'Node'.
neighbors :: (gr a b) Node -> [Node] | Graph gr
// | Find the labelled links coming into or going from a 'Context'.
lneighbors :: (gr a b) Node -> Adj b | Graph gr
// | Find all 'Node's that have a link from the given 'Node'.
suc :: (gr a b) Node -> [Node] | Graph gr
// | Find all 'Node's that link to to the given 'Node'.
pre :: (gr a b) Node -> [Node] | Graph gr
// | Find all 'Node's that are linked from the given 'Node' and the label of
// each link.
lsuc :: (gr a b) Node -> [(Node,b)] | Graph gr
// | Find all 'Node's that link to the given 'Node' and the label of each link.
lpre :: (gr a b) Node -> [(Node,b)] | Graph gr
// | Find all outward-bound 'LEdge's for the given 'Node'.
out :: (gr a b) Node -> [LEdge b] | Graph gr
// | Find all inward-bound 'LEdge's for the given 'Node'.
inn :: (gr a b) Node -> [LEdge b] | Graph gr
// | The outward-bound degree of the 'Node'.
outdeg :: (gr a b) Node -> Int | Graph gr
// | The inward-bound degree of the 'Node'.
indeg :: (gr a b) Node -> Int | Graph gr
// | The degree of the 'Node'.
deg :: (gr a b) Node -> Int | Graph gr
// | The 'Node' in a 'Context'.
node` :: (Context a b) -> Node
// | The label in a 'Context'.
lab` :: (Context a b) -> a
// | The 'LNode' from a 'Context'.
labNode` :: (Context a b) -> LNode a
// | All 'Node's linked to or from in a 'Context'.
neighbors` :: (Context a b) -> [Node]
// | All labelled links coming into or going from a 'Context'.
lneighbors` :: (Context a b) -> Adj b
// | All 'Node's linked to in a 'Context'.
suc` :: (Context a b) -> [Node]
// | All 'Node's linked from in a 'Context'.
pre` :: (Context a b) -> [Node]
// | All 'Node's linked from in a 'Context', and the label of the links.
lsuc` :: (Context a b) -> [(Node,b)]
// | All 'Node's linked from in a 'Context', and the label of the links.
lpre` :: (Context a b) -> [(Node,b)]
// | All outward-directed 'LEdge's in a 'Context'.
out` :: (Context a b) -> [LEdge b]
// | All inward-directed 'LEdge's in a 'Context'.
inn` :: (Context a b) -> [LEdge b]
// | The outward degree of a 'Context'.
outdeg` :: (Context a b) -> Int
// | The inward degree of a 'Context'.
indeg` :: (Context a b) -> Int
// | The degree of a 'Context'.
deg` :: (Context a b) -> Int
// | Checks if there is a directed edge between two nodes.
hasEdge :: (gr a b) Edge -> Bool | Graph gr
// | Checks if there is an undirected edge between two nodes.
hasNeighbor :: (gr a b) Node Node -> Bool | Graph gr
// | Checks if there is a labelled edge between two nodes.
hasLEdge :: (gr a b) (LEdge b) -> Bool | Graph gr & Eq b
// | Checks if there is an undirected labelled edge between two nodes.
hasNeighborAdj :: (gr a b) Node (b,Node) -> Bool | Graph gr & Eq b
//--------------------------------------------------------------------
// GRAPH EQUALITY
//--------------------------------------------------------------------
//slabNodes :: (gr a b) -> [LNode a] | Graph gr
//glabEdges :: (gr a b) -> [GroupEdges b] | Graph gr
//equal :: (gr a b) (gr a b) -> Bool | Graph gr & == a & == b
// This assumes that nodes aren't repeated (which shouldn't happen for
// sane graph instances). If node IDs are repeated, then the usage of
// slabNodes cannot guarantee stable ordering.
// Newtype wrapper just to test for equality of multiple edges. This
// is needed because without an Ord constraint on `b' it is not
// possible to guarantee a stable ordering on edge labels.
:: GroupEdges b = GEs (LEdge [b])
instance == (GroupEdges b) | Eq b
eqLists :: [a] [a] -> Bool | Eq a
//--------------------------------------------------------------------
// UTILITIES
//--------------------------------------------------------------------
// auxiliary functions used in the implementation of the
// derived class members
//
(.:) :: (c -> d) (a -> b -> c) a b -> d
flip2 :: (a,b) -> (b,a)
// projecting on context elements
//
context1l :: (gr a b) Node -> Adj b | Graph gr
context4l :: (gr a b) Node -> Adj b | Graph gr
mcontext :: (gr a b) Node -> MContext a b | Graph gr
context1l` :: (Context a b) -> Adj b
context4l` :: (Context a b) -> Adj b
//--------------------------------------------------------------------
// PRETTY PRINTING
//--------------------------------------------------------------------
// | Pretty-print the graph. Note that this loses a lot of
// information, such as edge inverses, etc.
//prettify :: (gr a b) -> String | DynGraph gr & Show a & Show b
prettify :: (gr a b) -> String | DynGraph gr & toString a & toString b
//--------------------------------------------------------------------
// Ordered Graph
//--------------------------------------------------------------------
// | OrdGr comes equipped with an Ord instance, so that graphs can be
// used as e.g. Map keys.
:: OrdGr gr a b = OrdGr (gr a b)
unOrdGr :: (OrdGr gr a b) -> gr a b
// TODO
//instance (Graph gr, Ord a, Ord b) => == (OrdGr gr a b) where
//g1 == g2 = compare g1 g2 == EQ
//instance (Graph gr, Ord a, Ord b) => Ord (OrdGr gr a b) where
//compare (OrdGr g1) (OrdGr g2) =
//(compare `on` sort . labNodes) g1 g2
//`mappend` (compare `on` sort . labEdges) g1 g2
defMatchAny :: (gr a b) -> GDecomp gr a b | Graph gr
// | The number of 'Node's in a 'Graph'.
defNoNodes :: (gr a b) -> Int | Graph gr
// | The minimum and maximum 'Node' in a 'Graph'.
defNodeRange :: (gr a b) -> (Node,Node) | Graph gr
// | A list of all 'LEdge's in the 'Graph'.
defLabEdges :: (gr a b) -> [LEdge b] | Graph gr
// (c) 1999-2005 by Martin Erwig [see file COPYRIGHT]
// | Static and Dynamic Inductive Graphs
implementation module Data.Graph.Inductive.Graph
import Control.Arrow
//import Data.Function (on)
import qualified Data.IntSet as IntSet
//import Data.List (delete, foldl, groupBy, sort, sortBy, (\\))
import qualified Data.List as DL
//import Data.Maybe (fromMaybe, isJust)
//import Data.Monoid (mappend)
import StdBool, StdTuple, StdFunc, StdMisc, StdEnum, StdString, StdOverloaded, StdClass
import Data.List
import Data.Maybe
import Data.Functor
import GenLexOrd
unLPath :: (LPath a) -> [LNode a]
unLPath (LP xs) = xs
//TODO
//instance toString (LPath a) | toString a where
//toString (LP xs) = foldr (\x xs -> toString x +++ " " +++ xs) "" xs
instance == (LPath a) | == a where
== (LP []) (LP []) = True
== (LP [(_,x):_]) (LP [(_,y):_]) = x==y
== (LP _) (LP _) = False
instance < (LPath a) | gLexOrd{|*|} a where
< (LP [(_,x):_]) (LP [(_,y):_]) = case x =?= y of
LT -> True
_ -> False
< _ _ = False
// | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node'
// and the remaining 'Graph'.
defMatchAny :: (gr a b) -> GDecomp gr a b | Graph gr
defMatchAny g = case labNodes g of
[] -> abort "Match Exception, Empty Graph"
[(v,_):_] -> (c,g`)
where
(Just c,g`) = match v g
// | The number of 'Node's in a 'Graph'.
defNoNodes :: (gr a b) -> Int | Graph gr
defNoNodes g = length (labNodes g)
// | The minimum and maximum 'Node' in a 'Graph'.
defNodeRange :: (gr a b) -> (Node,Node) | Graph gr
defNodeRange g
| isEmptyGraph g = abort "nodeRange of empty graph"
| otherwise = (minimum vs, maximum vs)
where
vs = nodes g
// | A list of all 'LEdge's in the 'Graph'.
defLabEdges :: (gr a b) -> [LEdge b] | Graph gr
defLabEdges g = ufold (\(_,v,_,s) xs -> map (\(l,w)->(v,w,l)) s ++ xs) [] g
// | The number of nodes in the graph. An alias for 'noNodes'.
order :: (gr a b) -> Int | Graph gr
order g = noNodes g
// | The number of edges in the graph.
//
// Note that this counts every edge found, so if you are
// representing an unordered graph by having each edge mirrored this
// will be incorrect.
//
// If you created an unordered graph by either mirroring every edge
// (including loops!) or using the @undir@ function in
// "Data.Graph.Inductive.Basic" then you can safely halve the value
// returned by this.
size :: (gr a b) -> Int | Graph gr
size g = length (labEdges g)
// | Fold a function over the graph.
ufold :: ((Context a b) c -> c) c (gr a b) -> c | Graph gr
ufold f u g
| isEmptyGraph g = u
| otherwise = f c (ufold f u g`)
where
(c,g`) = matchAny g
// | Map a function over the graph.
gmap :: ((Context a b) -> Context c d) (gr a b) -> gr c d | DynGraph gr
gmap f g = ufold (\c x -> f c <&> x) emptyGraph g
// | Map a function over the 'Node' labels in a graph.
nmap :: (a -> c) (gr a b) -> gr c b | DynGraph gr
nmap f g = gmap (\(p,v,l,s)->(p,v,f l,s)) g
// | Map a function over the 'Edge' labels in a graph.
emap :: (b -> c) (gr a b) -> gr a c | DynGraph gr
emap f g = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s)) g
where
map1 g = map (first g)
// | Map functions over both the 'Node' and 'Edge' labels in a graph.
nemap :: (a -> c) (b -> d) (gr a b) -> gr c d | DynGraph gr
nemap fn fe g = gmap (\(p,v,l,s) -> (fe` p,v,fn l,fe` s)) g
where
fe` = map (first fe)
// | List all 'Node's in the 'Graph'.
nodes :: (gr