diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks defaultUserHooks diff --git a/doc/IDEAS b/doc/IDEAS new file mode 100644 --- /dev/null +++ b/doc/IDEAS @@ -0,0 +1,27 @@ +This file holds ideas for new features. + +User Interface: + * Holding shift should cause the direction widget to snap to multiples of the + LSystem angle relative to north. + +Drawing: + * Add further drawing primitives, apart from line segments. + * Make these user customisable, perhaps through hs-plugins. + * Allow the user to attach them to various symbols in the LSystem grammar + via some sort of nice user interface. + * These are in essence, Cairo renderings with two special points, start + and end, perhaps (0,0) and (0,1). We can just use Cairo matrices to + scale them to the right size before drawing. + * Additional user customisable rotation primitives. + * Three dimensional rendering. This could be simulated using Cairo, but + needs lots of support in other areas. + +LSystems: + * Context sensitivity. This seems hard because it clashes with the current + monadic approach. (The function passed as the second argument to bind only + gets to see one symbol.) This may require arrows. + * (Mentioned above) Grammar extensions for arbitrary rotation. Eventually + if we move to 3D, this becomes even more necessary, since there will be + a lot of different kinds of rotations we'll probably want to express in + a given 3D system. + diff --git a/doc/TODO b/doc/TODO new file mode 100644 --- /dev/null +++ b/doc/TODO @@ -0,0 +1,13 @@ +This file is for more immediate, but probably more mundane TODO material +than the IDEAS file. + +Serialisation: + * Design a file format for saved L-Systems and a Haskell data structure + to go along with it. Decide what gets saved and what doesn't. + Needs at least axioms and productions. + * Also need to parse and render the file format. + Parsec, Text.PrettyPrint.HughesPJ, XML? + +User Interface: + * Get menus working, and attach them to serialisation functions. + diff --git a/lsystems/branchyTree.l b/lsystems/branchyTree.l new file mode 100644 --- /dev/null +++ b/lsystems/branchyTree.l @@ -0,0 +1,6 @@ +axiom F +F { + 1/3 F[++F][-F]F[---F[--F]], + 1/3 F[-F][++F]F[+++F[++F]], + 1/3 F[++F][-F]F[+F] +} diff --git a/lsystems/branchyTree2.l b/lsystems/branchyTree2.l new file mode 100644 --- /dev/null +++ b/lsystems/branchyTree2.l @@ -0,0 +1,11 @@ +angle 10 +length 6.5 +width 1.00 +foreground #00FF5C +background #000000 +axiom F +F { + 1/3 F[++GF][-GF]F[---GF[--F]], + 1/3 F[-F][++F]G[+++F[++F]], + 1/3 F[++GF][-F]F[+F] +} diff --git a/lsystems/glyph.l b/lsystems/glyph.l new file mode 100644 --- /dev/null +++ b/lsystems/glyph.l @@ -0,0 +1,7 @@ +axiom F+F+F+F+F+F +F { + 2/4 F-F++F-F, + 1/4 F-F-F+F++F+F-F-F, + 1/4 F-F[F]+[F]+F-F +} + diff --git a/lsystems/snowflake.l b/lsystems/snowflake.l new file mode 100644 --- /dev/null +++ b/lsystems/snowflake.l @@ -0,0 +1,4 @@ +axiom F+F+F+F+F+F +F { + 1/1 F-F++F-F +} diff --git a/nymphaea.cabal b/nymphaea.cabal new file mode 100644 --- /dev/null +++ b/nymphaea.cabal @@ -0,0 +1,27 @@ +name: nymphaea +version: 0.1 +synopsis: An interactive GUI for manipulating L-systems +description: An L-system is a small grammar specifying fractal functions, famous + for their uncanny resemblance to plants and other lifeforms. + nymphaea displays these L-systems in an attractive visual manner, and + allows you to manipulate them. +category: Graphics +license: BSD3 +license-file: LICENSE +author: Cale Gibbard, Paolo Martini +maintainer: Cale Gibbard +build-depends: base, random, containers, mtl, parsec, glib, gtk>0.9, glade, cairo +build-type: Simple +data-files: nymphaea.glade, nymphaea.gladep, lsystems/branchyTree.l, + lsystems/glyph.l, lsystems/snowflake.l, lsystems/branchyTree2.l, + doc/IDEAS, doc/TODO + +tested-with: GHC==6.8.2 + +executable: nymphaea +main-is: Nymphaea.hs +hs-source-dirs: src +other-modules: CairoExts, LSystem, MonadRandom, Parser + +ghc-options: -O2 -Wall -optl-Wl,-s +ghc-prof-options: -prof -auto-all diff --git a/nymphaea.glade b/nymphaea.glade new file mode 100644 --- /dev/null +++ b/nymphaea.glade @@ -0,0 +1,452 @@ + + + + + + True + Nymphaea + 600 + + + True + + + True + + + True + + + True + + + False + False + + + + + True + Line properties + + + False + False + 1 + + + + + True + True + + + True + Width + + + False + False + + + + + True + True + 1 0 100 0.10000000149 10 10 + 1 + 2 + True + + + 1 + + + + + False + False + 2 + + + + + True + True + + + True + Length + + + False + False + + + + + True + True + 6.5 0.10000000149 100 0.5 10 10 + 1 + 2 + + + 1 + + + + + False + False + 3 + + + + + True + True + + + True + Foreground + + + False + False + + + + + True + True + 0 + True + Pick a Foreground Color + + + False + False + 1 + + + + + False + False + 4 + + + + + True + True + + + True + Background + + + False + False + + + + + True + True + 0 + Pick a Background Color + + + False + False + 1 + + + + + False + False + 5 + + + + + True + + + False + False + 6 + + + + + True + Lindenmayer System + + + False + False + 7 + + + + + True + True + + + True + Iterations + + + False + False + + + + + True + True + 5 0 100 1 1 1 + 1 + True + + + 1 + + + + + False + False + 8 + + + + + True + True + + + True + Angle + + + False + False + + + + + True + True + 10 0.0099999997764800008 360 0.10000000149 1 1 + 1 + 2 + True + + + 1 + + + + + False + False + 9 + + + + + True + + + False + False + 10 + + + + + True + True + Draw! + True + 0 + + + False + False + GTK_PACK_END + 11 + + + + + False + False + + + + + True + + + False + 1 + + + + + True + + + True + Axiom + + + False + False + + + + + True + True + GTK_POLICY_AUTOMATIC + GTK_POLICY_AUTOMATIC + GTK_SHADOW_IN + + + 30 + True + True + F + + + + + False + 1 + + + + + True + Productions + + + False + False + 2 + + + + + True + True + GTK_POLICY_AUTOMATIC + GTK_POLICY_AUTOMATIC + GTK_SHADOW_IN + + + True + True + F -> { + 1/3: F[++GF][-GF]F[---GF[--F]], + 1/3: F[-F][++F]G[+++F[++F]], + 1/3: F[++GF][-F]F[+F] +} + + + + + 3 + + + + + 2 + + + + + + + True + + + False + False + 1 + + + + + + + GDK_WINDOW_TYPE_HINT_NORMAL + Paolo Martini © 2005 + This Haskell program renders deterministic and +nondeterministic context-free Lindenmayer systems +(also known as [N]DOL-Systems) using the cairo +vector graphics library and Gtk2Hs for the GUI. + http://haskell.galois.com/~paolo/darcs/lsystem + darcs repository of the sources + Copyright © 2005, Paolo Martini. +All rights reserved. + +Redistribution and use in the source and binary forms, with or without modification, +are permitted provided that the following conditions are met: +* Redistributions of source code must retain the above copyright notice, this list + of conditions and the following disclaimer. +* Redistributions in binary form must reproduce he above copyright notice, this + list of conditions and the following disclaimer in the documentation and/or + other materials provided with the distribution. +* The names of the contributors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + Paolo Martini +Cale Gibbard +Duncan Coutts + translator-credits + + You! :-) + + + + + + + False + GTK_PACK_END + + + + + + + Nymphaea: Drawing + 550 + 550 + + + True + + + + diff --git a/nymphaea.gladep b/nymphaea.gladep new file mode 100644 --- /dev/null +++ b/nymphaea.gladep @@ -0,0 +1,8 @@ + + + + + + + FALSE + diff --git a/src/CairoExts.hs b/src/CairoExts.hs new file mode 100644 --- /dev/null +++ b/src/CairoExts.hs @@ -0,0 +1,16 @@ +module CairoExts where + +import Graphics.UI.Gtk.Cairo +import Graphics.Rendering.Cairo as Cairo +import Graphics.UI.Gtk.Gdk.Drawable + +{- +This is really awkward because we don't have longer lived Surfaces. Perhaps just using ForeignPtrs +would be a better way to go, though GHC's garbage collection is rather broken when it comes to +ForeignPtrs to large data. +-} + +renderWithSurfaceFromDrawable :: (DrawableClass source, DrawableClass dest) => + source -> dest -> (Surface -> Render a) -> IO a +renderWithSurfaceFromDrawable src dst f = + renderWithDrawable src $ withTargetSurface $ \s -> liftIO $ renderWithDrawable dst (f s) diff --git a/src/LSystem.hs b/src/LSystem.hs new file mode 100644 --- /dev/null +++ b/src/LSystem.hs @@ -0,0 +1,44 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module LSystem where + +import qualified Data.Map as M +import Control.Monad.Writer +import MonadRandom + +type Alphabet = String +type Axiom = String +type Productions m = M.Map Char (m String) + +type LSystem m = (m Axiom, Productions m) + +result :: (Monad m) => + Int -- ^ iterations + -> LSystem m -- ^ Context-free Lindenmayer System + -> m String -- ^ result +result 0 (axioms,_) = axioms +result n (axioms,productions) = result (n-1) (axioms >>= expand productions, productions) + +expand :: (Monad m) => Productions m -> String -> m String +expand productions axiom = liftM join $ mapM apply axiom + where apply c = M.findWithDefault (return [c]) c productions + +{- +instance Monoid Rational where + mempty = 1 + mappend = (*) + +newtype WL a = WL { unWL :: (WriterT Rational [] a) } deriving (Functor, Monad, MonadPlus, MonadWriter Rational) +runWL = runWriterT . unWL +-} + +test1 :: Maybe String +test1 = result 7 (return "F", M.fromList [('F', Just "F+F-")]) + +test2 :: [String] +test2 = result 7 (return "F", M.fromList [('F', ["", "F+F", "F-F"])]) + +{- +test3 = result 3 (return "F", M.fromList [('F', WL $ WriterT [("",1/5), ("F+F",2/5), ("F-F",2/5)])]) +-} +-- test3 :: Rand String +test3 = result 3 (return "F", M.fromList [('F', fromList [("",1/5), ("F+F",2/5), ("F-F",2/5)])]) diff --git a/src/MonadRandom.hs b/src/MonadRandom.hs new file mode 100644 --- /dev/null +++ b/src/MonadRandom.hs @@ -0,0 +1,50 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +module MonadRandom ( + MonadRandom + , getRandom + , getRandomR + , evalRandomT + , evalRand + , fromList + ) where + +import System.Random +import Data.Ratio +import Control.Monad.State +import Control.Monad.Identity + +class Monad m => MonadRandom m where + getRandom :: (Random a) => m a + getRandomR :: (Random a) => (a,a) -> m a + +newtype RandomT m a = RandomT { unRT :: StateT StdGen m a } + deriving (Functor, Monad, MonadTrans) + +liftState :: (MonadState s m) => (s -> (a,s)) -> m a +liftState t = do v <- get + let (x, v') = t v + put v' + return x + +instance (Monad m) => MonadRandom (RandomT m) where + getRandom = RandomT $ liftState random + getRandomR (x,y) = RandomT $ liftState (randomR (x,y)) + +evalRandomT :: (Monad m) => RandomT m a -> StdGen -> m a +evalRandomT x g = evalStateT (unRT x) g + +newtype Rand a = Rand { unRand :: RandomT Identity a } + deriving (Functor, Monad, MonadRandom) + +evalRand :: Rand a -> StdGen -> a +evalRand x g = runIdentity (evalRandomT (unRand x) g) + +fromList :: [(a,Rational)] -> Rand a +fromList [] = error "MonadRandom.fromList called with empty list" +fromList [(x,_)] = return x +fromList xs = do let s = fromRational . sum . map snd $ xs -- total weight + cs = scanl1 (\(_,q) (y,t) -> (y, t+q)) xs -- cumulative weight + p <- fmap toRational $ getRandomR (0.0 :: Double,s) + return . fst . head . dropWhile (\(_,q) -> q < p) $ cs + diff --git a/src/Nymphaea.hs b/src/Nymphaea.hs new file mode 100644 --- /dev/null +++ b/src/Nymphaea.hs @@ -0,0 +1,343 @@ + +import Data.Maybe (fromJust) +import Control.Monad +import System.Random +import qualified Data.Map as M hiding (filter) +import Data.Char +import Data.Word +import Data.IORef + +-- import System.Mem + +-- import Control.Concurrent +-- import Control.Concurrent.MVar + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Glade +import Graphics.UI.Gtk.Cairo +import Graphics.Rendering.Cairo as Cairo +import System.Glib.Types + +import MonadRandom as R +import Parser +-- import Text.ParserCombinators.Parsec +import LSystem +import CairoExts + +data PinState = NoPin + | Pin (Double, Double) (Double, Double) + +main :: IO () +main = do + initGUI + dialogXml <- liftM fromJust $ xmlNew "nymphaea.glade" + + let getWidget :: WidgetClass widget => (GObject -> widget) -> String -> IO widget + getWidget = xmlGetWidget dialogXml + + windowMain <- getWidget castToWindow "windowMain" + windowMain `onDestroy` mainQuit +{- + windowAbout <- getWidget castToWindow "aboutDialog" +-} + + windowDraw <- getWidget castToWindow "windowDraw" + + -- Menus +{- + menuHelpAbout <- getWidget castToMenuItem "about1" + menuHelpAbout `onActivateLeaf` widgetShow windowAbout +-} + + -- spinButtons for position and line properties + sbLW <- getWidget castToSpinButton "spinbuttonLW" + sbLL <- getWidget castToSpinButton "spinbuttonLL" + + fgPick <- getWidget castToColorButton "foregroundPicker" + colorButtonSetColor fgPick (Color 0 0xffff 0x5c00) + colorButtonSetAlpha fgPick 0x5c00 + bgPick <- getWidget castToColorButton "backgroundPicker" + colorButtonSetColor bgPick (Color 0 0 0) + + sbI <- getWidget castToSpinButton "spinbuttonIterations" + sbA <- getWidget castToSpinButton "spinbuttonAngle" + txA <- getWidget castToTextView "textviewAxiom" + txP <- getWidget castToTextView "textviewProductions" + + btDraw <- getWidget castToButton "buttonDraw" + drawingArea <- getWidget castToDrawingArea "drawingarea1" + + -- TextTag for marking parse errors + {- + ttError <- textTagNew "Error" + set ttError [textTagUnderline := UnderlineError] + ttabError <- textTagTableNew + textTagTableAdd ttabError ttError + set [textBufferTagTable := ttabError]) + -} + {- State references -} + + -- Picture of the LSystem, if any. This only gets drawn when the window is exposed. + pixmapRef <- newIORef Nothing + -- We keep track of whether the user has resized the window since we last made a + -- new image, to avoid constructing too many pixmaps. + resizedRef <- newIORef False + -- Whether or not there is a pin widget to be displayed on the drawing area. + pinRef <- newIORef NoPin + + -- The starting location and angle of the LSystem. + startCoordsRef <- do newIORef (275,500) + startAngleRef <- do newIORef pi + + {- Event handling -} + + windowDraw `onButtonPress` \e -> do + -- Write starting coordinates + let (px,py) = (eventX e, eventY e) + writeIORef startCoordsRef (px, py) + -- Add a pin widget + writeIORef pinRef $ Pin (px, py) (px, py) + -- Force an expose + widgetQueueDraw drawingArea + return True + + -- When the mouse is moved, we update the pin, if any. + windowDraw `onMotionNotify` False $ \e -> do + pin <- readIORef pinRef + case pin of + NoPin -> return False + Pin (px,py) _ -> do let (nx,ny) = (eventX e, eventY e) + -- Update the pin with the new direction + writeIORef pinRef $ Pin (px,py) (nx,ny) + -- Force an expose + widgetQueueDraw drawingArea + return True + + -- When the button is released, we possibly set the + -- starting angle and then redraw. + windowDraw `onButtonRelease` \e -> do + let (u,v) = (eventX e, eventY e) + (x,y) <- readIORef startCoordsRef + let dx = (u - x) + dy = (v - y) + if dx^(2::Int) + dy^(2::Int) > 10^(2::Int) -- If the mouse is off the pin. + then writeIORef startAngleRef (atan2 dx dy) + else return () + -- Remove the pin + writeIORef pinRef NoPin + -- Redraw + buttonClicked btDraw + return True + + -- This prevents the drawing window from being deleted when + -- the user closes it. + windowDraw `onDelete` \_ -> do + widgetHideAll windowDraw + return True + + -- When the user resizes the window, we set a flag, so that + -- the draw button knows to allocate a new pixmap. + windowDraw `onSizeAllocate` \_ -> do + writeIORef resizedRef True + + drawingArea `onExpose` \(Expose {eventRegion = r}) -> do + -- Get the pixmap and pin and the drawing area. + Just pixmap <- readIORef pixmapRef + pin <- readIORef pinRef + drawWindow <- widgetGetDrawWindow drawingArea + -- Paint the pixmap to the drawing area and render a pin, if any. + renderWithSurfaceFromDrawable pixmap drawWindow $ \s -> do + region r + clip + setSourceSurface s 0 0 + paint + renderPin pin + return True + + btDraw `onClicked` do + (x,y) <- readIORef startCoordsRef + sa <- readIORef startAngleRef + lw <- spinButtonGetValue sbLW + ll <- spinButtonGetValue sbLL + + fg <- colorButtonGetColor fgPick + bg <- colorButtonGetColor bgPick + alpha <- colorButtonGetAlpha fgPick + + iterations <- liftM round $ spinButtonGetValue sbI + angle <- spinButtonGetValue sbA + axiomString <- textViewGetText txA + prodString <- textViewGetText txP + + case (parseLSystem axiomString prodString) of + Left err -> do + print err + {- + let pos = errorPos err + l = sourceLine pos + c = sourceColumn pos + tv = case sourceName pos of + "productions" -> txP + "axiom" -> txA + _ -> error "'Impossible' parse error." + buf <- textViewGetBuffer tv + iter <- textBufferGetIterAtLineOffset buf l c + iter' <- textIterCopy iter + b <- textIterForwardChar iter' + if not b + then textIterBackwardChar iter + else return False + textBufferApplyTag buf ttError iter iter' + -} + Right (ParsedLS axim prductions) -> do + (w,h) <- windowGetSize windowDraw + + g <- newStdGen + widgetShowNow windowDraw + widgetShowNow drawingArea + drawWindow <- widgetGetDrawWindow drawingArea + + {- Determine if user resized the window. If they did resize it, we need to + allocate a new pixmap. If not, we only allocate a new pixmap if there's + nothing in the pixmapRef. GHC's garbage collection is poor for ForeignRefs + to large objects so we have to be careful. -} + resized <- readIORef resizedRef + pixmap <- if resized then pixmapNew (Just drawWindow) w h Nothing + else do maybePixmap <- readIORef pixmapRef + case maybePixmap of + Nothing -> pixmapNew (Just drawWindow) w h Nothing + Just p -> return p + -- Write the pixmap back to the reference in case it's new. + writeIORef pixmapRef (Just pixmap) + -- Reset the resized flag so we don't create a new pixmap every time. + writeIORef resizedRef False + + let lsystem = result iterations (R.fromList axim, + M.map (R.fromList) (M.fromList prductions)) + selection = evalRand lsystem g + rendering = drawLSystem w h x y sa lw ll + fg bg alpha + iterations angle selection + + renderWithDrawable pixmap rendering + widgetQueueDraw drawingArea -- Force an expose event. + + return () + + widgetShowAll windowMain + mainGUI + +textViewGetText :: TextView -> IO String +textViewGetText textview = do + buffer <- textViewGetBuffer textview + start <- textBufferGetStartIter buffer + end <- textBufferGetEndIter buffer + textBufferGetText buffer start end False + +drawLSystem :: + Int -- ^ render width + -> Int -- ^ render height + -> Double -- ^ start x + -> Double -- ^ start y + -> Double -- ^ start angle + -> Double -- ^ line width + -> Double -- ^ line length + -> Color -- ^ foreground colour + -> Color -- ^ background colour + -> Word16 -- ^ alpha + -> Int -- ^ iterations + -> Double -- ^ angle + -> String -- ^ turtle graphics + -> Render () +drawLSystem _ _ x y sa linewidth lineLength + (Color fr fg fb) (Color br bg bb) a _ angle instructions = do + withRGBPattern (scaling br) (scaling bg) (scaling bb) $ \p -> do {setSource p; paint} + setSourceRGBA (scaling fr) (scaling fg) (scaling fb) (scaling a) + setLineWidth linewidth + translate x y + rotate (-sa) + moveTo 0 0 + renderLSystem lineLength angle instructions + where scaling z = fromIntegral z / 2^(16::Int) + +renderLSystem :: Double -> Double -> String -> Render () +renderLSystem lineLength angle lsystem = renderLSystem' [] lsystem + where + renderLSystem' _ [] = return () + renderLSystem' ps ('F':rs) = do relLineTo 0 lineLength + (x,y) <- getCurrentPoint + stroke + moveTo x y + renderLSystem' ps rs + renderLSystem' ps ('G':rs) = do relMoveTo 0 lineLength + renderLSystem' ps rs + renderLSystem' ps ('+':rs) = do rotate ( angle * pi / 180) + renderLSystem' ps rs + renderLSystem' ps ('-':rs) = do rotate (-angle * pi / 180) + renderLSystem' ps rs + renderLSystem' ps ('|':rs) = do rotate pi + renderLSystem' ps rs + renderLSystem' ps ('[':rs) = do save + p <- getCurrentPoint + renderLSystem' (p:ps) rs + renderLSystem' ((x,y):ps) (']':rs) = do restore + moveTo x y + renderLSystem' ps rs + renderLSystem' ps (r:rs) | isAlpha r = renderLSystem' ps rs + | otherwise = error $ + "renderLSystem: unknown operator " ++ show r + +{- +clearSurface :: Int -> Int -> Render () +clearSurface width height = do + save + rectangle 0 0 (realToFrac width) (realToFrac height) + setSourceRGB 1 1 1 + setOperator OperatorSource + Cairo.fill + restore +-} + +renderPin :: PinState -> Render () +renderPin NoPin = return () +renderPin (Pin (x,y) (x',y')) = do + renderPinCircle x y + if (x - x')^(2::Int) + (y - y')^(2::Int) > 10^(2::Int) + then renderPinVector x y (atan2 (x' - x) (y' - y)) + else return () + where + renderPinCircle m n = do + newPath -- main circle + withRadialPattern (m-3) (n-3) 0 m n 10 $ \p -> do + patternAddColorStopRGBA p 0 0.5 0.75 1 0.7 + patternAddColorStopRGBA p 1 0.00 0.25 1 0.5 + setSource p + arc m n 10 0 (2 * pi) + fillPreserve + + -- stroke to improve visibility with different backgrounds + setSourceRGBA 0.3 0.3 0.3 0.75 + setLineWidth 1 + stroke + + newPath -- little gleam to make it look round + setSourceRGBA 1 1 1 0.5 + arc (x-3) (y-3) 3 0 (2 * pi) + fillPreserve + + renderPinVector m n a = do + translate m n + rotate (-a) + newPath + moveTo 0 0 + lineTo 2 0 + lineTo 0 25 + lineTo (-2) 0 + lineTo 0 0 + setSourceRGBA 0 0 0.25 0.75 + fillPreserve + -- stroke is necessary for dark backgrounds + setSourceRGBA 1 1 1 0.50 + setLineWidth 1 + stroke + diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,86 @@ +module Parser (parseLSystem, ParsedLSystem (ParsedLS), axiom, productions) where + +import Text.ParserCombinators.Parsec +import Data.Ratio +-- import Debug.Trace + +data ParsedLSystem = ParsedLS { axiom :: [(String, Rational)], + productions :: [(Char,[(String,Rational)])] } + +parseLSystem :: String -> String -> Either ParseError ParsedLSystem +parseLSystem axm prductions = + case parse prods "productions" prductions of + Left err -> Left err + Right ps -> case parse rvalue "axiom" axm of + Left err -> Left err + Right a -> Right (ParsedLS a ps) + +-- Example: +-- +-- Char { +-- Probability String, +-- ..., +-- Probability String +-- }; +-- Char { ... } + +-- a ruleset is a set of ';'-separated rules +prods :: GenParser Char st [(Char, [([Char], Rational)])] +prods = semicolonSep production + +-- a single production is of the form x -> y where x is a turtle graphics command +-- and y is a string of commands, or a weighted set of them. +production :: GenParser Char st (Char, [([Char], Rational)]) +production = do + from <- lvalue + symbol "->" + to <- rvalue + return (from,to) + "production" + +-- alphabet +alphabet :: [Char] +alphabet = "FG+-[]" + +-- the "Char" in "Char { Probability String, .. }" +lvalue :: CharParser st Char +lvalue = oneOf alphabet + +-- either a weighted set of productions, or a single production +rvalue :: GenParser Char st [([Char], Rational)] +rvalue = weightedSet turtle <|> fmap (\x -> [(x,1)]) turtle + +weightedSet :: GenParser Char st t -> GenParser Char st [(t, Rational)] +weightedSet p = + inCurlyBraces $ commaSep $ do + prob <- probability + symbol ":" + to <- p + return (to, prob) + +turtle :: GenParser Char st [Char] +turtle = between spaces spaces $ many1 (oneOf alphabet) + +-- Probability could be a decimal (0.5) or a rational (1/2) +probability :: GenParser Char st Rational +probability = (try decimal) <|> rational "probability" + where decimal = do a <- many1 digit + char '.' + b <- many digit + return $ approxRational (read $ (a ++ "." ++ b) :: Double) 10^(- length b) + rational = do a <- many1 digit + b <- (do char '/'; many1 digit) <|> return "1" + return $ read (a ++ "%" ++ b) + +symbol :: String -> GenParser Char st String +symbol s = between spaces spaces (string s) + +semicolonSep :: GenParser Char st a -> GenParser Char st [a] +semicolonSep p = p `sepBy` symbol ";" + +commaSep :: GenParser Char st a -> GenParser Char st [a] +commaSep p = p `sepBy` symbol "," + +inCurlyBraces :: GenParser Char st a -> GenParser Char st a +inCurlyBraces p = between (symbol "{") (symbol "}") p +