nymphaea-0.3: src/Nymphaea.hs
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 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 LSystem
import CairoExts
data PinState = NoPin
| Pin (Double, Double) (Double, Double)
main :: IO ()
main = do
initGUI
dialogXml <- liftM fromJust (getDataFileName "nymphaea.glade" >>= xmlNew)
let getWidget :: WidgetClass widget => (GObject -> widget) -> String -> IO widget
getWidget = xmlGetWidget dialogXml
windowMain <- getWidget castToWindow "windowMain"
windowMain `onDestroy` mainQuit
windowDraw <- getWidget castToWindow "windowDraw"
-- 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"
{- 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 `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.
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 `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 `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 `on` sizeAllocate $
const . liftIO $ writeIORef resizedRef 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
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
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