Internal.hs

{-# Language CPP #-}

module HGraph.Directed.Generator.Hereditary.Internal where

import HGraph.Directed as D
import HGraph.Parallel
import HGraph.Debugging

import Data.List
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Set as S
import System.IO (hPutStrLn, stderr)
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad

data Fingerprint = Fingerprint
  { degreeSequence :: [(Int, Int)]
  } deriving (Eq, Ord)

enumerateParallel fGrow dStart vs = do
  newDigraph     <- newEmptyMVar
  digraphCount   <- newMVar $ length dStart
  candidateCount <- newMVar 0
  mCandidate     <- newEmptyMVar
  mDistinctDigraphs <- newMVar $ foldr 
    (\(dFingerprint, d) m -> M.insertWith (\(n0, ds0) (n1, ds1) -> (n0 + n1, ds0 ++ ds1))
                                          dFingerprint (1, [d]) m)
    M.empty $
    map (\d -> (fingerprint d, d))
        dStart
  forkIO $ mapM_ (\d -> hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar newDigraph $ Just (d, vs)) dStart
  let insertDigraph d = do
                        distinct <- readMVar mDistinctDigraphs
                        let dFingerprint = fingerprint d
                            mCandidates = M.lookup dFingerprint distinct
                        case mCandidates of
                             Just (n, candidates) ->
                               if and $ map (not . (D.isIsomorphicToI d)) candidates then do
                                  modifyMVar_ mDistinctDigraphs $ insertNewDigraph d dFingerprint n candidates 
                                  return True
                               else
                                  return False
                             Nothing -> do
                               modifyMVar_ mDistinctDigraphs $ insertNewDigraph d dFingerprint 0 [] 
                               return True

  generateDigraph <- processJobList
    (\(d, gen0, vs') -> do
      isNew <- if gen0 then
                  return True
               else
                  insertDigraph d
      if isNew then
         case vs' of
           [] -> return ( []
                        , if gen0 then [] else [(d, True)])
           (v : vs'') -> do
             let ds = fGrow d v
             return (map (\d' -> (d', False, vs'')) ds
                    , if gen0 then [] else [(d, False)])
      else
         return ([], [])
    )
    (map (\d -> (d, True, vs)) dStart)
  return generateDigraph

enumerateParallel' fGrow dStart vs = do
  generate <- enumerateParallel fGrow dStart vs
  return (fmap (fmap fst) generate)

exhaust generator =
  let loop = do
             g <- generator
             case g of
               Just g' -> do
                 gs <- loop
                 return $ g' : gs
               Nothing ->
                 return []
  in loop

random fChoices fCheck dStart vs = return $ head dStart

insertNewDigraph d
                 dFingerprint
                 checkedCandidates
                 candidates
                 knownDigraphs =
  do
  case M.lookup dFingerprint knownDigraphs of
       Just (n', candidates') -> do
        if and $ map (not . (isIsomorphicToI d)) $ take (n' - checkedCandidates) candidates' then
           addToDatabase n' candidates'
        else
           return knownDigraphs
       Nothing -> addToDatabase checkedCandidates candidates
  where
    addToDatabase n' candidates' = do
      return $ M.insert dFingerprint (n' + 1, d : candidates') knownDigraphs

fingerprint d = 
  Fingerprint
  { degreeSequence = sort $ map (\v -> (D.indegree d v, D.outdegree d v)) $ D.vertices d
  }