{- ORMOLU_DISABLE -}
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Copyright (C) 2016, Julia Longtin (julial@turinglace.com)
-- Released under the GNU AGPLV3+, see LICENSE

{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns     #-}

module Graphics.Implicit.ObjectUtil.GetImplicit2 (getImplicit2) where

import Prelude(cycle, (/=), uncurry, fst, Eq, zip, drop, abs, (-), (/), sqrt, (*), (+), length, fmap, (<=), (&&), (>=), (||), odd, ($), (>), filter, (<), minimum, (.), sin, cos)

import Graphics.Implicit.Definitions
    ( objectRounding, ObjectContext, SymbolicObj2(Square, Circle, Polygon, Rotate2, Transform2, Shared2), SharedObj (Empty), Obj2, ℝ2, ℝ )

import Graphics.Implicit.MathUtil
    ( distFromLineSeg, rmaximum )

import Data.List (nub)
import Graphics.Implicit.ObjectUtil.GetImplicitShared (getImplicitShared)
import Linear (V2(V2), V3(V3))
import qualified Linear

------------------------------------------------------------------------------
-- | Filter out equal consecutive elements in the list. This function will
-- additionally trim the last element of the list if it's equal to the first.
scanUniqueCircular :: Eq a => [a] -> [a]
scanUniqueCircular :: [a] -> [a]
scanUniqueCircular
    = ((a, a) -> a) -> [(a, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, a) -> a
forall a b. (a, b) -> a
fst
    ([(a, a)] -> [a]) -> ([a] -> [(a, a)]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> a -> Bool) -> (a, a) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(/=))
    ([(a, a)] -> [(a, a)]) -> ([a] -> [(a, a)]) -> [a] -> [(a, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [(a, a)]
forall a. [a] -> [(a, a)]
circularPairs

------------------------------------------------------------------------------
-- | Given @[a, b, c, ... n]@, return the pairs @[(a, b), (b, c), ... (n, a)]@.
circularPairs :: [a] -> [(a,a)]
circularPairs :: [a] -> [(a, a)]
circularPairs [a]
as = [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
as ([a] -> [(a, a)]) -> [a] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
cycle [a]
as

getImplicit2 :: ObjectContext -> SymbolicObj2 -> Obj2
-- Primitives
getImplicit2 :: ObjectContext -> SymbolicObj2 -> Obj2
getImplicit2 ObjectContext
ctx (Square (V2 ℝ
dx ℝ
dy)) =
    \(V2 ℝ
x ℝ
y) -> ℝ -> [ℝ] -> ℝ
rmaximum (ObjectContext -> ℝ
objectRounding ObjectContext
ctx) [ℝ -> ℝ
forall a. Num a => a -> a
abs (ℝ
xℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
dxℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
2) ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
dxℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
2, ℝ -> ℝ
forall a. Num a => a -> a
abs (ℝ
yℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
dyℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
2) ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
dyℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
2]
getImplicit2 ObjectContext
_ (Circle ℝ
r) =
    \(V2 ℝ
x ℝ
y) -> ℝ -> ℝ
forall a. Floating a => a -> a
sqrt (ℝ
x ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
* ℝ
x ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ ℝ
y ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
* ℝ
y) ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
r
-- FIXME: stop ignoring rounding for polygons.
getImplicit2 ObjectContext
_ (Polygon ([V2 ℝ] -> [V2 ℝ]
forall a. Eq a => [a] -> [a]
scanUniqueCircular -> points :: [V2 ℝ]
points@(V2 ℝ
_:V2 ℝ
_:V2 ℝ
_:[V2 ℝ]
_))) =
    \V2 ℝ
p -> let
        pairs :: [(ℝ2,ℝ2)]
        pairs :: [(V2 ℝ, V2 ℝ)]
pairs =  [V2 ℝ] -> [(V2 ℝ, V2 ℝ)]
forall a. [a] -> [(a, a)]
circularPairs [V2 ℝ]
points
        relativePairs :: [(V2 ℝ, V2 ℝ)]
relativePairs =  ((V2 ℝ, V2 ℝ) -> (V2 ℝ, V2 ℝ)) -> [(V2 ℝ, V2 ℝ)] -> [(V2 ℝ, V2 ℝ)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(V2 ℝ
a,V2 ℝ
b) -> (V2 ℝ
a V2 ℝ -> V2 ℝ -> V2 ℝ
forall a. Num a => a -> a -> a
- V2 ℝ
p, V2 ℝ
b V2 ℝ -> V2 ℝ -> V2 ℝ
forall a. Num a => a -> a -> a
- V2 ℝ
p) ) [(V2 ℝ, V2 ℝ)]
pairs
        crossing_points :: [ℝ]
crossing_points =
            [ℝ
x2 ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
y2ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*(ℝ
x2ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
x1)ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/(ℝ
y2ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
y1) | (V2 ℝ
x1 ℝ
y1, V2 ℝ
x2 ℝ
y2) <- [(V2 ℝ, V2 ℝ)]
relativePairs,
               ( (ℝ
y2 ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
<= ℝ
0) Bool -> Bool -> Bool
&& (ℝ
y1 ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
>= ℝ
0) ) Bool -> Bool -> Bool
|| ( (ℝ
y2 ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
>= ℝ
0) Bool -> Bool -> Bool
&& (ℝ
y1 ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
<= ℝ
0) ) ]
        -- FIXME: use partition instead?
        seemsInRight :: Bool
seemsInRight = Int -> Bool
forall a. Integral a => a -> Bool
odd (Int -> Bool) -> ([ℝ] -> Int) -> [ℝ] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ℝ] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ℝ] -> Int) -> ([ℝ] -> [ℝ]) -> [ℝ] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ℝ -> Bool) -> [ℝ] -> [ℝ]
forall a. (a -> Bool) -> [a] -> [a]
filter (ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
>ℝ
0) ([ℝ] -> Bool) -> [ℝ] -> Bool
forall a b. (a -> b) -> a -> b
$ [ℝ] -> [ℝ]
forall a. Eq a => [a] -> [a]
nub [ℝ]
crossing_points
        seemsInLeft :: Bool
