-- 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 x.
 OptimizeLogicalUnit v x -> Rep (OptimizeLogicalUnit v x) x)
-> (forall x.
    Rep (OptimizeLogicalUnit v x) x -> OptimizeLogicalUnit v x)
-> Generic (OptimizeLogicalUnit v x)
forall x.
Rep (OptimizeLogicalUnit v x) x -> OptimizeLogicalUnit v x
forall x.
OptimizeLogicalUnit v x -> Rep (OptimizeLogicalUnit v x) x
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
$cfrom :: forall v x x.
OptimizeLogicalUnit v x -> Rep (OptimizeLogicalUnit v x) x
from :: forall x.
OptimizeLogicalUnit v x -> Rep (OptimizeLogicalUnit v x) x
$cto :: forall v x x.
Rep (OptimizeLogicalUnit v x) x -> OptimizeLogicalUnit v x
to :: forall x.
Rep (OptimizeLogicalUnit v x) x -> OptimizeLogicalUnit v x
Generic, Int -> OptimizeLogicalUnit v x -> ShowS
[OptimizeLogicalUnit v x] -> ShowS
OptimizeLogicalUnit v x -> String
(Int -> OptimizeLogicalUnit v x -> ShowS)
-> (OptimizeLogicalUnit v x -> String)
-> ([OptimizeLogicalUnit v x] -> ShowS)
-> Show (OptimizeLogicalUnit v x)
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
$cshowsPrec :: forall v x. Int -> OptimizeLogicalUnit v x -> ShowS
showsPrec :: Int -> OptimizeLogicalUnit v x -> ShowS
$cshow :: forall v x. OptimizeLogicalUnit v x -> String
show :: OptimizeLogicalUnit v x -> String
$cshowList :: forall v x. [OptimizeLogicalUnit v x] -> ShowS
showList :: [OptimizeLogicalUnit v x] -> ShowS
Show, OptimizeLogicalUnit v x -> OptimizeLogicalUnit v x -> Bool
(OptimizeLogicalUnit v x -> OptimizeLogicalUnit v x -> Bool)
-> (OptimizeLogicalUnit v x -> OptimizeLogicalUnit v x -> Bool)
-> Eq (OptimizeLogicalUnit v x)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v x.
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
/= :: 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
_ = String -> u
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 = (F v x -> Bool) -> [F v x] -> [F v x]
forall a. (a -> Bool) -> [a] -> [a]
filter F v x -> Bool
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 ([F v x] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [F v x]
supportedFunctions)
                    Bool -> Bool -> Bool
&& [F v x] -> Bool
forall {v} {x}. (Typeable v, Typeable x) => [F v x] -> Bool
isOptimizationNeeded [F v x]
supportedFunctions
                    then [F v x] -> [F v x] -> [F v x]
forall {a} {x} {p}.
(IsString a, ToString a, Suffix a, Hashable a, Val x, Typeable a,
 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 ([F v x] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [F v x]
rNew) Bool -> Bool -> Bool
&& [F v x] -> Set (F v x)
forall a. Ord a => [a] -> Set a
S.fromList [F v x]
supportedFunctions Set (F v x) -> Set (F v x) -> Bool
forall a. Eq a => a -> a -> Bool
/= [F v x] -> Set (F v x)
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 :: forall v x. OptimizeLogicalUnit v x -> [F v x]
rOld :: [F v x]
rOld, [F v x]
rNew :: forall v x. OptimizeLogicalUnit v x -> [F v x]
rNew :: [F v x]
rNew} =
        [F v x] -> [F v x]
forall {a} {a}. (Ord a, Variables a a, Eq a) => [a] -> [a]
deleteExtraLogicalUnits ([F v x] -> [F v x]) -> [F v x] -> [F v x]
forall a b. (a -> b) -> a -> b
$ ([F v x]
fs [F v x] -> [F v x] -> [F v x]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [F v x]
rOld) [F v x] -> [F v x] -> [F v x]
forall a. Semigroup a => a -> a -> a
<> [F v x]
rNew

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

