gtk2hs-rpn-0.0.1: src/rpnTeste2.hs

module Main where {
import Graphics.UI.Gtk ;
import Graphics.UI.Gtk.Layout.Rpn ;
import Graphics.Rendering.Cairo ;
import Data.Monoid ;
import Data.IORef ;

desenharQuadrados = do {
    dw <- eventWindow ;
    (w,h) <- drawableGetSize ;

dQ :: IORef (Double,Double) -> Int -> RPN ;
dQ ior n = mconcat [
    cDRW ,
    tON widgetExposeEvent desenharQuadrados ,
    cFRM ,
    tSET label ,
    pCA
 ] where {
    widgetExposeEvent :: Signal Widget (EventM ECrossing Bool) ;
    widgetExposeEvent = exposeEvent ;
    label :: [AttrOp Frame] ;
    label = [frameLabel := ( show n ++ " cm" )] ;
    desenharQuadrados = do {
        dw <- eventWindow ;
        (w,h) <- drawableGetSize ;
        let (w',h') = (fromIntegral w, fromIntegral h) ;
        (eX,eY) <- readIORef ior ;
        xs <- [0,n'*eX..w'] ;
        ys <- [0,n'*eY..h'] ;
        renderWithDrawable dw $ do {


main = do {

 initGUI ;

     janelaPrincipal <- windowNew ;

     proporções <- newIORef ( 10 , 10 ) ;

     let {
         atualizarX = \v -> modifyIORef proporções $ \( _ , y ) -> ( 200 / v , y ) ;
         atualizarY = \v -> modifyIORef proporções $ \( x , _ ) -> ( x , 200 / v ) ;
         desenharQuadrados n = do {
             ( px , py ) <- readIORef proporções ;
             return $ Just $ \( w , h ) -> do {
                 let { dx = n * px ; dy = n * py } ;
                 sequence $ ( flip map ) [ 0 , dx .. w ] $
                  \v -> moveTo v 0 >> lineTo v h ;
                 sequence $ ( flip map ) [ 0 , dy .. h ] $
                  \v -> moveTo 0 v >> lineTo w v ;
                 stroke
             } ;
         } ;
         janelinha n = mconcat [
             rpnCairoLiveShape ( desenharQuadrados n ) 2000 ,
             rpnFrame $ Just $ "<b> Quadrados de " ++ show n ++ " <i> cm </i></b>"
         ] ;
     } ;

     [conteúdo] <- widgetFromRpn $ mconcat [

         rpnCairoShape $ const $ rectangle 10 10 200 200 >> stroke ,
         rpnMinimumSize 220 220 ,

         rpnSetOrientation OrientationVertical ,
         rpnScale 2 10 20 1 ( Just PosRight ) atualizarY ,

         rpnSetOrientation OrientationHorizontal ,
         rpnBox [ PackGrow , PackNatural ] ,

         rpnSetOrientation OrientationHorizontal ,
         rpnScale 2 10 20 1 ( Just PosBottom ) atualizarX ,

         rpnSetOrientation OrientationVertical ,
         rpnBox [ PackNatural , PackNatural ] ,

         rpnSetAlign ( 0.5 , 0.5 ) ,
         rpnAlign 0 0 ,

         rpnSetOrientation OrientationHorizontal ,
         rpnStockButton stockQuit mainQuit ,
         rpnButtonBox ButtonboxCenter [False] ,

         rpnSetOrientation OrientationVertical ,
         rpnBox [ PackGrow , PackNatural ] ,

         janelinha 1 ,
         janelinha 2 ,
         janelinha 3 ,
         rpnBox $ take 3 $ replicate 3 PackGrow ,

         rpnSetOrientation OrientationHorizontal ,
         rpnBox [ PackNatural , PackGrow ]

     ] ;

     containerAdd janelaPrincipal conteúdo ;

     widgetShowAll janelaPrincipal ;

     mainGUI

 }


}