nymphaea (empty) → 0.1
raw patch · 16 files changed
+1127/−0 lines, 16 filesdep +basedep +cairodep +containerssetup-changed
Dependencies added: base, cairo, containers, glade, glib, gtk, mtl, parsec, random
Files
- LICENSE +28/−0
- Setup.hs +5/−0
- doc/IDEAS +27/−0
- doc/TODO +13/−0
- lsystems/branchyTree.l +6/−0
- lsystems/branchyTree2.l +11/−0
- lsystems/glyph.l +7/−0
- lsystems/snowflake.l +4/−0
- nymphaea.cabal +27/−0
- nymphaea.glade +452/−0
- nymphaea.gladep +8/−0
- src/CairoExts.hs +16/−0
- src/LSystem.hs +44/−0
- src/MonadRandom.hs +50/−0
- src/Nymphaea.hs +343/−0
- src/Parser.hs +86/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++import Distribution.Simple++main = defaultMainWithHooks defaultUserHooks
+ doc/IDEAS view
@@ -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.+
+ doc/TODO view
@@ -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.+
+ lsystems/branchyTree.l view
@@ -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]+}
+ lsystems/branchyTree2.l view
@@ -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]+}
+ lsystems/glyph.l view
@@ -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+}+
+ lsystems/snowflake.l view
@@ -0,0 +1,4 @@+axiom F+F+F+F+F+F+F {+ 1/1 F-F++F-F+}
+ nymphaea.cabal view
@@ -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 <cgibbard@gmail.com>+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
+ nymphaea.glade view
@@ -0,0 +1,452 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!DOCTYPE glade-interface SYSTEM "glade-2.0.dtd">+<!--*- mode: xml -*-->+<glade-interface>+ <widget class="GtkWindow" id="windowMain">+ <property name="visible">True</property>+ <property name="title" translatable="yes">Nymphaea</property>+ <property name="default_width">600</property>+ <child>+ <widget class="GtkVBox" id="vbox1">+ <property name="visible">True</property>+ <child>+ <widget class="GtkHBox" id="hbox1">+ <property name="visible">True</property>+ <child>+ <widget class="GtkVBox" id="vbox2">+ <property name="visible">True</property>+ <child>+ <widget class="GtkHSeparator" id="hseparator3">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>+ <child>+ <widget class="GtkLabel" id="label3">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Line properties</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox5">+ <property name="visible">True</property>+ <property name="homogeneous">True</property>+ <child>+ <widget class="GtkLabel" id="label4">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Width</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>+ <child>+ <widget class="GtkSpinButton" id="spinbuttonLW">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="adjustment">1 0 100 0.10000000149 10 10</property>+ <property name="climb_rate">1</property>+ <property name="digits">2</property>+ <property name="numeric">True</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">2</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox6">+ <property name="visible">True</property>+ <property name="homogeneous">True</property>+ <child>+ <widget class="GtkLabel" id="label5">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Length</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>+ <child>+ <widget class="GtkSpinButton" id="spinbuttonLL">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="adjustment">6.5 0.10000000149 100 0.5 10 10</property>+ <property name="climb_rate">1</property>+ <property name="digits">2</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">3</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox7">+ <property name="visible">True</property>+ <property name="homogeneous">True</property>+ <child>+ <widget class="GtkLabel" id="label6">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Foreground</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>+ <child>+ <widget class="GtkColorButton" id="foregroundPicker">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="response_id">0</property>+ <property name="use_alpha">True</property>+ <property name="title" translatable="yes">Pick a Foreground Color</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">4</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox11">+ <property name="visible">True</property>+ <property name="homogeneous">True</property>+ <child>+ <widget class="GtkLabel" id="label12">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Background</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>+ <child>+ <widget class="GtkColorButton" id="backgroundPicker">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="response_id">0</property>+ <property name="title" translatable="yes">Pick a Background Color</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">5</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHSeparator" id="hseparator1">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">6</property>+ </packing>+ </child>+ <child>+ <widget class="GtkLabel" id="label7">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Lindenmayer System</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">7</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox8">+ <property name="visible">True</property>+ <property name="homogeneous">True</property>+ <child>+ <widget class="GtkLabel" id="label8">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Iterations</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>+ <child>+ <widget class="GtkSpinButton" id="spinbuttonIterations">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="adjustment">5 0 100 1 1 1</property>+ <property name="climb_rate">1</property>+ <property name="numeric">True</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">8</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox10">+ <property name="visible">True</property>+ <property name="homogeneous">True</property>+ <child>+ <widget class="GtkLabel" id="label11">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Angle</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>+ <child>+ <widget class="GtkSpinButton" id="spinbuttonAngle">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="adjustment">10 0.0099999997764800008 360 0.10000000149 1 1</property>+ <property name="climb_rate">1</property>+ <property name="digits">2</property>+ <property name="numeric">True</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">9</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHSeparator" id="hseparator4">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">10</property>+ </packing>+ </child>+ <child>+ <widget class="GtkButton" id="buttonDraw">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">Draw!</property>+ <property name="use_underline">True</property>+ <property name="response_id">0</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="pack_type">GTK_PACK_END</property>+ <property name="position">11</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>+ <child>+ <widget class="GtkVSeparator" id="vseparator1">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <widget class="GtkVBox" id="vbox3">+ <property name="visible">True</property>+ <child>+ <widget class="GtkLabel" id="label13">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Axiom</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>+ <child>+ <widget class="GtkScrolledWindow" id="scrolledwindow2">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>+ <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>+ <property name="shadow_type">GTK_SHADOW_IN</property>+ <child>+ <widget class="GtkTextView" id="textviewAxiom">+ <property name="height_request">30</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="text" translatable="yes">F</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <widget class="GtkLabel" id="label10">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Productions</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">2</property>+ </packing>+ </child>+ <child>+ <widget class="GtkScrolledWindow" id="scrolledwindow1">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>+ <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>+ <property name="shadow_type">GTK_SHADOW_IN</property>+ <child>+ <widget class="GtkTextView" id="textviewProductions">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="text" translatable="yes">F -> {+ 1/3: F[++GF][-GF]F[---GF[--F]],+ 1/3: F[-F][++F]G[+++F[++F]],+ 1/3: F[++GF][-F]F[+F]+}</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="position">3</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="position">2</property>+ </packing>+ </child>+ </widget>+ </child>+ <child>+ <widget class="GtkStatusbar" id="statusbar1">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ </child>+ </widget>+ <widget class="GtkAboutDialog" id="aboutDialog">+ <property name="type_hint">GDK_WINDOW_TYPE_HINT_NORMAL</property>+ <property name="copyright" translatable="yes">Paolo Martini © 2005</property>+ <property name="comments" translatable="yes">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.</property>+ <property name="website">http://haskell.galois.com/~paolo/darcs/lsystem</property>+ <property name="website_label" translatable="yes">darcs repository of the sources</property>+ <property name="license" translatable="yes">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.</property>+ <property name="authors">Paolo Martini+Cale Gibbard+Duncan Coutts</property>+ <property name="translator_credits" translatable="yes" comments="TRANSLATORS: Replace this string with your names, one name per line.">translator-credits</property>+ <property name="artists">+ You! :-)</property>+ <child internal-child="vbox">+ <widget class="GtkVBox" id="dialog-vbox1">+ <child internal-child="action_area">+ <widget class="GtkHButtonBox" id="dialog-action_area1">+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="pack_type">GTK_PACK_END</property>+ </packing>+ </child>+ </widget>+ </child>+ </widget>+ <widget class="GtkWindow" id="windowDraw">+ <property name="title" translatable="yes">Nymphaea: Drawing</property>+ <property name="default_width">550</property>+ <property name="default_height">550</property>+ <child>+ <widget class="GtkDrawingArea" id="drawingarea1">+ <property name="visible">True</property>+ </widget>+ </child>+ </widget>+</glade-interface>
+ nymphaea.gladep view
@@ -0,0 +1,8 @@+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->+<!DOCTYPE glade-project SYSTEM "http://glade.gnome.org/glade-project-2.0.dtd">++<glade-project>+ <name></name>+ <program_name></program_name>+ <gnome_support>FALSE</gnome_support>+</glade-project>
+ src/CairoExts.hs view
@@ -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)
+ src/LSystem.hs view
@@ -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)])])
+ src/MonadRandom.hs view
@@ -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+
+ src/Nymphaea.hs view
@@ -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+
+ src/Parser.hs view
@@ -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+