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

-- Allow our DiscreteAproxable class to handle multiple parameters.
{-# LANGUAGE MultiParamTypeClasses #-}

-- For the instance declaration of DiscreteAproxable SymbolicObj2 [Polyline]
{-# LANGUAGE FlexibleInstances #-}

-- | A module for retrieving approximate represententations of objects.
module Graphics.Implicit.Export.DiscreteAproxable (DiscreteAproxable, discreteAprox) where

import Prelude(pure, (-), (/), ($), (<), round, (+), maximum, abs, (*), fromIntegral, max, realToFrac, Int)

-- Definitions for our number system, objects, and the things we can use to approximately represent objects.
import Graphics.Implicit.Definitions (defaultObjectContext, ℝ, ℝ2, SymbolicObj2, SymbolicObj3, Polyline, TriangleMesh(getTriangles), NormedTriangleMesh(NormedTriangleMesh))

import Graphics.Implicit.ObjectUtil (getBox2, getBox3)

import Graphics.Implicit.Export.SymbolicObj3 (symbolicGetMesh)

import Graphics.Implicit.Export.SymbolicObj2 (symbolicGetContour)

import Graphics.Implicit.Export.Util (normTriangle)

-- We are the only ones that use this.
import Graphics.Implicit.Export.RayTrace (Color(Color), Camera(Camera), Light(Light), Scene(Scene), average, traceRay, cameraRay)

import Codec.Picture (DynamicImage(ImageRGBA8), PixelRGBA8(PixelRGBA8), generateImage)

import Control.Parallel.Strategies (using, rdeepseq, parBuffer)

import Linear ( V3(V3), V2(V2), (*^), (^/) )
import Linear.Affine ( Affine((.+^), (.-^)) )
import Graphics.Implicit.Primitives (getImplicit)

default (ℝ)

-- | There is a discrete way to aproximate this object.
--   eg. Aproximating a 3D object with a triangle mesh
--       would be DiscreteApproxable Obj3 TriangleMesh
class DiscreteAproxable obj aprox where
    discreteAprox :: ℝ -> obj -> aprox

instance DiscreteAproxable SymbolicObj3 TriangleMesh where
    discreteAprox :: ℝ -> SymbolicObj3 -> TriangleMesh
discreteAprox = ℝ -> SymbolicObj3 -> TriangleMesh
symbolicGetMesh

-- FIXME: number of CPUs hardcoded here.
instance DiscreteAproxable SymbolicObj3 NormedTriangleMesh where
    discreteAprox :: ℝ -> SymbolicObj3 -> NormedTriangleMesh
discreteAprox ℝ
res SymbolicObj3
obj = [NormedTriangle] -> NormedTriangleMesh
NormedTriangleMesh
        ([ ℝ -> Obj3 -> Triangle -> NormedTriangle
normTriangle ℝ
res (SymbolicObj3 -> Obj3
forall obj (f :: * -> *) a. Object obj f a => obj -> f a -> a
getImplicit SymbolicObj3
obj) Triangle
rawMesh
            | Triangle
rawMesh <- TriangleMesh -> [Triangle]
getTriangles (TriangleMesh -> [Triangle]) -> TriangleMesh -> [Triangle]
forall a b. (a -> b) -> a -> b
$ ℝ -> SymbolicObj3 -> TriangleMesh
symbolicGetMesh ℝ
res SymbolicObj3
obj
         ] [NormedTriangle] -> Strategy [NormedTriangle] -> [NormedTriangle]
forall a. a -> Strategy a -> a
`using` Int -> Strategy NormedTriangle -> Strategy [NormedTriangle]
forall a. Int -> Strategy a -> Strategy [a]
parBuffer Int
32 Strategy NormedTriangle
forall a. NFData a => Strategy a
rdeepseq)

-- FIXME: way too many magic numbers.
-- FIXME: adjustable resolution!
instance DiscreteAproxable SymbolicObj3 DynamicImage where
    discreteAprox :: ℝ -> SymbolicObj3 -> DynamicImage
discreteAprox ℝ
_ SymbolicObj3
symbObj = Image PixelRGBA8 -> DynamicImage
ImageRGBA8 (Image PixelRGBA8 -> DynamicImage)
-> Image PixelRGBA8 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> PixelRGBA8) -> Int -> Int -> Image PixelRGBA8
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> PixelRGBA8
pixelRenderer (ℝ -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round ℝ
w) (ℝ -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round ℝ
h)
        where
            -- Size of the image to produce.
            (V2 ℝ
w ℝ
h) = ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 ℝ
150 ℝ
150 :: ℝ2
            obj :: Obj3
obj = SymbolicObj3 -> Obj3
forall obj (f :: * -> *) a. Object obj f a => obj -> f a -> a
getImplicit SymbolicObj3
symbObj
            box :: (V3 ℝ, V3 ℝ)
box@(V3 ℝ
x1 ℝ
y1 ℝ
z1, V3 ℝ
_ ℝ
y2 ℝ
z2) = SymbolicObj3 -> (V3 ℝ, V3 ℝ)
getBox3 SymbolicObj3
symbObj
            av :: ℝ -> ℝ -> ℝ
            av :: ℝ -> ℝ -> ℝ
av ℝ
a ℝ
b = (ℝ
aℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ℝ
b)ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
2
            avY :: ℝ
avY = ℝ -> ℝ -> ℝ
av ℝ
y1 ℝ
y2
            avZ :: ℝ
avZ = ℝ -> ℝ -> ℝ
av ℝ
z1 ℝ
z2
            deviation :: ℝ
deviation = [ℝ] -> ℝ
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ℝ -> ℝ
forall a. Num a => a -> a
abs (ℝ -> ℝ) -> ℝ -> ℝ
forall a b. (a -> b) -> a -> b
$ ℝ
y1 ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
avY, ℝ -> ℝ
forall a. Num a => a -> a
abs (ℝ -> ℝ) -> ℝ -> ℝ
forall a b. (a -> b) -> a -> b
$ ℝ
y2 ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
avY, ℝ -> ℝ
forall a. Num a => a -> a
abs (ℝ -> ℝ) -> ℝ -> ℝ
forall a b. (a -> b) -> a -> b
$ ℝ
z1 ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
avZ, ℝ -> ℝ
forall a. Num a => a -> a
abs (ℝ -> ℝ) -> ℝ -> ℝ
forall a b. (a -> b) -> a -> b
$ ℝ
z2 ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
avZ]
            camera :: Camera
