{-# LANGUAGE NoMonomorphismRestriction #-}

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