Added tool to join vectors

lib/Petzval/Internal/Vec.hs

@@ -0,0 +1,95 @@
+{-# 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
+