content: {-# LANGUAGE Arrows #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE UnboxedTuples #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# OPTIONS_GHC -Wno-redundant-constraints #-}
  module Control.Arrow.Transformer.Abstract.Fix.Component(ComponentT,runComponentT,Component) where
  
  import           Prelude hiding (id,pred,lookup,map,head,iterate,(.),elem)
  
  import           Control.Category
  import           Control.Arrow hiding (loop)
  import           Control.Arrow.Primitive
  import           Control.Arrow.Strict
  import           Control.Arrow.Fix.Reuse
  import           Control.Arrow.Fix.SCC
  import           Control.Arrow.Fix.Cache as Cache
  import           Control.Arrow.Fix.CallCount
  import           Control.Arrow.Fix.ControlFlow
  import           Control.Arrow.Fix.Stack as Stack
  import           Control.Arrow.Fix.Context as Context
  import           Control.Arrow.Trans
  
  -- import           Control.Arrow.Transformer.Writer
  import           Control.Arrow.Transformer.State
  
  import           Data.Bits
  import           Data.Profunctor
  import           Data.Identifiable
  import           Data.Coerce
  import           Data.Empty
  
  import           Text.Printf
  
  newtype ComponentT component a c x y = ComponentT (StateT (component a) c x y)
    deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStrict,
              ArrowStackDepth,ArrowStackElements a,ArrowReuse a b,
              ArrowCache a b, ArrowParallelCache a b,ArrowIterateCache a b,ArrowGetCache cache,
              ArrowCallCount u, ArrowCallSite ctx, ArrowContext ctx u,
              ArrowControlFlow stmt, ArrowPrimitive, ArrowCFG graph)
  
  runComponentT :: (IsEmpty (comp a), Profunctor c) => ComponentT comp a c x y -> c x y
  runComponentT (ComponentT f) = dimap (\x -> (empty,x)) snd (runStateT f)
  {-# INLINE runComponentT #-}
  
  instance ArrowLift (ComponentT comp a c) where
    type Underlying (ComponentT comp a c) x y = c (comp a,x) (comp a,y)
  
  instance ArrowTrans (ComponentT comp a) where
    lift' f = ComponentT (lift' f)
    {-# INLINE lift' #-}
  
  instance (IsEmpty (comp a), ArrowRun c) => ArrowRun (ComponentT comp a c) where
    type Run (ComponentT comp a c) x y = Run c x y
    run f = run (runComponentT f)
    {-# INLINE run #-}
  
  instance (Identifiable a, Profunctor c,ArrowApply c) => ArrowApply (ComponentT comp a c) where
    app = ComponentT (lmap (first coerce) app)
    {-# INLINE app #-}
  
  --instance (Arrow c, Profunctor c) => ArrowState (Store addr val) (EnvStoreT var addr val c) where
  --  get = EnvStoreT get
  --  put = EnvStoreT put
  --  {-# INLINE get #-}
  --  {-# INLINE put #-}
  
  newtype Component a = Component Integer
  
  instance Show (Component a) where
    show (Component comp) = printf "%b" comp
  
  instance IsEmpty (Component a) where
    empty = mempty
  
  instance Semigroup (Component a) where
    Component c1 <> Component c2 = Component (c1 .|. c2)
  instance Monoid (Component a) where
    mempty = Component 0
    mappend = (<>)
  
  instance (Arrow c, Profunctor c) => ArrowSCC a (ComponentT Component a c) where
    add = lift $ proc (Component comp,(_,pointer)) -> do
      let comp' = (shiftL (1 :: Integer) pointer .|. comp)
      returnA -< (Component comp', ())
    {-# INLINE add #-}
  
    remove = lift $ proc (Component comp, (_, pointer)) -> do
      let comp' = (complement (shiftL (1 :: Integer) pointer) .&. comp)
      returnA -< (Component comp', ())
  
    elem = lift $ proc (Component comp, _) -> do
      returnA -< (Component comp, if testBit comp 0 then InSCC 0 else NotInSCC)
  
    size = lift $ proc (Component comp, _) -> do
      returnA -< (Component comp, popCount comp)
  
  instance (Identifiable a, ArrowStack a c) => ArrowStack a (ComponentT Component a c) where
    push f = lift $ proc (comp,(a,x)) -> do
      (comp',y) <- push (lmap (\x -> (mempty,x)) (unlift f)) -< (a,x)
      returnA -< (comp <> pop comp', y)
      where
        pop (Component comp) = Component (shiftR comp 1)
    {-# INLINE push #-}
  
  -- instance (Arrow c, Profunctor c) => ArrowInComponent a (ComponentT Component a c) where
  --   inComponent f = lift $ dimap (second snd) (\(comp, y) -> (comp,(isInComponent comp,y))) (unlift f)
  --     where
  --       isInComponent (Component comp)
  --         | comp == 0      = Empty
  --         | comp == 1      = Head Outermost
  --         | testBit comp 0 = Head Inner
  --         | otherwise      = Body
  --   {-# INLINE inComponent #-}
  --   {-# SCC inComponent #-}
  
  
  
  -- Standard Component ----------------------------------------------------------------------------------
  -- newtype Component a = Component (HashSet a) deriving (Eq,IsEmpty,Monoid,Semigroup)
  
  -- instance (Identifiable a, Arrow c, Profunctor c) => ArrowComponent a (ComponentT Component a c) where
  --   addToComponent = lift $ arr $ \(Component c,a) -> (Component (H.insert a c),())
  --   removeFromComponent = lift $ arr $ \(Component c,a) -> (Component (H.delete a c),())
  --   {-# INLINE addToComponent #-}
  --   {-# INLINE removeFromComponent #-}
  --   {-# SCC addToComponent #-}
  --   {-# SCC removeFromComponent #-}
  
  -- instance (Identifiable a, Arrow c, Profunctor c) => ArrowInComponent a (ComponentT Component a c) where
  --   inComponent = lift $ arr $ \(Component c,a) ->
  --     let comp | H.null c = Empty
  --              | H.singleton a == c = Head Outermost
  --              | H.member a c = Head Inner
  --              | otherwise = Body
  --     in (Component c,comp)
  --   {-# INLINE inComponent #-}
  --   {-# SCC inComponent #-}
  
  -- instance (Identifiable a, ArrowStack a c) => ArrowStack a (ComponentT Component a c) where
  --   push f = lift $ proc (comp,(a,x)) -> do
  --     (comp',y) <- push (lmap (\x -> (mempty,x)) (unlift f)) -< (a,x)
  --     returnA -< (comp <> comp', y)
  --   {-# INLINE push #-}
  --   {-# SCC push #-}
  
  -- -- Component with a mononone part ------------------------------------------------------------------
  -- data Monotone b where
  --   Monotone :: HashMap b a -> Monotone (a,b)
  
  -- instance IsEmpty (Monotone (a,b)) where
  --   empty = Monotone empty
  
  -- instance Identifiable b => Semigroup (Monotone (a,b)) where
  --   Monotone m1 <> Monotone m2 = Monotone (M.union m2 m1)
  
  -- instance Identifiable b => Monoid (Monotone (a,b)) where
  --   mempty = empty
  --   mappend = (<>)
  
  -- instance (PreOrd a, Identifiable b, Arrow c, Profunctor c) => ArrowComponent (a,b) (ComponentT Monotone (a,b) c) where
  --   addToComponent      = lift $ arr $ \(Monotone m,(a,b)) -> (Monotone (M.insert b a m), ())
  --   removeFromComponent = lift $ arr $ \(Monotone m,(a,b)) ->
  --     (Monotone (M.update (\a' -> if a' ⊑ a then Nothing else Just a') b m), ())
  --   {-# INLINE addToComponent #-}
  --   {-# INLINE removeFromComponent #-}
  --   {-# SCC addToComponent #-}
  --   {-# SCC removeFromComponent #-}
  
  -- instance (PreOrd a, Identifiable b, Profunctor c, Arrow c) => ArrowInComponent (a,b) (ComponentT Monotone (a,b) c) where
  --   inComponent = lift $ arr $ \(Monotone m,(a,b)) ->
  --     let comp | M.null m              = Empty
  --              | Just a ⊑ M.lookup b m = Head $ if M.size m == 1 then Outermost else Inner
  --              | otherwise             = Body
  --     in (Monotone m,comp)
  --   {-# INLINE inComponent #-}
  --   {-# SCC inComponent #-}
  
  -- instance (ArrowStack a c) => ArrowStack a (ComponentT Monotone a c) where
  --   push f = lift $ proc (comp,(a,x)) -> push (unlift f) -< (a,(comp,x))
  --   {-# INLINE push #-}
  --   {-# SCC push #-}
  