-- All extensions should be enabled explicitly due to doctest in this module.
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{- |
The optimization consists of two parts:
1) Replacing logic functions with lookup tables
2) Searching and merging lookup tables, if possible

>>> let a = constant 1 ["a"]
>>> let b = constant 2 ["b"]
>>> let c = constant 3 ["c"]
>>> let f1 = logicAnd "a" "b" ["f1"]
>>> let f2 = logicOr "f1" "c" ["f2"]
>>> let loopRes = loop 1 "e" ["f2"]
>>> let fs = [a, b, c, f1, f2, loopRes] :: [F String Int]
>>> optimizeLogicalUnitDecision fs $ head $ optimizeLogicalUnitOptions fs
[const(1) = a,const(2) = b,const(3) = c,loop(1, e) = f2,TruthTable fromList [([False,False,False],False),([False,False,True],True),([False,True,False],False),([False,True,True],True),([True,False,False],False),([True,False,True],True),([True,True,False],True),([True,True,True],True)] [a,b,c] = f2]
-}
module NITTA.Model.Problems.Refactor.OptimizeLogicalUnit (
    OptimizeLogicalUnit (..),
    OptimizeLogicalUnitProblem (..),
)
where

import Control.Monad (replicateM)
import Data.Foldable (foldl')
import Data.List qualified as L
import Data.Map qualified as M
import Data.Maybe
import Data.Set qualified as S
import GHC.Generics
import NITTA.Intermediate.Functions
import NITTA.Intermediate.Types

data OptimizeLogicalUnit v x = OptimizeLogicalUnit
    { forall v x. OptimizeLogicalUnit v x -> [F v x]
rOld :: [F v x]
    , forall v x. OptimizeLogicalUnit v x -> [F v x]
rNew :: [F v x]
    }
    deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall v x x.
Rep (OptimizeLogicalUnit v x) x -> OptimizeLogicalUnit v x
forall v x x.
OptimizeLogicalUnit v x -> Rep (OptimizeLogicalUnit v x) x
$cto :: forall v x x.
Rep (OptimizeLogicalUnit v x) x -> OptimizeLogicalUnit v x
$cfrom :: forall v x x.
OptimizeLogicalUnit v x -> Rep (OptimizeLogicalUnit v x) x
Generic, Int -> OptimizeLogicalUnit v x -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall v x. Int -> OptimizeLogicalUnit v x -> ShowS
forall v x. [OptimizeLogicalUnit v x] -> ShowS
forall v x. OptimizeLogicalUnit v x -> String
showList :: [OptimizeLogicalUnit v x] -> ShowS
$cshowList :: forall v x. [OptimizeLogicalUnit v x] -> ShowS
show :: OptimizeLogicalUnit v x -> String
$cshow :: forall v x. OptimizeLogicalUnit v x -> String
showsPrec :: Int -> OptimizeLogicalUnit v x -> ShowS
$cshowsPrec :: forall v x. Int -> OptimizeLogicalUnit v x -> ShowS
Show, OptimizeLogicalUnit v x -> OptimizeLogicalUnit v x -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v x.
OptimizeLogicalUnit v x -> OptimizeLogicalUnit v x -> Bool
/= :: OptimizeLogicalUnit v x -> OptimizeLogicalUnit v x -> Bool
$c/= :: forall v x.
OptimizeLogicalUnit v x -> OptimizeLogicalUnit v x -> Bool
== :: OptimizeLogicalUnit v x -> OptimizeLogicalUnit v x -> Bool
$c== :: forall v x.
OptimizeLogicalUnit v x -> OptimizeLogicalUnit v x -> Bool
Eq)

class OptimizeLogicalUnitProblem u v x | u -> v x where
    optimizeLogicalUnitOptions :: u -> [OptimizeLogicalUnit v x]
    optimizeLogicalUnitOptions u
_ = []

    -- | Function takes 'OptimizeLogicalUnit' and modify 'DataFlowGraph'
    optimizeLogicalUnitDecision :: u -> OptimizeLogicalUnit v x -> u
    optimizeLogicalUnitDecision u
