From a80a7f749ecf7e145c154f1cfc323010cb9ffb83 Mon Sep 17 00:00:00 2001
From: TQ Hirsch <thequux@thequux.com>
Date: Sun, 9 Oct 2022 13:21:45 +0200
Subject: [PATCH] Added tool to join vectors

---
 lib/Petzval/Internal/Vec.hs | 95 +++++++++++++++++++++++++++++++++++++
 petzval-hs.cabal            |  4 +-
 2 files changed, 98 insertions(+), 1 deletion(-)
 create mode 100644 lib/Petzval/Internal/Vec.hs

diff --git a/lib/Petzval/Internal/Vec.hs b/lib/Petzval/Internal/Vec.hs
new file mode 100644
index 0000000..2f8e44e
--- /dev/null
+++ b/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
+
diff --git a/petzval-hs.cabal b/petzval-hs.cabal
index 1e9a0f6..834987a 100644
--- a/petzval-hs.cabal
+++ b/petzval-hs.cabal
@@ -46,9 +46,11 @@ library
         Petzval.Optics.RTM
         Petzval.System
         Petzval.Trace
+    other-modules:
+        Petzval.Internal.Vec
     hs-source-dirs: lib
     build-depends:    base   ^>=4.15.1.0,
                       lens   ^>=5.2,
                       ad     ^>=4.5.2,
                       linear ^>=1.21,
-        
\ No newline at end of file
+                      mtl    ^>=2.2