isOptimizationNeeded :: [F v x] -> Bool
isOptimizationNeeded [F v x]
fs = [F v x] -> Int
forall {v} {x}. (Typeable v, Typeable x) => [F v x] -> Int
countLogicalUnits [F v x]
fs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| [F v x] -> 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 = (F v x -> Bool) -> t (F v x) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any F v x -> Bool
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 F v x -> Maybe (TruthTable v x)
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 = [F v x] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([F v x] -> Int) -> [F v x] -> Int
forall a b. (a -> b) -> a -> b
$ (F v x -> Bool) -> [F v x] -> [F v x]
forall a. (a -> Bool) -> [a] -> [a]
filter F v x -> Bool
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{} <- F v x -> Maybe (LogicFunction v x)
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{} <- F v x -> Maybe (LogicFunction v x)
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{} <- F v x -> Maybe (LogicFunction v x)
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 = [F a x] -> [[F a x]]
forall v x. Var v => [F v x] -> [[F v x]]
findMergeClusters [F a x]
allFunctions
        mergedLogicalUnits :: [F a x]
mergedLogicalUnits = ([F a x] -> Maybe (F a x)) -> [[F a x]] -> [F a x]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [F a x] -> Maybe (F a x)
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 = (F a x -> Bool) -> [F a x] -> [F a x]
forall a. (a -> Bool) -> [a] -> [a]
filter (\F a x
f -> F a x -> Bool
forall {v} {x}. (Typeable v, Typeable x) => F v x -> Bool
isSupportedByLogicalUnit F a x
f Bool -> Bool -> Bool
&& Set a -> Int
forall a. Set a -> Int
S.size (F a x -> Set a
forall f v. Function f v => f -> Set v
outputs F a x
f) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) [F a x]
allFunctions
        singleLogicalUnits :: [F a x]
singleLogicalUnits = (F a x -> Maybe (F a x)) -> [F a x] -> [F a x]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe F a x -> Maybe (F a x)
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 [F a x] -> [F a x] -> [F a x]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ ([[F a x]] -> [F a x]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[F a x]]
clusters [F a x] -> [F a x] -> [F a x]
forall a. [a] -> [a] -> [a]
++ [F a x]
singleFunctions)
     in [F a x]
mergedLogicalUnits [F a x] -> [F a x] -> [F a x]
forall a. [a] -> [a] -> [a]
++ [F a x]
singleLogicalUnits [F a x] -> [F a x] -> [F a x]
forall a. [a] -> [a] -> [a]
++ [F a x]
remainingFunctions
    where
        mergeCluster :: [F a x] -> Maybe (F a x)
mergeCluster [F a x]
cluster
            | [F a x] -> Bool
forall {a} {f}. (Ord a, Function f a) => [f] -> Bool
isSingleOutputChain [F a x]
cluster = Map Any Any -> [F a x] -> Maybe (F a x)
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 Map Any Any
forall k a. Map k a
M.empty [F a x]
cluster
            | Bool
otherwise = Maybe (F a x)
forall a. Maybe a
Nothing

        convertToLOGICALUNIT :: F v x -> Maybe (F v x)
convertToLOGICALUNIT F v x
f = case F v x -> Maybe (LogicFunction v x)
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)) ->
                [v] -> Set v -> ([Bool] -> Bool) -> Maybe (F v x)
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]
_ -> String -> Bool
forall a. HasCallStack => String -> a
error String
"Unexpected pattern"
                    )
            Just (LogicOr (I v
a) (I v
b) (O Set v
out)) ->
                [v] -> Set v -> ([Bool] -> Bool) -> Maybe (F v x)
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]
_ -> String -> Bool
forall a. HasCallStack => String -> a
error String
"Unexpected pattern"
                    )
            Just (LogicNot (I v
a) (O Set v
out)) ->
                [v] -> Set v -> ([Bool] -> Bool) -> Maybe (F v x)
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]
_ -> String -> Bool
forall a. HasCallStack => String -> a
error String
"Unexpected pattern"
                    )
            Maybe (LogicFunction v x)
_ -> Maybe (F 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) = [F v x] -> ([v], Set v)
forall {a} {a}. (Ord a, Function a a) => [a] -> ([a], Set a)
analyzeClusterIO [F v x]
fs
        evalFn :: [Bool] -> Bool
