module DrawDiagrams
( module Diagrams
, draw
, drawOn
) where
import Diagrams
import Control.Concurrent
import Control.Concurrent.MVar
import Graphics.UI.Gtk
import Graphics.Rendering.Cairo ( Render, liftIO )
import Graphics.Rendering.Diagrams.Engine ( render )
import Graphics.Rendering.Diagrams.Types ( runDiaRenderM, defaultDiaRenderEnv )
test1 = draw $ union [circle 2 `move` (x,0) | x<-[0..10]] `fill` white
draw :: Diagram -> IO ()
draw = drawOn 640 400
drawOn :: Int -> Int -> Diagram -> IO ()
drawOn w h dia = do
initGUI
dialog <- dialogNew
windowSetKeepAbove dialog True
windowSetDefaultSize dialog w h
set dialog [ windowWindowPosition := WinPosCenter ]
dialogAddButton dialog stockClose ResponseClose
contain <- dialogGetUpper dialog
canvas <- drawingAreaNew
af <- aspectFrameNew 0.5 0.5 (Just 1.6)
canvas `onSizeRequest` return (Requisition 160 100)
containerAdd af canvas
boxPackStartDefaults contain af
canvas `on` exposeEvent $ tryEvent $ liftIO $ do
win <- widgetGetDrawWindow canvas
(w, h) <- drawableGetSize win
let (w', h') = (fromIntegral w, fromIntegral h)
let sc = w' / 32
renderWithDrawable win $ do
flip runDiaRenderM defaultDiaRenderEnv $ render $
(rect w' h' `fill` white `strokeWidth` 0
<|> scaleY (1) dia `scale` sc `strokeWidth` (0.05*sc))
`move` (w'/2, h'/2)
s <- newEmptyMVar
tid <- forkIO $ do
_ <- getChar
putMVar s ()
forkIO $ do
widgetShowAll dialog
dialogRun dialog
putMVar s ()
_ <- takeMVar s
killThread tid
widgetDestroy dialog
flush