Haskell+gtk+gtkglext

gearsを移植。frame rateの表示とか、物体の回転とかは省いている。物体の回転は、quaternionで実現する予定。

{-# LANGUAGE TypeFamilies
 #-}

import System
import List

import Control.Monad
import Control.Monad.Trans

import Data.IORef
import Data.Tensor

import qualified Graphics.UI.Gtk as Gtk
import Graphics.UI.Gtk (AttrOp((:=)), on)
import qualified Graphics.UI.Gtk.Gdk.EventM as Gdk.EventM
import qualified Graphics.UI.Gtk.Gdk.Events as Gdk.Events
import qualified Graphics.UI.Gtk.OpenGL as GtkGL
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL (($=))
import Graphics.Rendering.OpenGL.GL.VertexSpec
import Graphics.Rendering.OpenGL.Raw.Core31 (GLfloat,GLdouble,GLint)

--アプリケーションの状態を表す変数（共通参照）
data AppCtx = AppCtx { isSync :: Bool,
                       angle  :: GLfloat,
                       gear1  :: GL.DisplayList,
                       gear2  :: GL.DisplayList,
                       gear3  :: GL.DisplayList,
                       view   :: Vector3 GLfloat,
                       idleHandlerId :: Gtk.HandlerId }
priorityRedraw :: Int
priorityRedraw = Gtk.priorityHighIdle + 20

createGear:: GLfloat -> GLfloat -> GLfloat -> GLint -> GLfloat -> IO () 
createGear innterRadius outerRadius width teeth toothDepth = do
  let r0 = innterRadius
      r1 = outerRadius - (toothDepth / 2.0)
      r2 = outerRadius + (toothDepth / 2.0)
      da = 2.0 * pi / (fromIntegral teeth) /4.0      
  GL.shadeModel $= GL.Flat
  GL.normal (Normal3 0.0 0.0 1.0 :: Normal3 GLfloat)
  GL.renderPrimitive GL.QuadStrip $ drawFrontFace teeth (r0, r1, r2, da)
  GL.renderPrimitive GL.Quads $ drawFrontSidesTeeth teeth (r0, r1, r2, da)
  GL.normal (Normal3 0.0 0.0 (-1.0) :: Normal3 GLfloat)
  GL.renderPrimitive GL.QuadStrip $ drawBackFace teeth (r0, r1, r2, da)
  GL.renderPrimitive GL.Quads $ drawBackSidesTeeth teeth (r0, r1, r2, da)
  GL.renderPrimitive GL.QuadStrip $ drawOutwardFaceOfTeeth teeth (r0, r1, r2, da)
  GL.shadeModel $= GL.Smooth
  GL.renderPrimitive GL.QuadStrip $ drawInsideRadiusCylinder teeth r0  
  where
    drawFrontFace :: GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> IO ()
    drawFrontFace teeth (r0, r1, r2, da) = drawFrontFaceRepeat 0 teeth (r0, r1, r2, da)
      where
        drawSurface :: GLint -> GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> IO ()
        drawSurface counter teeth (r0, r1, r2, da) = do
          let angle = ((fromIntegral counter) * 2.0 * pi)/(fromIntegral teeth)
          GL.vertex (Vertex3 (r0*(cos angle)) (r0*(sin angle)) (width*0.5) :: Vertex3 GLfloat)
          GL.vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) (width*0.5) :: Vertex3 GLfloat)
          if (counter < teeth) 
          then 
              (do
                GL.vertex (Vertex3 (r0*(cos angle)) (r0*(sin angle)) (width*0.5) :: Vertex3 GLfloat)
                GL.vertex (Vertex3 (r1*(cos $ angle + 3*da)) (r1*(sin $ angle + 3*da)) (width*0.5) :: Vertex3 GLfloat)
                drawFrontFaceRepeat (counter+1) teeth (r0, r1, r2, da)
                return ())
          else 
              drawFrontFaceRepeat (counter+1) teeth (r0, r1, r2, da)
        drawFrontFaceRepeat :: GLint -> GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> IO ()
        drawFrontFaceRepeat counter teeth (r0, r1, r2, da) = 
          if (counter <= teeth) 
          then drawSurface counter teeth (r0, r1, r2, da)
          else return ()

    drawFrontSidesTeeth :: GLint-> (GLfloat, GLfloat, GLfloat, GLfloat) -> IO ()
    drawFrontSidesTeeth teeth (r0, r1, r2, da) = drawFrontSidesTeethRepeat 0 teeth (r0, r1, r2, da)
        where
          drawFrontSidesTeethRepeat :: GLint -> GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> IO ()
          drawFrontSidesTeethRepeat counter teeth (r0, r1, r2, da) = do
            let angle = ((fromIntegral counter) * 2.0 * pi)/(fromIntegral teeth)
            if (counter < teeth) 
            then (do 
                   GL.vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) (width*0.5) :: Vertex3 GLfloat)
                   GL.vertex (Vertex3 (r2*(cos $ angle + da)) (r2*(sin $ angle + da)) (width*0.5) :: Vertex3 GLfloat)
                   GL.vertex (Vertex3 (r2*(cos $ angle + 2*da)) (r2*(sin $ angle + 2*da)) (width*0.5) :: Vertex3 GLfloat)
                   GL.vertex (Vertex3 (r1*(cos $ angle + 3*da)) (r1*(sin $ angle + 3*da)) (width*0.5) :: Vertex3 GLfloat) 
                   drawFrontSidesTeethRepeat (counter+1) teeth (r0, r1, r2, da))
            else return ()

    drawBackFace :: GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> IO ()
    drawBackFace teeth (r0, r1, r2, da) = drawBackFaceRepeat 0 teeth (r0, r1, r2, da)
        where
          drawSurface :: GLint -> GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> IO ()
          drawSurface counter teeth (r0, r1, r2, da) = do
            let angle = ((fromIntegral counter)*2.0*pi)/(fromIntegral teeth)
            GL.vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) (-width*0.5) :: Vertex3 GLfloat)
            GL.vertex (Vertex3 (r0*(cos angle)) (r0*(sin angle)) (-width*0.5) :: Vertex3 GLfloat)
            if (counter < teeth)
            then 
                (do
                  GL.vertex (Vertex3 (r1*(cos $ angle + 3*da)) (r1*(sin $ angle + 3*da)) (-width*0.5) :: Vertex3 GLfloat)
                  GL.vertex (Vertex3 (r0*(cos angle)) (r0*(sin angle)) (-width*0.5) :: Vertex3 GLfloat)
                  drawBackFaceRepeat (counter+1) teeth (r0, r1, r2, da))
            else
                drawBackFaceRepeat (counter+1) teeth (r0, r1, r2, da)                                     
          drawBackFaceRepeat :: GLint -> GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> IO ()
          drawBackFaceRepeat counter teeth (r0, r1, r2, da) = 
              if (counter <= teeth)
              then drawSurface counter teeth (r0, r1, r2, da)
              else return ()

    drawBackSidesTeeth :: GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> IO ()
    drawBackSidesTeeth teeth (r0, r1, r2, da) = drawBackSidesTeethRepeat 0 teeth (r0, r1, r2, da)
        where
          drawBackSidesTeethRepeat :: GLint -> GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> IO ()
          drawBackSidesTeethRepeat counter teeth (r0, r1, r2, da) = do
            let angle = ((fromIntegral counter)*2.0*pi)/(fromIntegral teeth)
            if (counter < teeth) 
            then (do 
                   GL.vertex (Vertex3 (r1*(cos $ angle + 3*da)) (r1*(sin $ angle + 3*da)) (-width*0.5) :: Vertex3 GLfloat)
                   GL.vertex (Vertex3 (r2*(cos $ angle + 2*da)) (r2*(sin $ angle + 2*da)) (-width*0.5) :: Vertex3 GLfloat)
                   GL.vertex (Vertex3 (r2*(cos $ angle + da)) (r2*(sin $ angle + da)) (-width*0.5) :: Vertex3 GLfloat)
                   GL.vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) (-width*0.5) :: Vertex3 GLfloat)
                   drawBackSidesTeethRepeat (counter+1) teeth (r0, r1, r2, da))
            else return ()

    drawOutwardFaceOfTeeth :: GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> IO ()
    drawOutwardFaceOfTeeth teeth (r0, r1, r2, da) = do 
      drawOutwardFaceOfTeethRepeat 0 teeth (r0, r1, r2, da)
      GL.vertex (Vertex3 (r1*(cos 0)) (r2*(sin 0)) (width*0.5) :: Vertex3 GLfloat)
      GL.vertex (Vertex3 (r1*(cos 0)) (r2*(sin 0)) (-width*0.5) :: Vertex3 GLfloat)
        where
          drawOutwardFaceOfTeethRepeat :: GLint -> GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> IO ()
          drawOutwardFaceOfTeethRepeat counter teeth (r0, r1, r2, da) = do
            if (counter < teeth) 
            then (do
                   let angle = ((fromIntegral counter)*2.0*pi)/(fromIntegral teeth)
                   drawFrontFaceOfTeeth counter teeth (r0, r1, r2, da) angle
                   drawBackFaceOfTeeth counter teeth (r0, r1, r2, da) angle
                   drawOutwardFaceOfTeethRepeat (counter+1) teeth (r0, r1, r2, da))
            else return ()
            where
              drawFrontFaceOfTeeth :: GLint -> GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> GLfloat -> IO ()
              drawFrontFaceOfTeeth counter teeth (r0, r1, r2, da) angle = do
                   let u' = r2*(cos $ angle+da) - r1*(cos $ angle)
                       v' = r2*(sin $ angle+da) - r1*(sin $ angle)
                       len = sqrt (u'*u' + v'+v')
                       u = u'/len
                       v = v'/len
                   GL.vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) (width*0.5) :: Vertex3 GLfloat)
                   GL.vertex (Vertex3 (r1*(cos angle)) (r1*(sin angle)) (-width*0.5) :: Vertex3 GLfloat)
                   GL.normal (Normal3 v (-u) 0.0 :: Normal3 GLfloat)
                   GL.vertex (Vertex3 (r2*(cos $ angle+da)) (r2*(sin $ angle+da)) (width*0.5) :: Vertex3 GLfloat)
                   GL.vertex (Vertex3 (r2*(cos $ angle+da)) (r2*(sin $ angle+da)) (-width*0.5) :: Vertex3 GLfloat)
                   GL.normal (Normal3 (cos angle) (sin angle) 0.0)
              drawBackFaceOfTeeth :: GLint -> GLint -> (GLfloat, GLfloat, GLfloat, GLfloat) -> GLfloat -> IO ()
              drawBackFaceOfTeeth counter teeth (r0, r1, r2, da) angle = do
                  let u' = r1*(cos $ angle + 3*da) - r2*(cos $ angle + 2*da)
                      v' = r1*(sin $ angle + 3*da) - r2*(sin $ angle + 2*da)
                      len = sqrt (u'*u' + v'+v')
                      u = u'/len
                      v = v'/len
                  GL.vertex (Vertex3 (r2*(cos $ angle + 2*da)) (r2*(sin $ angle + 2*da)) (width*0.5) :: Vertex3 GLfloat)
                  GL.vertex (Vertex3 (r2*(cos $ angle + 2*da)) (r2*(sin $ angle + 2*da)) (-width*0.5) :: Vertex3 GLfloat)
                  GL.normal (Normal3 v (-u) 0.0 :: Normal3 GLfloat)
                  GL.vertex (Vertex3 (r1*(cos $ angle + 3*da)) (r1*(sin $ angle + 3*da)) (width*0.5) :: Vertex3 GLfloat)
                  GL.vertex (Vertex3 (r1*(cos $ angle + 3*da)) (r1*(sin $ angle + 3*da)) (-width*0.5) :: Vertex3 GLfloat)
                  GL.normal (Normal3 (cos angle) (sin angle) 0.0)

    drawInsideRadiusCylinder :: GLint -> GLfloat -> IO ()
    drawInsideRadiusCylinder teeth r0 = drawInsideRadiusCylinderRepeat 0 teeth r0
      where
        drawInsideRadiusCylinderRepeat :: GLint -> GLint -> GLfloat -> IO ()
        drawInsideRadiusCylinderRepeat counter teeth r0 = 
          if (counter <= teeth) 
          then (do
                 let angle = ((fromIntegral counter)*2.0*pi)/(fromIntegral teeth)
                 GL.normal (Normal3 (-(cos angle)) (-(sin angle)) 0.0 :: Normal3 GLfloat)
                 GL.vertex (Vertex3 (r0*(cos angle)) (r0*(sin angle)) (-width*0.5) :: Vertex3 GLfloat)
                 GL.vertex (Vertex3 (r0*(cos angle)) (r0*(sin angle)) (width*0.5) :: Vertex3 GLfloat)
                 drawInsideRadiusCylinderRepeat (counter+1) teeth r0)
          else return ()

