{-# 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
  { Fingerprint -> [(Int, Int)]
degreeSequence :: [(Int, Int)]
  } deriving (Fingerprint -> Fingerprint -> Bool
(Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool) -> Eq Fingerprint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Fingerprint -> Fingerprint -> Bool
== :: Fingerprint -> Fingerprint -> Bool
$c/= :: Fingerprint -> Fingerprint -> Bool
/= :: Fingerprint -> Fingerprint -> Bool
Eq, Eq Fingerprint
Eq Fingerprint =>
(Fingerprint -> Fingerprint -> Ordering)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Fingerprint)
-> (Fingerprint -> Fingerprint -> Fingerprint)
-> Ord Fingerprint
Fingerprint -> Fingerprint -> Bool
Fingerprint -> Fingerprint -> Ordering
Fingerprint -> Fingerprint -> Fingerprint
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Fingerprint -> Fingerprint -> Ordering
compare :: Fingerprint -> Fingerprint -> Ordering
$c< :: Fingerprint -> Fingerprint -> Bool
< :: Fingerprint -> Fingerprint -> Bool
$c<= :: Fingerprint -> Fingerprint -> Bool
<= :: Fingerprint -> Fingerprint -> Bool
$c> :: Fingerprint -> Fingerprint -> Bool
> :: Fingerprint -> Fingerprint -> Bool
$c>= :: Fingerprint -> Fingerprint -> Bool
>= :: Fingerprint -> Fingerprint -> Bool
$cmax :: Fingerprint -> Fingerprint -> Fingerprint
max :: Fingerprint -> Fingerprint -> Fingerprint
$cmin :: Fingerprint -> Fingerprint -> Fingerprint
min :: Fingerprint -> Fingerprint -> Fingerprint
Ord)

enumerateParallel :: (t2 a -> t -> [t2 a])
-> [t2 a] -> [t] -> IO (IO (Maybe (t2 a, Bool)))
enumerateParallel t2 a -> t -> [t2 a]
fGrow [t2 a]
dStart [t]
vs = do
  MVar (Maybe (t2 a, [t]))
newDigraph     <- IO (MVar (Maybe (t2 a, [t])))
forall a. IO (MVar a)
newEmptyMVar
  MVar Int
