diff --git a/nymphaea.cabal b/nymphaea.cabal --- a/nymphaea.cabal +++ b/nymphaea.cabal @@ -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 -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 diff --git a/src/Nymphaea.hs b/src/Nymphaea.hs --- a/src/Nymphaea.hs +++ b/src/Nymphaea.hs @@ -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