module Shady.ParamSurf where
import Control.Applicative
import Control.Arrow ((&&&))
import Data.NumInstances ()
import Data.VectorSpace
import Data.Cross hiding (One,Two,Three)
import Data.Derivative
import Data.Basis
import Shady.Language.Exp
import Shady.Complex
import Shady.ITransform (ITrans(..))
type HeightField s = Complex s -> s
type Surf s = Complex s -> (s,s,s)
type USurf = forall s. Floating s => Surf s
type Curve2 s = s -> Complex s
type Curve3 s = s -> (s,s,s)
type Warp1 s = s -> s
type Warp2 s = Complex s -> Complex s
type Warp3 s = (s,s,s) -> (s,s,s)
cosU, sinU :: Floating s => s -> s
cosU = cos . (* pi)
sinU = sin . (* pi)
hfSurf :: HeightField s -> Surf s
hfSurf field = \ (u :+ v) -> (u, v, field (u :+ v))
fcurve :: Warp1 s -> Curve2 s
fcurve f = \ u -> u :+ f u
circle :: Floating s => Curve2 s
circle = liftA2 (:+) cosU sinU
semiCircle :: Floating s => Curve2 s
semiCircle = circle . (/ 2)
torus :: (Floating s, VectorSpace s, Scalar s ~ s) => s -> s -> Surf s
torus sr cr = revolve (const (sr :+ 0) ^+^ const cr *^ circle)
revolveG :: Floating s => (s -> Curve2 s) -> Surf s
revolveG curveF = \ (u :+ v) -> onXY (rotate (pi*v)) (addY (curveF v) u)
revolve :: Floating s => Curve2 s -> Surf s
revolve curve = revolveG (const curve)
sphere1 :: Floating s => Surf s
sphere1 = revolve semiCircle
profile :: Num s => Curve2 s -> Curve2 s -> Surf s
profile curve prof (u :+ v) = (cx*px,cy*px,py)
where
cx :+ cy = curve u
px :+ py = prof v
sphere2,sphere3 :: Floating s => Surf s
sphere2 = profile circle semiCircle
sphere3 = profile semiCircle circle
frustum :: (Floating s, VectorSpace s, Scalar s ~ s) => s -> s -> s -> Surf s
frustum baseR topR h = profile circle rad
where
rad t = lerp baseR topR (t + 1/2) :+ h*t
ucylinder :: (Floating s, VectorSpace s) => Surf s
ucylinder = profile circle (const 1)
xyPlane :: Num s => Surf s
xyPlane = hfSurf (const 0)
cartF :: (a -> b -> c) -> (s -> a) -> (s -> b) -> (Complex s -> c)
cartF op f g = \ (u :+ v) -> f u `op` g v
sweep :: VectorSpace s => Curve3 s -> Curve3 s -> Surf s
sweep = cartF (^+^)
eggcrateH :: Floating s => HeightField s
eggcrateH = cartF (*) cosU sinU
revolveH :: (Floating s, InnerSpace s, Scalar s ~ s) => Warp1 s -> HeightField s
revolveH = (. magnitude)
rippleH :: (Floating s, InnerSpace s, Scalar s ~ s) => HeightField s
rippleH = revolveH sinU
ripple :: Floating s => Surf s
ripple =
revolve (const (0.5 :+ 0) fcurve sinU)
displaceV :: (InnerSpace v, s ~ Scalar v, Floating s, HasNormal v) =>
v -> Scalar v -> v
displaceV v s = v ^+^ s *^ normal v
displace :: (InnerSpace v, Scalar v ~ s, Floating s, HasNormal v, Applicative f) =>
f v -> f (Scalar v) -> f v
displace = liftA2 displaceV
rotate :: Floating s => s -> Warp2 s
rotate theta = \ (x :+ y) -> (x * c y * s) :+ (y * c + x * s)
where c = cos theta
s = sin theta
addX, addY, addZ :: Num s => (a -> Complex s) -> (a -> (s,s,s))
addX = fmap (\ (y :+ z) -> (0,y,z))
addY = fmap (\ (x :+ z) -> (x,0,z))
addZ = fmap (\ (x :+ y) -> (x,y,0))
addYZ,addXZ,addXY :: Num s => (a -> s) -> (a -> (s,s,s))
addYZ = fmap (\ x -> (x,0,0))
addXZ = fmap (\ y -> (0,y,0))
addXY = fmap (\ z -> (0,0,z))
onX,onY,onZ :: Warp1 s -> Warp3 s
onX f (x,y,z) = (f x, y, z)
onY f (x,y,z) = (x, f y, z)
onZ f (x,y,z) = (x, y, f z)
onXY,onYZ,onXZ :: Warp2 s -> Warp3 s
onXY f (x,y,z) = (x',y',z ) where x' :+ y' = f (x :+ y)
onXZ f (x,y,z) = (x',y ,z') where x' :+ z' = f (x :+ z)
onYZ f (x,y,z) = (x ,y',z') where y' :+ z' = f (y :+ z)
onX',onY',onZ' :: Warp1 s -> (a -> (s,s,s)) -> (a -> (s,s,s))
onX' = fmap . onX
onY' = fmap . onY
onZ' = fmap . onZ
onXY',onXZ',onYZ' :: Warp2 s -> (a -> (s,s,s)) -> (a -> (s,s,s))
onXY' = fmap . onXY
onXZ' = fmap . onXZ
onYZ' = fmap . onYZ
type V2 a = (a,a)
type V3 a = (a,a,a)
type ER = FloatE
type ER2 = V2 ER
type ER3 = V3 ER
instance HasBasis FloatE where
type Basis FloatE = ()
basisValue () = 1
decompose s = [((),s)]
decompose' s = const s
instance HasBasis R2E where
type Basis R2E = Basis ER2
basisValue b = vec2 x y where (x,y) = basisValue b
decompose w = decompose (getX w, getX w)
decompose' w = (w <.>) . basisValue
type TR = ER :> ER
type T = ER2 :> ER
instance ITrans (Complex T) T where (*:) = const id
type SurfPt = V3 T
type SurfD = Surf T
type VN = (R3E, R3E)
toVN :: SurfPt -> VN
toVN = p3 &&& (p3 . normal)
where
p3 (q,r,s) = vec3 (powVal q) (powVal r) (powVal s)
type SurfVN = R2E -> VN
surfVN :: SurfD -> SurfVN
surfVN f p = toVN (f (fstD p' :+ sndD p'))
where
p' = (getX p, getY p)