_ OptimizeLogicalUnit v x
_ = forall a. HasCallStack => String -> a
error String
"not implemented"

instance (Var v, Val x) => OptimizeLogicalUnitProblem [F v x] v x where
    optimizeLogicalUnitOptions :: [F v x] -> [OptimizeLogicalUnit v x]
optimizeLogicalUnitOptions [F v x]
fs =
        let supportedFunctions :: [F v x]
supportedFunctions = forall a. (a -> Bool) -> [a] -> [a]
filter forall {v} {x}. (Typeable v, Typeable x) => F v x -> Bool
isSupportedByLogicalUnit [F v x]
fs

            rNew :: [F v x]
rNew =
                if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [F v x]
supportedFunctions)
                    Bool -> Bool -> Bool
&& forall {v} {x}. (Typeable v, Typeable x) => [F v x] -> Bool
isOptimizationNeeded [F v x]
supportedFunctions
                    then forall {x} {a} {p}.
(Typeable a, IsString a, ToString a, Suffix a, Hashable a, Val x,
 Ord a) =>
[F a x] -> p -> [F a x]
optimizeCluster [F v x]
supportedFunctions [F v x]
fs
                    else []
            result :: [OptimizeLogicalUnit v x]
result =
                [ OptimizeLogicalUnit{rOld :: [F v x]
rOld = [F v x]
supportedFunctions, [F v x]
rNew :: [F v x]
rNew :: [F v x]
rNew}
                | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [F v x]
rNew) Bool -> Bool -> Bool
&& forall a. Ord a => [a] -> Set a
S.fromList [F v x]
supportedFunctions forall a. Eq a => a -> a -> Bool
/= forall a. Ord a => [a] -> Set a
S.fromList [F v x]
rNew
                ]
         in [OptimizeLogicalUnit v x]
result

    optimizeLogicalUnitDecision :: [F v x] -> OptimizeLogicalUnit v x -> [F v x]
optimizeLogicalUnitDecision [F v x]
fs OptimizeLogicalUnit{[F v x]
rOld :: [F v x]
rOld :: forall v x. OptimizeLogicalUnit v x -> [F v x]
rOld, [F v x]
rNew :: [F v x]
rNew :: forall v x. OptimizeLogicalUnit v x -> [F v x]
rNew} =
        forall {a} {a}. (Ord a, Variables a a, Eq a) => [a] -> [a]
deleteExtraLogicalUnits forall a b. (a -> b) -> a -> b
$ ([F v x]
fs forall a. Eq a => [a] -> [a] -> [a]
L.\\ [F v x]
rOld) forall a. Semigroup a => a -> a -> a
<> [F v x]
rNew

deleteExtraLogicalUnits :: [a] -> [a]
deleteExtraLogicalUnits [a]
fs =
    forall a. Eq a => [a] -> [a]