digraphCount   <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar (Int -> IO (MVar Int)) -> Int -> IO (MVar Int)
forall a b. (a -> b) -> a -> b
$ [t2 a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [t2 a]
dStart
  MVar Integer
candidateCount <- Integer -> IO (MVar Integer)
forall a. a -> IO (MVar a)
newMVar Integer
0
  MVar Any
mCandidate     <- IO (MVar Any)
forall a. IO (MVar a)
newEmptyMVar
  MVar (Map Fingerprint (Int, [t2 a]))
mDistinctDigraphs <- Map Fingerprint (Int, [t2 a])
-> IO (MVar (Map Fingerprint (Int, [t2 a])))
forall a. a -> IO (MVar a)
newMVar (Map Fingerprint (Int, [t2 a])
 -> IO (MVar (Map Fingerprint (Int, [t2 a]))))
-> Map Fingerprint (Int, [t2 a])
-> IO (MVar (Map Fingerprint (Int, [t2 a])))
forall a b. (a -> b) -> a -> b
$ ((Fingerprint, t2 a)
 -> Map Fingerprint (Int, [t2 a]) -> Map Fingerprint (Int, [t2 a]))
-> Map Fingerprint (Int, [t2 a])
-> [(Fingerprint, t2 a)]
-> Map Fingerprint (Int, [t2 a])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 
    (\(Fingerprint
dFingerprint, t2 a
d) Map Fingerprint (Int, [t2 a])
m -> ((Int, [t2 a]) -> (Int, [t2 a]) -> (Int, [t2 a]))
-> Fingerprint
-> (Int, [t2 a])
-> Map Fingerprint (Int, [t2 a])
-> Map Fingerprint (Int, [t2 a])
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (\(Int
n0, [t2 a]
ds0) (Int
n1, [t2 a]
ds1) -> (Int
n0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n1, [t2 a]
ds0 [t2 a] -> [t2 a] -> [t2 a]
forall a. [a] -> [a] -> [a]
++ [t2 a]
ds1))
                                          Fingerprint
dFingerprint (Int
1, [t2 a
d]) Map Fingerprint (Int, [t2 a])
m)
    Map Fingerprint (Int, [t2 a])
forall k a. Map k a
M.empty ([(Fingerprint, t2 a)] -> Map Fingerprint (Int, [t2 a]))
-> [(Fingerprint, t2 a)] -> Map Fingerprint (Int, [t2 a])
forall a b. (a -> b) -> a -> b
$
    (t2 a -> (Fingerprint, t2 a)) -> [t2 a] -> [(Fingerprint, t2 a)]
forall a b. (a -> b) -> [a] -> [b]
map (\t2 a
d -> (t2 a -> Fingerprint
forall {t :: * -> *} {a}.
(Adjacency t, DirectedGraph t) =>
t a -> Fingerprint
fingerprint t2 a
d, t2 a
d))
        [t2 a]
dStart
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (t2 a -> IO ()) -> [t2 a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\t2 a
d -> String -> IO () -> IO ()
forall a. String -> IO a -> IO a
hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar newDigraph $ Just (d, vs)) dStart
  let insertDigraph :: t2 a -> IO Bool
insertDigraph t2 a
d = do
                        Map Fingerprint (Int, [t2 a])
distinct <- MVar (Map Fingerprint (Int, [t2 a]))
-> IO (Map Fingerprint (Int, [t2 a]))
forall a. MVar a -> IO a
readMVar MVar (Map Fingerprint (Int, [t2 a]))
mDistinctDigraphs
                        let dFingerprint :: Fingerprint
dFingerprint = t2 a -> Fingerprint
forall {t :: * -> *} {a}.
(Adjacency t, DirectedGraph t) =>
t a -> Fingerprint
fingerprint t2 a
d
                            mCandidates :: Maybe (Int, [t2 a])
mCandidates = Fingerprint -> Map Fingerprint (Int, [t2 a]) -> Maybe (Int, [t2 a])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Fingerprint
dFingerprint Map Fingerprint (Int, [t2 a])
distinct
                        case Maybe (Int, [t2 a])
mCandidates of
                             Just (Int
n, [t2 a]
candidates) ->
                               if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (t2 a -> Bool) -> [t2 a] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool
not (Bool -> Bool) -> (t2 a -> Bool) -> t2 a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t2 a -> t2 a -> Bool
forall {t1 :: * -> *} {t2 :: * -> *} {a} {k}.
(Adjacency t1, Adjacency t2, DirectedGraph t2, DirectedGraph t1,
 Ord k, Ord a) =>
t1 k -> t2 a -> Bool
D.isIsomorphicToI t2 a
d)) [t2 a]
candidates then do
                                  MVar (Map Fingerprint (Int, [t2 a]))
-> (Map Fingerprint (Int, [t2 a])
    -> IO (Map Fingerprint (Int, [t2 a])))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map Fingerprint (Int, [t2 a]))
mDistinctDigraphs ((Map Fingerprint (Int, [t2 a])
  -> IO (Map Fingerprint (Int, [t2 a])))
 -> IO ())
-> (Map Fingerprint (Int, [t2 a])
    -> IO (Map Fingerprint (Int, [t2 a])))
-> IO ()
forall a b. (a -> b) -> a -> b
$ t2 a
-> Fingerprint
-> Int
-> [t2 a]
-> Map Fingerprint (Int, [t2 a])
-> IO (Map Fingerprint (Int, [t2 a]))
forall {t2 :: * -> *} {k} {a} {m :: * -> *}.
(Adjacency t2, DirectedGraph t2, Ord k, Ord a, Monad m) =>
t2 a
-> k
-> Int
-> [t2 a]
-> Map k (Int, [t2 a])
-> m (Map k (Int, [t2 a]))
insertNewDigraph t2 a
d Fingerprint
dFingerprint Int
n [t2 a]
candidates 
                                  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                               else
                                  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                             Maybe (Int, [t2 a])
Nothing -> do
                               MVar (Map Fingerprint (Int, [t2 a]))
-> (Map Fingerprint (Int, [t2 a])
    -> IO (Map Fingerprint (Int, [t2 a])))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map Fingerprint (Int, [t2 a]))