createGearDisplayList :: Color4 GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLint -> GLfloat -> IO GL.DisplayList
createGearDisplayList color innterRadius outerRadius width teeth toothDepth = do
  GL.defineNewList GL.Compile $ do
    GL.materialAmbientAndDiffuse GL.Front $= color
    createGear innterRadius outerRadius width teeth toothDepth
    return ()

createDisplayList :: IORef AppCtx -> IO ()
createDisplayList appCtx = do
  -- gearのモデルを作る
  newGear1 <- createGearDisplayList red   1.0 4.0 1.0 20 0.7 
  newGear2 <- createGearDisplayList green 0.5 2.0 2.0 10 0.7
  newGear3 <- createGearDisplayList blue  1.3 2.0 0.5 10 0.7
  (AppCtx isSync angle _ _ _ view idleHandlerId) <- readIORef appCtx
  writeIORef appCtx AppCtx { isSync = isSync,
                             angle = angle,
                             gear1 = newGear1,
                             gear2 = newGear2,
                             gear3 = newGear3,
                             view  = view,
                             idleHandlerId = idleHandlerId }
  return ()
  where
    red   = Color4 0.8 0.1 0.0 1.0 :: Color4 GLfloat 
    green = Color4 0.0 0.8 0.2 1.0 :: Color4 GLfloat
    blue  = Color4 0.2 0.2 1.0 1.0 :: Color4 GLfloat

