nymphaea-0.1: 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 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