camera = V3 ℝ -> V3 ℝ -> V3 ℝ -> ℝ -> Camera
Camera (ℝ -> ℝ -> ℝ -> V3 ℝ
forall a. a -> a -> a -> V3 a
V3 (ℝ
x1ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
deviationℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*ℝ
2.2) ℝ
avY ℝ
avZ) (ℝ -> ℝ -> ℝ -> V3 ℝ
forall a. a -> a -> a -> V3 a
V3 ℝ
0 (-ℝ
1) ℝ
0) (ℝ -> ℝ -> ℝ -> V3 ℝ
forall a. a -> a -> a -> V3 a
V3 ℝ
0 ℝ
0 (-ℝ
1)) ℝ
1.0
            lights :: [Light]
lights = [V3 ℝ -> ℝ -> Light
Light (ℝ -> ℝ -> ℝ -> V3 ℝ
forall a. a -> a -> a -> V3 a
V3 (ℝ
x1ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
deviationℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*ℝ
1.5) (ℝ
y1 ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
0.4ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*(ℝ
y2ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
y1)) ℝ
avZ) (ℝ
0.03ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*ℝ
deviation) ]
            scene :: Scene
scene = Obj3 -> Color -> [Light] -> Color -> Scene
Scene Obj3
obj (Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Color
Color Pixel8
200 Pixel8
200 Pixel8
230 Pixel8
255) [Light]
lights (Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Color
Color Pixel8
255 Pixel8
255 Pixel8
255 Pixel8
0)
            -- passed to generateImage, it's external, and determines this type.
            pixelRenderer :: Int -> Int -> PixelRGBA8
            pixelRenderer :: Int -> Int -> PixelRGBA8
pixelRenderer Int
a Int
b = ℝ -> ℝ -> PixelRGBA8
renderScreen
                (Int -> ℝ
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
aℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
w ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
0.5) (Int -> ℝ
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
h ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
0.5)
            renderScreen :: ℝ -> ℝ -> PixelRGBA8
            renderScreen :: ℝ -> ℝ -> PixelRGBA8
renderScreen ℝ
a ℝ
b =
                Color -> PixelRGBA8
