module Data.Yoko.MinCtors.Minima
(NCtor, NRec, NP1, NP0, Minima2, Minima1, Minimum,
DTsCVec, SumInfo, SC_SumInfo,
SiblingInT, SiblingInC, addMinima2, addSiblingInTs,
solve_sibling_set, solve_sibling_set',
plug10, plug0, plug10', plug0') where
import Data.Yoko.TypeBasics
import Data.Yoko.View
import Data.Yoko.MinCtors.MMap (MMap)
import qualified Data.Yoko.MinCtors.MMap as MMap
import qualified Data.Foldable as F
import Data.Semigroup (Min(..))
import Data.Traversable (traverse)
import Data.Maybe (catMaybes)
instance Functor Min where fmap f (Min a) = Min (f a)
type NCtor = Int
type NRec = Int
type NP1 = Int
type NP0 = Int
type Minima2 = MMap (NP1, NP0) Min NCtor
type Minima1 = MMap NP0 Min NCtor
type Minimum = MMap () Min NCtor
scale :: Int -> Minima2 -> Minima2
scale i = MMap.mapWithMonoKeys (\(np1, np0) -> (i * np1, i * np0)) (fmap (i *))
addMinima2 :: Minima2 -> Minima2 -> Minima2
addMinima2 m m' = flip MMap.foldMap m $ \(np1, np0) (Min k) ->
flip MMap.foldMap m' $ \(np1', np0') (Min k') ->
MMap.singleton (np1 + np1', np0 + np0') (Min $ k + k')
type DTsCVec t = CVec (SiblingDTs t)
type SumInfo t = MMap (DTsCVec t NRec, NP1, NP0) Min NCtor
scaleSiblingInTs :: Int -> SiblingInT ts -> SiblingInT ts
scaleSiblingInTs i = MMap.mapWithMonoKeys (\(r, np1, np0) -> (fmap (i *) r, i * np1, i * np0)) (fmap (i *))
addSiblingInTs :: Ord (CVec ts NRec) => SiblingInT ts -> SiblingInT ts -> SiblingInT ts
addSiblingInTs m m' = flip MMap.foldMap m $ \(rs, np1, np0) (Min k) ->
flip MMap.foldMap m' $ \(rs', np1', np0') (Min k') ->
MMap.singleton (cvZipWith (+) rs rs', np1 + np1', np0 + np0') (Min $ k + k')
data SC_SumInfo t = SC_SumInfo
type instance App SC_SumInfo t = SumInfo t
solve_sibling_set ::
(Eq (CVec ts Minima2), VRepeat ts,
VFunctor (SiblingInC ts) ts, VEnum ts) => Vec ts SC_SumInfo -> Work ts
solve_sibling_set = solve_sibling_set' . homogenize
solve_sibling_set' ::
(Eq (CVec ts Minima2), VRepeat ts, VEnum ts) => CVec ts (SiblingInT ts) -> Work ts
solve_sibling_set' table = chaotic (step table) $ initialize table
type Work ts = CVec ts Minima2
type SiblingInT ts = MMap (CVec ts NRec, NP1, NP0) Min NCtor
homogenize :: forall ts. VFunctor (SiblingInC ts) ts =>
Vec ts SC_SumInfo -> CVec ts (SiblingInT ts)
homogenize = (CVec .) $ vMap (Proxy :: Proxy (SiblingInC ts)) $ \_ -> id
class (ts ~ SiblingDTs t) => SiblingInC (ts :: [k]) (t :: k)
instance (ts ~ SiblingDTs t) => SiblingInC ts t
initialize :: CVec ts (SiblingInT ts) -> Work ts
initialize = fmap $ \ctors -> flip MMap.foldMap ctors $ \(recs, np1, np0) k ->
if F.all (0 ==) recs
then MMap.singleton (np1, np0) k
else MMap.empty
step :: VEnum ts => CVec ts (SiblingInT ts) -> Work ts -> Work ts
step table sofar = cvZipWith leftbias sofar $ flip fmap table $
MMap.foldMap $ \(recs, np1, np0) k ->
let all_answered = flip traverse (cvAddIndexes recs) $ \(idx, times) ->
if times <= 0 then Just Nothing
else let answer = sofar `cvAt` idx
in if MMap.null answer then Nothing
else Just $ Just $ scale times answer
in ($ all_answered) $ maybe MMap.empty $
foldl addMinima2 (MMap.singleton (np1, np0) k) . catMaybes . cvec2list
leftbias m1 m2 = if MMap.null m1 then m2 else m1
chaotic :: Eq a => (a -> a) -> a -> a
chaotic f = w where w x = let x' = f x in if x == x' then x else w x'
plug0 :: Ord (CVec ts NRec) => Minima1 -> SiblingInT ts -> SiblingInT ts
plug0 f s0 = flip MMap.foldMap f $ \np0 (Min k) ->
MMap.map (fmap (+k)) $ scaleSiblingInTs np0 s0
plug10 :: Ord (CVec ts NRec) => Minima2 -> SiblingInT ts -> SiblingInT ts -> SiblingInT ts
plug10 f s1 s0 = flip MMap.foldMap f $ \(np1, np0) (Min k) ->
MMap.map (fmap (+k)) $ scaleSiblingInTs np1 s1 `addSiblingInTs` scaleSiblingInTs np0 s0
plug0' :: Minima1 -> Minima2 -> Minima2
plug0' f s0 = flip MMap.foldMap f $ \np0 (Min k) ->
MMap.map (fmap (+k)) $ scale np0 s0
plug10' :: Minima2 -> Minima2 -> Minima2 -> Minima2
plug10' f s1 s0 = flip MMap.foldMap f $ \(np1, np0) (Min k) ->
MMap.map (fmap (+k)) $ scale np1 s1 `addMinima2` scale np0 s0