seemsInLeft = Int -> Bool
forall a. Integral a => a -> Bool
odd (Int -> Bool) -> ([ℝ] -> Int) -> [ℝ] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ℝ] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ℝ] -> Int) -> ([ℝ] -> [ℝ]) -> [ℝ] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ℝ -> Bool) -> [ℝ] -> [ℝ]
forall a. (a -> Bool) -> [a] -> [a]
filter (ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
<ℝ
0) ([ℝ] -> Bool) -> [ℝ] -> Bool
forall a b. (a -> b) -> a -> b
$ [ℝ] -> [ℝ]
forall a. Eq a => [a] -> [a]
nub [ℝ]
crossing_points
        isIn :: Bool
isIn = Bool
seemsInRight Bool -> Bool -> Bool
&& Bool
seemsInLeft
        dists :: [ℝ]
        dists :: [ℝ]
dists = ((V2 ℝ, V2 ℝ) -> ℝ) -> [(V2 ℝ, V2 ℝ)] -> [ℝ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (V2 ℝ -> (V2 ℝ, V2 ℝ) -> ℝ
distFromLineSeg V2 ℝ
p) [(V2 ℝ, V2 ℝ)]
pairs
    in
        [ℝ] -> ℝ
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [ℝ]
dists ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
* if Bool
isIn then -ℝ
1 else ℝ
1
getImplicit2 ObjectContext
ctx (Polygon [V2 ℝ]
_) = ObjectContext -> SharedObj SymbolicObj2 V2 ℝ -> Obj2
forall obj (f :: * -> *).
(Object obj f ℝ, VectorStuff (f ℝ), ComponentWiseMultable (f ℝ),
 Metric f) =>
ObjectContext -> SharedObj obj f ℝ -> f ℝ -> ℝ
getImplicitShared @SymbolicObj2 ObjectContext
ctx SharedObj SymbolicObj2 V2 ℝ
forall obj (f :: * -> *) a. SharedObj obj f a
Empty
-- (Rounded) CSG
getImplicit2 ObjectContext
ctx (Rotate2 ℝ
θ SymbolicObj2
symbObj) =
    \(V2 ℝ
x ℝ
y) -> let
        obj :: Obj2
obj = ObjectContext -> SymbolicObj2 -> Obj2
getImplicit2 ObjectContext
ctx SymbolicObj2
symbObj
    in
        Obj2
obj Obj2 -> Obj2
forall a b. (a -> b) -> a -> b
$ ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 (ℝ
xℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*ℝ -> ℝ
forall a. Floating a => a -> a
cos ℝ
θ ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ ℝ
yℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*ℝ -> ℝ
forall a. Floating a => a -> a
sin ℝ
θ) (ℝ
yℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*ℝ -> ℝ
forall a. Floating a => a -> a
cos ℝ
θ ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
xℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*ℝ -> ℝ
forall a. Floating a => a -> a
sin ℝ
θ)
getImplicit2 ObjectContext
ctx (Transform2 M33 ℝ
m SymbolicObj2
symbObj) =
    \V2 ℝ
vin ->
    let
        obj :: Obj2
obj = ObjectContext -> SymbolicObj2 -> Obj2
getImplicit2 ObjectContext
ctx SymbolicObj2
symbObj
        augment :: V2 a -> V3 a
augment (V2 a
x a
y) = (a -> a -> a -> V3 a
forall a. a -> a -> a -> V3 a
V3 a
x a
y a
1)
        normalize :: V3 a -> V2 a
normalize (V3 a
x a
y a
w) = (a -> a -> V2 a
forall a. a -> a -> V2 a
V2 (a
xa -> a -> a
forall a. Fractional a => a -> a -> a
/a
w) (a
ya -> a -> a
forall a. Fractional a => a -> a -> a
/a
w))
    in
        Obj2
obj Obj2 -> Obj2
forall a b. (a -> b) -> a -> b
$ (V3 ℝ -> V2 ℝ
forall a. Fractional a => V3 a -> V2 a
normalize (V3 ℝ -> V2 ℝ) -> (V2 ℝ -> V3 ℝ) -> V2 ℝ -> V2 ℝ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((M33 ℝ -> M33 ℝ
forall a. Fractional a => M33 a -> M33 a
Linear.inv33 M33 ℝ
m) M33 ℝ -> V3 ℝ -> V3 ℝ
forall (m :: * -> *) (r :: * -> *) a.
(Functor m, Foldable r, Additive r, Num a) =>
m (r a) -> r a -> m a
Linear.!*) (V3 ℝ -> V3 ℝ) -> (V2 ℝ -> V3 ℝ) -> V2 ℝ -> V3 ℝ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V2 ℝ -> V3 ℝ
forall a. Num a => V2 a -> V3 a
augment (V2 ℝ -> V2 ℝ) -> V2 ℝ -> V2 ℝ
forall a b. (a -> b) -> a -> b
$ V2 ℝ
vin)
getImplicit2 ObjectContext
ctx (Shared2 SharedObj SymbolicObj2 V2 ℝ
obj) = ObjectContext -> SharedObj SymbolicObj2 V2 ℝ -> Obj2
forall obj (f :: * -> *).
(Object obj f ℝ, VectorStuff (f ℝ), ComponentWiseMultable (f ℝ),
 Metric f) =>
ObjectContext -> SharedObj obj f ℝ -> f ℝ -> ℝ
getImplicitShared ObjectContext
ctx SharedObj SymbolicObj2 V2 ℝ
obj