setupGLenv :: GtkGL.GLWindow -> IO ()
setupGLenv glWindow = do
  GL.position (GL.Light 0) $= lightPosition  
  GL.frontFace $= GL.CW
  GL.cullFace  $= Just GL.Front -- glCullFace(GL_FRONT); glEnable (GL_CULL_FACE);
  GL.normalize $= GL.Enabled
  GL.lighting  $= GL.Enabled
  GL.light (GL.Light 0) $= GL.Enabled
  GL.depthFunc $= Just GL.Less -- glEnable(GL_DEPTH_TEST)
  
  --透視変換を設定
  (w,h) <- GtkGL.glDrawableGetSize glWindow
  let ratio = (fromIntegral h)/(fromIntegral w)
  GL.viewport $= (GL.Position 0 0, (GL.Size (fromIntegral w) (fromIntegral h)))
  GL.matrixMode $= GL.Projection
  GL.loadIdentity
  GL.frustum (-1.0) 1.0 (-ratio) ratio 5.0 60.0
  GL.matrixMode $= GL.Modelview 0
  GL.loadIdentity  
  GL.translate (Vector3 0.0 0.0 (-40.0)::Vector3 GLfloat)
  return ()
  where
    lightPosition = Vertex4 5.0 5.0 10.0 0.0 :: Vertex4 GLfloat

