Internal.hs

{-# 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 HEmpty = HEmpty
  {-# INLINE schedule #-}

instance (System m sys) => Schedule m (HSet '[sys]) where
  type Scheduled m (HSet '[sys]) = HSet (GroupsToNestedHSet m (GroupSystems m '[sys]))
  schedule (HCons sys HEmpty) = HCons (HCons sys HEmpty) 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 = 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 _ = HEmpty
  {-# INLINE compileGroups #-}

instance (CompileGroup m group systems) => CompileGroups m '[group] systems where
  compileGroups systems = HCons (compileGroup @m @group @systems systems) HEmpty
  {-# INLINE compileGroups #-}

instance
  (CompileGroup m group systems, CompileGroups m rest systems) =>
  CompileGroups m (group ': rest) systems
  where
  compileGroups systems =
    HCons (compileGroup @m @group @systems systems) (compileGroups @m @rest @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 _ = HEmpty
  {-# INLINE compileGroup #-}

instance (ExtractSystem m sys systems) => CompileGroup m '[sys] systems where
  compileGroup systems = HCons (extractSystem @m @sys @systems systems) HEmpty
  {-# INLINE compileGroup #-}

instance
  (ExtractSystem m sys systems, CompileGroup m rest systems) =>
  CompileGroup m (sys ': rest) systems
  where
  compileGroup systems =
    HCons (extractSystem @m @sys @systems systems) (compileGroup @m @rest @systems systems)
  {-# INLINE compileGroup #-}

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

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

instance (ExtractSystem m sys rest) => ExtractSystem m sys (other ': rest) where
  extractSystem (HCons _ rest) = extractSystem @m @sys @rest 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 sys) = "Run " ++ show sys

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