L.nub
        [ a
f1
        | a
f1 <- [a]
fs
        , a
f2 <- [a]
fs
        , a
f1 forall a. Eq a => a -> a -> Bool
/= a
f2
        , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
S.null (forall a v. Variables a v => a -> Set v
variables a
f1 forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` forall a v. Variables a v => a -> Set v
variables a
f2)
        ]

isOptimizationNeeded :: [F v x] -> Bool
isOptimizationNeeded [F v x]
fs = forall {v} {x}. (Typeable v, Typeable x) => [F v x] -> Int
countLogicalUnits [F v x]
fs forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| forall {t :: * -> *} {v} {x}.
(Foldable t, Typeable v, Typeable x) =>
t (F v x) -> Bool
hasLogicFunctions [F v x]
fs
    where
        hasLogicFunctions :: t (F v x) -> Bool
hasLogicFunctions t (F v x)
fns = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {v} {x}. (Typeable v, Typeable x) => F v x -> Bool
isSupportedByLogicalUnit t (F v x)
fns

        isLogicalUnit :: F v x -> Bool
isLogicalUnit F v x
f = case forall (f :: * -> * -> *) v x.
(Typeable f, Typeable v, Typeable x) =>
F v x -> Maybe (f v x)
castF F v x
f of
            Just (TruthTable{}) -> Bool
True
            Maybe (TruthTable v x)
_ -> Bool
False

        countLogicalUnits :: [F v x] -> Int
countLogicalUnits [F v x]
fns = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall {v} {x}. (Typeable v, Typeable x) => F v x -> Bool
isLogicalUnit [F v x]
fns

isSupportedByLogicalUnit :: F v x -> Bool
isSupportedByLogicalUnit F v x
f
    | Just LogicAnd{} <- forall (f :: * -> * -> *) v x.
(Typeable f, Typeable v, Typeable x) =>
F v x -> Maybe (f v x)
castF F v x
f = Bool
True
    | Just LogicOr{} <- forall (f :: * -> * -> *) v x.
(Typeable f, Typeable v, Typeable x) =>
F v x -> Maybe (f v x)
castF F v x
f = Bool
True
    | Just LogicNot{} <- forall (f :: * -> * -> *) v x.
(Typeable f, Typeable v, Typeable x) =>
F v x -> Maybe (f v x)
castF F v x
f = Bool
True
    | Bool
otherwise = Bool
False

optimizeCluster :: [F a x] -> p -> [F a x]
optimizeCluster [F a x]
allFunctions p
_ =
    let clusters :: [[F a x]]
clusters = forall v x. Var v => [F v x] -> [[F v x]]
findMergeClusters [F a x]
allFunctions
        mergedLogicalUnits :: [F a x]
mergedLogicalUnits = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {x} {x}.
(IsString a, ToString a, Suffix a, Hashable a, Val x, Typeable a,
 Typeable x, Ord a) =>
[F a x] -> Maybe (F a x)
mergeCluster [[F a x]]
clusters

        singleFunctions :: [F a x]
singleFunctions = forall a. (a -> Bool) -> [a] -> [a]
filter (\F a x
f -> forall {v} {x}. (Typeable v, Typeable x) => F v x -> Bool
isSupportedByLogicalUnit F a x
f Bool -> Bool -> Bool
&& forall a. Set a -> Int
S.size (forall f v. Function f v => f -> Set v
outputs F a x
f) forall a. Eq a => a -> a -> Bool
/= Int
1) [F a x]
allFunctions
        singleLogicalUnits :: [F a x]
singleLogicalUnits = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {v} {x} {x}.
(IsString v, ToString v, Suffix v, Hashable v, Val x, Typeable v,
 Typeable x, Ord v) =>
F v x -> Maybe (F v x)
convertToLOGICALUNIT [F a x]
singleFunctions

        remainingFunctions :: [F a x]
remainingFunctions = [F a x]
allFunctions forall a. Eq a => [a] -> [a] -> [a]
L.\\ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[F a x]]
clusters forall a. [a] -> [a] -> [a]
++ [F a x]
singleFunctions)
     in [F a x]
mergedLogicalUnits forall a. [a] -> [a] -> [a]
++ [F a x]
singleLogicalUnits forall a. [a] -> [a] -> [a]
++ [F a x]
remainingFunctions
    where
        mergeCluster :: [F a x] -> Maybe (F a x)
mergeCluster [F a x]
cluster
            | forall {f} {a}. (Function f a, Ord a) => [f] -> Bool
isSingleOutputChain [F a x]
cluster = forall {v} {x} {x} {p}.
(IsString v, ToString v, Suffix v, Hashable v, Val x, Typeable v,
 Typeable x, Ord v) =>
p -> [F v x] -> Maybe (F v x)
mergeLogicCluster forall k a. Map k a
M.empty [F a x]
cluster
            | Bool
otherwise = forall a. Maybe a
Nothing

        convertToLOGICALUNIT :: F v x -> Maybe (F v x)
convertToLOGICALUNIT F v x
f = case forall (f :: * -> * -> *) v x.
(Typeable f, Typeable v, Typeable x) =>
F v x -> Maybe (f v x)
castF F v x
f of
            Just (LogicAnd (I v
a) (I v
b) (O Set v
out)) ->
                forall v x.
(Var v, Val x) =>
[v] -> Set v -> ([Bool] -> Bool) -> Maybe (F v x)
buildCombinedLOGICALUNIT
                    [v
a, v
b]
                    Set v
out
                    ( \case
                        [Bool
x, Bool
y] -> Bool
x Bool -> Bool -> Bool
&& Bool
y
                        [Bool]
_ -> forall a. HasCallStack => String -> a
error String
"Unexpected pattern"
                    )
            Just (LogicOr (I v
a) (I v
b) (O Set v
out)) ->
                forall v x.
(Var v, Val x) =>
[v] -> Set v -> ([Bool] -> Bool) -> Maybe (F v x)
buildCombinedLOGICALUNIT
                    [v
a, v
b]
                    Set v
out
                    ( \case
                        [Bool
x, Bool
y] -> Bool
x Bool -> Bool -> Bool
|| Bool
y
                        [Bool]
_ -> forall a. HasCallStack => String -> a
error String
"Unexpected pattern"
                    )
            Just (LogicNot (I v
a) (O Set v
out)) ->
                forall v x.
(Var v, Val x) =>
[v] -> Set v -> ([Bool] -> Bool) -> Maybe (F v x)
buildCombinedLOGICALUNIT
                    [v
a]
                    Set v
out
                    ( \case
                        [Bool
x] -> Bool -> Bool
not Bool
x
                        [Bool]
_ -> forall a. HasCallStack => String -> a
error String
"Unexpected pattern"
                    )
            Maybe (LogicFunction v x)
_ -> forall a. Maybe a
Nothing

mergeLogicCluster :: p -> [F v x] -> Maybe (F v x)
mergeLogicCluster p
_ [F v x]
fs =
    let ([v]
inputVars, Set v
finalOutput) = forall {a} {a}. (Function a a, Ord a) => [a] -> ([a], Set a)
analyzeClusterIO [F v x]
fs
        evalFn :: [Bool] -> Bool
evalFn = forall {k} {x}.
(Ord k, Typeable k, Typeable x) =>
[F k x] -> [k] -> [Bool] -> Bool
buildCombinedLogic [F v x]
fs [v]
inputVars
     in forall v x.
(Var v, Val x) =>
[v] -> Set v -> ([Bool] -> Bool) -> Maybe (F v x)
buildCombinedLOGICALUNIT [v]
inputVars Set v
finalOutput [Bool] -> Bool
evalFn

isSingleOutputChain :: [f] -> Bool
isSingleOutputChain [f]
fs =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\f
f -> forall a. Set a -> Int
S.size (forall f v. Function f v => f -> Set v
outputs f
f) forall a. Eq a => a -> a -> Bool
== Int
1) [f]
fs
        Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== Int
1) [forall a. Set a -> Int
S.size (forall f v. Function f v => f -> Set v
outputs ([f]
fs forall a. [a] -> Int -> a
!! Int
i) forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` forall f v. Function f v => f -> Set v
inputs ([f]
fs forall a. [a] -> Int -> a
!! (Int
i forall a. Num a => a -> a -> a
+ Int
1))) | Int
i <- [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [f]
fs forall a. Num a => a -> a -> a
- Int
2]]