initGLDrawEnv :: IORef AppCtx -> GtkGL.GLWindow -> IO ()
initGLDrawEnv appCtx glWindow = do
  createDisplayList appCtx
  setupGLenv glWindow

draw :: IORef AppCtx -> GtkGL.GLWindow -> IO Bool
draw appCtx glWindow = do
  (AppCtx _ angle gear1 gear2 gear3 view@(Vector3 view_rotx view_roty view_rotz) _) <- readIORef appCtx
  GL.clear [GL.ColorBuffer, GL.DepthBuffer]
  GL.preservingMatrix $ do
    GL.rotate view_rotx (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat)
    GL.rotate view_roty (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat)
    GL.rotate view_rotz (Vector3 0.0 0.0 1.0 :: Vector3 GLfloat)
    GL.preservingMatrix $ do
      GL.translate (Vector3 (-3.0) (-2.0) 0.0 :: Vector3 GLfloat)
      GL.rotate angle (Vector3 0.0 0.0 1.0 :: Vector3 GLfloat)
      GL.callList gear1
    GL.preservingMatrix $ do
      GL.translate (Vector3 3.1 (-2.0) 0.0 :: Vector3 GLfloat)
      GL.rotate (-2.0*angle-9.0) (Vector3 0.0 0.0 1.0 :: Vector3 GLfloat)
      GL.callList gear2
    GL.preservingMatrix $ do
      GL.translate (Vector3 (-3.1) (4.0) 0.0 :: Vector3 GLfloat)
      GL.rotate (-2.0*angle-25.0) (Vector3 0.0 0.0 1.0 :: Vector3 GLfloat)
      GL.callList gear3
  GtkGL.glDrawableSwapBuffers glWindow
  return True
  
