From 1c8f2881bc322f13c84e772c9f79f56eba593b16 Mon Sep 17 00:00:00 2001
From: Richard Marko <srk@48.io>
Date: Tue, 16 Aug 2022 08:11:26 +0200
Subject: [PATCH] ilerp experiment

---
 example-haskell/SomeModule.hs | 54 +++++++++++++++++++++++++++++++++--
 1 file changed, 52 insertions(+), 2 deletions(-)

diff --git a/example-haskell/SomeModule.hs b/example-haskell/SomeModule.hs
index 8784009..d5bc4de 100644
--- a/example-haskell/SomeModule.hs
+++ b/example-haskell/SomeModule.hs
@@ -1,14 +1,64 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module SomeModule where
 
+import Control.Applicative
 import Linear
 import Graphics.Implicit
 import Graphics.Implicit.Primitives
+--import Graphics.Implicit.ObjectUtil.GetBoxShared
 
 import SomeOtherModule
 
-res = 2
+--res = 0.016
+res = 0.5
 
-obj = union $ [
+ilerp
+  :: forall obj f . (Object obj (f ℝ), Applicative f, Semigroup obj)
+  => ℝ
+  -> obj
+  -> obj
+  -> obj
+ilerp s a b = implicit
+  (\i ->
+    (1 - s) * getImplicit a i
+  +      s  * getImplicit b i
+  )
+  $ --(getBox a) <> (getBox b)
+  getBox $
+    (scale :: f ℝ -> obj -> obj) (pure (1-s)) a
+    <> (scale :: f ℝ -> obj -> obj) (pure s) b
+--        <> b
+
+ilerp'
+  :: forall obj f . (Object obj (f ℝ), Applicative f, Semigroup obj)
+  => ℝ
+  -> obj
+  -> obj
+  -> obj
+ilerp' s a b = implicit
+  (\i ->
+    (1 - s) * getImplicit a i
+  +      s  * getImplicit b i
+  )
+  $ --(getBox a) <> (getBox b)
+    let (a1 :: f ℝ, b1) = getBox a
+        (a2 :: f ℝ, b2) = getBox a
+        sa1 = liftA2 (*) (pure $ 1 - s) a1
+        sb1 = liftA2 (*) (pure $ 1 - s) b1
+        sa2 = liftA2 (*) (pure s) a2
+        sb2 = liftA2 (*) (pure s) b2
+    in pointsBox [sa1, sb1, sa2, sb2]
+
+pointsBox :: (Applicative f, Ord a, Num a) => [f a] -> (f a, f a)
+pointsBox [] = (pure 0, pure 0)
+pointsBox (a : as) = (foldr (liftA2 min) a as, foldr (liftA2 max) a as)
+
+obj = ilerp' 1.0 (cube False (pure 3)) (cylinder2 7 5 6)
+--obj = cube False (V3 3 0.095 0.045)
+
+objz = union $ [
     cube False (V3 20 20 14)
   , translate (V3 20 20 20) (sphere 15)
   , translate (V3 30 20 20) (sphere 5)