analyzeClusterIO :: [a] -> ([a], Set a)
analyzeClusterIO [a]
fs =
    let allInputs :: Set a
allInputs = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall f v. Function f v => f -> Set v
inputs [a]
fs
        allOutputs :: Set a
allOutputs = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall f v. Function f v => f -> Set v
outputs [a]
fs
        externalInputs :: Set a
externalInputs = forall a. Ord a => Set a -> Set a -> Set a
S.difference Set a
allInputs Set a
allOutputs
        finalOutput :: Set a
finalOutput = forall f v. Function f v => f -> Set v
outputs forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [a]
fs
     in (forall a. Set a -> [a]
S.toList Set a
externalInputs, Set a
finalOutput)

buildCombinedLogic :: [F k x] -> [k] -> [Bool] -> Bool
buildCombinedLogic [F k x]
fs [k]
inputVars =
    let evalCombination :: [Bool] -> Bool
evalCombination [Bool]
comb =
            let varMap :: Map k Bool
varMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [k]
inputVars [Bool]
comb
                resultMap :: Map k Bool
resultMap = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map k Bool
vm F k x
f -> forall {k} {x}.
(Typeable k, Typeable x, Ord k) =>
F k x -> Map k Bool -> Map k Bool
applyLogicGate F k x
f Map k Bool
vm) Map k Bool
varMap [F k x]
fs
             in Map k Bool
