diff options
Diffstat (limited to 'Graphics/Glyph/GeometryBuilder.hs')
| -rw-r--r-- | Graphics/Glyph/GeometryBuilder.hs | 181 |
1 files changed, 181 insertions, 0 deletions
diff --git a/Graphics/Glyph/GeometryBuilder.hs b/Graphics/Glyph/GeometryBuilder.hs new file mode 100644 index 0000000..31be715 --- /dev/null +++ b/Graphics/Glyph/GeometryBuilder.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Graphics.Glyph.GeometryBuilder where + +import Data.Sequence as Seq +import Data.Setters +import Data.Maybe + +import Graphics.Glyph.Util +import Graphics.Glyph.BufferBuilder + +import Data.ByteStringBuilder +import Data.ByteString.Lazy +import Data.ByteString.Lazy.Char8 as BSLC +import Data.Foldable as Fold + +import Text.Printf + +data OutType = TriangleStrip | Triangles +instance Show OutType where + show TriangleStrip = "triangle_strip" + show Triangles = "triangle_strip" + +buildSourceAsString :: GeometryBuilder a -> String +buildSourceAsString = BSLC.unpack . buildSource + +buildSource :: GeometryBuilder a -> ByteString +buildSource builder = + runBuilder $ do + putSLn "#version 150" + putSLn "#extension GL_ARB_explicit_attrib_location : enable" + putSLn "#extension GL_ARB_explicit_uniform_location : enable" + putSLn "layout(points) in ;" + + let isVertex (Vertex _ _ _ _) = True + isVertex _ = False + putSLn $ printf "layout(%s,max_vertices=%d) out ;" + (show $ maybeDefault TriangleStrip $ gOutType builder) + (Seq.length $ Seq.filter isVertex $ gList builder) + + forM_ (textureOut builder) $ putSLn.("out vec2 "++) . (++";") + forM_ (normalOut builder) $ putSLn.("out vec3 "++) . (++";") + forM_ (positionOut builder) $ putSLn.("out vec4 "++) . (++";") + + let pjMatStr = fromJust (pjMatrixUniform builder >||> Just "pjMatrix") + let mvMatStr = fromJust (mvMatrixUniform builder >||> Just "mvMatrix") + + Fold.mapM_ (putSLn.("uniform mat4 "++).(++";")) [pjMatStr, mvMatStr] + + putSLn "void main() {" + + let vertexOutF = + case positionOut builder of + Nothing -> + printf "\tgl_Position = %s * (gl_in[0].gl_Position + %s * vec4(%f,%f,%f,%f));" + pjMatStr mvMatStr + Just str -> + printf "\tgl_Position = %s * (%s = gl_in[0].gl_Position + %s * vec4(%f,%f,%f,%f));" + pjMatStr str mvMatStr + let normalOutF = case normalOut builder of + Nothing -> const3 "" + Just str -> printf "\t%s = -inverse(transpose(mat3(%s))) * vec3(%f,%f,%f);" str mvMatStr + + let textureOutF = case textureOut builder of + Nothing -> const2 "" + Just str -> printf "\t%s = vec2(%f,%f);" str + + forM_ (gList builder) $ \datum -> + case datum of + Vertex x y z w -> putSLn $ vertexOutF x y z w + Normal x y z -> putSLn $ normalOutF x y z + Texture x y -> putSLn $ textureOutF x y + EmitVertex -> putSLn "\tEmitVertex();" + EndPrimitive -> putSLn "\tEndPrimitive();" + putSLn "}" + +data GeometryDatum = + Vertex Float Float Float Float | + Texture Float Float | + Normal Float Float Float | + EmitVertex | + EndPrimitive + +data GeometryBuilder a = GeometryBuilder { + gList :: (Seq GeometryDatum), + + gOutType :: Maybe OutType, + pjMatrixUniform :: Maybe String, + mvMatrixUniform :: Maybe String, + maxVerts :: Maybe Int, + + textureOut :: Maybe String, + normalOut :: Maybe String, + positionOut :: Maybe String, + gRet :: a +} + +$(declareSetters ''GeometryBuilder) + +generating :: OutType -> GeometryBuilder () -> GeometryBuilder () +generating TriangleStrip builder = setGOutType (Just TriangleStrip) $ builder +generating Triangles builder = do + let (nSeq,_) = + Fold.foldl' (\(tSeq,cnt) datum -> + case datum of + EmitVertex -> + if cnt == (2::Int) then (tSeq |> datum |> EndPrimitive, 0) + else (tSeq |> datum, cnt + 1) + _ -> (tSeq |> datum,cnt) + ) (Seq.empty, 0) (gList builder) + + setGOutType (Just Triangles) $ + setGList nSeq builder + +projectionMatrixUniform :: String -> GeometryBuilder () +projectionMatrixUniform str = setPjMatrixUniform (Just str) $ return () + +modelViewMatrixUniform :: String -> GeometryBuilder () +modelViewMatrixUniform str = setMvMatrixUniform (Just str) $ return () + +maxVerticies :: Int -> GeometryBuilder () +maxVerticies i = setMaxVerts (Just i) $ return () + +textureOutput :: String -> GeometryBuilder () +textureOutput str = setTextureOut (Just str) $ return () + +normalOutput :: String -> GeometryBuilder () +normalOutput str = setNormalOut (Just str) $ return () + +positionOutput :: String -> GeometryBuilder () +positionOutput str = setPositionOut (Just str) $ return () + +gVertex4 :: Float -> Float -> Float -> Float -> GeometryBuilder () +gVertex4 x y z w = setGList (Seq.singleton $ Vertex x y z w) $ return () + +gNormal3 :: Float -> Float -> Float -> GeometryBuilder () +gNormal3 x y z = setGList (Seq.singleton $ Normal x y z) $ return () + +gTexture2 :: Float -> Float -> GeometryBuilder () +gTexture2 x y = setGList (Seq.singleton $ Texture x y) $ return () + +gEmitVertex :: GeometryBuilder () +gEmitVertex = setGList (Seq.singleton $ EmitVertex) $ return () + +gEndPrimitive :: GeometryBuilder () +gEndPrimitive = setGList (Seq.singleton $ EndPrimitive) $ return () + +gVertex4E :: Float -> Float -> Float -> Float -> GeometryBuilder () +gVertex4E x y z w = gVertex4 x y z w >> gEmitVertex + + +instance Monad GeometryBuilder where + aB >> bB = GeometryBuilder + (gList aB >< gList bB) + (select gOutType gOutType) + (select pjMatrixUniform pjMatrixUniform) + (select mvMatrixUniform mvMatrixUniform) + (select maxVerts maxVerts) + (select textureOut textureOut) + (select normalOut normalOut) + (select positionOut positionOut) + (gRet bB) + where select f1 f2 = (f1 bB) >||> (f2 aB) + aB >>= func = aB >> func (gRet aB) + return = GeometryBuilder + Seq.empty + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + fail = error + + +instance IsModelBuilder Float GeometryBuilder where + plotVertex3 x y z = gVertex4E x y z 0 + plotNormal = gNormal3 + plotTexture = gTexture2 + |