{-# LANGUAGE TypeFamilies, ViewPatterns, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
module Petzval.Internal.Vec where

import Linear

-- | Vector that can be shrunk by one element.
-- Laws:
-- @
-- (uncurry vextR) . vshrinkR = id
-- (uncurry vextL) . vshrinkL = id
-- @
class VExtend (v :: * -> *) where
  type VExtended (v :: * -> *) :: * -> *
  vextR :: v a -> a -> VExtended v a
  vextL :: a -> v a -> VExtended v a

class VShrink (v :: * -> *) where
  type VShrunk (v :: * -> *) :: * -> *
  vshrinkR :: v a -> (VShrunk v a, a)
  vshrinkL :: v a -> (a, VShrunk v a)

class VEmpty (v :: * -> *)

class VConcat (v1 :: * -> *) (v2 :: * -> *) where
  type VConcated v1 v2 :: * -> *
  vconcat :: v1 a -> v2 a -> (VConcated v1 v2) a

instance {-# OVERLAPPED #-}  VConcat V0 v where
  type VConcated V0 v = v
  vconcat V0 v = v


-- I'd love for this to work, but alas, it's incoherent because the constraints are ignored during matching
--instance {-# OVERLAPPABLE #-} (VShrink v1, VExtend v2, VConcat (VShrunk v1) (VExtended v2)) => VConcat v1 v2 where
--  type VConcated v1 v2 = VConcated (VShrunk v1) (VExtended v2)
--  vconcat (vshrinkR -> (v1, a)) v2 = vconcat v1 $ vextL a v2

instance (VExtend v) => VConcat V1 v where
  type VConcated V1 v = VExtended v
  vconcat (V1 a) v = vextL a v

instance (VExtend v, VConcat V1 (VExtended v)) => VConcat V2 v where
  type VConcated V2 v = VConcated V1 (VExtended v)
  vconcat (vshrinkR -> (v1,a)) v2 = v1 `vconcat` vextL a v2

instance (VExtend v, VConcat V2 (VExtended v)) => VConcat V3 v where
  type VConcated V3 v = VConcated V2 (VExtended v)
  vconcat (vshrinkR -> (v1,a)) v2 = v1 `vconcat` vextL a v2

instance (VExtend v, VConcat V3 (VExtended v)) => VConcat V4 v where
  type VConcated V4 v = VConcated V3 (VExtended v)
  vconcat (vshrinkR -> (v1,a)) v2 = v1 `vconcat` vextL a v2

-- shrink instances
instance VShrink V1 where
  type VShrunk V1 = V0
  vshrinkL (V1 a) = (a, V0)
  vshrinkR (V1 a) = (V0, a)

instance VShrink V2 where
  type VShrunk V2 = V1
  vshrinkL (V2 a b) = (a, V1 b)
  vshrinkR (V2 a b) = (V1 a, b)

instance VShrink V3 where
  type VShrunk V3 = V2
  vshrinkL (V3 a b c) = (a, V2 b c)
  vshrinkR (V3 a b c) = (V2 a b, c)

instance VShrink V4 where
  type VShrunk V4 = V3
  vshrinkL (V4 a b c d) = (a, V3 b c d)
  vshrinkR (V4 a b c d) = (V3 a b c, d)
  
-- extend instances
instance VExtend V0 where
  type VExtended V0 = V1
  vextL a V0 = V1 a
  vextR V0 a = V1 a
  
instance VExtend V1 where
  type VExtended V1 = V2
  vextL e (V1 a) = V2 e a
  vextR (V1 a) e = V2 a e

instance VExtend V2 where
  type VExtended V2 = V3
  vextL e (V2 a b) = V3 e a b
  vextR (V2 a b) e = V3 a b e

instance VExtend V3 where
  type VExtended V3 = V4
  vextL e (V3 a b c) = V4 e a b c
  vextR (V3 a b c) e = V4 a b c e