main :: IO ()
main = do
  Gtk.initGUI
  GtkGL.initGL
  args <- getArgs
  
  -- 共通参照を作成
  appCtx <- newIORef AppCtx { isSync = not $ any (\s -> (s == "--async")) args,
                              angle = 0.0,
                              gear1 = GL.DisplayList 0,
                              gear2 = GL.DisplayList 0,
                              gear3 = GL.DisplayList 0,
                              view = Vector3 20.0 30.0 0.0,
                              idleHandlerId = 0 }
  
  -- OpenGL frame bufferの設定
  glConfig <- GtkGL.glConfigNew[GtkGL.GLModeRGBA,
                                GtkGL.GLModeDepth,
                                GtkGL.GLModeDouble]  
  
  window <- createWindow appCtx glConfig
  Gtk.widgetShowAll window
  Gtk.mainGUI
  
  where       
    idleCallback :: IORef AppCtx -> GtkGL.GLDrawingArea -> IO Bool
    idleCallback appCtx drawingArea = do
      (AppCtx isSync angle gear1 gear2 gear3 view idleHandlerId) <- readIORef appCtx
      writeIORef appCtx AppCtx { isSync = isSync,
                                 angle = if (angle+2.0 >= 360.0)
                                         then 0.0
                                         else angle+2.0, 
                                 gear1 = gear1,
                                 gear2 = gear2,
                                 gear3 = gear3,
                                 view  = view,
                                 idleHandlerId = idleHandlerId }
      drawWindow <- Gtk.widgetGetDrawWindow drawingArea
      allocation <- Gtk.widgetGetAllocation drawingArea
      Gtk.drawWindowInvalidateRect drawWindow allocation False -- onExpose Eventを発生させる。
      if isSync 
        then 
        do 
          Gtk.drawWindowProcessUpdates drawWindow False
          return True
        else return True

    idleAdd :: IORef AppCtx -> GtkGL.GLDrawingArea-> IO ()
    idleAdd appCtx drawingArea = do
      (AppCtx isSync angle gear1 gear2 gear3 view idleHandlerId) <- readIORef appCtx
      if (idleHandlerId == 0)
        then 
        do
          newHandlerId <- Gtk.idleAdd (idleCallback appCtx drawingArea) priorityRedraw
          writeIORef appCtx AppCtx {  isSync = isSync,
                                      angle = angle,
                                      gear1 = gear1,
                                      gear2 = gear2,
                                      gear3 = gear3,
                                      view = view,
                                      idleHandlerId = newHandlerId }
        else return ()

    idleRemove :: IORef AppCtx -> GtkGL.GLDrawingArea-> IO ()
    idleRemove appCtx drawingArea = do
      (AppCtx isSync angle gear1 gear2 gear3 view idleHandlerId) <- readIORef appCtx
      if (idleHandlerId /= 0)
        then 
        do
          Gtk.idleRemove idleHandlerId
          writeIORef appCtx AppCtx { isSync = isSync,
                                     angle = angle,
                                     gear1 = gear1,
                                     gear2 = gear2,
                                     gear3 = gear3,
                                     view = view,
                                     idleHandlerId = 0 }
        else return ()

    afterRealizeCallback :: IORef AppCtx -> GtkGL.GLDrawingArea -> IO ()
    afterRealizeCallback appCtx drawingArea = 
      GtkGL.withGLDrawingArea drawingArea $ initGLDrawEnv appCtx 

    onConfigureEventCallback :: IORef AppCtx -> GtkGL.GLDrawingArea -> Gdk.Events.Event -> IO Bool
    onConfigureEventCallback appCtx drawingArea _ = 
         GtkGL.withGLDrawingArea drawingArea (\glWindow -> do
                                                 (w,h) <- GtkGL.glDrawableGetSize glWindow
                                                 let ratio = (fromIntegral h)/(fromIntegral w) 
                                                 GL.viewport $= (GL.Position 0 0, (GL.Size (fromIntegral w) (fromIntegral h)))
                                                 GL.matrixMode $= GL.Projection
                                                 GL.loadIdentity
                                                 GL.frustum (-1.0) 1.0 (-ratio) ratio 5.0 60.0
                                                 GL.matrixMode $= GL.Modelview 0
                                                 GL.loadIdentity
                                                 GL.translate (Vector3 0.0 0.0 (-40.0)::Vector3 GLfloat)
                                                 return True)
                                                          
    onExposeCallback :: IORef AppCtx -> GtkGL.GLDrawingArea -> Gdk.Events.Event -> IO Bool
    onExposeCallback appCtx drawingArea _ = 
         GtkGL.withGLDrawingArea drawingArea $ draw appCtx

    mapEventCallback :: IORef AppCtx -> GtkGL.GLDrawingArea -> Gdk.EventM.EventM Gdk.EventM.EAny ()
    mapEventCallback appCtx drawingArea = liftIO $ idleAdd appCtx drawingArea

    unmapEventCallback :: IORef AppCtx -> GtkGL.GLDrawingArea -> Gdk.EventM.EventM Gdk.EventM.EAny ()
    unmapEventCallback appCtx drawingArea = liftIO $ idleRemove appCtx drawingArea
      
    visibilityNotifyEventCallback :: IORef AppCtx -> GtkGL.GLDrawingArea -> Gdk.EventM.EventM Gdk.EventM.EVisibility ()
    visibilityNotifyEventCallback appCtx drawingArea = do
      visibility <- Gdk.EventM.eventVisibilityState
      liftIO $
       if (visibility == Gtk.VisibilityFullyObscured)
       then idleRemove appCtx drawingArea
       else idleAdd appCtx drawingArea
      return ()

    createWindow :: IORef AppCtx -> GtkGL.GLConfig -> IO Gtk.Window
    createWindow appCtx glConfig = do
      
      -- 描画Widget作成
      drawingArea <- GtkGL.glDrawingAreaNew glConfig
      Gtk.widgetSetSizeRequest drawingArea 500 500
      
      -- どのEventを取るかのmask
      Gtk.widgetAddEvents drawingArea [Gtk.ScrollMask, Gtk.Button1MotionMask]
      
      -- drawingAreaにrealize after eventを登録する
      Gtk.afterRealize drawingArea $ afterRealizeCallback appCtx drawingArea

      -- drawingAreaにconfigure eventを登録する
      Gtk.onConfigure drawingArea $ onConfigureEventCallback appCtx drawingArea

      -- drawingAreaにexpose eventを登録する
      Gtk.onExpose drawingArea $ onExposeCallback appCtx drawingArea

      -- drawingAreaに map eventを登録する
      drawingArea `on` Gtk.mapEvent $ Gdk.EventM.tryEvent $ mapEventCallback appCtx drawingArea

      -- drawingAreaに unmap eventを登録する
      drawingArea `on` Gtk.unmapEvent $ Gdk.EventM.tryEvent $ unmapEventCallback appCtx drawingArea

      -- drawingAreaに visibility notify eventを登録する
      drawingArea `on` Gtk.visibilityNotifyEvent $ Gdk.EventM.tryEvent $ visibilityNotifyEventCallback appCtx drawingArea

      -- Quit Button
      quitButton <- Gtk.buttonNewWithLabel "Quit"
      Gtk.onClicked quitButton Gtk.mainQuit
      
      -- vbox作成
      vbox <- Gtk.vBoxNew False 0
      -- vboxにdrawingAreaを付ける。
      Gtk.set vbox [ Gtk.containerChild := drawingArea,
                     Gtk.containerChild := quitButton ]
       
      -- ベースのwindow widget
      window <- Gtk.windowNew
      Gtk.set window [ Gtk.windowTitle    := "Gears",
                       Gtk.containerChild := vbox ]
      Gtk.widgetSetRedrawOnAllocate window True      
      -- Destroy Eventに終了関数をつなげる 
      Gtk.onDestroy window Gtk.mainQuit
      
      return window