{-# OPTIONS -Wall #-}

{- | 
Module      :  LPFPCore.Geometry
Copyright   :  (c) Scott N. Walck 2023
License     :  BSD3 (see LICENSE)
Maintainer  :  Scott N. Walck <walck@lvc.edu>
Stability   :  stable

Code from chapter 23 of the book Learn Physics with Functional Programming
-}

module LPFPCore.Geometry where

import LPFPCore.SimpleVec ( R, Vec, (*^) )
import LPFPCore.CoordinateSystems ( Position, cylindrical, spherical, cart, cyl, sph
                         , shiftPosition, displacement )

data Curve = Curve { Curve -> R -> Position
curveFunc          :: R -> Position
                   , Curve -> R
startingCurveParam :: R  -- t_a
                   , Curve -> R
endingCurveParam   :: R  -- t_b
                   }

circle2 :: Curve
circle2 :: Curve
circle2 = (R -> Position) -> R -> R -> Curve
Curve (\R
t -> R -> R -> R -> Position
cart (R
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
cos R
t) (R
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
sin R
t) R
0) R
0 (R
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi)

circle2' :: Curve
circle2' :: Curve
circle2' = (R -> Position) -> R -> R -> Curve
Curve (\R
phi -> R -> R -> R -> Position
cyl R
2 R
phi R
0) R
0 (R
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi)

unitCircle :: Curve
unitCircle :: Curve
unitCircle = (R -> Position) -> R -> R -> Curve
Curve (\R
t -> R -> R -> R -> Position
cyl R
1 R
t R
0) R
0 (R
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi)

straightLine :: Position  -- starting position
             -> Position  -- ending position
             -> Curve     -- straight-line curve
straightLine :: Position -> Position -> Curve
straightLine Position
r1 Position
r2 = let d :: Displacement
d = Position -> Position -> Displacement
displacement Position
r1 Position
r2
                         f :: R -> Position
f R
t = Displacement -> Position -> Position
shiftPosition (R
t R -> Displacement -> Displacement
*^ Displacement
d) Position
r1
                     in (R -> Position) -> R -> R -> Curve
Curve R -> Position
f R
0 R
1

data Surface = Surface { Surface -> (R, R) -> Position
surfaceFunc :: (R,R) -> Position
                       , Surface -> R
lowerLimit  :: R       -- s_l
                       , Surface -> R
upperLimit  :: R       -- s_u
                       , Surface -> R -> R
lowerCurve  :: R -> R  -- t_l(s)
                       , Surface -> R -> R
upperCurve  :: R -> R  -- t_u(s)
                       }

unitSphere :: Surface
unitSphere :: Surface
unitSphere = ((R, R) -> Position) -> R -> R -> (R -> R) -> (R -> R) -> Surface
Surface (\(R
th,R
phi) -> R -> R -> R -> Position
cart (forall a. Floating a => a -> a
sin R
th forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
cos R
phi)
                                        (forall a. Floating a => a -> a
sin R
th forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
sin R
phi)
                                        (forall a. Floating a => a -> a
cos R
th))
                     R
0 forall a. Floating a => a
pi (forall a b. a -> b -> a
const R
0) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ R
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi)

unitSphere' :: Surface
unitSphere' :: Surface
unitSphere' = ((R, R) -> Position) -> R -> R -> (R -> R) -> (R -> R) -> Surface
Surface (\(R
th,R
phi) -> R -> R -> R -> Position
sph R
1 R
th R
phi)
                      R
0 forall a. Floating a => a
pi (forall a b. a -> b -> a
const R
0) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ R
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi)

parabolaSurface :: Surface
parabolaSurface :: Surface
parabolaSurface = ((R, R) -> Position) -> R -> R -> (R -> R) -> (R -> R) -> Surface
Surface (\(R
x,R
y) -> R -> R -> R -> Position
cart R
x R
y R
0)
                          (-R
2) R
2 (\R
x -> R
xforall a. Num a => a -> a -> a
*R
x) (forall a b. a -> b -> a
const R
4)

shiftSurface :: Vec -> Surface -> Surface
shiftSurface :: Displacement -> Surface -> Surface
shiftSurface Displacement
d (Surface (R, R) -> Position
g R
sl R
su R -> R
tl R -> R
tu)
    = ((R, R) -> Position) -> R -> R -> (R -> R) -> (R -> R) -> Surface
Surface (Displacement -> Position -> Position
shiftPosition Displacement
d forall b c a. (b -> c) -> (a -> b) -> a -> c
. (R, R) -> Position
g) R
sl R
su R -> R
tl R -> R
tu

centeredSphere :: R -> Surface
centeredSphere :: R -> Surface
centeredSphere R
r = ((R, R) -> Position) -> R -> R -> (R -> R) -> (R -> R) -> Surface
Surface (\(R
th,R
phi) -> R -> R -> R -> Position
sph R
r R
th R
phi)
                           R
0 forall a. Floating a => a
pi (forall a b. a -> b -> a
const R
0) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ R
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi)

sphere :: R -> Position -> Surface
sphere :: R -> Position -> Surface
sphere R
radius Position
center
    = Displacement -> Surface -> Surface