colorToPixelRGBA8 (Color -> PixelRGBA8) -> Color -> PixelRGBA8
forall a b. (a -> b) -> a -> b
$
                    [Color] -> Color
average [
                        Ray -> ℝ -> (V3 ℝ, V3 ℝ) -> Scene -> Color
traceRay
                            (Camera -> V2 ℝ -> Ray
cameraRay Camera
camera (ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 ℝ
a ℝ
b V2 ℝ -> V2 ℝ -> V2 ℝ
forall a. Num a => a -> a -> a
+ ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 ( ℝ
0.25ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
w) (ℝ
0.25ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
h)))
                            ℝ
2 (V3 ℝ, V3 ℝ)
box Scene
scene,
                        Ray -> ℝ -> (V3 ℝ, V3 ℝ) -> Scene -> Color
traceRay
                            (Camera -> V2 ℝ -> Ray
cameraRay Camera
camera (ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 ℝ
a ℝ
b V2 ℝ -> V2 ℝ -> V2 ℝ
forall a. Num a => a -> a -> a
+ ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 (-ℝ
0.25ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
w) (ℝ
0.25ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
h)))
                            ℝ
0.5 (V3 ℝ, V3 ℝ)
box Scene
scene,
                        Ray -> ℝ -> (V3 ℝ, V3 ℝ) -> Scene -> Color
traceRay
                            (Camera -> V2 ℝ -> Ray
cameraRay Camera
camera (ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 ℝ
a ℝ
b V2 ℝ -> V2 ℝ -> V2 ℝ
forall a. Num a => a -> a -> a
+ ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 (ℝ
0.25ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
w) (-ℝ
0.25ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
h)))
                            ℝ
0.5 (V3 ℝ, V3 ℝ)
box Scene
scene,
                        Ray -> ℝ -> (V3 ℝ, V3 ℝ) -> Scene -> Color
traceRay
                            (Camera -> V2 ℝ -> Ray
cameraRay Camera
camera (ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 ℝ
a ℝ
b V2 ℝ -> V2 ℝ -> V2 ℝ
forall a. Num a => a -> a -> a
+ ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 (-ℝ
0.25ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
w) (-ℝ
0.25ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
h)))
                            ℝ
0.5 (V3 ℝ, V3 ℝ)
box Scene
scene
                        ]
                    where
                      colorToPixelRGBA8 :: Color -> PixelRGBA8
                      colorToPixelRGBA8 :: Color -> PixelRGBA8
colorToPixelRGBA8 (Color Pixel8
rr Pixel8
gg Pixel8
bb Pixel8
aa) = Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
rr Pixel8
gg Pixel8
bb Pixel8
aa

instance DiscreteAproxable SymbolicObj2 [Polyline] where
    discreteAprox :: ℝ -> SymbolicObj2 -> [Polyline]
discreteAprox ℝ
res = ℝ -> ObjectContext -> SymbolicObj2 -> [Polyline]
symbolicGetContour ℝ
res ObjectContext
defaultObjectContext

-- FIXME: way too many magic numbers.
-- FIXME: adjustable resolution?
instance DiscreteAproxable SymbolicObj2 DynamicImage where
    discreteAprox :: ℝ -> SymbolicObj2 -> DynamicImage
discreteAprox ℝ
_ SymbolicObj2
symbObj = Image PixelRGBA8 -> DynamicImage
ImageRGBA8 (Image PixelRGBA8 -> DynamicImage)
-> Image PixelRGBA8 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> PixelRGBA8) -> Int -> Int -> Image PixelRGBA8
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> PixelRGBA8
pixelRenderer (ℝ -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round ℝ
w) (ℝ -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round ℝ
h)
        where
            -- Size of the image to produce.
            V2 ℝ
w ℝ
h = ℝ -> V2 ℝ
forall (f :: * -> *) a. Applicative f => a -> f a
pure ℝ
150 :: ℝ2
            obj :: V2 ℝ -> ℝ
obj = SymbolicObj2 -> V2 ℝ -> ℝ
forall obj (f :: * -> *) a. Object obj f a => obj -> f a -> a
getImplicit SymbolicObj2
symbObj
            (p1 :: V2 ℝ
p1@(V2 ℝ
x1 ℝ
_), p2 :: V2 ℝ
p2@(V2 ℝ
_ ℝ
y2)) = SymbolicObj2 -> (V2 ℝ, V2 ℝ)
getBox2 SymbolicObj2
symbObj
            V2 ℝ