resultMap forall k a. Ord k => Map k a -> k -> a
M.! forall a. Int -> Set a -> a
S.elemAt Int
0 (forall f v. Function f v => f -> Set v
outputs forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [F k x]
fs)
     in [Bool] -> Bool
evalCombination

applyLogicGate :: F k x -> Map k Bool -> Map k Bool
applyLogicGate F k x
f Map k Bool
varMap = case forall (f :: * -> * -> *) v x.
(Typeable f, Typeable v, Typeable x) =>
F v x -> Maybe (f v x)
castF F k x
f of
    Just (LogicAnd (I k
a) (I k
b) (O Set k
out)) ->
        case forall a. Set a -> [a]
S.toList Set k
out of
            [k
outVar] -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
outVar (Map k Bool
varMap forall k a. Ord k => Map k a -> k -> a
M.! k
a Bool -> Bool -> Bool
&& Map k Bool
varMap forall k a. Ord k => Map k a -> k -> a
M.! k
b) Map k Bool
varMap
            [k]
_ -> forall a. HasCallStack => String -> a
error String
"LogicAnd must have exactly one output: 1"
    Just (LogicOr (I k
a) (I k
b) (O Set k
out)) ->
        case forall a. Set a -> [a]
S.toList Set k
out of
            [k
outVar] -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
outVar (Map k Bool
varMap forall k a. Ord k => Map k a -> k -> a
M.! k
a Bool -> Bool -> Bool
|| Map k Bool
varMap forall k a. Ord k => Map k a -> k -> a
M.! k
b) Map k Bool
varMap
            [k]
_ -> forall a. HasCallStack => String -> a
error String
"LogicOr must have exactly one output: 2"
    Just (LogicNot (I k
a) (O Set k
out)) ->
        case forall a. Set a -> [a]
S.toList Set k
out of
            [k
outVar] -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
outVar (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Map k Bool
varMap forall k a. Ord k => Map k a -> k -> a
M.! k
a) Map k Bool
varMap
            [k]
_ -> forall a. HasCallStack => String -> a
error String
"LogicNot must have exactly one output: 3"
    Maybe (LogicFunction k x)
_ -> Map k Bool
varMap

buildCombinedLOGICALUNIT :: (Var v, Val x) => [v] -> S.Set v -> ([Bool] -> Bool) -> Maybe (F v x)
buildCombinedLOGICALUNIT :: forall v x.
(Var v, Val x) =>
[v] -> Set v -> ([Bool] -> Bool) -> Maybe (F v x)
buildCombinedLOGICALUNIT [v]
inputVars Set v
outputSet [Bool] -> Bool
evalFn =
    let logicalunitInputs :: [I v]
logicalunitInputs = forall a b. (a -> b) -> [a] -> [b]
map forall v. v -> I v
I [v]
inputVars
        logicalunitOutput :: O v
logicalunitOutput = forall v. Set v -> O v
O Set v
outputSet
        inputCombinations :: [[Bool]]
inputCombinations = forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
inputVars) [Bool
False, Bool
True]
        tbl :: Map [Bool] Bool
