sylvia 0.2.1 → 0.2.2
raw patch · 11 files changed
+582/−496 lines, 11 filesdep +comonad-transformersdep +data-lensdep +data-lens-template
Dependencies added: comonad-transformers, data-lens, data-lens-template
Files
- Main.hs +2/−1
- README.mkd +4/−2
- Sylvia/Render/Backend.hs +78/−0
- Sylvia/Render/Backend/Cairo.hs +184/−0
- Sylvia/Render/Core.hs +230/−0
- Sylvia/Render/Pair.hs +73/−0
- Sylvia/Renderer/Impl.hs +0/−234
- Sylvia/Renderer/Impl/Cairo.hs +0/−182
- Sylvia/Renderer/Pair.hs +0/−71
- Sylvia/UI/GTK.hs +3/−2
- sylvia.cabal +8/−4
Main.hs view
@@ -6,7 +6,8 @@ import Options.Applicative -import Sylvia.Renderer.Impl.Cairo+import Sylvia.Render.Core+import Sylvia.Render.Backend.Cairo import Sylvia.Text.Parser import Sylvia.UI.GTK
README.mkd view
@@ -16,10 +16,12 @@ cabal configure cabal install --only-dependencies cabal build- dist/build/sylvia+ dist/build/sylvia '\ 0 0' -See [Building from source][] for more detailed instructions.+See [Building from source][] for more detailed instructions, and+[Examples][] for examples, of course. [wiki]: https://github.com/lfairy/sylvia/wiki [Building from source]: https://github.com/lfairy/sylvia/wiki/Building-from-source+[Examples]: https://github.com/lfairy/sylvia/wiki/Examples
+ Sylvia/Render/Backend.hs view
@@ -0,0 +1,78 @@+-- |+-- Module : Sylvia.Render.Backend+-- Copyright : GPLv3+--+-- Maintainer : chrisyco@gmail.com+-- Portability : portable+--+-- This module provides an interface, 'Backend', that all rendering+-- methods must implement.++module Sylvia.Render.Backend+ (+ -- * An interface+ Backend(..)++ -- * Helper functions+ , drawDot+ , drawBox+ , stackHorizontally+ ) where++import Data.Monoid++import Sylvia.Render.Pair++-- | An action that yields an image.+--+-- 'mempty' should yield an empty image and 'mappend' should stack two+-- images together.+class Monoid r => Backend r where+ -- | Draw a dotted rectangle.+ drawDottedRectangle+ :: PInt -- ^ Corner position+ -> PInt -- ^ Size+ -> r++ -- | Draw a line segment from one point to another.+ drawLine :: PInt -> PInt -> r++ -- | Draw a line, but instead of drawing a diagonal line, draw a+ -- zigzag instead.+ drawZigzag :: PInt -> PInt -> r++ -- | Draw a simple circle segment, centered at a point.+ drawCircleSegment+ :: PInt -- ^ Center point+ -> Double -- ^ Start angle, in radians+ -> Double -- ^ End angle, also in radians. Radians are cool.+ -> r++ -- | Translate the given image by a vector.+ relativeTo :: PInt -> r -> r++-- | Draw a full circle, centered at a point.+drawDot :: Backend r => PInt -> r+drawDot center = drawCircleSegment center 0 (2 * pi)++-- | Draw a box, complete with a throat and ear.+drawBox+ :: Backend r+ => PInt -- ^ Top-left corner point+ -> PInt -- ^ Size+ -> Int -- ^ Y offset of ear and throat+ -> r+drawBox corner size throatY+ = drawDottedRectangle corner size+ <> drawCircleSegment (corner |+| ( 0 :| height + throatY)) (1 * rightAngle) (3 * rightAngle)+ <> drawCircleSegment (corner |+| (width :| height + throatY)) (3 * rightAngle) (1 * rightAngle)+ where+ width :| height = size+ rightAngle = pi / 2++-- | Take a list of images and line them up in a row.+stackHorizontally :: Backend r => [(r, PInt)] -> (r, PInt)+stackHorizontally = foldr step (mempty, 0 :| 0)+ where+ step (image', (w' :| h')) (image, (w :| h))+ = (relativeTo ((-w - 1) :| 0) image' <> image, (w + w' + 2) :| max h h')
+ Sylvia/Render/Backend/Cairo.hs view
@@ -0,0 +1,184 @@+-- |+-- Module : Sylvia.Render.Backend.Cairo+-- Copyright : GPLv3+--+-- Maintainer : chrisyco@gmail.com+-- Portability : non-portable (requires FFI)+--+-- Render using the Cairo graphics library.++module Sylvia.Render.Backend.Cairo+ (+ -- * Types+ Image+ , Context(..)++ -- * Drawing the image+ , runImage+ , runImageWithPadding+ , writePNG++ -- * Testing+ , testRender++ -- * Re-exports+ , module Sylvia.Render.Backend+ ) where++import Control.Applicative+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Data.Default+import Data.Lens.Common (getL)+import Data.Monoid (Monoid(..))+import Graphics.Rendering.Cairo++import Sylvia.Render.Backend+import Sylvia.Render.Core (render)+import Sylvia.Render.Pair+import Sylvia.Text.Parser++newtype Image = I { unI :: ImageM () }++type ImageM = ReaderT Context Render++-- | Render an image.+--+-- The resulting image's throat will be at (0, 0); in practice, this will+-- mean that if the result is run directly, most of the image would be+-- off the page. To fix this, use the 'translate' function or call+-- 'runImageWithPadding' instead.+runImage :: Context -> Image -> Render ()+runImage ctx = flip runReaderT ctx . unI++-- | Render an image, translating it so its top-left corner is at (0, 0).+--+-- If you only want to render the thing, this is the function to use.+runImageWithPadding+ :: Context+ -> (Image, PInt) -- The image, along with its size in grid units+ -> (Render (), PInt) -- Rendering action, with its size in pixels+runImageWithPadding ctx (image, innerSize) = (action, realSize)+ where+ action = runImage ctx $ relativeTo (innerSize |+| (1 :| 1)) image+ realSize = ctxGridSize ctx |*| (innerSize |+| (2 :| 2))++-- | Lift a rendering action into the 'ImageM' monad, wrapping it in+-- calls to 'save' and 'restore' to stop its internal state from leaking+-- out.+cairo :: Render a -> ImageM a+cairo action = lift $ do+ save+ result <- action+ restore+ return result++-- | A 'Context' contains the environment required for rendering an+-- expression.+data Context = C+ { ctxGridSize :: PInt+ -- ^ The size of one grid unit. Whenever the rendering code+ -- specifies a coordinate, it is multiplied by this factor before+ -- it is drawn on the screen.+ , ctxOffset :: PInt+ -- ^ The origin of the image. You shouldn't need to fiddle with+ -- this directly – try 'relativeTo' instead.+ }++instance Default Context where+ def = C { ctxGridSize = (20 :| 10), ctxOffset = (0 :| 0) }++-- | Map a relative coordinate to an absolute one, scaling and shifting+-- it in the process.+getAbsolute :: PInt -> ImageM PDouble+getAbsolute pair = getRelative =<< (pair |+|) <$> asks ctxOffset++-- | Scale a relative coordinate.+getRelative :: PInt -> ImageM PDouble+getRelative pair = fromIntegralP . (pair |*|) <$> asks ctxGridSize++-- | Add a half-pixel offset. This can make lines noticeably sharper, by+-- aligning points to the pixel grid.+addHalf :: PDouble -> PDouble+addHalf = (|+| (0.5 :| 0.5))++instance Monoid Image where+ mempty = I $ return ()+ I a `mappend` I b = I $ a >> b++instance Backend Image where+ drawDottedRectangle corner size = I $ do+ x :| y <- addHalf <$> getAbsolute corner+ dx :| dy <- getRelative size+ cairo $ do+ newPath+ rectangle x y dx dy+ setDash [1, 1] 0.5+ setLineWidth 1+ stroke++ drawLine src dest = I $ do+ x1 :| y1 <- addHalf <$> getAbsolute src+ x2 :| y2 <- addHalf <$> getAbsolute dest+ cairo $ do+ newPath+ moveTo x1 y1+ lineTo x2 y2+ setLineWidth 1+ stroke++ drawZigzag src dest = I $ do+ x1 :| y1 <- addHalf <$> getAbsolute src+ x2 :| y2 <- addHalf <$> getAbsolute dest+ let xmid = (x1 + x2) / 2+ cairo $ do+ newPath+ moveTo x1 y1+ lineTo xmid y1+ lineTo xmid y2+ lineTo x2 y2+ setLineWidth 1+ stroke++ drawCircleSegment center start end = I $ do+ cx :| cy <- getAbsolute center+ -- A dot's diameter is approximately equal to one vertical grid unit+ radius <- asks (fromIntegral . (`div` 2) . getL sndP . ctxGridSize)+ cairo $ do+ newPath+ arc cx cy radius start end+ setSourceRGB 0 0 0+ fill++ relativeTo delta = I . local addOffset . unI+ where+ addOffset ctx@C{ ctxOffset = offset }+ = ctx{ ctxOffset = offset |+| delta }++writePNG :: FilePath -> (Image, PInt) -> IO ()+writePNG filename imagePack = withImageSurface FormatRGB24 w h $ \surface -> do+ -- Fill the background with white+ renderWith surface $ setSourceRGB 1 1 1 >> paint+ -- Render ALL the things+ renderWith surface $ action+ -- Save the image+ surfaceWriteToPNG surface filename+ where+ (action, (w :| h)) = runImageWithPadding def imagePack++testRender :: IO ()+testRender = writePNG "result.png" . stackHorizontally $ map render es+ where+ es = map (fromRight . parseExp) $+ [ "L 0"+ , "LL 1"+ , "LL 0"+ , "LLL 2 0 (1 0)"+ , "(L 0 0) (L 0 0)"+ , "L (L 1 (0 0)) (L 1 (0 0))"+ ]++fromRight :: Show e => Either e a -> a+fromRight e = case e of+ Left sinister -> error $ "Unexpected Left: " ++ show sinister+ Right dextrous -> dextrous
+ Sylvia/Render/Core.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : Sylvia.Render.Core+-- Copyright : GPLv3+--+-- Maintainer : chrisyco@gmail.com+-- Portability : portable+--+-- This module provides the algorithm used to render expressions. It can+-- be called in two ways:+--+-- 1. A function, 'render', that uses "Sylvia.Render.Backend" to draw a+-- pretty picture;+--+-- 2. Another function, 'render'', that spews its internals all over the+-- place.++module Sylvia.Render.Core+ (+ -- * A function+ render++ -- * Another function+ , render'++ -- ** The result type+ , Result()+ , resultImage+ , resultSize+ , resultRhyme+ , resultThroatY++ -- ** Internal bits and pieces+ , Rhyme+ , RhymeUnit()+ , ruIndex+ , ruDest+ ) where++import Control.Applicative+import Data.Foldable (foldMap)+import Data.Lens.Common+import Data.Lens.Template+import Data.List (foldl')+import Data.Monoid+import Data.Void (Void, vacuous)++import Sylvia.Render.Backend+import Sylvia.Render.Pair+import Sylvia.Model++type Rhyme = [RhymeUnit]++-- | Specifies a /rhyme line/: a straight line protruding from the left+-- edge of a bounding box, connecting a variable to the sub-expression+-- that uses it.+data RhymeUnit = RhymeUnit+ { _ruIndex :: Integer+ , _ruDest :: Int+ }+ deriving (Show)++$(makeLens ''RhymeUnit)++-- | The result of a rendering operation.+data Result r = Result+ { _resultImage :: r+ -- ^ The rendered image.+ , _resultSize :: PInt+ -- ^ The size of the image's bounding box in grid units, when all+ -- round things are removed.+ , _resultRhyme :: Rhyme+ -- ^ The expression's rhyme.+ , _resultThroatY :: Int+ -- ^ The Y offset of the expression's ear and throat, measured+ -- from the /bottom/ of its bounding box.+ }+ deriving (Show)++$(makeLens ''Result)++-- | Render an expression, returning an image along with its size.+render :: Backend r => Exp Void -> (r, PInt)+render e =+ let Result image size rhyme _ = render' $ vacuous e+ in case rhyme of+ [] -> (image, size)+ _ -> error $ "render: the impossible happened -- "+ ++ "extra free variables: " ++ show rhyme++-- | Render an expression, with extra juicy options.+render' :: Backend r => Exp Integer -> Result r+render' e = case e of+ Ref x -> Result mempty (0 :| 0) [RhymeUnit x 0] 0+ Lam e' -> renderLambda e'+ App a b -> case a of+ Lam _ -> renderBeside a b+ _ -> renderAtop a b++renderBeside :: Backend r => Exp Integer -> Exp Integer -> Result r+renderBeside a b = Result image size rhyme aThroatY+ where+ image = mconcat $+ [ aImage+ , bImage+ ]+ (Result aImage (aWidth :| aHeight) aRhyme aThroatY,+ Result bImage (bWidth :| bHeight) bRhyme bThroatY)+ = alignThroats+ (render' a)+ (shiftX (-aWidth) $ renderWithThroatLine False 1 b)+ size = (aWidth + bWidth :| max aHeight bHeight)+ rhyme = aRhyme ++ bRhyme++alignThroats :: Backend r => Result r -> Result r -> (Result r, Result r)+alignThroats+ a@(Result _ _ _ aThroatY)+ b@(Result _ _ _ bThroatY)+ = (shiftY' (minThroatY - aThroatY) a,+ shiftY' (minThroatY - bThroatY) b)+ where+ minThroatY = min aThroatY bThroatY++renderAtop :: Backend r => Exp Integer -> Exp Integer -> Result r+renderAtop a b = Result image size rhyme bThroatY+ where+ image = mconcat $+ -- Draw the two sub-expressions+ [ aImage+ , bImage+ -- Extend the lower sub-expression so it matches up with the+ -- bigger one+ , relativeTo (-bWidth :| 0)+ $ extendAcross (bWidth - aWidth) bRhyme+ -- Connect them with a vertical line+ , drawLine (0 :| aThroatY) (0 :| bThroatY)+ -- Application dot+ , drawDot (0 :| bThroatY)+ ]+ Result aImage (aWidth :| aHeight) aRhyme aThroatY+ = shiftY (-1 - bHeight) $ renderWithThroatLine False bWidth a+ Result bImage (bWidth :| bHeight) bRhyme bThroatY+ = renderWithThroatLine False 1 b+ size = (aWidth :| aHeight + bHeight + 1)+ rhyme = aRhyme ++ bRhyme++-- | Render an expression with a horizontal line sticking out of its+-- throat. Doesn't sound too comfortable, to be honest.+--+-- The 'resultSize' includes the length of this extra line.+renderWithThroatLine+ :: Backend r+ => Bool -- ^ Whether the enclosing expression is a lambda.+ -> Int -- ^ Length of the throat line. This should be positive.+ -> Exp Integer -> Result r+renderWithThroatLine outerIsLam lineLength e = Result image size rhyme throatY+ where+ Result innerImage innerSize rhyme innerThroatY = render' e+ -- Shift the main image to the left, then draw a line next to it+ image = relativeTo (-lineLength :| 0) innerImage <> throatLine+ throatLine = drawZigzag (-lineLength :| innerThroatY) (0 :| throatY)+ throatY = if outerIsLam && containsLam e then innerThroatY - 1 else innerThroatY+ size = innerSize |+| (lineLength :| 0)++-- | Return whether there is a nested box touching the bottom edge of the+-- bounding box. If True, it means that everything in the image should+-- be shifted down one unit, making the ear and throat lines zigzag.+containsLam :: Exp a -> Bool+containsLam e = case e of+ Ref _ -> False+ Lam _ -> True+ App _ b -> containsLam b++-- | Render a lambda expression.+renderLambda :: Backend r => Exp (Inc Integer) -> Result r+renderLambda e' = Result image size rhyme throatY+ where+ Result innerImage (innerWidth :| innerHeight) innerRhyme throatY+ = shiftY (-1) . renderWithThroatLine True 1 $ fmap shiftDown e'+ -- Draw a box around it+ image = drawBox (negateP size) size throatY+ <> relativeTo (-width :| 0) rhymeImage+ <> innerImage+ (rhymeImage, rhyme) = renderRhyme throatY innerRhyme+ rhymeHeight = fromInteger . maximumOr 0 $ map (getL ruIndex) innerRhyme+ size@(width :| _) = (innerWidth + 1 :| (max innerHeight rhymeHeight) + 2)++-- | Like 'maximum', but returns a default value on an empty list rather+-- than throwing a hissy fit.+maximumOr :: Ord a => a -> [a] -> a+maximumOr def = foldl' max def++-- | Render an expression's rhyme.+renderRhyme+ :: Backend r+ => Int -- ^ Throat offset (see 'resultThroatY')+ -> Rhyme -- ^ The inner expression's rhyme+ -> (r, Rhyme) -- ^ The resulting image, along with the outer rhyme+renderRhyme throatY innerRhyme = (foldMap renderOne innerRhyme, outerRhyme)+ where+ renderOne (RhymeUnit index dest) = drawLine (0 :| throatY - fromInteger index) (1 :| dest)+ outerRhyme =+ [ RhymeUnit (pred index) (throatY - fromInteger index)+ | RhymeUnit index _ <- innerRhyme+ , index > 0+ ]++-- | Shift an image horizontally by a specified amount.+shiftX :: Backend r => Int -> Result r -> Result r+shiftX dx = modL resultImage (relativeTo (dx :| 0))++-- | Shift an image vertically by a specified amount, changing the rhyme+-- and throat position to compensate.+shiftY :: Backend r => Int -> Result r -> Result r+shiftY dy+ = modL resultImage (relativeTo (0 :| dy))+ . modL resultRhyme (map (modL ruDest (+ dy)))+ . modL resultThroatY (+ dy)++-- | Like 'shiftY', but expand the image's bounding box rather than shifting it.+shiftY' :: Backend r => Int -> Result r -> Result r+shiftY' dy+ = modL resultSize (modL sndP (subtract dy)) -- dy is usually negative, so this /increases/ the size+ . shiftY dy++extendAcross :: Backend r => Int -> Rhyme -> r+extendAcross dx = foldMap $ drawLine+ <$> ( 0 :|) . getL ruDest+ <*> (dx :|) . getL ruDest
+ Sylvia/Render/Pair.hs view
@@ -0,0 +1,73 @@+-- |+-- Module : Sylvia.Render.Pair+-- Copyright : GPLv3+--+-- Maintainer : chrisyco@gmail.com+-- Portability : portable+--+-- Strict pairs, and operations on them.++module Sylvia.Render.Pair+ (+ -- * Building and dismantling pairs+ P(..)+ , fstP+ , sndP++ -- * Fancy type aliases+ , PInt+ , PDouble++ -- * Operations on pairs+ , (|+|)+ , (|*|)+ , negateP+ , fromIntegralP+ ) where++import Control.Applicative+import Control.Comonad.Trans.Store+import Data.Lens.Common++-- | A strict pair.+data P a = !a :| !a+ deriving (Eq, Ord, Bounded, Read, Show)++infix 5 :|++instance Functor P where+ fmap f (x :| y) = f x :| f y++instance Applicative P where+ pure x = x :| x+ f :| g <*> x :| y = f x :| g y++-- | A pair of integers.+type PInt = P Int++-- | A pair of doubles.+type PDouble = P Double++-- | Add or multiply the corresponding values in two pairs.+(|+|), (|*|) :: Num a => P a -> P a -> P a+(|+|) = liftA2 (+)+(|*|) = liftA2 (*)++infixl 6 |+|+infixl 7 |*|++-- | Negate the contents of a pair.+negateP :: Num a => P a -> P a+negateP = fmap negate++-- | Apply 'fromIntegral' to the contents of a pair.+fromIntegralP :: (Integral a, Num b) => P a -> P b+fromIntegralP = fmap fromIntegral++-- | Lens on the first element.+fstP :: Lens (P a) a+fstP = Lens $ \(x :| y) -> store (\x' -> x' :| y) x++-- | Lens on the second element.+sndP :: Lens (P a) a+sndP = Lens $ \(x :| y) -> store (\y' -> x :| y') y
− Sylvia/Renderer/Impl.hs
@@ -1,234 +0,0 @@--- |--- Module : Sylvia.Renderer.Impl--- Copyright : GPLv3------ Maintainer : chrisyco@gmail.com--- Portability : portable------ This module provides three things:------ 1. An interface, 'RenderImpl', that all rendering methods must--- implement;------ 2. A function, 'render', that uses the aforementioned interface to--- draw a pretty picture;------ 3. Another function, 'render'', that spews its internals all over the--- place.--module Sylvia.Renderer.Impl- (- -- * An interface- RenderImpl(..)-- -- * A function- , render-- -- * Another function- , render'- , Result(..)- , Rhyme- , RhymeUnit(..)-- -- * Miscellany- , stackHorizontally- ) where--import Control.Applicative-import Data.Foldable ( foldMap )-import Data.List ( foldl' )-import Data.Monoid-import Data.Void ( Void, vacuous )--import Sylvia.Model-import Sylvia.Renderer.Pair---- | An action that yields an image.------ 'mempty' should yield an empty image and 'mappend' should stack two--- images together.-class Monoid r => RenderImpl r where- -- | Draw a dotted rectangle.- drawDottedRectangle- :: PInt -- ^ Corner position- -> PInt -- ^ Size- -> r-- -- | Draw a line segment from one point to another.- drawLine :: PInt -> PInt -> r-- -- | Draw a line, but instead of drawing a diagonal line, draw a- -- zigzag instead.- drawZigzag :: PInt -> PInt -> r-- -- | Draw a simple circle segment, centered at a point.- drawCircleSegment- :: PInt -- ^ Center point- -> Double -- ^ Start angle, in radians- -> Double -- ^ End angle, also in radians. Radians are cool.- -> r-- -- | Translate the given image by a vector.- relativeTo :: PInt -> r -> r---- | Draw a full circle, centered at a point.-drawDot :: RenderImpl r => PInt -> r-drawDot center = drawCircleSegment center 0 (2 * pi)---- | Draw a box, complete with a throat and ear.-drawBox- :: RenderImpl r- => PInt -- ^ Top-left corner point- -> PInt -- ^ Size- -> Int -- ^ Y offset of ear and throat- -> r-drawBox corner size throatY- = drawDottedRectangle corner size- <> drawCircleSegment (corner |+| ( 0 :| height + throatY)) (1 * rightAngle) (3 * rightAngle)- <> drawCircleSegment (corner |+| (width :| height + throatY)) (3 * rightAngle) (1 * rightAngle)- where- width :| height = size- rightAngle = pi / 2--type Rhyme = [RhymeUnit]---- | Specifies a /rhyme line/: a straight line protruding from the left--- edge of a bounding box, connecting a variable to the sub-expression--- that uses it.-data RhymeUnit = RhymeUnit- { ruIndex :: Integer- , ruDest :: Int- }- deriving (Show)---- | The result of a rendering operation.-data Result r = Result- { resultImage :: r- -- ^ The rendered image.- , resultSize :: PInt- -- ^ The size of the image's bounding box in grid units, when all- -- round things are removed.- , resultRhyme :: Rhyme- -- ^ The expression's rhyme.- , resultThroatY :: Int- -- ^ The Y offset of the expression's ear and throat, measured- -- from the /bottom/ of its bounding box.- }- deriving (Show)---- | Render an expression, returning an image along with its size.-render :: RenderImpl r => Exp Void -> (r, PInt)-render e =- let Result image size rhyme _ = render' $ vacuous e- in case rhyme of- [] -> (image, size)- _ -> error $ "render: the impossible happened -- "- ++ "extra free variables: " ++ show rhyme---- | Render an expression, with extra juicy options.-render' :: RenderImpl r => Exp Integer -> Result r-render' e = case e of- Ref x -> Result mempty (0 :| 0) [RhymeUnit x 0] 0- Lam e' -> renderLambda e'- App a b -> Result image size rhyme bThroatY- where- image = mconcat $- -- Draw the two sub-expressions- [ aImage- , bImage- -- Extend the shorter sub-expression so it matches up with- -- the bigger one- , extendRhyme (-aWidth) (-bWidth) bRhyme- -- Connect them with a vertical line- , drawLine (0 :| aThroatY) (0 :| bThroatY)- -- Application dot- , drawDot (0 :| bThroatY)- ]- Result aImage (aWidth :| aHeight) aRhyme aThroatY- = shiftY (-1 - bHeight) $ renderWithThroatLine False bWidth a- Result bImage (bWidth :| bHeight) bRhyme bThroatY- = renderWithThroatLine False 1 b- size = (aWidth :| aHeight + bHeight + 1)- rhyme = aRhyme ++ bRhyme---- | Render an expression with a horizontal line sticking out of its--- throat. Doesn't sound too comfortable, to be honest.------ The 'resultSize' includes the length of this extra line.-renderWithThroatLine- :: RenderImpl r- => Bool -- ^ Whether the enclosing expression is a lambda.- -> Int -- ^ Length of the throat line. This should be positive.- -> Exp Integer -> Result r-renderWithThroatLine outerIsLam lineLength e = Result image size rhyme throatY- where- Result image' size' rhyme throatY' = render' e- -- Shift the main image to the left, then draw a line next to it- image = relativeTo (-lineLength :| 0) image' <> throatLine- throatLine = drawZigzag (-lineLength :| throatY') (0 :| throatY)- throatY = if outerIsLam && containsLam e then throatY' - 1 else throatY'- size = size' |+| (lineLength :| 0)--containsLam :: Exp a -> Bool-containsLam e = case e of- Ref _ -> False- Lam _ -> True- App _ b -> containsLam b---- | Render a lambda expression.-renderLambda :: RenderImpl r => Exp (Inc Integer) -> Result r-renderLambda e' = Result image size rhyme throatY- where- Result image' (innerWidth :| innerHeight) innerRhyme throatY- = shiftY (-1) . renderWithThroatLine True 1 $ fmap shiftDown e'- image = drawBox (negateP size) size throatY- <> relativeTo (-width :| 0) rhymeImage- <> image'- (rhymeImage, rhyme) = renderRhyme throatY innerRhyme- rhymeHeight = fromInteger . maximumOr 0 $ map ruIndex innerRhyme- size@(width :| _) = (innerWidth + 1 :| (max innerHeight rhymeHeight) + 2)---- | Like 'maximum', but returns a default value on an empty list rather--- than throwing a hissy fit.-maximumOr :: Ord a => a -> [a] -> a-maximumOr def = foldl' max def---- | Render an expression's rhyme.-renderRhyme- :: RenderImpl r- => Int -- ^ Throat offset (see 'resultThroatY')- -> Rhyme -- ^ The inner expression's rhyme- -> (r, Rhyme) -- ^ The resulting image, along with the outer rhyme-renderRhyme throatY innerRhyme = (foldMap renderOne innerRhyme, outerRhyme)- where- renderOne (RhymeUnit index dest) = drawLine (0 :| throatY - fromInteger index) (1 :| dest)- outerRhyme =- [ RhymeUnit (pred index) (throatY - fromInteger index)- | RhymeUnit index _ <- innerRhyme- , index > 0- ]---- | Shift an image vertically by a specified amount, changing the rhyme--- and throat position to compensate.-shiftY :: RenderImpl r => Int -> Result r -> Result r-shiftY dy (Result image size rhyme throatY)- = Result image' size rhyme' throatY'- where- image' = relativeTo (0 :| dy) image- rhyme' = map shiftRhyme rhyme- throatY' = throatY + dy-- shiftRhyme :: RhymeUnit -> RhymeUnit- shiftRhyme (RhymeUnit index dest) = RhymeUnit index (dest + dy)--extendRhyme :: RenderImpl r => Int -> Int -> Rhyme -> r-extendRhyme srcX destX = foldMap $ drawLine- <$> (srcX :|) . ruDest- <*> (destX :|) . ruDest---- | Take a list of images and line them up in a row.-stackHorizontally :: RenderImpl r => [(r, PInt)] -> (r, PInt)-stackHorizontally = foldr step (mempty, 0 :| 0)- where- step (image', (w' :| h')) (image, (w :| h))- = (relativeTo ((-w - 1) :| 0) image' <> image, (w + w' + 2) :| max h h')
− Sylvia/Renderer/Impl/Cairo.hs
@@ -1,182 +0,0 @@--- |--- Module : Sylvia.Renderer.Impl.Cairo--- Copyright : GPLv3------ Maintainer : chrisyco@gmail.com--- Portability : non-portable (requires FFI)------ Renderer using the Cairo graphics library.--module Sylvia.Renderer.Impl.Cairo- (- -- * Types- Image- , Context(..)-- -- * Drawing the image- , runImage- , runImageWithPadding- , writePNG-- -- * Testing- , testRender-- -- * Re-exports- , module Sylvia.Renderer.Impl- ) where--import Control.Applicative-import Control.Monad.Trans.Class-import Control.Monad.Trans.Reader-import Data.Default-import Data.Monoid (Monoid(..))-import Graphics.Rendering.Cairo--import Sylvia.Renderer.Impl-import Sylvia.Renderer.Pair-import Sylvia.Text.Parser--newtype Image = I { unI :: ImageM () }--type ImageM = ReaderT Context Render---- | Render an image.------ The resulting image's throat will be at (0, 0); in practice, this will--- mean that if the result is run directly, most of the image would be--- off the page. To fix this, use the 'translate' function or call--- 'runImageWithPadding' instead.-runImage :: Context -> Image -> Render ()-runImage ctx = flip runReaderT ctx . unI---- | Render an image, translating it so its top-left corner is at (0, 0).------ If you only want to render the thing, this is the function to use.-runImageWithPadding- :: Context- -> (Image, PInt) -- The image, along with its size in grid units- -> (Render (), PInt) -- Rendering action, with its size in pixels-runImageWithPadding ctx (image, innerSize) = (action, realSize)- where- action = runImage ctx $ relativeTo (innerSize |+| (1 :| 1)) image- realSize = ctxGridSize ctx |*| (innerSize |+| (2 :| 2))---- | Lift a rendering action into the 'ImageM' monad, wrapping it in--- calls to 'save' and 'restore' to stop its internal state from leaking--- out.-cairo :: Render a -> ImageM a-cairo action = lift $ do- save- result <- action- restore- return result---- | A 'Context' contains the environment required for rendering an--- expression.-data Context = C- { ctxGridSize :: PInt- -- ^ The size of one grid unit. Whenever the rendering code- -- specifies a coordinate, it is multiplied by this factor before- -- it is drawn on the screen.- , ctxOffset :: PInt- -- ^ The origin of the image. You shouldn't need to fiddle with- -- this directly – try 'relativeTo' instead.- }--instance Default Context where- def = C { ctxGridSize = (20 :| 10), ctxOffset = (0 :| 0) }---- | Map a relative coordinate to an absolute one, scaling and shifting--- it in the process.-getAbsolute :: PInt -> ImageM PDouble-getAbsolute pair = getRelative =<< (pair |+|) <$> asks ctxOffset---- | Scale a relative coordinate.-getRelative :: PInt -> ImageM PDouble-getRelative pair = fromIntegralP . (pair |*|) <$> asks ctxGridSize---- | Add a half-pixel offset. This can make lines noticeably sharper, by--- aligning points to the pixel grid.-addHalf :: PDouble -> PDouble-addHalf = (|+| (0.5 :| 0.5))--instance Monoid Image where- mempty = I $ return ()- I a `mappend` I b = I $ a >> b--instance RenderImpl Image where- drawDottedRectangle corner size = I $ do- x :| y <- addHalf <$> getAbsolute corner- dx :| dy <- getRelative size- cairo $ do- newPath- rectangle x y dx dy- setDash [1, 1] 0.5- setLineWidth 1- stroke-- drawLine src dest = I $ do- x1 :| y1 <- addHalf <$> getAbsolute src- x2 :| y2 <- addHalf <$> getAbsolute dest- cairo $ do- newPath- moveTo x1 y1- lineTo x2 y2- setLineWidth 1- stroke-- drawZigzag src dest = I $ do- x1 :| y1 <- addHalf <$> getAbsolute src- x2 :| y2 <- addHalf <$> getAbsolute dest- let xmid = (x1 + x2) / 2- cairo $ do- newPath- moveTo x1 y1- lineTo xmid y1- lineTo xmid y2- lineTo x2 y2- setLineWidth 1- stroke-- drawCircleSegment center start end = I $ do- cx :| cy <- getAbsolute center- -- A dot's diameter is approximately equal to one vertical grid unit- radius <- asks (fromIntegral . (`div` 2) . sndP . ctxGridSize)- cairo $ do- newPath- arc cx cy radius start end- setSourceRGB 0 0 0- fill-- relativeTo delta = I . local addOffset . unI- where- addOffset ctx@C{ ctxOffset = offset }- = ctx{ ctxOffset = offset |+| delta }--writePNG :: FilePath -> (Image, PInt) -> IO ()-writePNG filename imagePack = withImageSurface FormatRGB24 w h $ \surface -> do- -- Fill the background with white- renderWith surface $ setSourceRGB 1 1 1 >> paint- -- Render ALL the things- renderWith surface $ action- -- Save the image- surfaceWriteToPNG surface filename- where- (action, (w :| h)) = runImageWithPadding def imagePack--testRender :: IO ()-testRender = writePNG "result.png" . stackHorizontally $ map render es- where- es = map (fromRight . parseExp) $- [ "L 0"- , "LL 1"- , "LL 0"- , "LLL 2 0 (1 0)"- , "(L 0 0) (L 0 0)"- , "L (L 1 (0 0)) (L 1 (0 0))"- ]--fromRight :: Show e => Either e a -> a-fromRight e = case e of- Left sinister -> error $ "Unexpected Left: " ++ show sinister- Right dextrous -> dextrous
− Sylvia/Renderer/Pair.hs
@@ -1,71 +0,0 @@--- |--- Module : Sylvia.Renderer.Pair--- Copyright : GPLv3------ Maintainer : chrisyco@gmail.com--- Portability : portable------ Strict pairs, and operations on them.--module Sylvia.Renderer.Pair- (- -- * Building and dismantling pairs- P(..)- , fstP- , sndP-- -- * Fancy type aliases- , PInt- , PDouble-- -- * Operations on pairs- , (|+|)- , (|*|)- , negateP- , fromIntegralP- ) where--import Control.Applicative---- | A strict pair.-data P a = !a :| !a- deriving (Eq, Ord, Bounded, Read, Show)--infix 5 :|--instance Functor P where- fmap f (x :| y) = f x :| f y--instance Applicative P where- pure x = x :| x- f :| g <*> x :| y = f x :| g y---- | A pair of integers.-type PInt = P Int---- | A pair of doubles.-type PDouble = P Double---- | Add or multiply the corresponding values in two pairs.-(|+|), (|*|) :: Num a => P a -> P a -> P a-(|+|) = liftA2 (+)-(|*|) = liftA2 (*)--infixl 6 |+|-infixl 7 |*|---- | Negate the contents of a pair.-negateP :: Num a => P a -> P a-negateP = fmap negate---- | Apply 'fromIntegral' to the contents of a pair.-fromIntegralP :: (Integral a, Num b) => P a -> P b-fromIntegralP = fmap fromIntegral---- | Get the first element of a pair.-fstP :: P a -> a-fstP (x :| _) = x---- | Get the second element of a pair.-sndP :: P a -> a-sndP (_ :| y) = y
Sylvia/UI/GTK.hs view
@@ -18,8 +18,9 @@ import System.IO ( hPutStr, hPutStrLn, stderr ) import Sylvia.Model-import Sylvia.Renderer.Pair-import Sylvia.Renderer.Impl.Cairo+import Sylvia.Render.Core+import Sylvia.Render.Pair+import Sylvia.Render.Backend.Cairo title :: String title = "Sylvia"
sylvia.cabal view
@@ -1,5 +1,5 @@ Name: sylvia-Version: 0.2.1+Version: 0.2.2 Synopsis: Lambda calculus visualization Category: Game @@ -30,7 +30,10 @@ Main-Is: Main.hs Build-Depends: base == 4.*+ , comonad-transformers , data-default+ , data-lens+ , data-lens-template , optparse-applicative == 0.4.* , parsec >= 3.1.2 && < 3.2 , transformers@@ -40,9 +43,10 @@ Other-Modules: Sylvia.Model- Sylvia.Renderer.Impl- Sylvia.Renderer.Impl.Cairo- Sylvia.Renderer.Pair+ Sylvia.Render.Backend+ Sylvia.Render.Backend.Cairo+ Sylvia.Render.Core+ Sylvia.Render.Pair Sylvia.Text.Parser Sylvia.Text.PrettyPrint Sylvia.UI.GTK