{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Aztecs.ECS.Schedule.Internal where

import Aztecs.ECS.Access.Internal
import Aztecs.ECS.HSet
import Aztecs.ECS.Query.Internal
import Aztecs.ECS.System
import Data.Kind

class Schedule m s where
  type Scheduled m s :: Type

  schedule :: s -> Scheduled m s

type family SystemInOf m sys :: [Type] where
  SystemInOf m sys = AccessType (SystemIn m sys)

type family HasInputOverlap (inputs1 :: [Type]) (inputs2 :: [Type]) :: Bool where
  HasInputOverlap inputs1 inputs2 =
    Or
      (HasComponentOverlap (WriteComponents inputs1) (AccessToComponents inputs2))
      (HasComponentOverlap (WriteComponents inputs2) (AccessToComponents inputs1))

type family HasComponentOverlap (components1 :: [Type]) (components2 :: [Type]) :: Bool where
  HasComponentOverlap '[] components2 = 'False
  HasComponentOverlap (c ': rest) components2 =
    Or (Contains c components2) (HasComponentOverlap rest components2)

type family GroupSystems m (systems :: [Type]) :: [[Type]] where
  GroupSystems m '[] = '[]
  GroupSystems m '[sys] = '[ '[sys]]
  GroupSystems m (sys1 ': sys2 ': rest) =
    If
      (HasInputOverlap (SystemInOf m sys1) (SystemInOf m sys2))
      (GroupSystemsConflict m (sys1 ': sys2 ': rest))
      (GroupSystemsNoConflict m (sys1 ': sys2 ': rest))

type family GroupSystemsConflict m (systems :: [Type]) :: [[Type]] where
  GroupSystemsConflict m (sys ': rest) = '[sys] ': GroupSystems m rest

type family GroupSystemsNoConflict m (systems :: [Type]) :: [[Type]] where
  GroupSystemsNoConflict m (sys1 ': sys2 ': rest) =
    MergeCompatibleSystems m '[sys1, sys2] rest

type family MergeCompatibleSystems m (group :: [Type]) (remaining :: [Type]) :: [[Type]] where
  MergeCompatibleSystems m group '[] = '[group]
  MergeCompatibleSystems m group (sys ': rest) =
    If
      (CanAddSystemToGroup m sys group)
      (MergeCompatibleSystems m (AppendToGroup sys group) rest)
      (group ': GroupSystems m (sys ': rest))

type family CanAddSystemToGroup m (sys :: Type) (group :: [Type]) :: Bool where
  CanAddSystemToGroup m sys '[] = 'True
  CanAddSystemToGroup m sys (groupSys ': rest) =
    And
      (Not (HasInputOverlap (SystemInOf m sys) (SystemInOf m groupSys)))
      (CanAddSystemToGroup m sys rest)

type family AppendToGroup (sys :: Type) (group :: [Type]) :: [Type] where
  AppendToGroup sys group = sys ': group

type family If (condition :: Bool) (then_ :: k) (else_ :: k) :: k where
  If 'True then_ else_ = then_
  If 'False then_ else_ = else_

type family GroupsToNestedHSet m (groups :: [[Type]]) :: [Type] where
  GroupsToNestedHSet m '[] = '[]
  GroupsToNestedHSet m (group ': rest) = HSet (MapToIdentityT m group) ': GroupsToNestedHSet m rest

instance Schedule m (HSet '[]) where
  type Scheduled m (HSet '[]) = HSet '[]
  schedule :: HSet '[] -> Scheduled m (HSet '[])
schedule HSet '[]
HEmpty = HSet '[]
Scheduled m (HSet '[])
HEmpty
  {-# INLINE schedule #-}

instance (System m sys) => Schedule m (HSet '[sys]) where
  type Scheduled m (HSet '[sys]) = HSet (GroupsToNestedHSet m (GroupSystems m '[sys]))
  schedule :: HSet '[sys] -> Scheduled m (HSet '[sys])
schedule (HCons t
sys HSet ts1
HEmpty) = HSet '[t] -> HSet '[] -> HSet '[HSet '[t]]
forall t (ts1 :: [*]). t -> HSet ts1 -> HSet (t : ts1)
HCons (t -> HSet '[] -> HSet '[t]
forall t (ts1 :: [*]). t -> HSet ts1 -> HSet (t : ts1)
HCons t
sys HSet '[]
HEmpty) HSet '[]
HEmpty
  {-# INLINE schedule #-}

instance
  ( System m sys,
    AllSystems m rest,
    rest ~ (sys2 ': rest'),
    CompileGroups m (GroupSystems m (sys ': rest)) (sys ': rest)
  ) =>
  Schedule m (HSet (sys ': rest))
  where
  type Scheduled m (HSet (sys ': rest)) = HSet (GroupsToNestedHSet m (GroupSystems m (sys ': rest)))
  schedule :: HSet (sys : rest) -> Scheduled m (HSet (sys : rest))
schedule = forall {k} (m :: k) (groups :: [[*]]) (systems :: [*]).
CompileGroups m groups systems =>
HSet systems -> HSet (GroupsToNestedHSet m groups)
forall (m :: * -> *) (groups :: [[*]]) (systems :: [*]).
CompileGroups m groups systems =>
HSet systems -> HSet (GroupsToNestedHSet m groups)
compileGroups @m @(GroupSystems m (sys ': rest)) @(sys ': rest)
  {-# INLINE schedule #-}

class AllSystems m systems

instance AllSystems m '[]

instance (System m (Run constraints sys), AllSystems m rest) => AllSystems m (Run constraints sys ': rest)

instance {-# OVERLAPPABLE #-} (System m sys, AllSystems m rest) => AllSystems m (sys ': rest)

class CompileGroups m (groups :: [[Type]]) (systems :: [Type]) where
  compileGroups :: HSet systems -> HSet (GroupsToNestedHSet m groups)

instance CompileGroups m '[] systems where
  compileGroups :: HSet systems -> HSet (GroupsToNestedHSet m '[])
compileGroups HSet systems
_ = HSet '[]
HSet (GroupsToNestedHSet m '[])
HEmpty
  {-# INLINE compileGroups #-}

instance (CompileGroup m group systems) => CompileGroups m '[group] systems where
  compileGroups :: HSet systems -> HSet (GroupsToNestedHSet m '[group])
compileGroups HSet systems
systems = HSet (MapToIdentityT m group)
-> HSet '[] -> HSet '[HSet (MapToIdentityT m group)]
forall t (ts1 :: [*]). t -> HSet ts1 -> HSet (t : ts1)
HCons (forall (m :: k) (group :: [*]) (systems :: [*]).
CompileGroup m group systems =>
HSet systems -> HSet (MapToIdentityT m group)
forall {k} (m :: k) (group :: [*]) (systems :: [*]).
CompileGroup m group systems =>
HSet systems -> HSet (MapToIdentityT m group)
compileGroup @m @group @systems HSet systems
systems) HSet '[]
HEmpty
  {-# INLINE compileGroups #-}

instance
  (CompileGroup m group systems, CompileGroups m rest systems) =>
  CompileGroups m (group ': rest) systems
  where
  compileGroups :: HSet systems -> HSet (GroupsToNestedHSet m (group : rest))
compileGroups HSet systems
systems =
    HSet (MapToIdentityT m group)
-> HSet (GroupsToNestedHSet m rest)
-> HSet (HSet (MapToIdentityT m group) : GroupsToNestedHSet m rest)
forall t (ts1 :: [*]). t -> HSet ts1 -> HSet (t : ts1)
HCons (forall (m :: k) (group :: [*]) (systems :: [*]).
CompileGroup m group systems =>
HSet systems -> HSet (MapToIdentityT m group)
forall {k} (m :: k) (group :: [*]) (systems :: [*]).
CompileGroup m group systems =>
HSet systems -> HSet (MapToIdentityT m group)
compileGroup @m @group @systems HSet systems
systems) (forall (m :: k) (groups :: [[*]]) (systems :: [*]).
CompileGroups m groups systems =>
HSet systems -> HSet (GroupsToNestedHSet m groups)
forall {k} (m :: k) (groups :: [[*]]) (systems :: [*]).
CompileGroups m groups systems =>
HSet systems -> HSet (GroupsToNestedHSet m groups)
compileGroups @m @rest @systems HSet systems
systems)
  {-# INLINE compileGroups #-}

class CompileGroup m (group :: [Type]) (systems :: [Type]) where
  compileGroup :: HSet systems -> HSet (MapToIdentityT m group)

type family MapToIdentityT m (systems :: [Type]) :: [Type] where
  MapToIdentityT m '[] = '[]
  MapToIdentityT m (sys ': rest) = sys ': MapToIdentityT m rest

instance CompileGroup m '[] systems where
  compileGroup :: HSet systems -> HSet (MapToIdentityT m '[])
compileGroup HSet systems
_ = HSet '[]
HSet (MapToIdentityT m '[])
HEmpty
  {-# INLINE compileGroup #-}

instance (ExtractSystem m sys systems) => CompileGroup m '[sys] systems where
  compileGroup :: HSet systems -> HSet (MapToIdentityT m '[sys])
compileGroup HSet systems
systems = sys -> HSet '[] -> HSet '[sys]
forall t (ts1 :: [*]). t -> HSet ts1 -> HSet (t : ts1)
HCons (forall (m :: k) sys (systems :: [*]).
ExtractSystem m sys systems =>
HSet systems -> sys
forall {k} (m :: k) sys (systems :: [*]).
ExtractSystem m sys systems =>
HSet systems -> sys
extractSystem @m @sys @systems HSet systems
systems) HSet '[]
HEmpty
  {-# INLINE compileGroup #-}

instance
  (ExtractSystem m sys systems, CompileGroup m rest systems) =>
  CompileGroup m (sys ': rest) systems
  where
  compileGroup :: HSet systems -> HSet (MapToIdentityT m (sys : rest))
compileGroup HSet systems
systems =
    sys
-> HSet (MapToIdentityT m rest)
-> HSet (sys : MapToIdentityT m rest)
forall t (ts1 :: [*]). t -> HSet ts1 -> HSet (t : ts1)
HCons (forall (m :: k) sys (systems :: [*]).
ExtractSystem m sys systems =>
HSet systems -> sys
forall {k} (m :: k) sys (systems :: [*]).
ExtractSystem m sys systems =>
HSet systems -> sys
extractSystem @m @sys @systems HSet systems
systems) (forall (m :: k) (group :: [*]) (systems :: [*]).
CompileGroup m group systems =>
HSet systems -> HSet (MapToIdentityT m group)
forall {k} (m :: k) (group :: [*]) (systems :: [*]).
CompileGroup m group systems =>
HSet systems -> HSet (MapToIdentityT m group)
compileGroup @m @rest @systems HSet systems
systems)
  {-# INLINE compileGroup #-}

class ExtractSystem m (sys :: Type) (systems :: [Type]) where
  extractSystem :: HSet systems -> sys

instance ExtractSystem m sys (sys ': rest) where
  extractSystem :: HSet (sys : rest) -> sys
extractSystem (HCons t
sys HSet ts1
_) = sys
t
sys
  {-# INLINE extractSystem #-}

instance (ExtractSystem m sys rest) => ExtractSystem m sys (other ': rest) where
  extractSystem :: HSet (other : rest) -> sys
extractSystem (HCons t
_ HSet ts1
rest) = forall (m :: k) sys (systems :: [*]).
ExtractSystem m sys systems =>
HSet systems -> sys
forall {k} (m :: k) sys (systems :: [*]).
ExtractSystem m sys systems =>
HSet systems -> sys
extractSystem @m @sys @rest HSet rest
HSet ts1
rest
  {-# INLINE extractSystem #-}

data Before (sys :: Type)

data After (sys :: Type)

data Run (constraints :: [Type]) (sys :: Type) where
  Run :: sys -> Run constraints sys

type family UnwrapSystem (runSys :: Type) :: Type where
  UnwrapSystem (Run constraints sys) = sys
  UnwrapSystem sys = sys

type family GetConstraints (runSys :: Type) :: [Type] where
  GetConstraints (Run constraints sys) = constraints
  GetConstraints sys = '[]

instance (Show sys) => Show (Run constraints sys) where
  show :: Run constraints sys -> String
show (Run sys
sys) = String
"Run " String -> ShowS
forall a. [a] -> [a] -> [a]
++ sys -> String
forall a. Show a => a -> String
show sys
sys

instance (System m sys) => System m (Run constraints sys) where
  type SystemIn m (Run constraints sys) = SystemIn m sys
  runSystem :: Run constraints sys -> SystemIn m (Run constraints sys) -> m ()
runSystem (Run sys
sys) = sys -> SystemIn m sys -> m ()
forall (m :: * -> *) sys.
System m sys =>
sys -> SystemIn m sys -> m ()
runSystem sys
sys
  {-# INLINE runSystem #-}