diff --git a/docimages/twoBeziers.png b/docimages/twoBeziers.png new file mode 100644 Binary files /dev/null and b/docimages/twoBeziers.png differ diff --git a/gelatin.cabal b/gelatin.cabal --- a/gelatin.cabal +++ b/gelatin.cabal @@ -1,5 +1,5 @@ name: gelatin -version: 0.1.0.0 +version: 0.1.0.1 synopsis: A graphics description language. description: An EDSL for describing pictures and scenes. homepage: https://github.com/schell/gelatin diff --git a/src/Gelatin/Compiler.hs b/src/Gelatin/Compiler.hs --- a/src/Gelatin/Compiler.hs +++ b/src/Gelatin/Compiler.hs @@ -167,14 +167,6 @@ glr <- compilePictureData b dat return (a, glr) ---extractTransformData :: PictureData t (V2 Float) Float v -> [RenderTransform] ---extractTransformData PictureData{..} = --- let afs = map Spatial _picDataAffine --- ts = Alpha _picDataAlpha : Multiply _picDataMultiply : afs --- in case _picDataReplaceColor of --- Nothing -> ts --- Just c -> ColorReplacement c : ts --- compileGeometry :: GeometryCompiler vx v r s -> [StrokeAttr] -> RawGeometry vx -> IO (Renderer v r s) compileGeometry GeometryCompiler{..} _ (RawTriangles v) = @@ -199,39 +191,3 @@ clean = mapM_ fst glrs glr = foldl (applyCompilerOption b) (clean, render) _picDataOptions return glr - ---compileColorPictureData :: Rez -> ColorPictureData -> IO Renderer ---compileColorPictureData = compilePictureData rgbaCompiler --- ---compileTexturePictureData :: Rez -> TexturePictureData -> IO Renderer ---compileTexturePictureData = compilePictureData uvCompiler ----------------------------------------------------------------------------------- ----- Top level compilation functions ----------------------------------------------------------------------------------- ---compileColorPictureT :: MonadIO m => Rez -> ColorPictureT m a -> m (a, Renderer) ---compileColorPictureT rz pic = do --- (a, dat) <- runPictureT pic --- glr <- liftIO $ compileColorPictureData rz dat --- return (a,glr) --- ---compileTexturePictureT :: MonadIO m => Rez -> TexturePictureT m a -> m (a, Renderer) ---compileTexturePictureT rz pic = do --- (a, dat) <- runPictureT pic --- glr <- liftIO $ compileTexturePictureData rz dat --- return (a,glr) --- ---compileColorPicture :: MonadIO m => Rez -> ColorPicture a -> m (a, Renderer) ---compileColorPicture rz pic = do --- let (a, dat) = runPicture pic --- glr <- liftIO $ compileColorPictureData rz dat --- return (a,glr) --- ---compileTexturePicture :: MonadIO m => Rez -> TexturePicture a -> m (a, Renderer) ---compileTexturePicture rz pic = do --- let (a, dat) = runPicture pic --- glr <- liftIO $ compileTexturePictureData rz dat --- return (a,glr) --------------------------------------------------------------------------------- --- Specifying a proper backend. --------------------------------------------------------------------------------- - diff --git a/src/Gelatin/Picture.hs b/src/Gelatin/Picture.hs --- a/src/Gelatin/Picture.hs +++ b/src/Gelatin/Picture.hs @@ -1,3 +1,11 @@ +-- | A picture in gelatin's context is a collection of vertices, organized into +-- geometries of triangles, beziers, triangle strips, triangle fans and polylines. +-- The vertices of these pictures can be anything, but the currently available +-- backends already support these vertices: +-- +-- * @(V2 Float, V4 Float)@, ie. colored points in 2d space +-- * @(V2 Float, V2 Float)@, ie. textured points in 2d space +-- module Gelatin.Picture ( -- * Defining Vertex Data VerticesT(..) @@ -10,8 +18,6 @@ , addVertexList , segment , mapVertices - -- * Making shapes - , module S -- * Defining Geometry (Vertex Data + Drawing Operation) , RawGeometry(..) , mapRawGeometry @@ -39,8 +45,12 @@ , getTextures , setRenderingOptions , getRenderingOptions + -- * An example of creating a Picture + -- $creating + -- * Making shapes + , module S -- * Measuring Pictures (2d) - , mapToSpaceVec + , mapPictureVertices , pictureBounds2 , pictureSize2 , pictureOrigin2 @@ -57,3 +67,20 @@ import Gelatin.Picture.Internal import Gelatin.Picture.Shapes as S + +-- $creating +-- Here is an example of drawing two colored beziers into a 2d picture using +-- colors from the 'Gelatin.Core.Color' module: +-- +-- > bezierPicture :: Picture tex (V2 Float, V4 Float) () +-- > bezierPicture = setGeometry $ beziers $ do +-- > bez (V2 0 0, white) (V2 200 0, blue) (V2 200 200, green) +-- > bez (V2 400 200, white) (V2 400 0, blue) (V2 200 0, green) +-- +-- Here is the rendering of that picture after being compiled by a backend: +-- +-- <> +-- +-- As you can see the two beziers have different fill directions, the first is +-- fill inner while the second is fill outer. This is determined by the bezier's +-- winding. diff --git a/src/Gelatin/Picture/Internal.hs b/src/Gelatin/Picture/Internal.hs --- a/src/Gelatin/Picture/Internal.hs +++ b/src/Gelatin/Picture/Internal.hs @@ -21,7 +21,10 @@ -------------------------------------------------------------------------------- -- A Monad for defining vertex data -------------------------------------------------------------------------------- +-- | A monad transformer for defining geometry. newtype VerticesT a m b = Vertices { unVertices :: StateT (Vector a) m b } +-- | A pure context for defining geometry. +-- This is 'VerticesT' parameterized over 'Identity'. type Vertices a = VerticesT a Identity () instance Functor m => Functor (VerticesT a m) where @@ -43,32 +46,44 @@ -------------------------------------------------------------------------------- -- Pretty General Operators -------------------------------------------------------------------------------- +-- | Append three elements to a 'Vector'. +-- /O(n + 3)/ snoc3 :: Unbox a => Vector a -> a -> a -> a -> Vector a -snoc3 v a b = V.snoc (V.snoc (V.snoc v a) b) +snoc3 v a b c = V.fromList [a,b,c] V.++ v +-- | Add a triangle of vertices. tri :: (Monad m, Unbox a) => a -> a -> a -> VerticesT a m () tri a b c = Vertices $ modify $ \v -> snoc3 v a b c +-- | Add a bezier of vertices. +-- This is an alias of 'tri' but looks better in the context +-- of drawing beziers. bez :: (Monad m, Unbox a) => a -> a -> a -> VerticesT a m () bez = tri +-- | Add one vertex. to :: (Monad m, Unbox a) => a -> VerticesT a m () to = Vertices . modify . flip V.snoc +-- | Add two vertices. segment :: (Monad m, Unbox a) => a -> a -> VerticesT a m () segment a b = to a >> to b +-- | Add vertices from a list. addVertexList :: (Monad m, Unbox a) => [a] -> VerticesT a m () addVertexList ys = Vertices $ do xs <- get put $ xs V.++ V.fromList ys +-- | Extract the raw 'Vector' of vertices monadically. runVerticesT :: (Monad m, Unbox a) => VerticesT a m b -> m (Vector a) runVerticesT = flip execStateT V.empty . unVertices +-- | Extract the raw 'Vector' of vertices. runVertices :: Unbox a => Vertices a -> Vector a runVertices = runIdentity . runVerticesT +-- | Map all the vertices in the computation. mapVertices :: (Monad m, Unbox a, Unbox c) => (a -> c) -> VerticesT a m b -> VerticesT c m () mapVertices f s = Vertices $ do @@ -77,12 +92,23 @@ -------------------------------------------------------------------------------- -- Mixing drawing types and transforming them -------------------------------------------------------------------------------- +-- | Mixed drawing types roughly corresponding to OpenGL's draw modes. data RawGeometry a = RawTriangles (Vector a) + -- ^ A collection of points known to be triangles. | RawBeziers (Vector a) + -- ^ A collection of points known to be beziers. | RawTriangleStrip (Vector a) + -- ^ A collection of points known to be a triangle strip. | RawTriangleFan (Vector a) + -- ^ A collection of points known to be a triangle fan. | RawLine (Vector a) + -- ^ A collection of points known to be a polyline. + -- *Note* that in the future polylines will be expressed in + -- terms of the other constructors. + + +-- | Map all the vertices within a 'RawGeometry'. mapRawGeometry :: (Unbox a, Unbox b) => (a -> b) -> RawGeometry a -> RawGeometry b mapRawGeometry f (RawTriangles vs) = RawTriangles $ V.map f vs mapRawGeometry f (RawBeziers vs) = RawBeziers $ V.map f vs @@ -92,8 +118,11 @@ -------------------------------------------------------------------------------- -- A Monad for defining geometry -------------------------------------------------------------------------------- +-- | A monad transformer for defining collections of geometries, specifically +-- mixed collections of triangles, beziers, strips, fans and polylines. newtype GeometryT a m b = Geometry { unGeometry :: StateT (B.Vector (RawGeometry a)) m b} +-- | A pure context for defining collections of geometry. type Geometry a = GeometryT a Identity () instance Functor m => Functor (GeometryT a m) where @@ -113,46 +142,56 @@ instance MonadIO m => MonadIO (GeometryT a m) where liftIO = lift . liftIO +-- | Add some geometry. add :: Monad m => RawGeometry a -> StateT (B.Vector (RawGeometry a)) m () add a = modify (`B.snoc` a) +-- | Define and add some triangles. triangles :: (Unbox a, Monad m) => VerticesT a m () -> GeometryT a m () triangles vs = Geometry $ do v <- lift $ runVerticesT vs add $ RawTriangles v +-- | Define and add some beziers. beziers :: (Monad m, Unbox a) => VerticesT a m () -> GeometryT a m () beziers vs = Geometry $ do v <- lift $ runVerticesT vs add $ RawBeziers v +-- | Define and add a triangle strip. strip :: (Monad m, Unbox a) => VerticesT a m () -> GeometryT a m () strip vs = Geometry $ do v <- lift $ runVerticesT vs add $ RawTriangleStrip v +-- | Define and add a triangle fan. fan :: (Monad m, Unbox a) => VerticesT a m () -> GeometryT a m () fan vs = Geometry $ do v <- lift $ runVerticesT vs add $ RawTriangleFan v +-- | Define and add a polyline. line :: (Monad m, Unbox a) => VerticesT a m () -> GeometryT a m () line vs = Geometry $ do v <- lift $ runVerticesT vs add $ RawLine v +-- | Extract the raw 'Vector' of geometries monadically. runGeometryT :: Monad m => GeometryT a m b -> m (B.Vector (RawGeometry a)) runGeometryT = flip execStateT B.empty . unGeometry +-- | Extract the raw 'Vector' of geometries. runGeometry :: Geometry a -> B.Vector (RawGeometry a) runGeometry = runIdentity . runGeometryT +-- | Map all the vertices within all geometries in the computation. mapGeometry :: (Monad m, Unbox a, Unbox c) => (a -> c) -> GeometryT a m b -> GeometryT c m () mapGeometry f s = Geometry $ do gs <- lift $ runGeometryT s put $ B.map (mapRawGeometry f) gs +-- | Extract only the raw 'Vector' of vertices within the geometry. vertexData :: RawGeometry v -> Vector v vertexData (RawTriangles vs) = vs vertexData (RawBeziers vs) = vs @@ -162,10 +201,12 @@ -------------------------------------------------------------------------------- -- Special Rendering Options -------------------------------------------------------------------------------- +-- | Some special rendering options. Not much to see here. data RenderingOption = StencilMaskOption -------------------------------------------------------------------------------- -- Picture Data -------------------------------------------------------------------------------- +-- | Underlying picture data used to accumulate a visible picture. data PictureData texture vertex = PictureData { _picDataGeometry :: B.Vector (RawGeometry vertex) -- ^ This picture's vertex data. @@ -181,6 +222,7 @@ -------------------------------------------------------------------------------- -- Helpers for Common Picture Types -------------------------------------------------------------------------------- +-- | The empty 'PictureData'. emptyPictureData :: PictureData t v emptyPictureData = PictureData { _picDataGeometry = B.empty @@ -189,89 +231,115 @@ , _picDataOptions = [] } +-- | Map 'realToFrac' over both. bothToFrac :: (Real a, Fractional b) => (V2 a, V2 a) -> (V2 b, V2 b) bothToFrac= second (fmap realToFrac) . first (fmap realToFrac) -------------------------------------------------------------------------------- -- Picture Construction -------------------------------------------------------------------------------- +-- | A monad transformer computation that defines a picture. type PictureT tex vert = StateT (PictureData tex vert) +-- | Extract the result and 'PictureData' from a 'PictureT' computation. runPictureT :: PictureT t v m a -> m (a, PictureData t v) runPictureT = flip runStateT emptyPictureData -------------------------------------------------------------------------------- -- Identity Parameterized Pictures -------------------------------------------------------------------------------- +-- | 'PictureT' parameterized over 'Identity'. type Picture t v = PictureT t v Identity +-- | Extract the result and 'PictureData' of a pure 'Picture' computation. runPicture :: Picture t v a -> (a, PictureData t v) runPicture = runIdentity . runPictureT +-- | Set the geometries of the 'PictureT' with a 'Vector' explicitly. setRawGeometry :: Monad m => B.Vector (RawGeometry v) -> PictureT t v m () setRawGeometry vs = picDataGeometry .= vs +-- | Extract the current geometries of the 'PictureT' as a 'Vector'. getRawGeometry :: Monad m => PictureT t v m (B.Vector (RawGeometry v)) getRawGeometry = use picDataGeometry +-- | Define and set the geometries of the 'PictureT'. setGeometry :: Monad m => GeometryT v m () -> PictureT t v m () setGeometry = (setRawGeometry =<<) . lift . runGeometryT +-- | Set the stroke attributes of the 'PictureT'. setStroke :: Monad m => [StrokeAttr] -> PictureT t v m () setStroke = (picDataStroke .=) +-- | Get the current stroke attributes of the 'PictureT'. getStroke :: Monad m => PictureT t v m [StrokeAttr] getStroke = use picDataStroke +-- | Set the textures contained within the 'PictureT'. +-- These textures @[t]@ are backend dependent. setTextures :: Monad m => [t] -> PictureT t v m () setTextures = (picDataTextures .=) +-- | Get the current textures within the 'PictureT'. getTextures :: Monad m => PictureT t v m [t] getTextures = use picDataTextures +-- | Set any special rendering options. Nothing to see here. setRenderingOptions :: Monad m => [RenderingOption] -> PictureT t v m () setRenderingOptions = (picDataOptions .=) +-- | Get any special rendering options. Nothing to see here. getRenderingOptions :: Monad m => PictureT t v m [RenderingOption] getRenderingOptions = use picDataOptions -------------------------------------------------------------------------------- -- Measuring pictures -------------------------------------------------------------------------------- -mapToSpaceVec :: (Monad m, Unbox v, Unbox s) - => (v -> s) -> PictureT t v m (V.Vector s) -mapToSpaceVec vertToSpace = do +-- | Evaluates the current geometry in the 'PictureT', mapping each vertex. +mapPictureVertices + :: (Monad m, Unbox v, Unbox s) + => (v -> s) + -> PictureT t v m (V.Vector s) +mapPictureVertices mapper = do gs <- use picDataGeometry - let f = V.map vertToSpace . vertexData . (gs B.!) + let f = V.map mapper . vertexData . (gs B.!) return $ V.concatMap f $ V.enumFromTo 0 (B.length gs - 1) +-- | Determines the bounds of a 'PictureT' defined in 2d space. pictureBounds2 :: (Monad m, Unbox v) => (v -> V2 Float) -> PictureT t v m (V2 Float, V2 Float) -pictureBounds2 = (boundingBox <$>) . mapToSpaceVec +pictureBounds2 = (boundingBox <$>) . mapPictureVertices +-- | Determines the bounds of a 'PictureT' defined in 3d space. pictureBounds3 :: (Monad m, Unbox v) => (v -> V3 Float) -> PictureT t v m BCube -pictureBounds3 = (boundingCube <$>) . mapToSpaceVec +pictureBounds3 = (boundingCube <$>) . mapPictureVertices +-- | Determines the size of a 'PictureT' defined in 2d space. pictureSize2 :: (Monad m, Unbox v) => (v -> V2 Float) -> PictureT t v m (V2 Float) pictureSize2 = pictureBounds2 >=> (return . uncurry (flip (-))) +-- | Determines the size of a 'PictureT' defined in 3d space. pictureSize3 :: (Monad m, Unbox v) => (v -> V3 Float) -> PictureT t v m (V3 Float) pictureSize3 = pictureBounds3 >=> (return . uncurry (flip (-))) +-- | Determines the origin of a 'PictureT' defined in 2d space. pictureOrigin2 :: (Monad m, Unbox v) => (v -> V2 Float) -> PictureT t v m (V2 Float) pictureOrigin2 = (fst <$>) . pictureBounds2 +-- | Determines the origin of a 'PictureT' defined in 3d space. pictureOrigin3 :: (Monad m, Unbox v) => (v -> V3 Float) -> PictureT t v m (V3 Float) pictureOrigin3 = (fst <$>) . pictureBounds3 +-- | Determines the center point of a 'PictureT' defined in 2d space. pictureCenter2 :: (Monad m, Unbox v) => (v -> V2 Float) -> PictureT t v m (V2 Float) pictureCenter2 vertToSpace = do (tl,br) <- pictureBounds2 vertToSpace return $ tl + (br - tl)/2 +-- | Determines the center point of a 'PictureT' defined in 3d space. pictureCenter3 :: (Monad m, Unbox v) => (v -> V3 Float) -> PictureT t v m (V3 Float) pictureCenter3 vertToSpace = do