-----------------------------------------------------------------------------
--
-- Example : Render a brass sphere
-- Copyright : Kree Cole-McLaughlin
-- License : GPL
--
-- Maintainer : Kree Cole-McLaughlin
-- Stability : Experimental
-- Portability : Portable
--
--
-----------------------------------------------------------------------------
module Main where
import Graphics.GPipe
import qualified Data.Vec as Vec
import Data.Vec.Nat
import Data.Vec.LinAlg.Transform3D
import Data.Monoid
import Data.IORef
import Graphics.UI.GLUT( Window,
mainLoop,
postRedisplay,
idleCallback,
getArgsAndInitialize,
($=) )
eyePosition = 0:.0:.13:.()
lightPos = 3.54:.1.5:.(-3.54):.()
lightColor = 0.95:.0.95:.0.95:.()
globalAmbient = 0.1:.0.1:.0.1:.()
camera (width:.height:.()) = toGPU $ Perspective
eyePosition (0:.0:.0:.()) (0:.1:.0:.()) 1 20 (pi/3)
(fromIntegral width / fromIntegral height)
lights = map toGPU [ Ambient globalAmbient,
Diffuse lightColor lightPos ]
brassMaterial = toGPU $ Material
(0:.0:.0:.())
(0.33:.0.22:.0.33:.())
(0.78:.0.57:.0.11:.())
(0.99:.0.91:.0.81:.())
27.8
data Material a = Material {
emissive :: Vec3 a,
ambient :: Vec3 a,
diffuse :: Vec3 a,
specular :: Vec3 a,
shininess :: a
}
instance GPU a => GPU (Material a) where
type CPU (Material a) = Material (CPU a)
toGPU (Material e a d s sh) = Material
(toGPU e) (toGPU a) (toGPU d)
(toGPU s) (toGPU sh)
data Light a = Ambient (Vec3 a)
| Diffuse (Vec3 a) (Vec3 a)
instance GPU a => GPU (Light a) where
type CPU (Light a) = Light (CPU a)
toGPU (Ambient a) = Ambient (toGPU a)
toGPU (Diffuse c p) = Diffuse (toGPU c) (toGPU p)
data View a = Perspective {
eyePos :: Vec3 a,
lookAt :: Vec3 a,
upDir :: Vec3 a,
nearZ :: a,
farZ :: a,
fov :: a,
aspect :: a
}
instance GPU a => GPU (View a) where
type CPU (View a) = View (CPU a)
toGPU (Perspective ep la ud nz fz fov as) = Perspective
(toGPU ep) (toGPU la) (toGPU ud)
(toGPU nz) (toGPU fz)
(toGPU fov) (toGPU as)
viewMat :: Floating a => View a -> Vec.Mat44 a
viewMat view = projMat `multmm` viewMat
where projMat = perspective (nearZ view) (farZ view) (fov view) (aspect view)
viewMat = viewTrans `multmm` viewRot
viewTrans = translation (-(eyePos view))
viewRot = rotationLookAt (upDir view) (eyePos view) (lookAt view)
rectGrid :: Int -> Int -> PrimitiveStream Triangle (Vec3 (Vertex Float))
rectGrid w h = toGPUStream TriangleList $
foldr (sphericalCoordGrid w h) [] nodes
where nodes = [ (i,j) | i <- [1..w], j <- [1..h] ]
sphericalCoordGrid w h (i,j) tris =
tris ++ [ x1:.y1:.0:.(), x2:.y1:.0:.(), x1:.y2:.0:.(),
x2:.y1:.0:.(), x2:.y2:.0:.(), x1:.y2:.0:.() ]
where x1 = 2*pi*(fromIntegral i) / (fromIntegral w)
x2 = 2*pi*(fromIntegral i+1) / (fromIntegral w)
y1 = (2*pi*(fromIntegral j) / (fromIntegral h)) - pi
y2 = (2*pi*(fromIntegral j+1) / (fromIntegral h)) - pi
-- This renders a sphere from the grid of triangles produced by the above function
renderSphere :: Float -> PrimitiveStream Triangle (Vec3 (Vertex Float))
-> PrimitiveStream Triangle (Vec4 (Vertex Float), Vec3 (Vertex Float))
renderSphere radius grid = fmap (buildSphere (toGPU radius)) grid
buildSphere :: Vertex Float -> Vec3 (Vertex Float) -> (Vec4 (Vertex Float), Vec3 (Vertex Float))
buildSphere r (x:.y:._:.()) = (homPoint pos, normalize pos)
where pos = (r*cosx*cosy):.(r*sinx*cosy):.(r*siny):.()
cosx = cos x
sinx = sin x
cosy = cos y
siny = sin y
observe :: View (Vertex Float)
-> PrimitiveStream Triangle (Vec4 (Vertex Float), Vec3 (Vertex Float))
-> PrimitiveStream Triangle (Vec4 (Vertex Float), Vec3 (Vertex Float))
observe view tris = fmap (\(pos,norm) -> ( (viewMat view) `multmv` pos, norm )) tris
-- Lighting pipeline: emmisive -> ambient -> diffuse -> specular
emissiveLight :: Vec3 (Vertex Float)
-> PrimitiveStream Triangle (Vec4 (Vertex Float), Vec3 (Vertex Float))
-> PrimitiveStream Triangle (Vec4 (Vertex Float), (Vec3 (Vertex Float), Vec3 (Vertex Float)))
emissiveLight ke tris = fmap (\(pos,norm) -> (pos,(norm,ke))) tris
ambientLight :: Vec3 (Vertex Float) -> Vec3 (Vertex Float)
-> PrimitiveStream Triangle (Vec4 (Vertex Float), (Vec3 (Vertex Float), Vec3 (Vertex Float)))
-> PrimitiveStream Triangle (Vec4 (Vertex Float), (Vec3 (Vertex Float), Vec3 (Vertex Float)))
ambientLight ga ka tris = fmap (\(pos,(norm,clr)) -> (pos,(norm,clr+ka*ga))) tris
diffuseLight :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) -> Vec3 (Vertex Float)
-> PrimitiveStream Triangle (Vec4 (Vertex Float), (Vec3 (Vertex Float), Vec3 (Vertex Float)))
-> PrimitiveStream Triangle (Vec4 (Vertex Float), (Vec3 (Vertex Float), Vec3 (Vertex Float)))
diffuseLight lc lp kd tris = fmap dlight tris
where dlight (pos,(norm,clr)) = (pos,(norm,clr + (kd*lc*(Vec.vec dl))))
where dl = norm `dot` ld
ld = normalize (lp - (project pos))
specularLight :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) -> Vec3 (Vertex Float)
-> Vec3 (Vertex Float) -> Vertex Float
-> PrimitiveStream Triangle (Vec4 (Vertex Float), (Vec3 (Vertex Float), Vec3 (Vertex Float)))
-> PrimitiveStream Triangle (Vec4 (Vertex Float), (Vec3 (Vertex Float), Vec3 (Vertex Float)))
specularLight ep lc lp ks sh tris = fmap slight tris
where slight (pos,(norm,clr)) = (pos,(norm,clr + ks*lc*(Vec.vec sl)))
where sl = (max (norm `dot` h) 0) ** sh
h = normalize (ld + v)
ld = normalize (lp - (project pos))
v = normalize (ep - (project pos))
vertexLighting :: View (Vertex Float) -> Material (Vertex Float) -> [Light (Vertex Float)]
-> PrimitiveStream Triangle (Vec4 (Vertex Float), Vec3 (Vertex Float))
-> PrimitiveStream Triangle (Vec4 (Vertex Float), (Vec3 (Vertex Float), Vec3 (Vertex Float)))
vertexLighting view mat lights tris = foldr (applyLight view mat) emissiveTris lights
where emissiveTris = emissiveLight (emissive mat) tris
applyLight :: View (Vertex Float) -> Material (Vertex Float) -> Light (Vertex Float)
-> PrimitiveStream Triangle (Vec4 (Vertex Float), (Vec3 (Vertex Float), Vec3 (Vertex Float)))
-> PrimitiveStream Triangle (Vec4 (Vertex Float), (Vec3 (Vertex Float), Vec3 (Vertex Float)))
applyLight view mat light tris =
case light of
Ambient ga -> ambientLight ga (ambient mat) tris
Diffuse lightClr lightPos ->
specularLight (eyePos view) lightClr lightPos (specular mat) (shininess mat) $
diffuseLight lightClr lightPos (diffuse mat) tris
stripNormals :: PrimitiveStream Triangle (Vec4 (Vertex Float), (Vec3 (Vertex Float), Vec3 (Vertex Float)))
-> PrimitiveStream Triangle (Vec4 (Vertex Float), Vec3 (Vertex Float))
stripNormals tris = fmap (\(pos,(norm,color)) -> (pos,color)) tris
-- This implements the fragment shader
fragRGBThrough :: FragmentStream (Vec3 (Fragment Float), a) -> FragmentStream (Color RGBFormat (Fragment Float))
fragRGBThrough frags = fmap (\(color,_) -> RGB color) frags
rastSphere :: View (Vertex Float) -> FragmentStream (Color RGBFormat (Fragment Float))
rastSphere view = fmap (\(front,color) -> RGB color) $ rasterizeFrontAndBack $ sphere
where sphere = stripNormals litSphere
litSphere = vertexLighting view brassMaterial lights projSphere
projSphere = observe view basicSphere
basicSphere = renderSphere 2.0 grid
grid = rectGrid 40 40
sphereFrame :: View (Vertex Float) -> FrameBuffer RGBFormat () ()
sphereFrame view = draw (rastSphere view) clear
where
draw = paintColor NoBlending (RGB $ Vec.vec True)
clear = newFrameBufferColor (RGB (0.1:.0.3:.0.6:.()))
main :: IO ()
main = do
getArgsAndInitialize
newWindow "Brass Sphere"
(100:.100:.())
(400:.400:.())
(renderFrame)
initWindow
mainLoop
renderFrame :: Vec2 Int -> IO (FrameBuffer RGBFormat () ())
renderFrame size = return $ sphereFrame view
where view = camera size
initWindow :: Window -> IO ()
initWindow win = idleCallback $= Nothing --Just (postRedisplay (Just win))