dx ℝ
dy = V2 ℝ
p2 V2 ℝ -> V2 ℝ -> V2 ℝ
forall a. Num a => a -> a -> a
- V2 ℝ
p1
            dxy :: ℝ
dxy = ℝ -> ℝ -> ℝ
forall a. Ord a => a -> a -> a
max ℝ
dx ℝ
dy
            -- passed to generateImage, it's external, and determines this type.
            pixelRenderer :: Int -> Int -> PixelRGBA8
            pixelRenderer :: Int -> Int -> PixelRGBA8
pixelRenderer Int
mya Int
myb = PixelRGBA8
mycolor
                where
                    xy :: ℝ -> ℝ -> V2 ℝ
xy ℝ
a ℝ
b = (ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 ℝ
x1 ℝ
y2 V2 ℝ -> Diff V2 ℝ -> V2 ℝ
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.-^ ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 (ℝ
dxyℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
dx) (ℝ
dyℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
dxy) V2 ℝ -> ℝ -> V2 ℝ
forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/ℝ
2) V2 ℝ -> Diff V2 ℝ -> V2 ℝ
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ ℝ
dxy ℝ -> V2 ℝ -> V2 ℝ
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 (ℝ
aℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
w) (-ℝ
bℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
h)
                    s :: ℝ
s = ℝ
0.25 :: ℝ
                    V2 ℝ
a' ℝ
b' = ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 (Int -> ℝ
forall a b. (Real a, Fractional b) => a -> b
realToFrac Int
mya) (Int -> ℝ
forall a b. (Real a, Fractional b) => a -> b
realToFrac Int
myb) :: ℝ2
                    mycolor :: PixelRGBA8
mycolor = Color -> PixelRGBA8
colorToPixelRGBA8 (Color -> PixelRGBA8) -> Color -> PixelRGBA8
forall a b. (a -> b) -> a -> b
$ [Color] -> Color
average [V2 ℝ -> Color
objColor (V2 ℝ -> Color) -> V2 ℝ -> Color
forall a b. (a -> b) -> a -> b
$ ℝ -> ℝ -> V2 ℝ
xy ℝ
a' ℝ
b', V2 ℝ -> Color
objColor (V2 ℝ -> Color) -> V2 ℝ -> Color
forall a b. (a -> b) -> a -> b
$ ℝ -> ℝ -> V2 ℝ
xy ℝ
a' ℝ
b',
                        V2 ℝ -> Color
objColor (V2 ℝ -> Color) -> V2 ℝ -> Color
forall a b. (a -> b) -> a -> b
$ ℝ -> ℝ -> V2 ℝ
xy (ℝ
a'ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ℝ
s) (ℝ
b'ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ℝ
s),
                        V2 ℝ -> Color
objColor (V2 ℝ -> Color) -> V2 ℝ -> Color
forall a b. (a -> b) -> a -> b
$ ℝ -> ℝ -> V2 ℝ
xy (ℝ
a'ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
s) (ℝ
b'ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
s),
                        V2 ℝ -> Color
objColor (V2 ℝ -> Color) -> V2 ℝ -> Color
forall a b. (a -> b) -> a -> b
$ ℝ -> ℝ -> V2 ℝ
xy (ℝ
a'ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ℝ
s) (ℝ
b'ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ℝ
s),
                        V2 ℝ -> Color
objColor (V2 ℝ -> Color) -> V2 ℝ -> Color
forall a b. (a -> b) -> a -> b
$ ℝ -> ℝ -> V2 ℝ
xy (ℝ
a'ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
s) (ℝ
b'ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
s)]
                    colorToPixelRGBA8 :: Color -> PixelRGBA8
                    colorToPixelRGBA8 :: Color -> PixelRGBA8
colorToPixelRGBA8 (Color Pixel8
rr Pixel8
gg Pixel8
bb Pixel8
aa) = Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
rr Pixel8
gg Pixel8
bb Pixel8
aa
            objColor :: V2 ℝ -> Color
objColor V2 ℝ
p = if V2 ℝ -> ℝ
obj V2 ℝ
p ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
< ℝ
0 then Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Color
Color Pixel8
150 Pixel8
150 Pixel8
160 Pixel8
255 else Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Color
Color Pixel8
255 Pixel8
255 Pixel8
255 Pixel8
0