mDistinctDigraphs ((Map Fingerprint (Int, [t2 a])
  -> IO (Map Fingerprint (Int, [t2 a])))
 -> IO ())
-> (Map Fingerprint (Int, [t2 a])
    -> IO (Map Fingerprint (Int, [t2 a])))
-> IO ()
forall a b. (a -> b) -> a -> b
$ t2 a
-> Fingerprint
-> Int
-> [t2 a]
-> Map Fingerprint (Int, [t2 a])
-> IO (Map Fingerprint (Int, [t2 a]))
forall {t2 :: * -> *} {k} {a} {m :: * -> *}.
(Adjacency t2, DirectedGraph t2, Ord k, Ord a, Monad m) =>
t2 a
-> k
-> Int
-> [t2 a]
-> Map k (Int, [t2 a])
-> m (Map k (Int, [t2 a]))
insertNewDigraph t2 a
d Fingerprint
dFingerprint Int
0 [] 
                               Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  IO (Maybe (t2 a, Bool))
generateDigraph <- ((t2 a, Bool, [t]) -> IO ([(t2 a, Bool, [t])], [(t2 a, Bool)]))
-> [(t2 a, Bool, [t])] -> IO (IO (Maybe (t2 a, Bool)))
forall a b. (a -> IO ([a], [b])) -> [a] -> IO (IO (Maybe b))
processJobList
    (\(t2 a
d, Bool
gen0, [t]
vs') -> do
      Bool
isNew <- if Bool
gen0 then
                  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
               else
                  t2 a -> IO Bool
insertDigraph t2 a
d
      if Bool
isNew then
         case [t]
vs' of
           [] -> ([(t2 a, Bool, [t])], [(t2 a, Bool)])
-> IO ([(t2 a, Bool, [t])], [(t2 a, Bool)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( []
                        , if Bool
gen0 then [] else [(t2 a
d, Bool
True)])
           (t
v : [t]
vs'') -> do
             let ds :: [t2 a]
ds = t2 a -> t -> [t2 a]
fGrow t2 a
d t
v
             ([(t2 a, Bool, [t])], [(t2 a, Bool)])
-> IO ([(t2 a, Bool, [t])], [(t2 a, Bool)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((t2 a -> (t2 a, Bool, [t])) -> [t2 a] -> [(t2 a, Bool, [t])]
forall a b. (a -> b) -> [a] -> [b]
map (\t2 a
d' -> (t2 a
d', Bool
False, [t]
vs'')) [t2 a]
ds
                    , if Bool
gen0 then [] else [(t2 a
d, Bool
False)])
      else
         ([(t2 a, Bool, [t])], [(t2 a, Bool)])
-> IO ([(t2 a, Bool, [t])], [(t2 a, Bool)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
    )
    ((t2 a -> (t2 a, Bool, [t])) -> [t2 a] -> [(t2 a, Bool, [t])]
forall a b. (a -> b) -> [a] -> [b]
map (\t2 a
d -> (t2 a
d, Bool
True, [t]
vs)) [t2 a]
dStart)
  IO (Maybe (t2 a, Bool)) -> IO (IO (Maybe (t2 a, Bool)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IO (Maybe (t2 a, Bool))
generateDigraph

enumerateParallel' :: (t2 a -> t -> [t2 a]) -> [t2 a] -> [t] -> IO (IO (Maybe (t2 a)))
enumerateParallel' t2 a -> t -> [t2 a]
fGrow [t2 a]
dStart [t]
vs = do
  IO (Maybe (t2 a, Bool))
generate <- (t2 a -> t -> [t2 a])
-> [t2 a] -> [t] -> IO (IO (Maybe (t2 a, Bool)))
forall {t2 :: * -> *} {a} {t}.
(Adjacency t2, DirectedGraph t2, Ord a) =>
(t2 a -> t -> [t2 a])
-> [t2 a] -> [t] -> IO (IO (Maybe (t2 a, Bool)))
enumerateParallel t2 a -> t -> [t2 a]
fGrow [t2 a]
dStart [t]
vs
  IO (Maybe (t2 a)) -> IO (IO (Maybe (t2 a)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe (t2 a, Bool) -> Maybe (t2 a))
-> IO (Maybe (t2 a, Bool)) -> IO (Maybe (t2 a))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((t2 a, Bool) -> t2 a) -> Maybe (t2 a, Bool) -> Maybe (t2 a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t2 a, Bool) -> t2 a
forall a b. (a, b) -> a
fst) IO (Maybe (t2 a, Bool))
generate)

exhaust :: m (Maybe a) -> m [a]
exhaust m (Maybe a)
generator =
  let loop :: m [a]
loop = do
             Maybe a
g <- m (Maybe a)
generator
             case Maybe a
g of
               Just a
g' -> do
                 [a]
gs <- m [a]
loop
                 [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ a
g' a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
gs
               Maybe a
Nothing ->
                 [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  in m [a]
loop

random :: p -> p -> [a] -> p -> m a
random p
fChoices p
fCheck [a]
dStart p
vs = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. HasCallStack => [a] -> a
head [a]
dStart

insertNewDigraph :: t2 a
-> k
-> Int
-> [t2 a]
-> Map k (Int, [t2 a])
-> m (Map k (Int, [t2 a]))
insertNewDigraph t2 a
d
                 k
dFingerprint
                 Int
checkedCandidates
                 [t2 a]
candidates
                 Map k (Int, [t2 a])
knownDigraphs =
  do
  case k -> Map k (Int, [t2 a]) -> Maybe (Int, [t2 a])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
dFingerprint Map k (Int, [t2 a])
knownDigraphs of
       Just (Int
n', [t2 a]
candidates') -> do
        if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (t2 a -> Bool) -> [t2 a] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool
not (Bool -> Bool) -> (t2 a -> Bool) -> t2 a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t2 a -> t2 a -> Bool
forall {t1 :: * -> *} {t2 :: * -> *} {a} {k}.
(Adjacency t1, Adjacency t2, DirectedGraph t2, DirectedGraph t1,
 Ord k, Ord a) =>
t1 k -> t2 a -> Bool
isIsomorphicToI t2 a
d)) ([t2 a] -> [Bool]) -> [t2 a] -> [Bool]
forall a b. (a -> b) -> a -> b
$ Int -> [t2 a] -> [t2 a]
forall a. Int -> [a] -> [a]
take (Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
checkedCandidates) [t2 a]
candidates' then
           Int -> [t2 a] -> m (Map k (Int, [t2 a]))
addToDatabase Int
n' [t2 a]
candidates'
        else
           Map k (Int, [t2 a]) -> m (Map k (Int, [t2 a]))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Map k (Int, [t2 a])
knownDigraphs
       Maybe (Int, [t2 a])
Nothing -> Int -> [t2 a] -> m (Map k (Int, [t2 a]))
addToDatabase Int
checkedCandidates [t2 a]
candidates
  where
    addToDatabase :: Int -> [t2 a] -> m (Map k (Int, [t2 a]))
addToDatabase Int
n' [t2 a]
candidates' = do
      Map k (Int, [t2 a]) -> m (Map k (Int, [t2 a]))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k (Int, [t2 a]) -> m (Map k (Int, [t2 a])))
-> Map k (Int, [t2 a]) -> m (Map k (Int, [t2 a]))
forall a b. (a -> b) -> a -> b
$ k -> (Int, [t2 a]) -> Map k (Int, [t2 a]) -> Map k (Int, [t2 a])
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
dFingerprint (Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, t2 a
d t2 a -> [t2 a] -> [t2 a]
forall a. a -> [a] -> [a]
: [t2 a]
candidates') Map k (Int, [t2 a])
knownDigraphs

fingerprint :: t a -> Fingerprint
fingerprint t a
d = 
  Fingerprint
  { degreeSequence :: [(Int, Int)]
degreeSequence = [(Int, Int)] -> [(Int, Int)]
forall a. Ord a => [a] -> [a]
sort ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ (a -> (Int, Int)) -> [a] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
v -> (t a -> a -> Int
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
D.indegree t a
d a
v, t a -> a -> Int
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
D.outdegree t a
d a
v)) ([a] -> [(Int, Int)]) -> [a] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
D.vertices t a
d
  }