Generator.hs

module HGraph.Directed.Generator
       ( bidirectedCycle
       , randomAcyclicDigraph
       , randomDigraph
       , oneWayGrid
       )
where

import Control.Monad.State
import Data.List
import HGraph.Directed
import HGraph.Utils
import qualified Data.Set as S
import qualified HGraph.Undirected.AdjacencyMap as U
import qualified HGraph.Undirected              as U
import qualified HGraph.Undirected.Generator    as U
import System.Random

-- | A cycle where vertices are connected in both directions
bidirectedCycle d0 n =
  foldr addArc (foldr addVertex d0 [0..n-1]) $ 
    (zip ((n-1) : [0..n-2]) (0 : [1..n-1]))
    ++ (zip (0:[n-1,n-2..1]) ((n-1):[n-2,n-3..0]))

-- |Generate a random weakly-connected acyclic digraph with `n` vertices and `m` + `n` - 1 arcs.
randomAcyclicDigraph d0 n m' = do
  utree <- U.randomTree U.emptyGraph n
  let m = max (n - 1) (min m' (n * (n - 1) `div` 2))
      dtree = acyclicOrientation d0 utree
  if (m + n - 1) > (n * (n - 1)) `div` 4 then do
    d' <- removeRandomArcs (foldr addArc (foldr addVertex (empty d0) $ vertices dtree)
                            [ (v,u)
                            | v <- vertices dtree
                            , u <- vertices dtree
                            , v < u && (not $ arcExists dtree (v,u))
                            ]
                     )
                     (m - n + 1)
    return $ foldr addArc d' $ arcs dtree
  else
    addRandomArcsAcyclic dtree m

-- An acyclic grid where columns only go down and rows only go left.
oneWayGrid d0 w h = 
      foldr addArc (foldr addVertex (empty d0) ([0..w * h - 1])) $
                      [ (v, v + 1)
                      | r <- [0..h-1]
                      , c <- [0..w-2]
                      , let v = r*w + c
                      ]
                      ++
                      [ (v, v + w)
                      | r <- [0..h-2]
                      , c <- [0..w-1]
                      , let v = r*w + c
                      ]

acyclicOrientation d0 g = foldr addArc (foldr addVertex (empty d0) $ U.vertices g) $
  [ if u < v then (u,v) else (v,u)
  | (u,v) <- U.edges g
  ]

randomDigraph g0 n m
  | m > (n * (n - 1)) = randomDigraph g0 n (n * (n - 1))
  | m > (n * (n - 1)) `div` 2 = do -- dense graph
    let g1 = foldr addArc (foldr addVertex (empty g0) [1..n]) [(v,u) | v <- [1..n], u <- [1..n], v /= u]
    removeRandomArcs g1 m
  | otherwise = do -- sparse graph
    let g1 = foldr addVertex (empty g0) [0..n-1]
    addRandomArcs g1 m

addRandomArcs g m
  | numArcs g == m = return g
  | otherwise = do
    v <- randomN 0 (numVertices g - 1)
    u <- randomN 0 (numVertices g - 1)
    if u /= v then
      addRandomArcs (addArc (v,u) g) m
    else
      addRandomArcs g m

addRandomArcsAcyclic g m
  | numArcs g == m = return g
  | otherwise = do
    v <- randomN 0 (numVertices g - 2)
    u <- randomN (v + 1) (numVertices g - 1)
    if v < u then
      addRandomArcsAcyclic (addArc (v,u) g) m
    else
      addRandomArcsAcyclic g m

removeRandomArcs g m
  | numArcs g == m = return g
  | otherwise = do
    v <- randomN 0 (numVertices g - 1)
    u <- randomN 0 (numVertices g - 1)
    if u /= v && arcExists g (v,u) then
      removeRandomArcs (removeArc (v,u) g) m
    else
      removeRandomArcs g m