cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs

   1 -- | Wrapper around Data.Graph with support for edge labels
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 module Distribution.Solver.Modular.LabeledGraph (
   4     -- * Graphs
   5     Graph
   6   , Vertex
   7     -- ** Building graphs
   8   , graphFromEdges
   9   , graphFromEdges'
  10   , buildG
  11   , transposeG
  12     -- ** Graph properties
  13   , vertices
  14   , edges
  15     -- ** Operations on the underlying unlabeled graph
  16   , forgetLabels
  17   , topSort
  18   ) where
  19
  20 import Distribution.Solver.Compat.Prelude
  21 import Prelude ()
  22
  23 import Data.Array
  24 import Data.Graph (Vertex, Bounds)
  25 import qualified Data.Graph as G
  26
  27 {-------------------------------------------------------------------------------
  28   Types
  29 -------------------------------------------------------------------------------}
  30
  31 type Graph e = Array Vertex [(e, Vertex)]
  32 type Edge  e = (Vertex, e, Vertex)
  33
  34 {-------------------------------------------------------------------------------
  35   Building graphs
  36 -------------------------------------------------------------------------------}
  37
  38 -- | Construct an edge-labeled graph
  39 --
  40 -- This is a simple adaptation of the definition in Data.Graph
  41 graphFromEdges :: forall key node edge. Ord key
  42                => [ (node, key, [(edge, key)]) ]
  43                -> ( Graph edge
  44                   , Vertex -> (node, key, [(edge, key)])
  45                   , key -> Maybe Vertex
  46                   )
  47 graphFromEdges edges0 =
  48     (graph, \v -> vertex_map ! v, key_vertex)
  49   where
  50     max_v        = length edges0 - 1
  51     bounds0      = (0, max_v) :: (Vertex, Vertex)
  52     sorted_edges = sortBy lt edges0
  53     edges1       = zip [0..] sorted_edges
  54
  55     graph        = array bounds0 [(v, (mapMaybe mk_edge ks))
  56                                  | (v, (_, _, ks)) <- edges1]
  57     key_map      = array bounds0 [(v, k                    )
  58                                  | (v, (_, k, _ )) <- edges1]
  59     vertex_map   = array bounds0 edges1
  60
  61     (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
  62
  63     mk_edge :: (edge, key) -> Maybe (edge, Vertex)
  64     mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v)
  65
  66     --  returns Nothing for non-interesting vertices
  67     key_vertex :: key -> Maybe Vertex
  68     key_vertex k = findVertex 0 max_v
  69       where
  70         findVertex a b
  71           | a > b     = Nothing
  72           | otherwise = case compare k (key_map ! mid) of
  73               LT -> findVertex a (mid-1)
  74               EQ -> Just mid
  75               GT -> findVertex (mid+1) b
  76           where
  77             mid = a + (b - a) `div` 2
  78
  79 graphFromEdges' :: Ord key
  80                 => [ (node, key, [(edge, key)]) ]
  81                 -> ( Graph edge
  82                    , Vertex -> (node, key, [(edge, key)])
  83                    )
  84 graphFromEdges' x = (a,b)
  85   where
  86     (a,b,_) = graphFromEdges x
  87
  88 transposeG :: Graph e -> Graph e
  89 transposeG g = buildG (bounds g) (reverseE g)
  90
  91 buildG :: Bounds -> [Edge e] -> Graph e
  92 buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)
  93   where
  94     reassoc (v, e, w) = (v, (e, w))
  95
  96 reverseE :: Graph e -> [Edge e]
  97 reverseE g = [ (w, e, v) | (v, e, w) <- edges g ]
  98
  99 {-------------------------------------------------------------------------------
 100   Graph properties
 101 -------------------------------------------------------------------------------}
 102
 103 vertices :: Graph e -> [Vertex]
 104 vertices = indices
 105
 106 edges :: Graph e -> [Edge e]
 107 edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ]
 108
 109 {-------------------------------------------------------------------------------
 110   Operations on the underlying unlabelled graph
 111 -------------------------------------------------------------------------------}
 112
 113 forgetLabels :: Graph e -> G.Graph
 114 forgetLabels = fmap (map snd)
 115
 116 topSort :: Graph e -> [Vertex]
 117 topSort = G.topSort . forgetLabels