{- 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 :: forall a. Eq a => [a] -> [a]
scanUniqueCircular
    = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(/=))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. [a] -> [(a, a)]
circularPairs [a]
as = forall a b. [a] -> [b] -> [(a, b)]
zip [a]
as forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ 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 (ℝ
xforall a. Num a => a -> a -> a
-ℝ
dxforall a. Fractional a => a -> a -> a
/ℝ
2) forall a. Num a => a -> a -> a
- ℝ
dxforall a. Fractional a => a -> a -> a
/ℝ
2, forall a. Num a => a -> a
abs (ℝ
yforall a. Num a => a -> a -> a
-ℝ
dyforall a. Fractional a => a -> a -> a
/ℝ
2) forall a. Num a => a -> a -> a
- ℝ
dyforall 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 (forall a. Eq a => [a] -> [a]
scanUniqueCircular -> points :: [ℝ2]
points@(ℝ2
_:ℝ2
_:ℝ2
_:[ℝ2]
_))) =
    \ℝ2
p -> let
        pairs :: [(ℝ2,ℝ2)]
        pairs :: [(ℝ2, ℝ2)]
pairs =  forall a. [a] -> [(a, a)]
circularPairs [ℝ2]
points
        relativePairs :: [(ℝ2, ℝ2)]
relativePairs =  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ℝ2
a,ℝ2
b) -> (ℝ2
a forall a. Num a => a -> a -> a
- ℝ2
p, ℝ2
b forall a. Num a => a -> a -> a
- ℝ2
p) ) [(ℝ2, ℝ2)]
pairs
        crossing_points :: [ℝ]
crossing_points =
            [ℝ
x2 forall a. Num a => a -> a -> a
- ℝ
y2forall a. Num a => a -> a -> a
*(ℝ
x2forall a. Num a => a -> a -> a
-ℝ
x1)forall a. Fractional a => a -> a -> a
/(ℝ
y2forall a. Num a => a -> a -> a
-ℝ
y1) | (V2 ℝ
x1 ℝ
y1, V2 ℝ
x2 ℝ
y2) <- [(ℝ2, ℝ2)]
relativePairs,
               ( (ℝ
y2 forall a. Ord a => a -> a -> Bool
<= ℝ
0) Bool -> Bool -> Bool
&& (ℝ
y1 forall a. Ord a => a -> a -> Bool
>= ℝ
0) ) Bool -> Bool -> Bool
|| ( (ℝ
y2 forall a. Ord a => a -> a -> Bool
>= ℝ
0) Bool -> Bool -> Bool
&& (ℝ
y1 forall a. Ord a => a -> a -> Bool
<= ℝ
0) ) ]
        -- FIXME: use partition instead?
        seemsInRight :: Bool
seemsInRight = forall a. Integral a => a -> Bool
odd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
>ℝ
0) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [ℝ]
crossing_points
        seemsInLeft :: Bool
seemsInLeft = forall a. Integral a => a -> Bool
odd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
<ℝ
0) 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ℝ2 -> (ℝ2, ℝ2) -> ℝ
distFromLineSeg ℝ2
p) [(ℝ2, ℝ2)]
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 [ℝ2]
_) = forall obj (f :: * -> *).
(Object obj f ℝ, VectorStuff (f ℝ), ComponentWiseMultable (f ℝ),
 Metric f) =>
ObjectContext -> SharedObj obj f ℝ -> f ℝ -> ℝ
getImplicitShared @SymbolicObj2 ObjectContext
ctx 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 forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> V2 a
V2 (ℝ
xforall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
cos ℝ
θ forall a. Num a => a -> a -> a
+ ℝ
yforall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
sin ℝ
θ) (ℝ
yforall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
cos ℝ
θ forall a. Num a => a -> a -> a
- ℝ
xforall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
sin ℝ
θ)
getImplicit2 ObjectContext
ctx (Transform2 M33 ℝ
m SymbolicObj2
symbObj) =
    \ℝ2
vin ->
    let
        obj :: Obj2
obj = ObjectContext -> SymbolicObj2 -> Obj2
getImplicit2 ObjectContext
ctx SymbolicObj2
symbObj
        augment :: V2 a -> V3 a
augment (V2 a
x a
y) = 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) = forall a. a -> a -> V2 a
V2 (a
xforall a. Fractional a => a -> a -> a
/a
w) (a
yforall a. Fractional a => a -> a -> a
/a
w)
    in
        Obj2
obj (forall {a}. Fractional a => V3 a -> V2 a
normalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => M33 a -> M33 a
Linear.inv33 M33 ℝ
m forall (m :: * -> *) (r :: * -> *) a.
(Functor m, Foldable r, Additive r, Num a) =>
m (r a) -> r a -> m a
Linear.!*) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Num a => V2 a -> V3 a
augment forall a b. (a -> b) -> a -> b
$ ℝ2
vin)
getImplicit2 ObjectContext
ctx (Shared2 SharedObj SymbolicObj2 V2 ℝ
obj) = forall obj (f :: * -> *).
(Object obj f ℝ, VectorStuff (f ℝ), ComponentWiseMultable (f ℝ),
 Metric f) =>
ObjectContext -> SharedObj obj f ℝ -> f ℝ -> ℝ
getImplicitShared ObjectContext
ctx SharedObj SymbolicObj2 V2 ℝ
obj