{- ORMOLU_DISABLE -}
-- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)
-- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com)
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Released under the GNU AGPLV3+, see LICENSE
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module Graphics.Implicit.ObjectUtil.GetImplicitShared (getImplicitShared, normalize) where

import {-# SOURCE #-} Graphics.Implicit.Primitives (Object(getImplicit'))

import Prelude (flip, (-), (*), (>), (<), (&&), (/), product, abs, (**), fmap, (.), negate, ($), const)

import Graphics.Implicit.Definitions
    ( objectRounding, ObjectContext, SharedObj(Empty, Full, Complement, UnionR, IntersectR, DifferenceR, Translate, Scale, Mirror, Shell, Outset, EmbedBoxedObj, WithRounding), ComponentWiseMultable((⋯/)), ℝ, minℝ )

import Graphics.Implicit.MathUtil (infty, rmax, rmaximum, rminimum, reflect)

-- Use getImplicit2 for handling extrusion of 2D shapes to 3D.
import Graphics.Implicit.ObjectUtil.GetBoxShared (VectorStuff(elements, uniformV))

import Linear (Metric(dot))

------------------------------------------------------------------------------
-- | Normalize a dimensionality-polymorphic vector.
normalize
    :: forall f
     . (VectorStuff (f ℝ), Metric f)
    => f ℝ
    -> ℝ
normalize :: f ℝ -> ℝ
normalize f ℝ
v =
  let all1s :: f ℝ
all1s = ℝ -> f ℝ
forall vec. VectorStuff vec => ℝ -> vec
uniformV @(f ℝ) ℝ
1
   in ℝ -> ℝ
forall a. Num a => a -> a
abs ([ℝ] -> ℝ
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product (f ℝ -> [ℝ]
forall vec. VectorStuff vec => vec -> [ℝ]
elements f ℝ
v)) ℝ -> ℝ -> ℝ
forall a. Floating a => a -> a -> a
** (ℝ
1 ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ (f ℝ
all1s f ℝ -> f ℝ -> ℝ
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` f ℝ
all1s))

-- Get a function that describes the surface of the object.
getImplicitShared
    :: forall obj f
     . ( Object obj f ℝ
       , VectorStuff (f ℝ)
       , ComponentWiseMultable (f ℝ)
       , Metric f
       )
    => ObjectContext
    -> SharedObj obj f ℝ
    -> f ℝ
    -> ℝ
getImplicitShared :: ObjectContext -> SharedObj obj f ℝ -> f ℝ -> ℝ
getImplicitShared ObjectContext
_ SharedObj obj f ℝ
Empty = ℝ -> f ℝ -> ℝ
forall a b. a -> b -> a
const ℝ
forall t. Fractional t => t
infty
getImplicitShared ObjectContext
_ SharedObj obj f ℝ
Full = ℝ -> f ℝ -> ℝ
forall a b. a -> b -> a
const (ℝ -> f ℝ -> ℝ) -> ℝ -> f ℝ -> ℝ
forall a b. (a -> b) -> a -> b
$ -ℝ
forall t. Fractional t => t
infty
getImplicitShared ObjectContext
ctx (Complement obj
symbObj) =
  ℝ -> ℝ
forall a. Num a => a -> a
negate (ℝ -> ℝ) -> (f ℝ -> ℝ) -> f ℝ -> ℝ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectContext -> obj -> f ℝ -> ℝ
forall obj (f :: * -> *) a.
Object obj f a =>
ObjectContext -> obj -> f a -> a
getImplicit' ObjectContext
ctx obj
symbObj
getImplicitShared ObjectContext
ctx (UnionR ℝ
_ []) =
  ObjectContext -> SharedObj obj f ℝ -> f ℝ -> ℝ
forall obj (f :: * -> *).
(Object obj f ℝ, VectorStuff (f ℝ), ComponentWiseMultable (f ℝ),
 Metric f) =>
ObjectContext -> SharedObj obj f ℝ -> f ℝ -> ℝ
getImplicitShared @obj ObjectContext
ctx SharedObj obj f ℝ
forall obj (f :: * -> *) a. SharedObj obj f a
Empty
getImplicitShared ObjectContext
ctx (UnionR ℝ
r [obj]
symbObjs) = \f ℝ
p ->
  ℝ -> [ℝ] -> ℝ
rminimum ℝ
r ([ℝ] -> ℝ) -> [ℝ] -> ℝ
forall a b. (a -> b) -> a -> b
$ (obj -> ℝ) -> [obj] -> [ℝ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((obj -> f ℝ -> ℝ) -> f ℝ -> obj -> ℝ
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ObjectContext -> obj -> f ℝ -> ℝ
forall obj (f :: * -> *) a.
Object obj f a =>
ObjectContext -> obj -> f a -> a
getImplicit' ObjectContext
ctx) f ℝ
p) [obj]
symbObjs
getImplicitShared ObjectContext
ctx (IntersectR ℝ
_ []) =
  ObjectContext -> SharedObj obj f ℝ -> f ℝ -> ℝ
forall obj (f :: * -> *).
(Object obj f ℝ, VectorStuff (f ℝ), ComponentWiseMultable (f ℝ),
 Metric f) =>
ObjectContext -> SharedObj obj f ℝ -> f ℝ -> ℝ
getImplicitShared @obj ObjectContext
ctx SharedObj obj f ℝ
forall obj (f :: * -> *) a. SharedObj obj f a
Full
getImplicitShared ObjectContext
ctx (IntersectR ℝ
r [obj]
symbObjs) = \f ℝ
p ->
  ℝ -> [ℝ] -> ℝ
rmaximum ℝ
r ([ℝ] -> ℝ) -> [ℝ] -> ℝ
forall a b. (a -> b) -> a -> b
$ (obj -> ℝ) -> [obj] -> [ℝ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((obj -> f ℝ -> ℝ) -> f ℝ -> obj -> ℝ
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ObjectContext -> obj -> f ℝ -> ℝ
forall obj (f :: * -> *) a.
Object obj f a =>
ObjectContext -> obj -> f a -> a
getImplicit' ObjectContext
ctx) f ℝ
p) [obj]
symbObjs
getImplicitShared ObjectContext
ctx (DifferenceR ℝ
_ obj
symbObj []) =
  ObjectContext -> obj -> f ℝ -> ℝ
forall obj (f :: * -> *) a.
Object obj f a =>
ObjectContext -> obj -> f a -> a
getImplicit' ObjectContext
ctx obj
symbObj
getImplicitShared ObjectContext
ctx (DifferenceR ℝ
r obj
symbObj [obj]
symbObjs) =
    let headObj :: f ℝ -> ℝ
headObj = ObjectContext -> obj -> f ℝ -> ℝ
forall obj (f :: * -> *) a.
Object obj f a =>
ObjectContext -> obj -> f a -> a
getImplicit' ObjectContext
ctx obj
symbObj
    in
      \f ℝ
p -> do
        let
          maxTail :: ℝ
maxTail = ℝ -> [ℝ] -> ℝ
rmaximum ℝ
r
                  ([ℝ] -> ℝ) -> [ℝ] -> ℝ
forall a b. (a -> b) -> a -> b
$ (obj -> ℝ) -> [obj] -> [ℝ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SharedObj obj f ℝ -> f ℝ -> ℝ) -> f ℝ -> SharedObj obj f ℝ -> ℝ
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ObjectContext -> SharedObj obj f ℝ -> f ℝ -> ℝ
forall obj (f :: * -> *).
(Object obj f ℝ, VectorStuff (f ℝ), ComponentWiseMultable (f ℝ),
 Metric f) =>
ObjectContext -> SharedObj obj f ℝ -> f ℝ -> ℝ
getImplicitShared ObjectContext
ctx) f ℝ
p (SharedObj obj f ℝ -> ℝ) -> (obj -> SharedObj obj f ℝ) -> obj -> ℝ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. obj -> SharedObj obj f ℝ
forall obj (f :: * -> *) a. obj -> SharedObj obj f a
Complement) [obj]
symbObjs
        if ℝ
maxTail ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
> -ℝ
minℝ Bool -> Bool -> Bool
&& ℝ
maxTail ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
< ℝ
minℝ
          then ℝ -> ℝ -> ℝ -> ℝ
rmax ℝ
r (f ℝ -> ℝ
headObj f ℝ
p) ℝ
minℝ
          else ℝ -> ℝ -> ℝ -> ℝ
rmax ℝ
r (f ℝ -> ℝ
headObj f ℝ
p) ℝ
maxTail

-- Simple transforms
getImplicitShared ObjectContext
ctx (Translate f ℝ
v obj
symbObj) = \f ℝ
p ->
  ObjectContext -> obj -> f ℝ -> ℝ
forall obj (f :: * -> *) a.
Object obj f a =>
ObjectContext -> obj -> f a -> a
getImplicit' ObjectContext
ctx obj
symbObj (f ℝ
p f ℝ -> f ℝ -> f ℝ
forall a. Num a => a -> a -> a
- f ℝ
v)
getImplicitShared ObjectContext
ctx (Scale f ℝ
s obj
symbObj) = \f ℝ
p ->
  f ℝ -> ℝ
forall (f :: * -> *). (VectorStuff (f ℝ), Metric f) => f ℝ -> ℝ
normalize f ℝ
s ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
* ObjectContext -> obj -> f ℝ -> ℝ
forall obj (f :: * -> *) a.
Object obj f a =>
ObjectContext -> obj -> f a -> a
getImplicit' ObjectContext
ctx obj
symbObj (f ℝ
p f ℝ -> f ℝ -> f ℝ
forall a. ComponentWiseMultable a => a -> a -> a
⋯/ f ℝ
s)
getImplicitShared ObjectContext
ctx (Mirror f ℝ
v obj
symbObj) =
    ObjectContext -> obj -> f ℝ -> ℝ
forall obj (f :: * -> *) a.
Object obj f a =>
ObjectContext -> obj -> f a -> a
getImplicit' ObjectContext
ctx obj
symbObj (f ℝ -> ℝ) -> (f ℝ -> f ℝ) -> f ℝ -> ℝ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f ℝ -> f ℝ -> f ℝ
forall (f :: * -> *) a.
(Num (f a), Fractional a, Metric f) =>
f a -> f a -> f a
reflect f ℝ
v
-- Boundary mods
getImplicitShared ObjectContext
ctx (Shell ℝ
w obj
symbObj) = \f ℝ
p ->
  ℝ -> ℝ
forall a. Num a => a -> a
abs (ObjectContext -> obj -> f ℝ -> ℝ
forall obj (f :: * -> *) a.
Object obj f a =>
ObjectContext -> obj -> f a -> a
getImplicit' ObjectContext
ctx obj
symbObj f ℝ
p) ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
wℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
2
getImplicitShared ObjectContext
ctx (Outset ℝ
d obj
symbObj) = \f ℝ
p ->
  ObjectContext -> obj -> f ℝ -> ℝ
forall obj (f :: * -> *) a.
Object obj f a =>
ObjectContext -> obj -> f a -> a
getImplicit' ObjectContext
ctx obj
symbObj f ℝ
p ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
d
-- Misc
getImplicitShared ObjectContext
_ (EmbedBoxedObj (f ℝ -> ℝ
obj,(f ℝ, f ℝ)
_)) = f ℝ -> ℝ
obj
getImplicitShared ObjectContext
ctx (WithRounding ℝ
r obj
obj) = ObjectContext -> obj -> f ℝ -> ℝ
forall obj (f :: * -> *) a.
Object obj f a =>
ObjectContext -> obj -> f a -> a
getImplicit' (ObjectContext
ctx { objectRounding :: ℝ
objectRounding = ℝ
r }) obj
obj