----------------------------------------------------------------------------- -- -- 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))