sylvia 0.2.0.1 → 0.2.1
raw patch · 6 files changed
+107/−43 lines, 6 filesdep +optparse-applicative
Dependencies added: optparse-applicative
Files
- Main.hs +40/−8
- README.mkd +2/−3
- Sylvia/Renderer/Impl.hs +16/−4
- Sylvia/Renderer/Impl/Cairo.hs +36/−15
- Sylvia/UI/GTK.hs +10/−11
- sylvia.cabal +3/−2
Main.hs view
@@ -1,17 +1,49 @@+{-# LANGUAGE RecordWildCards #-}+ module Main ( main ) where -import System.Environment ( getArgs )+import Options.Applicative +import Sylvia.Renderer.Impl.Cairo import Sylvia.Text.Parser import Sylvia.UI.GTK main :: IO ()-main = do- args <- getArgs- case args of- [input] -> case parseExp input of- Left err -> putStrLn $ show err- Right res -> showInWindow res- _ -> putStrLn "Usage: sylvia 'expression'"+main = execParser opts >>= process+ where+ opts = info (helper <*> sylvia)+ ( fullDesc+ & progDesc "Render a lambda expression"+ & header "sylvia - a lambda calculus visualizer"+ )++process :: Sylvia -> IO ()+process (Sylvia{..}) = do+ case parseExp input of+ Left derp -> print derp+ Right e -> case outputFile of+ Nothing -> showInWindow [e]+ Just filename -> writePNG filename $ render e++data Sylvia = Sylvia+ { outputFile :: Maybe FilePath+ , input :: String+ }+ deriving (Show)++sylvia :: Parser Sylvia+sylvia = Sylvia+ <$> nullOption+ ( long "output"+ & short 'o'+ & metavar "FILENAME"+ & help "Write the result to a PNG image"+ & value Nothing+ & reader (Just . Just)+ )+ <*> argument Just+ ( metavar "EXPR"+ & help "Expression to render, in zero-based De Bruijn index notation"+ )
README.mkd view
@@ -11,12 +11,11 @@ Quick start ----------- - git clone git://github.com/chrisyco/sylvia+ git clone git://github.com/lfairy/sylvia cd sylvia- cabal configure --enable-tests+ cabal configure cabal install --only-dependencies cabal build- cabal test dist/build/sylvia See [Building from source][] for more detailed instructions.
Sylvia/Renderer/Impl.hs view
@@ -29,6 +29,9 @@ , Result(..) , Rhyme , RhymeUnit(..)++ -- * Miscellany+ , stackHorizontally ) where import Control.Applicative@@ -163,12 +166,14 @@ -- 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 && isLambda e then throatY' - 1 else throatY'+ throatY = if outerIsLam && containsLam e then throatY' - 1 else throatY' size = size' |+| (lineLength :| 0) -isLambda :: Exp a -> Bool-isLambda (Lam _) = True-isLambda _ = False+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@@ -220,3 +225,10 @@ 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 view
@@ -11,10 +11,13 @@ ( -- * Types Image- , runImage- , runImage' , Context(..) + -- * Drawing the image+ , runImage+ , runImageWithPadding+ , writePNG+ -- * Testing , testRender @@ -23,11 +26,10 @@ ) where import Control.Applicative-import Control.Arrow ( (***) ) import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Default-import Data.Monoid ( Monoid(..), (<>) )+import Data.Monoid (Monoid(..)) import Graphics.Rendering.Cairo import Sylvia.Renderer.Impl@@ -38,11 +40,26 @@ 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 -runImage' :: Context -> (Image, PInt) -> (Render (), PInt)-runImage' ctx = runImage ctx *** (ctxGridSize ctx |*|)+-- | 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@@ -54,9 +71,16 @@ 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@@ -129,23 +153,20 @@ addOffset ctx@C{ ctxOffset = offset } = ctx{ ctxOffset = offset |+| delta } -dumpPNG :: PInt -> Image -> IO ()-dumpPNG size action = withImageSurface FormatRGB24 w h $ \surface -> do+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- let action' = relativeTo (1 :| 1) action- renderWith surface $ runImage def action'+ renderWith surface $ action -- Save the image- surfaceWriteToPNG surface "result.png"+ surfaceWriteToPNG surface filename where- w :| h = ctxGridSize def |*| (size |+| (2 :| 2)) -- padding+ (action, (w :| h)) = runImageWithPadding def imagePack testRender :: IO ()-testRender = uncurry dumpPNG $ foldl step (0 :| 0, mempty) es+testRender = writePNG "result.png" . stackHorizontally $ map render es where- step ((w :| h), image) e = ((w + w' + 1) :| (max h h'), image <> relativeTo ((w + w') :| h') image')- where (image', (w' :| h')) = render e es = map (fromRight . parseExp) $ [ "L 0" , "LL 1"
Sylvia/UI/GTK.hs view
@@ -24,8 +24,8 @@ title :: String title = "Sylvia" -showInWindow :: Exp Void -> IO ()-showInWindow e = do+showInWindow :: [Exp Void] -> IO ()+showInWindow es = do "Initializing GTK" -:- do initGUI @@ -40,26 +40,25 @@ "Creating canvas" -:- do canvas <- drawingAreaNew- let (_, (w :| h)) = renderCairo e+ let (_, (w :| h)) = renderCairo es widgetSetSizeRequest canvas w h set window [ containerChild := canvas ]- canvas `on` exposeEvent $ updateCanvas e+ canvas `on` exposeEvent $ updateCanvas es "Show ALL the things!" -:- do widgetShowAll window mainGUI -updateCanvas :: Exp Void -> EventM EExpose Bool-updateCanvas e = do+updateCanvas :: [Exp Void] -> EventM EExpose Bool+updateCanvas es = do win <- eventWindow liftIO $ do- let (action, size) = renderCairo e- let (w :| h) = fmap fromIntegral $ size |+| ctxGridSize def- renderWithDrawable win $ translate w h >> action+ let (action, _) = renderCairo es+ renderWithDrawable win action return True -renderCairo :: Exp Void -> (Render (), PInt)-renderCairo = runImage' def . render+renderCairo :: [Exp Void] -> (Render (), PInt)+renderCairo = runImageWithPadding def . stackHorizontally . map render infixr 1 -:- (-:-) :: String -> IO a -> IO a
sylvia.cabal view
@@ -1,5 +1,5 @@ Name: sylvia-Version: 0.2.0.1+Version: 0.2.1 Synopsis: Lambda calculus visualization Category: Game @@ -19,7 +19,7 @@ License: GPL License-File: LICENSE-Copyright: 2011 Chris Wong+Copyright: 2012 Chris Wong Build-Type: Simple Extra-Source-Files: README.mkd@@ -31,6 +31,7 @@ Build-Depends: base == 4.* , data-default+ , optparse-applicative == 0.4.* , parsec >= 3.1.2 && < 3.2 , transformers , void >= 0.5.5 && < 0.6