tbl = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [([Bool]
comb, [Bool] -> Bool
evalFn [Bool]
comb) | [Bool]
comb <- [[Bool]]
inputCombinations]
     in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {f} {v} {x}.
(Function f v, Patch f (v, v), Locks f v, Show f, Label f,
 FunctionSimulation f v x, Typeable f, Eq f) =>
f -> F v x
packF forall a b. (a -> b) -> a -> b
$ forall v x. Map [Bool] Bool -> [I v] -> O v -> TruthTable v x
TruthTable Map [Bool] Bool
tbl [I v]
logicalunitInputs O v
logicalunitOutput

topSort :: Eq a => [(a, [a])] -> [a]
topSort :: forall a. Eq a => [(a, [a])] -> [a]
topSort [] = []
topSort [(a, [a])]
g = case forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(a, [a])]
g of
    ([], [(a, [a])]
_) -> []
    ([(a, [a])]
ready, [(a, [a])]
rest) ->
        forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, [a])]
ready
            forall a. [a] -> [a] -> [a]
++ forall a. Eq a => [(a, [a])] -> [a]
topSort
                [ (a
x, forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
readyNodes) [a]
ys)
                | (a
x, [a]
ys) <- [(a, [a])]
rest
                ]
        where
            readyNodes :: [a]
readyNodes = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, [a])]
ready

findMergeClusters :: Var v => [F v x] -> [[F v x]]
findMergeClusters :: forall v x. Var v => [F v x] -> [[F v x]]
findMergeClusters [F v x]
fs =
    let deps :: [(F v x, [F v x])]
deps = forall {a} {a}. (Ord a, Function a a) => [a] -> [(a, [a])]
buildDependencyGraph [F v x]
fs
        sorted :: [F v x]
sorted = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [(a, [a])] -> [a]
topSort [(F v x, [F v x])]
deps
        clusters :: [[F v x]]
clusters = forall {a} {a}. (Function a a, Ord a) => [a] -> [[a]]
groupChains [F v x]
sorted
     in [[F v x]]
clusters
    where
        buildDependencyGraph :: [a] -> [(a, [a])]
buildDependencyGraph [a]
fns =
            [ (a
f, [a
g | a
g <- [a]
fns, forall {a} {f} {f}.
(Ord a, Function f a, Function f a) =>
f -> f -> Bool
sharesDependency a
f a
g])
            | a
f <- [a]
fns
            ]

        sharesDependency :: f -> f -> Bool
sharesDependency f
f f
g =
            Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
S.null (forall f v. Function f v => f -> Set v
outputs f
f forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` forall f v. Function f v => f -> Set v
inputs f
g)

        groupChains :: [a] -> [[a]]
groupChains [] = []
        groupChains (a
x : [a]
xs) =
            let ([a]
chain, [a]
rest) = forall {a} {a}. (Function a a, Ord a) => [a] -> [a] -> ([a], [a])
collectChain [a
x] [a]
xs
             in [a]
chain forall a. a -> [a] -> [a]
: [a] -> [[a]]
groupChains [a]
rest
            where
                collectChain :: [a] -> [a] -> ([a], [a])
collectChain [a]
acc' [] = ([a]
acc', [])
                collectChain [a]
acc' (a
y : [a]
ys)
                    | forall {a} {f} {f}.
(Ord a, Function f a, Function f a) =>
f -> f -> Bool
sharesDependency (forall a. [a] -> a
last [a]
acc') a
y
                        Bool -> Bool -> Bool
&& forall {f} {a}. (Function f a, Ord a) => [f] -> Bool
isSingleOutputChain ([a]
acc' forall a. [a] -> [a] -> [a]
++ [a
y]) =
                        [a] -> [a] -> ([a], [a])
collectChain ([a]
acc' forall a. [a] -> [a] -> [a]
++ [a
y]) [a]
ys
                    | Bool
otherwise = ([a]
acc', a
y forall a. a -> [a] -> [a]
: [a]
ys)