evalFn = [F v x] -> [v] -> [Bool] -> Bool
forall {k} {x}.
(Ord k, Typeable k, Typeable x) =>
[F k x] -> [k] -> [Bool] -> Bool
buildCombinedLogic [F v x]
fs [v]
inputVars
     in [v] -> Set v -> ([Bool] -> Bool) -> Maybe (F v x)
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 =
    (f -> Bool) -> [f] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\f
f -> Set a -> Int
forall a. Set a -> Int
S.size (f -> Set a
forall f v. Function f v => f -> Set v
outputs f
f) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) [f]
fs
        Bool -> Bool -> Bool
&& (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) [Set a -> Int
forall a. Set a -> Int
S.size (f -> Set a
forall f v. Function f v => f -> Set v
outputs ([f]
fs [f] -> Int -> f
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` f -> Set a
forall f v. Function f v => f -> Set v
inputs ([f]
fs [f] -> Int -> f
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))) | Int
i <- [Int
0 .. [f] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [f]
fs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2]]

analyzeClusterIO :: [a] -> ([a], Set a)
analyzeClusterIO [a]
fs =
    let allInputs :: Set a
allInputs = [Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set a] -> Set a) -> [Set a] -> Set a
forall a b. (a -> b) -> a -> b
$ (a -> Set a) -> [a] -> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Set a
forall f v. Function f v => f -> Set v
inputs [a]
fs
        allOutputs :: Set a
allOutputs = [Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set a] -> Set a) -> [Set a] -> Set a
forall a b. (a -> b) -> a -> b
$ (a -> Set a) -> [a] -> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Set a
forall f v. Function f v => f -> Set v
outputs [a]
fs
        externalInputs :: Set a
externalInputs = Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.difference Set a
allInputs Set a
allOutputs
        finalOutput :: Set a
finalOutput = a -> Set a
forall f v. Function f v => f -> Set v
outputs (a -> Set a) -> a -> Set a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. HasCallStack => [a] -> a
last [a]
fs
     in (Set a -> [a]
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 = [(k, Bool)] -> Map k Bool
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(k, Bool)] -> Map k Bool) -> [(k, Bool)] -> Map k Bool
forall a b. (a -> b) -> a -> b
$ [k] -> [Bool] -> [(k, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k]
inputVars [Bool]
comb
                resultMap :: Map k Bool
resultMap = (Map k Bool -> F k x -> Map k Bool)
-> Map k Bool -> [F k x] -> Map k Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map k Bool
vm F k x
f -> F k x -> Map k Bool -> Map k Bool
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 Map k Bool -> k -> Bool
forall k a. Ord k => Map k a -> k -> a
M.! Int -> Set k -> k
forall a. Int -> Set a -> a
S.elemAt Int
0 (F k x -> Set k
forall f v. Function f v => f -> Set v
outputs (F k x -> Set k) -> F k x -> Set k
forall a b. (a -> b) -> a -> b
$ [F k x] -> F k x
forall a. HasCallStack => [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 F k x -> Maybe (LogicFunction k x)
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 Set k -> [k]
forall a. Set a -> [a]
S.toList Set k
out of
            [k
outVar] -> k -> Bool -> Map k Bool -> Map k Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
outVar (Map k Bool
varMap Map k Bool -> k -> Bool
forall k a. Ord k => Map k a -> k -> a
M.! k
a Bool -> Bool -> Bool
&& Map k Bool
varMap Map k Bool -> k -> Bool
forall k a. Ord k => Map k a -> k -> a
M.! k
b) Map k Bool
varMap
            [k]
_ -> String -> Map k Bool
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 Set k -> [k]
forall a. Set a -> [a]
S.toList Set k
out of
            [k
outVar] -> k -> Bool -> Map k Bool -> Map k Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
outVar (Map k Bool
varMap Map k Bool -> k -> Bool
forall k a. Ord k => Map k a -> k -> a
M.! k
a Bool -> Bool -> Bool
|| Map k Bool
varMap Map k Bool -> k -> Bool
forall k a. Ord k => Map k a -> k -> a
M.! k
b) Map k Bool
varMap
            [k]
_ -> String -> Map k Bool
forall a. HasCallStack => String -> a
error String
"LogicOr must have exactly one output: 2"
    Just (LogicNot (I k
a) (O Set k
out)) ->
        case Set k -> [k]
forall a. Set a -> [a]
S.toList Set k
out of
            [k
outVar] -> k -> Bool -> Map k Bool -> Map k Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
outVar (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map k Bool
varMap Map k Bool -> k -> Bool
forall k a. Ord k => Map k a -> k -> a
M.! k
a) Map k Bool
varMap
            [k]
_ -> String -> Map k Bool
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 = (v -> I v) -> [v] -> [I v]
forall a b. (a -> b) -> [a] -> [b]
map v -> I v
forall v. v -> I v
I [v]
inputVars
        logicalunitOutput :: O v
logicalunitOutput = Set v -> O v
forall v. Set v -> O v
O Set v
outputSet
        inputCombinations :: [[Bool]]
inputCombinations = Int -> [Bool] -> [[Bool]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
inputVars) [Bool
False, Bool
True]
        tbl :: Map [Bool] Bool
tbl = [([Bool], Bool)] -> Map [Bool] Bool
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [([Bool]
comb, [Bool] -> Bool
evalFn [Bool]
comb) | [Bool]
comb <- [[Bool]]
inputCombinations]
     in F v x -> Maybe (F v x)
forall a. a -> Maybe a
Just (F v x -> Maybe (F v x)) -> F v x -> Maybe (F v x)
forall a b. (a -> b) -> a -> b
$ TruthTable v x -> F v x
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 (TruthTable v x -> F v x) -> TruthTable v x -> F v x
forall a b. (a -> b) -> a -> b
$ Map [Bool] Bool -> [I v] -> O v -> TruthTable v x
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 ((a, [a]) -> Bool) -> [(a, [a])] -> ([(a, [a])], [(a, [a])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> ((a, [a]) -> [a]) -> (a, [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [a]) -> [a]
forall a b. (a, b) -> b
snd) [(a, [a])]
g of
    ([], [(a, [a])]
_) -> []
    ([(a, [a])]
ready, [(a, [a])]
rest) ->
        ((a, [a]) -> a) -> [(a, [a])] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, [a]) -> a
forall a b. (a, b) -> a
fst [(a, [a])]
ready
            [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [(a, [a])] -> [a]
forall a. Eq a => [(a, [a])] -> [a]
topSort
                [ (a
x, (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> [a] -> Bool
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 = ((a, [a]) -> a) -> [(a, [a])] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, [a]) -> a
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 = [F v x] -> [(F v x, [F v x])]
forall {a} {a}. (Ord a, Function a a) => [a] -> [(a, [a])]
buildDependencyGraph [F v x]
fs
        sorted :: [F v x]
sorted = [F v x] -> [F v x]
forall a. [a] -> [a]
reverse ([F v x] -> [F v x]) -> [F v x] -> [F v x]
forall a b. (a -> b) -> a -> b
$ [(F v x, [F v x])] -> [F v x]
forall a. Eq a => [(a, [a])] -> [a]
topSort [(F v x, [F v x])]
deps
        clusters :: [[F v x]]
clusters = [F v x] -> [[F v x]]
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, a -> a -> Bool
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set a -> Bool
forall a. Set a -> Bool
S.null (f -> Set a
forall f v. Function f v => f -> Set v
outputs f
f Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` f -> Set a
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) = [a] -> [a] -> ([a], [a])
forall {a} {a}. (Function a a, Ord a) => [a] -> [a] -> ([a], [a])
collectChain [a
x] [a]
xs
             in [a]
chain [a] -> [[a]] -> [[a]]
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)
                    | a -> a -> Bool
forall {a} {f} {f}.
(Ord a, Function f a, Function f a) =>
f -> f -> Bool
sharesDependency ([a] -> a
forall a. HasCallStack => [a] -> a
last [a]
acc') a
y
                        Bool -> Bool -> Bool
&& [a] -> Bool
forall {a} {f}. (Ord a, Function f a) => [f] -> Bool
isSingleOutputChain ([a]
acc' [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
y]) =
                        [a] -> [a] -> ([a], [a])
collectChain ([a]
acc' [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
y]) [a]
ys
                    | Bool
otherwise = ([a]
acc', a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys)