attempted geometry as functions

CSG.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}

-- |
--
-- Constructive solid geometry. Not quite FRep or signed distance function.
module CSG where

import qualified Data.IntSet as Set
import Data.Vector (Vector)
import qualified Data.Vector as V
import Linear
import Linear.Plucker

type P = V3 Float

-- | A shell or wire
type Flat = F Float P

-- | A solid. true when the query point is inside the solid
type Full = F Float (Bool, P)

data F1 a b = F1 (Vector (Maybe (V2 a))) (Vector a -> b)

newtype F a b = F_ (F1 a (V3 a -> b))

pattern F a b = F_ (F1 a b)

instance Functor (F a) where
  fmap f (F n mf) = F n (\v p -> f $ mf v p)

instance Applicative (F a) where
  pure x = F mempty (\_ _ -> x)
  F n mf1 <*> F m mf2 = F (n <> m) (\ab p -> case V.splitAt (V.length n) ab of (a, b) -> mf1 a p $ mf2 b p)

instance Functor (F1 a) where
  fmap f (F1 n mf) = F1 n (f . mf)

instance Applicative (F1 a) where
  pure x = F1 mempty (\_ -> x)
  F1 n mf1 <*> F1 m mf2 = F1 (n <> m) (\ab -> case V.splitAt (V.length n) ab of (a, b) -> mf1 a $ mf2 b)

ask :: F a (V3 a)
ask = F [] \_ p -> p

local :: (V3 a -> V3 a) -> F a b -> F a b
local f (F b g) = F b (\b' p -> g b' (f p))

seg :: P -> P -> Flat
seg a b = F [] \_ -> closestOnSegment a b

boundary :: Flat -> Full
boundary = liftA2 (\q p -> (nearZero (qd p q), p)) ask

extrude :: V3 Float -> Full -> Full
extrude t g = do
  ~(b, x) <- g
  y <- seg 0 t
  pure (b, x + y)

union :: Full -> Full -> Full
union f g = do
  ~(b, x) <- f
  ~(c, y) <- g
  p <- ask
  pure (max b c, closest1 p x y)

intersection :: Full -> Full -> Full
intersection (F_ f) (F_ g) = F_ do
  a <- f
  b <- g
  pure \p -> mush (b <$> a p) & mush (a <$> b p) $ p
  where
    (&) (a, x) (b, y) p = (a && b, closest1 p x y)
    mush (b, (c, x)) = (b && c, x)

cut a b = _

-- line
-- strip
-- polygon, circle, dxf
-- extrude, loft, pipe, helix

closest1 p = closest2 p p

closest2 :: P -> P -> P -> P -> P
closest2 p q a b | qd p a < qd q b = a | otherwise = b

-- * from hgcode

closestOnSegment :: (Ord a, Fractional a) => V3 a -> V3 a -> V3 a -> V3 a
closestOnSegment a b p =
  let q = closestToOrigin (plucker3D (a - p) (b - p)) + p
      a1 = lerpi (V2 a b) p
   in if a1 < 0
        then a
        else
          if a1 > 1
            then b
            else q

-- | lerpi = lerp inverse
--
-- > lerpi (V2 a b) (lerp x a b) == x
-- > lerp (lerpi (V2 a b) x) a b == x
lerpi :: (Fractional a, Metric f) => V2 (f a) -> f a -> a
lerpi (V2 a b) p = (p ^-^ a) `dot` (b ^-^ a) / qd b a