content: {-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables, TypeFamilies #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  {- |
     Module      : Data.Graph.Inductive.Arbitrary
     Description : Arbitrary definition for fgl graphs
     Copyright   : (c) Ivan Lazar Miljenovic
     License     : BSD3
     Maintainer  : Ivan.Miljenovic@gmail.com
  
  This module provides default definitions for use with QuickCheck's
  'Arbitrary' class.
  
  Both "Data.Graph.Inductive.Tree"- and
  "Data.Graph.Inductive.PatriciaTree"-based graph implementations have
  'Arbitrary' instances.  In most cases, this is all you will need.
  
  If, however, you want to create arbitrary custom graph-like data
  structures, then you will probably want to do some custom processing
  from an arbitrary 'GraphNodesEdges' value, either directly or with a
  custom 'ArbGraph' instance.
  
   -}
  module Data.Graph.Inductive.Arbitrary
         ( -- * Explicit graph creation
           -- $explicit
           arbitraryGraph
         , arbitraryGraphWith
         , shrinkGraph
         , shrinkGraphWith
           -- * Types of graphs
         , ArbGraph(..)
         , GrProxy(..)
         , shrinkF
         , arbitraryGraphBy
           -- ** Specific graph structures
         , NoMultipleEdges(..)
         , NoLoops(..)
         , SimpleGraph
         , Undirected(..)
           -- ** Connected graphs
         , Connected(..)
         , connGraph
           -- * Node and edge lists
         , arbitraryNodes
         , arbitraryEdges
         , GraphNodesEdges(..)
         ) where
  
  import           Data.Graph.Inductive.Graph        (DynGraph, Graph, LEdge,
                                                      LNode, Node, delNode,
                                                      insEdges, insNode, mkGraph,
                                                      newNodes, nodes, toEdge)
  import qualified Data.Graph.Inductive.PatriciaTree as P
  import qualified Data.Graph.Inductive.Tree         as T
  
  import Test.QuickCheck (Arbitrary (..), Gen, elements, listOf)
  
  import Control.Applicative (liftA3)
  import Control.Arrow       (second)
  import Data.Function       (on)
  import Data.List           (deleteBy, groupBy, sortBy)
  import Data.Maybe          (mapMaybe)
  
  #if __GLASGOW_HASKELL__ < 710
  import Control.Applicative ((<$>), (<*>))
  #endif
  
  -- -----------------------------------------------------------------------------
  
  -- | Generally a list of labelled nodes.
  arbitraryNodes :: (Arbitrary a) => Gen [LNode a]
  arbitraryNodes = arbitrary >>= mapM ((<$> arbitrary) . (,)) . uniq
  
  -- | Given a specified list of nodes, generate a list of edges.
  arbitraryEdges :: (Arbitrary b) => [LNode a] -> Gen [LEdge b]
  arbitraryEdges lns
    | null lns  = return []
    | otherwise = listOf (liftA3 (,,) nGen nGen arbitrary)
    where
      nGen = elements (map fst lns)
  
  -- | Defined so as to be able to generate valid 'arbitrary' node and
  --   edge lists.
  --
  --   If any specific structure (no multiple edges, no loops, etc.) is
  --   required then you will need to post-process this after generating
  --   it, or else create a new instance of 'ArbGraph'.
  data GraphNodesEdges a b = GNEs { graphNodes :: [LNode a]
                                  , graphEdges :: [LEdge b]
                                  }
    deriving (Eq, Ord, Show, Read)
  
  instance (Arbitrary a, Arbitrary b) => Arbitrary (GraphNodesEdges a b) where
    arbitrary = do ns <- arbitraryNodes
                   GNEs ns <$> arbitraryEdges ns
  
    shrink (GNEs ns es) = case ns of
                            _:_:_ -> map delN ns
                            _     -> []
      where
        delN ln@(n,_) = GNEs ns' es'
          where
            ns' = deleteBy ((==)`on`fst) ln ns
            es' = filter (not . hasN) es
  
            hasN (v,w,_) = v == n || w == n
  
  -- -----------------------------------------------------------------------------
  
  -- | Representation of generating arbitrary graph structures.
  --
  --   Typically, you would only use this for the 'toBaseGraph' function
  --   or if you wanted to make a custom graph wrapper.
  --
  --   The intent of this class is to simplify defining and using
  --   different wrappers on top of graphs (e.g. you may wish to have an
  --   'Undirected' graph, or one with 'NoLoops', or possibly both!).
  class (DynGraph (BaseGraph ag)) => ArbGraph ag where
    type BaseGraph ag :: * -> * -> *
  
    toBaseGraph :: ag a b -> BaseGraph ag a b
  
    fromBaseGraph :: BaseGraph ag a b -> ag a b
  
    -- | Any manipulation of edges that should be done to satisfy the
    --   requirements of the specified wrapper.
    edgeF :: GrProxy ag -> [LEdge b] -> [LEdge b]
  
    -- | Shrinking function (assuming only one node is removed at a
    --   time) which also returns the node that is removed.
    shrinkFWith :: ag a b -> [(Node, ag a b)]
  
  -- | In most cases, for an instance of 'ArbGraph' the 'Arbitrary'
  --   instance definition will\/can have @shrink = shrinkF@.
  shrinkF :: (ArbGraph ag) => ag a b -> [ag a b]
  shrinkF = map snd . shrinkFWith
  
  instance ArbGraph T.Gr where
    type BaseGraph T.Gr = T.Gr
  
    toBaseGraph = id
    fromBaseGraph = id
  
    edgeF _ = id
  
    shrinkFWith = shrinkGraphWith
  
  instance ArbGraph P.Gr where
    type BaseGraph P.Gr = P.Gr
  
    toBaseGraph = id
    fromBaseGraph = id
  
    edgeF _ = id
  
    shrinkFWith = shrinkGraphWith
  
  -- | A simple graph-specific proxy type.
  data GrProxy (gr :: * -> * -> *) = GrProxy
    deriving (Eq, Ord, Show, Read)
  
  -- -----------------------------------------------------------------------------
  
  {- $explicit
  
  If you wish to explicitly create a generated graph value (rather than
  using the 'Arbitrary' class) then you will want to use these
  functions.
  
  -}
  
  -- | Generate an arbitrary graph.  Multiple edges are allowed.
  arbitraryGraph :: (Graph gr, Arbitrary a, Arbitrary b) => Gen (gr a b)
  arbitraryGraph = arbitraryGraphWith id
  
  -- | Generate an arbitrary graph, using the specified function to
  --   manipulate the generated list of edges (e.g. remove multiple
  --   edges).
  arbitraryGraphWith :: (Graph gr, Arbitrary a, Arbitrary b)
                        => ([LEdge b] -> [LEdge b]) -> Gen (gr a b)
  arbitraryGraphWith f = do GNEs ns es <- arbitrary
                            let es' = f es
                            return (mkGraph ns es')
  
  -- | Generate an instance of 'ArbGraph' using the class methods.
  arbitraryGraphBy :: forall ag a b. (ArbGraph ag, Arbitrary a, Arbitrary b)
                      => Gen (ag a b)
  arbitraryGraphBy = fromBaseGraph
                     <$> arbitraryGraphWith (edgeF (GrProxy :: GrProxy ag))
  
  -- Ensure we have a list of unique Node values; this will also sort
  -- the list, but that shouldn't matter.
  uniq :: [Node] -> [Node]
  uniq = uniqBy id
  
  uniqBy :: (Ord b) => (a -> b) -> [a] -> [a]
  uniqBy f = map head . groupBy ((==) `on` f) . sortBy (compare `on` f)
  
  -- | For a graph with at least two nodes, return every possible way of
  --   deleting a single node (i.e. will never shrink to an empty
  --   graph).
  shrinkGraph :: (Graph gr) => gr a b -> [gr a b]
  shrinkGraph = map snd . shrinkGraphWith
  
  -- | As with 'shrinkGraph', but also return the node that was deleted.
  shrinkGraphWith :: (Graph gr) => gr a b -> [(Node, gr a b)]
  shrinkGraphWith gr = case nodes gr of
                         -- Need to have at least 2 nodes before we delete one!
                         ns@(_:_:_) -> map ((,) <*> (`delNode` gr)) ns
                         _          -> []
  
  instance (Arbitrary a, Arbitrary b) => Arbitrary (T.Gr a b) where
    arbitrary = arbitraryGraph
  
    shrink = shrinkGraph
  
  instance (Arbitrary a, Arbitrary b) => Arbitrary (P.Gr a b) where
    arbitrary = arbitraryGraph
  
    shrink = shrinkGraph
  
  -- | A newtype wrapper to generate a graph without multiple edges
  --   (loops allowed).
  newtype NoMultipleEdges gr a b = NME { nmeGraph :: gr a b }
                                   deriving (Eq, Show, Read)
  
  instance (ArbGraph gr) => ArbGraph (NoMultipleEdges gr) where
    type BaseGraph (NoMultipleEdges gr) = BaseGraph gr
  
    toBaseGraph = toBaseGraph. nmeGraph
    fromBaseGraph = NME . fromBaseGraph
  
    edgeF _ = uniqBy toEdge . edgeF (GrProxy :: GrProxy gr)
  
    shrinkFWith = map (second NME) . shrinkFWith . nmeGraph
  
  instance (ArbGraph gr, Arbitrary a, Arbitrary b) => Arbitrary (NoMultipleEdges gr a b) where
    arbitrary = arbitraryGraphBy
  
    shrink = shrinkF
  
  -- | A newtype wrapper to generate a graph without loops (multiple
  --   edges allowed).
  newtype NoLoops gr a b = NL { looplessGraph :: gr a b }
                           deriving (Eq, Show, Read)
  
  instance (ArbGraph gr) => ArbGraph (NoLoops gr) where
    type BaseGraph (NoLoops gr) = BaseGraph gr
  
    toBaseGraph = toBaseGraph . looplessGraph
    fromBaseGraph = NL . fromBaseGraph
  
    edgeF _ = filter notLoop . edgeF (GrProxy :: GrProxy gr)
  
    shrinkFWith = map (second NL) . shrinkFWith . looplessGraph
  
  notLoop :: LEdge b -> Bool
  notLoop (v,w,_) = v /= w
  
  instance (ArbGraph gr, Arbitrary a, Arbitrary b) => Arbitrary (NoLoops gr a b) where
    arbitrary = arbitraryGraphBy
  
    shrink = shrinkF
  
  -- | A wrapper to generate a graph without multiple edges and
  --   no loops.
  type SimpleGraph gr = NoLoops (NoMultipleEdges gr)
  
  -- | A newtype wrapper such that each (non-loop) edge also has its
  --   reverse in the graph.
  --
  --   Note that there is no way to guarantee this after any additional
  --   edges are added or removed.
  --
  --  You should also apply this wrapper /after/ 'NoMultipleEdges' or
  --  else the wrong reverse edge might be removed.
  newtype Undirected gr a b = UG { undirGraph :: gr a b }
                              deriving (Eq, Show, Read)
  
  instance (ArbGraph gr) => ArbGraph (Undirected gr) where
    type BaseGraph (Undirected gr) = BaseGraph gr
  
    toBaseGraph = toBaseGraph . undirGraph
    fromBaseGraph = UG . fromBaseGraph
  
    edgeF _ = undirect . edgeF (GrProxy :: GrProxy gr)
  
    shrinkFWith = map (second UG) . shrinkFWith . undirGraph
  
  undirect :: [LEdge b] -> [LEdge b]
  undirect = concatMap undir
    where
      undir le@(v,w,b)
        | notLoop le = [le, (w,v,b)]
        | otherwise  = [le]
  
  instance (ArbGraph gr, Arbitrary a, Arbitrary b) => Arbitrary (Undirected gr a b) where
    arbitrary = arbitraryGraphBy
  
    shrink = shrinkF
  
  -- -----------------------------------------------------------------------------
  
  -- | A brute-force approach to generating connected graphs.
  --
  --   The resultant graph (obtained with 'connGraph') will /never/ be
  --   empty: it will, at the very least, contain an additional
  --   connected node (obtained with 'connNode').
  --
  --   Note that this is /not/ an instance of 'ArbGraph' as it is not
  --   possible to arbitrarily layer a transformer on top of this.
  data Connected ag a b = CG { connNode     :: Node
                             , connArbGraph :: ag a b
                             }
                          deriving (Eq, Show, Read)
  
  instance (ArbGraph ag, Arbitrary a, Arbitrary b) => Arbitrary (Connected ag a b) where
    arbitrary = arbitraryGraphBy >>= toConnGraph
  
    shrink = shrinkConnGraph
  
  toConnGraph :: forall ag a b. (ArbGraph ag, Arbitrary a, Arbitrary b)
                 => ag a b -> Gen (Connected ag a b)
  toConnGraph ag = do a <- arbitrary
                      ces <- concat <$> mapM mkE ws
                      return $ CG { connNode     = v
                                  , connArbGraph = fromBaseGraph
                                                   . insEdges ces
                                                   . insNode (v,a)
                                                   $ g
                                  }
    where
      g = toBaseGraph ag
  
      [v] = newNodes 1 g
  
      ws = nodes g
  
      mkE w = do b <- arbitrary
                 return (edgeF p [(v,w,b)])
  
      p :: GrProxy ag
      p = GrProxy
  
  shrinkConnGraph :: (ArbGraph ag) => Connected ag a b -> [Connected ag a b]
  shrinkConnGraph cg = mapMaybe keepConn . shrinkFWith $ g
    where
      v = connNode cg
      g = connArbGraph cg
  
      keepConn (w,sgs) | v == w    = Nothing
                       | otherwise = Just (cg { connArbGraph = sgs })
  
  -- | The underlying graph represented by this 'Connected' value.
  connGraph :: (ArbGraph ag) => Connected ag a b -> BaseGraph ag a b
  connGraph = toBaseGraph . connArbGraph
  
  -- -----------------------------------------------------------------------------
  