Генерация всех уникальных направленных графов с 2 входами для каждого узла

Я пытаюсь сгенерировать все уникальные орграфы, соответствующие спецификации:

• каждый узел должен иметь ровно 2 входа
• и разрешается произвольно много выходов в другие узлы графа

Мое текущее решение медленное. Например, для 6 узлов algo потребовалось 1,5 дня, чтобы добраться туда, где я думаю, что он завершен, но он, вероятно, будет проверять еще несколько дней.

Мой алгоритм для графа с узлами n:

1. Генерировать все n-строки длины 0, где один символ - это 1, например, для n=3, [[0,0,1], [0,1,0], [1,0,0]]. Их можно рассматривать как строки из Матрицы идентичности.

2. Сгенерируйте все возможные матрицы n * n, где каждая строка - это все возможные комбинации step 1. + step 1.

Это матрица связности, где каждая ячейка представляет собой соединение от column-index до row-index

Итак, при n=3 возможны следующие варианты:

• [0,1,0] + [1,0,0] = [1,1,0]
• [1,0,0] + [1,0,0] = [2,0,0]

Эти представьте входные данные для узла, и, добавив Шаг 1 к самому себе, результат всегда будет представлять 2 входа.

Для примера:

     A B C     
A' [[0,1,1],
B'  [0,2,0],
C'  [1,1,0]]

Таким образом, B и C соединяются с A один раз каждый: B -> A', C -> A',

И B соединяется с собой дважды: B => B'

Мне нужны только уникальные, поэтому для каждой сгенерированной матрицы связности я могу сохранить ее только в том случае, если она не изоморфна уже видимому графу.

Этот шаг стоит дорого. Мне нужно преобразовать график в a "каноническая форма", пробегая через каждую перестановку изоморфных графов, сортируя их и рассматривая первый из них как"каноническую форму".

Если кто-нибудь нырнет в тестирование любого из них, вот количество уникальных графов для узлов n:

2 - 6
3 - 44
4 - 475
5 - 6874
6 - 109,934 (I think, it's not done running yet but I haven't found a new graph in >24 hrs.)
7 - I really wanna know! 

Возможные оптимизации:

1. Поскольку я получаю возможность генерировать графики для тестирования, есть ли способ исключить их без тестирования, как изоморфные уже виденным?

2. Есть ли здесь более быстрый алгоритм графа-изоморфизма? Я думаю, что это связано с" Nauty", и есть другие, о которых я читал в статьях, но у меня еще не было опыта (или пропускной способности), чтобы реализовать их.

Вот наглядная матрица связности, которую можно построить на graphonline.ru для развлечения, показывая собственные соединения и 2 соединения с одним и тем же узлом:

1, 0, 0, 0, 0, 1, 
1, 0, 0, 0, 1, 0, 
0, 1, 0, 1, 0, 0, 
0, 1, 2, 0, 0, 0, 
0, 0, 0, 1, 0, 1, 
0, 0, 0, 0, 1, 0,

Вот код в haskell, если вы хотите поиграть с ним, но меня больше беспокоит получение правильного алгоритма (например, сокращение пространства поиска), чем реализация:

-- | generate all permutations of length n given symbols from xs
npermutations :: [a] -> Int -> [[a]]
npermutations xs size = mapM (const xs) [1..size]

identity :: Int -> [[Int]]
identity size = scanl
                (xs _ -> take size $ 0 : xs)      -- keep shifting right
                (1 : (take (size - 1) (repeat 0))) -- initial, [1,0,0,...]
                [1 .. size-1]                      -- correct size

-- | return all possible pairings of [Column]
columnPairs :: [[a]] -> [([a], [a])]
columnPairs xs = (map (x y -> (x,y)) xs)
                 <*> xs

-- | remove duplicates
rmdups :: Ord a => [a] -> [a]
rmdups = rmdups' Set.empty where
  rmdups' _ [] = []
  rmdups' a (b : c) = if Set.member b a
    then rmdups' a c
    else b : rmdups' (Set.insert b a) c


-- | all possible patterns for inputting 2 things into one node.
-- eg [0,1,1] means cells B, and C project into some node
--    [0,2,0] means cell B projects twice into one node
binaryInputs :: Int -> [[Int]]
binaryInputs size = rmdups $ map -- rmdups because [1,0]+[0,1] is same as flipped
         ((x,y) -> zipWith (+) x y)
         (columnPairs $ identity size)

transposeAdjMat :: [[Int]] -> [[Int]]
transposeAdjMat ([]:_) = []
transposeAdjMat m = (map head m) : transposeAdjMat (map tail m)

-- | AdjMap [(name, inbounds)]
data AdjMap a = AdjMap [(a, [a])] deriving (Show, Eq)

addAdjColToMap :: Int -- index
               -> [Int] -- inbound
               -> AdjMap Int
               -> AdjMap Int
addAdjColToMap ix col (AdjMap xs) = 
  let conns = foldl (c (cnt, i) -> case cnt of
                        1 -> i:c
                        2 -> i:i:c
                        _ -> c
                    ) 
              [] 
              (zip col [0..])  in
    AdjMap ((ix, conns) : xs)

adjMatToMap :: [[Int]] -> AdjMap Int
adjMatToMap cols = foldl 
  (adjMap@(AdjMap nodes) col -> addAdjColToMap (length nodes) col adjMap)
  (AdjMap [])
  cols

-- | a graph's canonical form : http://mfukar.github.io/2015/09/30/haskellxiii.html
-- very expensive algo, of course
canon :: (Ord a, Enum a, Show a) => AdjMap a -> String
canon (AdjMap g) = minimum $ map f $ Data.List.permutations [1..(length g)]
   where
      -- Graph vertices:
      vs = map fst g
      -- Find, via brute force on all possible orderings (permutations) of vs,
      -- a mapping of vs to [1..(length g)] which is minimal.
      -- For example, map [1, 5, 6, 7] to [1, 2, 3, 4].
      -- Minimal is defined lexicographically, since `f` returns strings:
      f p = let n = zip vs p
            in (show [(snd x, sort id $ map (x -> snd $ head $ snd $ break ((==) x . fst) n)
                                      $ snd $ take_edge g x)
                     | x <- sort snd n])
      -- Sort elements of N in ascending order of (map f N):
      sort f n = foldr (x xs -> let (lt, gt) = break ((<) (f x) . f) xs
                                  in lt ++ [x] ++ gt) [] n
      -- Get the first entry from the adjacency list G that starts from the given node X
      -- (actually, the vertex is the first entry of the pair, hence `(fst x)`):
      take_edge g x = head $ dropWhile ((/=) (fst x) . fst) g

-- | all possible matrixes where each node has 2 inputs and arbitrary outs
binaryMatrixes :: Int -> [[[Int]]]
binaryMatrixes size = let columns = binaryInputs size 
                          unfiltered = mapM (const columns) [1..size] in
  fst $ foldl'
  ((keep, seen) x -> let can = canon . adjMatToMap $ x in
                        (if Set.member can seen 
                         then keep
                         else id $! x : keep
                        , Set.insert can seen))
  ([], Set.fromList [])
  unfiltered