shiftSurface (Position -> Position -> Displacement
displacement (R -> R -> R -> Position
cart R
0 R
0 R
0) Position
center)
      (R -> Surface
centeredSphere R
radius)

northernHemisphere :: Surface
northernHemisphere :: Surface
northernHemisphere = ((R, R) -> Position) -> R -> R -> (R -> R) -> (R -> R) -> Surface
Surface (\(R
th,R
phi) -> R -> R -> R -> Position
sph R
1 R
th R
phi)
                             R
0 (forall a. Floating a => a
piforall a. Fractional a => a -> a -> a
/R
2) (forall a b. a -> b -> a
const R
0) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ R
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi)

disk :: R -> Surface
disk :: R -> Surface
disk R
radius = ((R, R) -> Position) -> R -> R -> (R -> R) -> (R -> R) -> Surface
Surface (\(R
s,R
phi) -> R -> R -> R -> Position
cyl R
s R
phi R
0)
                      R
0 R
radius (forall a b. a -> b -> a
const R
0) (forall a b. a -> b -> a
const (R
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi))

unitCone :: R -> Surface
unitCone :: R -> Surface
unitCone R
theta = ((R, R) -> Position) -> R -> R -> (R -> R) -> (R -> R) -> Surface
Surface (\(R
r,R
phi) -> R -> R -> R -> Position
sph R
r R
theta R
phi)
                         R
0 R
1 (forall a b. a -> b -> a
const R
0) (forall a b. a -> b -> a
const (R
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi))

data Volume = Volume { Volume -> (R, R, R) -> Position
volumeFunc :: (R,R,R) -> Position
                     , Volume -> R
loLimit    :: R            -- s_l
                     , Volume -> R
upLimit    :: R            -- s_u
                     , Volume -> R -> R
loCurve    :: R -> R       -- t_l(s)
                     , Volume -> R -> R
upCurve    :: R -> R       -- t_u(s)
                     , Volume -> R -> R -> R
loSurf     :: R -> R -> R  -- u_l(s,t)
                     , Volume -> R -> R -> R
upSurf     :: R -> R -> R  -- u_u(s,t)
                     }

unitBall :: Volume
unitBall :: Volume
unitBall = ((R, R, R) -> Position)
-> R
-> R
-> (R -> R)
-> (R -> R)
-> (R -> R -> R)
-> (R -> R -> R)
-> Volume
Volume (R, R, R) -> Position
spherical R
0 R
1 (forall a b. a -> b -> a
const R
0) (forall a b. a -> b -> a
const forall a. Floating a => a
pi)
                  (\R
_ R
_ -> R
0) (\R
_ R
_ -> R
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi)

centeredCylinder :: R       -- radius
                 -> R       -- height
                 -> Volume  -- cylinder
centeredCylinder :: R -> R -> Volume
centeredCylinder R
radius R
height
  = ((R, R, R) -> Position)
-> R
-> R
-> (R -> R)
-> (R -> R)
-> (R -> R -> R)
-> (R -> R -> R)
-> Volume
Volume (R, R, R) -> Position
cylindrical R
0 R
radius (forall a b. a -> b -> a
const R
0) (forall a b. a -> b -> a
const (R
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi))
           (\R
_ R
_ -> R
0) (\R
_ R
_ -> R
height)

circle :: Position  -- center position
       -> R         -- radius
       -> Curve
circle :: Position -> R -> Curve
circle Position
r R
radius = forall a. HasCallStack => a
undefined Position
r R
radius

square :: Curve
square :: Curve
square = (R -> Position) -> R -> R -> Curve
Curve R -> Position
squareFunc R
0 R
4

squareFunc :: R -> Position
squareFunc :: R -> Position
squareFunc R
t
    |           R
t forall a. Ord a => a -> a -> Bool
< R
1  = R -> R -> R -> Position
cart forall a. HasCallStack => a
undefined    (-R
1)   R
0
    | R
1 forall a. Ord a => a -> a -> Bool
<= R
t Bool -> Bool -> Bool
&& R
t forall a. Ord a => a -> a -> Bool
< R
2  = R -> R -> R -> Position
cart     R
1     forall a. HasCallStack => a
undefined R
0
    | R
2 forall a. Ord a => a -> a -> Bool
<= R
t Bool -> Bool -> Bool
&& R
t forall a. Ord a => a -> a -> Bool
< R
3  = R -> R -> R -> Position
cart forall a. HasCallStack => a
undefined      R
1    R
0
    | Bool
otherwise        = R -> R -> R -> Position
cart   (-R
1)    forall a. HasCallStack => a
undefined R
0

northernHalfBall :: Volume
northernHalfBall :: Volume
northernHalfBall = forall a. HasCallStack => a
undefined

centeredBall :: R -> Volume
centeredBall :: R -> Volume
centeredBall = forall a. HasCallStack => a
undefined

shiftVolume :: Vec -> Volume -> Volume
shiftVolume :: Displacement -> Volume -> Volume
shiftVolume = forall a. HasCallStack => a
undefined

quarterDiskBoundary :: R -> Curve
quarterDiskBoundary :: R -> Curve
quarterDiskBoundary = forall a. HasCallStack => a
undefined

quarterCylinder :: R -> R -> Volume
quarterCylinder :: R -> R -> Volume
quarterCylinder = forall a. HasCallStack => a
undefined