{-# LANGUAGE CPP               #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedLabels  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module MeshSketch where

import Codec.Picture             as Juicy
import Control.Concurrent
import Control.Monad
import Data.Word
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Int
import Data.IORef
import Data.Text (Text)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Vector     as V
import qualified Data.Vector.Generic as G
import Foreign.Marshal.Array
import Foreign.Storable
import GI.Gdk
import GI.Gdk.Objects
import GI.GLib.Constants
import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen)
import LambdaCube.GL             as LC
import LambdaCube.GL.Mesh        as LC
import Numeric.LinearAlgebra as Math hiding ((<>))
import System.Environment
import System.IO
import System.IO.Error
import Control.Exception
import LambdaCube.GL as LC
import LambdaCube.IR as LC
import LambdaCube.Gtk
import LambdaCube.GL.Data (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
import LambdaCube.GL.Type (TextureCubeData(..),Object(..))
-- import Text.Show.Pretty (ppShow)
import qualified Graphics.Rendering.OpenGL as GL
import Data.Char
import Text.Printf

import CubeMap
import GLWidget (nullableContext, withCurrentGL)
import LambdaCube.GL.HMatrix
import LambdaCubeWidget (loadPipeline,DynamicPipeline(..))
import Animator
import LoadMesh
import InfinitePlane
import MtlParser (ObjMaterial(..))
import Matrix
import PointPrimitiveRing


prettyDebug :: GL.DebugMessage -> String
prettyDebug (GL.DebugMessage src typ (GL.DebugMessageID mid) severity msg) = unwords ws
 where
    ws = [wsrc,wtyp,wmid,wseverity,msg]
    -- DebugSourceShaderCompiler DebugTypeOther 1 DebugSeverityNotification
    wsrc = filter isUpper $ drop 11 $ show src
    wtyp = take 2 $ drop 9 $ show typ
    wmid = printf "%03i" mid
    wseverity = drop 13 $ show severity

setupGLDebugging :: IO ()
setupGLDebugging = do
    let pdebug m@(GL.DebugMessage src typ mid severity msg) = do
            putStrLn (">> " ++ prettyDebug m)
    GL.debugOutput GL.$= GL.Enabled
    GL.debugOutputSynchronous GL.$= GL.Enabled
    GL.debugMessageControl (GL.MessageGroup Nothing Nothing Nothing) GL.$= GL.Enabled
    GL.debugMessageCallback GL.$= Just pdebug

type Plane = Vector Float

-- State created by uploadState.
data State = State
    { stAnimator   :: Animator
    , stCamera     :: IORef Camera
    , stFullscreen :: IO ()
    , stSkyboxes   :: Skyboxes
    , stSkybox     :: IORef Int
    , stSkyTexture :: IORef TextureCubeData
    , stDragFrom   :: IORef (Maybe (Vector Float,Camera))
    , stRingBuffer :: Ring
    , stPenDown    :: IORef Bool
    , stPlane      :: IORef (Maybe Plane)
    , stDragPlane  :: IORef (Maybe (Vector Float,Plane))
    }

data Camera = Camera
    { camHeightAngle   :: Float
    , camTarget        :: Vector Float -- 3-vector
    , camDirection     :: Vector Float -- 3-vector
    , camDistance      :: Float
    , camWidth         :: Float
    , camHeight        :: Float
    , camUp            :: Vector Float -- 3-vector
    , camWorldToScreen :: Maybe (Matrix Float) -- 4×4
    , camScreenToWorld :: Maybe (Matrix Float) -- 4×4
    }

camPos :: Camera -> Vector Float
camPos c = camTarget c - scale (camDistance c) (camDirection c)

initCamera :: Camera
initCamera = Camera
    { camHeightAngle = pi/6
    , camTarget      = fromList [0,0,0]
    , camDirection   = scale (1/d) $ fromList [-2,-2,-10]
    , camDistance    = d
    , camWidth       = 700
    , camHeight      = 700
    , camUp          = fromList [0,1,0]
    , camWorldToScreen = Nothing
    , camScreenToWorld = Nothing
    }
    where d = realToFrac $ norm_2 $ fromList [2::Float,2,10]

viewProjection :: Camera -> (Camera,(Matrix Float,Vector Float))
viewProjection c
    | Just m <- camWorldToScreen c = (c,(m,pos))
    | otherwise                    = (c { camWorldToScreen = Just m' }, (m',pos))
 where
    m' = proj <> cam
    cam = lookat pos (camTarget c) (camUp c)
    pos = camPos c
    proj = perspective 0.1 100 (camHeightAngle c) (camWidth c / camHeight c)

realToFracVector :: ( Real a
                    , Fractional b
                    , Storable a
                    , Storable b
                    ) => Vector a -> Vector b
realToFracVector v = Math.fromList $ map realToFrac $ Math.toList v

realToFracMatrix :: (Real a, Fractional t, Element t, Element a) => Matrix a -> Matrix t
realToFracMatrix m = fromLists $ map realToFrac <$> toLists m

invFloat :: Matrix Float -> Matrix Float
invFloat m = realToFracMatrix $ inv (realToFracMatrix m :: Matrix Double)

projectionView :: Camera -> (Camera,Matrix Float)
projectionView c
    | Just m <- camScreenToWorld c = (c,m)
    | Just w <- camWorldToScreen c = projectionView c{ camScreenToWorld = Just $ invFloat w }
    | otherwise                    = projectionView $ fst $ viewProjection c

addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object]
addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
  obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh
         -- diffuseTexture and diffuseColor values can change on each model
  case mat >>= flip Map.lookup mtlLib of
    Nothing -> return ()
    Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do
      "diffuseTexture" @= return t -- set model's diffuse texture
      "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
  return obj

