nymphaea 0.2 → 0.3
raw patch · 2 files changed
+58/−94 lines, 2 filesdep ~basedep ~gtknew-uploader
Dependency ranges changed: base, gtk
Files
- nymphaea.cabal +4/−4
- src/Nymphaea.hs +54/−90
nymphaea.cabal view
@@ -1,5 +1,5 @@ name: nymphaea-version: 0.2+version: 0.3 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.@@ -10,18 +10,18 @@ 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-depends: base<=4.1.0.0, random, containers, mtl, parsec, glib, gtk>=0.10.0, 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+tested-with: GHC==6.10.3 executable: nymphaea main-is: Nymphaea.hs hs-source-dirs: src other-modules: CairoExts, LSystem, MonadRandom, Parser -ghc-options: -O2 -Wall -optl-Wl,-s+ghc-options: -O2 ghc-prof-options: -prof -auto-all
src/Nymphaea.hs view
@@ -7,22 +7,17 @@ import Data.Word import Data.IORef --- import System.Mem---- import Control.Concurrent--- import Control.Concurrent.MVar- import Paths_nymphaea (getDataFileName) import Graphics.UI.Gtk import Graphics.UI.Gtk.Glade import Graphics.UI.Gtk.Cairo+import Graphics.UI.Gtk.Gdk.EventM import Graphics.Rendering.Cairo as Cairo import System.Glib.Types import MonadRandom as R import Parser--- import Text.ParserCombinators.Parsec import LSystem import CairoExts @@ -39,18 +34,9 @@ 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"@@ -69,14 +55,6 @@ 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.@@ -93,68 +71,71 @@ {- 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+ windowDraw `on` buttonPressEvent $+ do -- Write starting coordinates+ (px,py) <- eventCoordinates+ liftIO $ do 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+ widgetAddEvents windowDraw [ButtonMotionMask]+ windowDraw `on` motionNotifyEvent $+ do pin <- liftIO $ readIORef pinRef+ case pin of+ NoPin -> return False+ Pin (px,py) _ -> do (nx,ny) <- eventCoordinates+ -- Update the pin with the new direction+ liftIO $ do 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+ windowDraw `on` buttonReleaseEvent $+ do (u,v) <- eventCoordinates+ (x,y) <- liftIO $ 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 liftIO $ writeIORef startAngleRef (atan2 dx dy)+ else return ()+ liftIO $+ do -- 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+ windowDraw `on` deleteEvent $+ do liftIO $ 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+ windowDraw `on` sizeAllocate $ + const . liftIO $ 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+ drawingArea `on` exposeEvent $+ do r <- eventRegion+ -- Get the pixmap and pin and the drawing area.+ liftIO $ do 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@@ -174,23 +155,6 @@ 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