Generator.hs

module HGraph.Undirected.Generator
       ( grid
       , cycleGraph
       , completeTree
       , completeGraph
       , randomGraph
       , randomTree
       )
where

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

cycleGraph g0 n = foldr addEdge (foldr addVertex g0 [0..n-1]) [(x, (x + 1) `mod` n) | x <- [0..n-1]]

grid g0 w h = foldr addEdge (foldr addVertex g0 vs) es
  where
    vs = [(x,y) | x <- [1..w], y <- [1..h]]
    es = concat [[(v,(x+1,y)), (v, (x,y+1))] | x <- [1..w-1], y <- [1..h-1], let v = (x,y)]
      ++ [((x, h), (x+1, h)) | x <- [1..w-1]]
      ++ [((w, y), (w, y+1)) | y <- [1..h-1]]

completeTree g0 depth arity = completeTree' (addVertex 0 (empty g0)) 0 1
  where
    completeTree' g root d
      | d > depth = g
      | otherwise = head $ drop arity $
                    iterate' (\h -> let r1 = numVertices h
                                   in addEdge (root,r1) (completeTree' (addVertex r1 h) r1 (d+1) ) ) g

completeGraph g0 k = foldr addEdge (foldr addVertex (empty g0) [0..k-1]) [(u,v) | u <- [0..k-1], v <- [u+1..k-1] ]

randomTree g0 n = do
  randomTree' (foldr addVertex (empty g0) [0..n-1]) (S.singleton 0) (S.fromList [1..n-1])
  where
    randomTree' g added missing
      | S.null missing = return g
      | otherwise = do
        v <- fmap (\i -> S.elemAt i missing) $ randomN 0 (S.size missing - 1)
        u <- fmap (\i -> S.elemAt i added) $ randomN 0 (S.size added - 1)
        randomTree' (addEdge (v,u) g) (S.insert v added) (S.delete v missing)

randomGraph g0 n m
  | m > (n * (n - 1)) `div` 4 = do -- dense graph
    let g1 = foldr addEdge (foldr addVertex (empty g0) [1..n]) [(v,u) | v <- [1..n], u <- [v+1..n]]
    removeRandomEdges g1 m
  | otherwise = do -- sparse graph
    let g1 = foldr addVertex (empty g0) [0..n-1]
    addRandomEdges g1 m

addRandomEdges g m
  | numEdges g == m = return g
  | otherwise = do
    v <- randomN 0 (numVertices g - 1)
    u <- randomN 0 (numVertices g - 1)
    if u /= v then
      addRandomEdges (addEdge (v,u) g) m
    else
      addRandomEdges g m

removeRandomEdges g m
  | numEdges g == m = return g
  | otherwise = do
    v <- randomN 0 (numVertices g - 1)
    u <- randomN 0 (numVertices g - 1)
    if u /= v && edgeExists g (v,u) then
      removeRandomEdges (removeEdge (v,u) g) m
    else
      removeRandomEdges g m