scratch/Graph.hs

   1 module Graph where
   2
   3 import qualified Data.Set as S
   4 import qualified Data.Map as M
   5 import Data.Maybe
   6 import Control.Monad
   7 import Control.Monad.State
   8
   9 data G a = Node  a (G a) (G a)
  10          | Leaf  a
  11          | Nil deriving (Show)
  12
  13 type LoopCheck a = S.Set a
  14
  15
  16 {- Actually i am not sure about the cata and algebra definition.
  17  -
  18  -  ** check: http://dl.acm.org/citation.cfm?id=128035
  19  -}
  20
  21 -- Represents an acumulator
  22 type TreeAlgebra a r = (a -> r, r -> r -> r)
  23
  24 foldG :: TreeAlgebra a r -> r -> G a -> r
  25 foldG (f,g) s (Leaf val)     = g (f val) s
  26 foldG (f,g) s (Node val l r) = g (f val) $ g (foldG (f,g) s l) (foldG (f,g) s r)
  27
  28 printG = foldG ((: []), (++)) []
  29
  30 loopCheck :: (Ord k) => G a -> (G a -> k) -> State (LoopCheck k) Bool
  31 loopCheck g f = do state <- get
  32                    return $ S.member (f g) state
  33
  34 addNode :: (Ord k) => k -> State (LoopCheck k) ()
  35 addNode k = do s <- get
  36                put $ S.insert k s
  37                return ()
  38
  39 foldGM :: (Ord k) => TreeAlgebra a r -> (G a -> k) -> r -> G a -> State (LoopCheck k) r
  40 foldGM _     _ s    Nil           = return s
  41 foldGM (f,g) c s k@(Leaf val)     = loopCheck k c >>= \p -> if p then return s else return $ g (f val) s
  42 foldGM (f,g) c s k@(Node val l r) = loopCheck k c >>= \p -> if p then return s else continue
  43                                     where t        = foldGM (f,g) c s
  44                                           self     = g (f val)
  45                                           continue = do addNode $ c k
  46                                                         left  <- t l
  47                                                         right <- t r
  48                                                         return $ self $ g left right
  49
  50 -- Generates a node from a list of children.
  51 packNodes :: [G a] -> a -> G a
  52 packNodes (x:y:[]) e = Node e x y    -- full binary
  53 packNodes (x:[]  ) e = Node e x Nil  -- unary
  54 packNodes []       e = Leaf e        -- leaf
  55
  56 -- Generates a cyclic datastructure given edges and nodes
  57 -- TODO: remove lists with maps in inputs
  58 toG :: (Ord k,Show k) => ([r] -> a -> r) -> [(k,[k])] -> k -> [(k, a)] -> Maybe r
  59 toG g xs start pls = let nodeTable = M.fromList pls
  60                          payload s = case M.lookup s nodeTable of
  61                                        Just x  -> x
  62                                        Nothing -> error "edge with no corresponding node"
  63
  64                          conn = M.fromList $ map (
  65                                   \(f,ts) -> let pl t = node f (payload t) t
  66                                                  succ = map pl ts
  67                                             in (f, g succ (payload f))
  68                                  ) xs
  69
  70                          node f p t = case M.lookup t conn of
  71                                             (Just x) -> x
  72                                             Nothing
  73                                               -> error $ "illformed edge/node list in toG" ++ (show t)
  74                    in M.lookup start conn
  75
  76
  77
  78 testG = [(0,[1,2]),(1,[3]),(2,[0]),(3,[])]
  79 nodeLoads :: [(Int,String)]
  80 nodeLoads = [(0,"a"),(1,"b"),(2,"c"),(3,"d")]
  81
  82
  83