mkFullscreenToggle :: IsWindow a => a -> IO (IO ())
mkFullscreenToggle w = do
    full <- newIORef False
    return $ do
        b <- atomicModifyIORef' full $ \b -> (not b, not b)
        if b then windowFullscreen w
             else windowUnfullscreen w


xzPlaneVector :: Vector Float
xzPlaneVector = fromList [ 0,1,0 -- unit normal
                         , 0 ]   -- distance from origin

uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
uploadState obj glarea storage = do
    -- load OBJ geometry and material descriptions
    (objMesh,mtlLib) <- uploadOBJToGPU obj
    -- load materials textures
    gpuMtlLib <- uploadMtlLib mtlLib
    -- add OBJ to pipeline input
    addOBJToObjectArray storage "objects" objMesh gpuMtlLib
    -- grid plane
    uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []

    ring <- newRing storage 100

    -- setup FrameClock
    w <- toWidget glarea
    tm <- newAnimator w
    cam <- newIORef initCamera

    Just pwidget <- get w #parent
    Just parent <- get pwidget #window
    toggle <- mkFullscreenToggle parent
    skyboxes <- loadSkyboxes
    skybox <- newIORef 0
    skybox_id <- skyboxLoad skyboxes 0 >>= \case
        Right ts -> do
            skybox_id <- uploadCubeMapToGPU ts
            LC.updateUniforms storage $ do
               "CubeMap" @= return skybox_id
            return skybox_id
        Left msg -> do
            putStrLn msg
            return (TextureCubeName 0)
    skytex <- newIORef skybox_id
    mi <- LC.uploadMeshToGPU cubeMesh
    LC.addMeshToObjectArray storage "SkyCube" [] mi

    drag <- newIORef Nothing
    dragPlane <- newIORef Nothing
    pendown <- newIORef False
    plane <- newIORef $ Just (xzPlaneVector G.// [(3,-1)])

    let st = State
            { stAnimator     = tm
            , stCamera       = cam
            , stFullscreen   = toggle
            , stSkyboxes     = skyboxes
            , stSkybox       = skybox
            , stSkyTexture   = skytex
            , stDragFrom     = drag
            , stRingBuffer   = ring
            , stPenDown      = pendown
            , stPlane        = plane
            , stDragPlane    = dragPlane
            }
    -- _ <- addAnimation tm (whirlingCamera st)

    return st


destroyState :: GLArea -> State -> IO ()
destroyState glarea st = do
    -- widgetRemoveTickCallback glarea (stTickCallback st)
    return ()

deg30 :: Float
deg30 = pi/6

ĵ :: Vector Float
ĵ = fromList [0,1,0]

computePlaneModel :: Vector Float -> Matrix Float
computePlaneModel plane = if n̂ == ĵ then translate4 p
                                    else translate4 p <> rotate4 cosθ axis
 where
    n̂ = G.init plane
    c = plane!3
    p = scale c n̂
    cosθ = dot n̂ ĵ
    axis = ĵ `cross` n̂

whirlingCamera :: State -> Animation
whirlingCamera st = Animation $ \_ t -> do
    let tf = realToFrac t :: Float
        rot = rotMatrixZ (-tf/2) <> rotMatrixX (-tf/pi)
    modifyIORef (stCamera st) $ \cam -> cam
                            { camUp            = fromList [0,1,0] <# rot
                            , camDirection     = (scale (1/camDistance cam) $ fromList [-2,-2,-10]) <# rot
                            , camWorldToScreen = Nothing
                            , camScreenToWorld = Nothing
                            }
    return $ Just (whirlingCamera st)

setUniforms :: glctx -> GLStorage -> State -> IO ()
setUniforms gl storage st = do
    (mvp,pos) <- atomicModifyIORef' (stCamera st) viewProjection
    mplane <- readIORef (stPlane st)
    let planeModel = maybe (ident 4) computePlaneModel mplane
    LC.updateUniforms storage $ do
      "CameraPosition" @= return (pos :: Vector Float)
      "ViewProjection" @= return (mvp :: Matrix Float)
      "PlaneModel" @= return planeModel
    updateRingUniforms storage (stRingBuffer st)

data MeshSketch = MeshSketch
    { mmWidget   :: GLArea
    , mmRealized :: IORef (Maybe Realized)
    }

data Realized = Realized
    { stStorage  :: GLStorage
    , stRenderer :: GLRenderer
    , stState    :: State
    }

new :: IO GLArea
new = do
    m <- do
        objName <- head . (++ ["cube.obj"]) <$> getArgs
        mobj <- loadOBJ objName
        -- mpipeline <- (\s -> return (Right (DynamicPipeline savedPipeline (makeSchema s)))) $ do
        mpipeline <- loadPipeline "hello_obj2.json" $ do
          defObjectArray "SkyCube" Triangles $ do
            "position"  @: Attribute_V3F
          defObjectArray "objects" Triangles $ do
            "position"  @: Attribute_V4F
            "normal"    @: Attribute_V3F
            "uvw"       @: Attribute_V3F
          defObjectArray "plane" Triangles $ do
            "position"  @: Attribute_V4F
          defObjectArray "Points" Points $ do
            "position"  @: Attribute_V3F
          defUniforms $ do
            "PointBuffer"     @: FTextureBuffer
            "CubeMap"         @: FTextureCube
            "CameraPosition"  @: V3F
            "ViewProjection"  @: M44F
            "PlaneModel"      @: M44F
            "PointsMax"       @: Int
            "PointsStart"     @: Int
            "diffuseTexture"  @: FTexture2D
            "diffuseColor"    @: V4F
        return $ (,) <$> mobj <*> mpipeline
    either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \(obj,pipeline) -> do

        -- putStrLn $ ppShow (dynamicPipeline pipeline)

        ref <- newIORef Nothing
        -- glarea <- newGLWidget return (lambdaRender app glmethods)
        do
            g <- gLAreaNew
            let mm = MeshSketch g ref
            gLAreaSetHasDepthBuffer g True
            st <- return g
            _ <- on g #realize       $ withCurrentGL g (onRealize obj (dynamicPipeline pipeline) (dynamicSchema pipeline) mm)
            _ <- on g #unrealize     $ onUnrealize mm
            -- _ <- on g #createContext $ nullableContext (glCreateContext w st)
            return g

onUnrealize :: MeshSketch -> IO ()
onUnrealize mm = do
    m <- readIORef (mmRealized mm)
    forM_ m $ \st -> do
        LC.disposeStorage (stStorage st)
        LC.disposeRenderer (stRenderer st)
        -- lcDestroyState lc x

onRealize :: MeshData -> Pipeline -> PipelineSchema -> MeshSketch -> IO ()
onRealize mesh pipeline schema mm = do
    onUnrealize mm
    setupGLDebugging
    storage <- LC.allocStorage schema
    renderer <- LC.allocRenderer pipeline
    compat <- LC.setStorage renderer storage -- check schema compatibility
    x <- uploadState mesh (mmWidget mm) storage
    let r = Realized
            { stStorage  = storage
            , stRenderer = renderer
            , stState    = x
            }
        w = mmWidget mm
    set w [ #canFocus := True ] -- For keyboard events.
    widgetAddEvents w
        [ EventMaskPointerMotionMask
        , EventMaskButtonPressMask
        , EventMaskButtonReleaseMask
        , EventMaskTouchMask
        , EventMaskScrollMask
        , EventMaskKeyPressMask -- , EventMaskKeyReleaseMask
        ]
    _ <- on w #event  $ \ev -> do gLAreaMakeCurrent w
                                  onEvent w r ev
    _ <- on w #render $ onRender w r
    _ <- on w #resize $ onResize w r
    writeIORef (mmRealized mm) $ Just r

onRender :: w -> Realized -> GLContext -> IO Bool
onRender w realized gl = do
    r <- fixupRenderTarget (stRenderer realized)
    setUniforms gl (stStorage realized) (stState realized)
    LC.renderFrame r
    return True

onResize :: GLArea -> Realized -> Int32 -> Int32 -> IO ()
onResize glarea realized w h = do
    -- Plenty of options here.  I went with the last one.
    -- 1. gLContextGetWindow :: HasCallStack => GLContext -> IO (Maybe Window)
    -- 2. getGLContextWindow ::                 GLContext -> IO (Maybe Window)
    -- 3. widgetGetWindow    :: HasCallStack => GLArea    -> IO (Maybe Window)
    mwin <- widgetGetWindow glarea
    forM_ mwin $ \win -> do
        (wd,ht) <- do wd <- windowGetWidth win
                      ht <- windowGetHeight win
                      return (fromIntegral wd,fromIntegral ht)
        modifyIORef' (stCamera $ stState realized)
                  $ \c -> c { camWidth  = fromIntegral wd
                            , camHeight = fromIntegral ht
                            , camWorldToScreen = Nothing
                            , camScreenToWorld = Nothing
                            }
        LC.setScreenSize (stStorage realized) wd ht

unit :: (Linear t c, Fractional t, Normed (c t)) => c t -> c t
unit v = scale (1/realToFrac (norm_2 v)) v

-- This computes a point in world coordinates on the view screen if
-- we assume the camera is located at the origin.
computeDirection :: Camera -> Double -> Double -> Vector Float
computeDirection cam h k | Just pv <- camScreenToWorld cam  =
    let d0 = fromList [ 2 * realToFrac h/camWidth cam - 1
                      , 1 - 2 * realToFrac k/camHeight cam
                      , 1
                      , 1
                      ] :: Vector Float
        d1 = pv #> d0
        d2 = scale (1 /(d1!3)) $ G.init d1
        {-
        p = camPos cam
        d3 = d2 - p
        d4 = unit d3
        -}
    in d2
computeDirection cam h k =
    let d̂ = camDirection cam -- forward
        û = camUp cam        -- upward
        r̂ = d̂ `cross` û      -- rightward
        xr = realToFrac h - (camWidth cam / 2)
        xu = (camHeight cam / 2) - realToFrac k
        xd = (camHeight cam / 2) / tan (camHeightAngle cam / 2)
    in scale xr r̂ + scale xu û + scale xd d̂

rotate :: ( Floating a
          , Math.Container Vector a
          , Indexable (Vector a) a
          , Normed (Vector a)
          ) => a -> Vector a -> Matrix a
rotate cosθ u = (3><3)
  [ cosθ + ux² mcosθ       , (uy.uy)mcosθ - uz sinθ , (ux.uz)mcosθ + uy sinθ
  , (uy.ux)mcosθ + uz sinθ , cosθ + uy² mcosθ       , (uy.uz)mcosθ - ux sinθ
  , (uz.ux)mcosθ - uy sinθ , (uz.uy)mcosθ + ux sinθ , cosθ + uz² mcosθ
  ]
 where
    sinθ = sqrt (1 - cosθ * cosθ)
    mcosθ = 1 - cosθ
    û = unit u
    ux a = (û!0) * a
    uy a = (û!1) * a
    uz a = (û!2) * a
    ux² = ux . ux
    uy² = uy . uy
    uz² = uz . uz

rotate4 :: ( Floating a
          , Math.Container Vector a
          , Indexable (Vector a) a
          , Normed (Vector a)
          ) => a -> Vector a -> Matrix a
rotate4 cosθ u = (4><4)
  [ cosθ + ux² mcosθ       , (uy.uy)mcosθ - uz sinθ , (ux.uz)mcosθ + uy sinθ , 0
  , (uy.ux)mcosθ + uz sinθ , cosθ + uy² mcosθ       , (uy.uz)mcosθ - ux sinθ , 0
  , (uz.ux)mcosθ - uy sinθ , (uz.uy)mcosθ + ux sinθ , cosθ + uz² mcosθ       , 0
  , 0                      , 0                      , 0                      , 1
  ]
 where
    sinθ = sqrt (1 - cosθ * cosθ)
    mcosθ = 1 - cosθ
    û = unit u
    ux a = (û!0) * a
    uy a = (û!1) * a
    uz a = (û!2) * a
    ux² = ux . ux
    uy² = uy . uy
    uz² = uz . uz

translate4 :: (Storable a, Num a, Indexable c a) => c -> Matrix a
translate4 p = (4><4)
    [ 1 , 0 , 0 , p!0
    , 0 , 1 , 0 , p!1
    , 0 , 0 , 1 , p!2
    , 0 , 0 , 0 , 1
    ]

updateCameraRotation :: IsWidget a => a -> State -> Double -> Double -> IO ()
updateCameraRotation w st h k = do
    m <- readIORef (stDragFrom st)
    forM_ m $ \(df0,cam) -> do
        let d̂ = camDirection cam -- forward
            û = camUp cam        -- upward
            -- r̂ = d̂ `cross` û      -- rightward
#if 0
            -- This turned out to be pointless.
            promote :: Vector Float -> Vector Double
            promote = realToFracVector
            demote :: Vector Double -> Vector Float
            demote = realToFracVector
#else
            promote = id
            demote = id
            {-# INLINE promote #-}
            {-# INLINE demote #-}
#endif
            df = promote df0
            dt = promote $ computeDirection cam h k
            cosθ = dot df dt / realToFrac (norm_2 df) / realToFrac (norm_2 dt)
            axis0 = df `cross` dt
            small x = abs x < 0.00001
            axis = let xs = toList axis0
                    in if any isNaN xs || all small xs
                        then fromList [0,1,0]
                        else axis0
            cam' = cam
                    { camDirection     = demote $ promote d̂ <# rotate cosθ axis
                    , camUp            = demote $ promote û <# rotate cosθ axis
                    , camWorldToScreen = Nothing
                    , camScreenToWorld = Nothing
                    }
        writeIORef (stCamera st) cam'
        mwin <- widgetGetWindow w
        forM_ mwin $ \win ->
            windowInvalidateRect win Nothing False

sanitizeCamera :: State -> IO ()
sanitizeCamera st = do
    modifyIORef (stCamera st) $ \cam ->
        let d = camDirection cam
            u = camUp cam
            d̂ = case unit d of
                dd | any isNaN (toList dd) -> fromList [0,0,-1]
                   | otherwise             -> dd
            û = case unit u of
                uu | any isNaN (toList uu) -> fromList [0,1,0]
                   | otherwise             -> uu
        in cam
            { camDirection = d̂
            , camUp        = û
            , camWorldToScreen = Nothing
            , camScreenToWorld = Nothing
            }


worldCoordinates :: State -> Double -> Double -> Maybe (Vector Float) -> IO (Vector Float)
worldCoordinates st h k mplane = do
    pv <- atomicModifyIORef' (stCamera st) projectionView
    cam <- readIORef (stCamera st)
    let q0 = fromList [ 2 * realToFrac h/camWidth cam - 1
                      , 1 - 2 * realToFrac k/camHeight cam
                      , 1
                      , 1
                      ] :: Vector Float
        q1 = pv #> q0
        q2 = scale (1 /(q1!3)) $ G.init q1
        p = camPos cam
        d = q2 - p
        d̂ = unit d
    return $ case mplane of
        -- Write on the plane.
        Just plane -> let n̂ = G.init plane
                          c = plane!3
                          a = (c - dot p n̂) / dot d̂ n̂
                       in p + scale a d̂

        -- Write on the camDistance sphere.
        Nothing    -> p + scale (camDistance cam) d̂

pushRing :: IsWidget w => w -> State -> Double -> Double -> IO (Vector Float)
pushRing w st h k = do
    plane <- readIORef (stPlane st)
    d <- worldCoordinates st h k plane
    Just win <- getWidgetWindow w
    pushBack (stRingBuffer st) (d!0) (d!1) (d!2)
    windowInvalidateRect win Nothing False
    return d


onEvent :: IsWidget w => w -> Realized -> Event -> IO Bool
onEvent w realized ev = do
    msrc <- eventGetSourceDevice ev
    inputSource <- forM msrc $ \src -> do
        src <- get src #inputSource
        return src
    etype <- get ev #type
    -- putStrLn $ "onEvent! " ++ show (etype,inputSource)
    let put x = putStrLn (show inputSource ++ " " ++ show x)
        st = stState realized
    case etype of

        EventTypeMotionNotify -> do
            mev <- get ev #motion
            h <- get mev #x
            k <- get mev #y
            pd <- readIORef (stDragPlane st)
            case pd of
              Nothing -> case inputSource of
                Just InputSourcePen -> do
                    isDown <- readIORef (stPenDown st)
                    when isDown $ do
                        d <- pushRing w st h k
                        put (etype,(h,k),d)
                _ -> do
                    put (h,k)
                    updateCameraRotation w st h k
                    return ()
              Just (from,plane) -> do
                -- doDragPlane
                pos <- camPos <$> readIORef (stCamera st)
                n <- subtract pos <$> worldCoordinates st h k Nothing
                let n̂ = unit n
                p <- worldCoordinates st h k (Just $ n̂ `G.snoc` (from `dot` n̂))
                let δ = dot (p - from) (G.init plane)
                writeIORef (stPlane st) $ Just $ plane G.// [(3,δ + plane!3)]
                mwin <- widgetGetWindow w
                forM_ mwin $ \win -> windowInvalidateRect win Nothing False
                putStrLn ("drag-plane " ++ show (δ,p))
                -- end doDragPlane

        EventTypeButtonPress -> do
            bev <- get ev #button
            h <- get bev #x
            k <- get bev #y
            cam <- readIORef (stCamera st)
            if h < realToFrac (camWidth cam) * 0.9 then
              case inputSource of
                Just InputSourcePen -> do
                    writeIORef (stPenDown st) True
                    d <- pushRing w st h k
                    Just win <- getWidgetWindow w
                    windowInvalidateRect win Nothing False
                    put (etype,(h,k),d)
                _ -> do
                    _ {- d -} <- worldCoordinates st h k Nothing
                    cam <- readIORef (stCamera st)
                    let d = computeDirection cam h k
                    writeIORef (stDragFrom st) $ Just (d,cam)
                    put (etype,(h,k),d)
                    return ()
            else do
                mplane <- readIORef (stPlane st)
                forM_ mplane $ \plane -> do
                    p <- worldCoordinates st h k mplane
                    writeIORef (stDragPlane st) $ Just (p,plane)
                    putStrLn $ "Start plane drag: " ++ show p

        EventTypeButtonRelease -> do
            bev <- get ev #button
            h <- get bev #x
            k <- get bev #y
            pd <- readIORef (stDragPlane st)
            case pd of
              Nothing -> case inputSource of
                Just InputSourcePen -> do
                    writeIORef (stPenDown st) False
                    d <- pushRing w st h k
                    Just win <- getWidgetWindow w
                    windowInvalidateRect win Nothing False
                _ -> do
                    updateCameraRotation w st h k
                    sanitizeCamera st
                    writeIORef (stDragFrom st) Nothing
              Just (from,plane) -> do
                writeIORef (stDragPlane st) Nothing
                -- doDragPlane
                pos <- camPos <$> readIORef (stCamera st)
                n <- subtract pos <$> worldCoordinates st h k Nothing
                let n̂ = unit n
                p <- worldCoordinates st h k (Just $ n̂ `G.snoc` (from `dot` n̂))
                let δ = dot (p - from) (G.init plane)
                writeIORef (stPlane st) $ Just $ plane G.// [(3,δ + plane!3)]
                mwin <- widgetGetWindow w
                forM_ mwin $ \win -> windowInvalidateRect win Nothing False
                putStrLn ("drag-plane " ++ show (δ,p))
                -- end doDragPlane


        EventTypeScroll -> do
            sev <- get ev #scroll
            d <- get sev #direction
            let δ = case d of
                    ScrollDirectionDown -> - pi/180
                    ScrollDirectionUp   -> pi/180
                    _                   -> 0
            when (δ /= 0) $ do
                modifyIORef (stCamera st) $ \cam -> cam
                    { camHeightAngle   = δ + camHeightAngle cam
                    , camWorldToScreen = Nothing
                    , camScreenToWorld = Nothing
                    }
                mwin <- widgetGetWindow w
                forM_ mwin $ \win ->
                    windowInvalidateRect win Nothing False
            put d
            return ()

        EventTypeKeyPress -> do
            kev <- get ev #key
            val <- get kev #keyval <&> \k -> if k > 0x5A then k - 0x20 else k
            case val of
                KEY_N -> do
                    modifyIORef' (stSkybox st) $ \n -> (n + 1) `mod` (skyboxCount $ stSkyboxes st)
                    idx <- readIORef (stSkybox st)
                    when (skyboxCount (stSkyboxes st) > 1) $ do
                        Right ts <- skyboxLoad (stSkyboxes st) idx
                        disposeTextureCube =<< readIORef (stSkyTexture st)
                        skybox_id <- uploadCubeMapToGPU ts
                        LC.updateUniforms (stStorage realized) $ do
                            "CubeMap" @= return skybox_id
                        writeIORef (stSkyTexture st) skybox_id
                        put (skyboxNames (stSkyboxes st) !! idx)
                        return ()
                KEY_F -> do
                    put 'F'
                    stFullscreen st
                _ -> return ()

        e -> return ()

    return False