path: root/MeshSketch.hs

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

import Codec.Picture             as Juicy
import Control.Concurrent
import Control.Monad
import Data.Bool
import Data.Data
import Data.Word
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Int
import Data.IORef
import Data.Maybe
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 qualified Data.Vector.Storable.Mutable as MV
import Foreign.Marshal.Array
import Foreign.Storable
import GHC.Exts (RealWorld)
import GI.Gdk
import GI.GObject.Functions (signalHandlerDisconnect)
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 qualified Foreign.C.Types

import CubeMap
import GLWidget (nullableContext, withCurrentGL)
import LambdaCube.GL.Input.Type
import LambdaCube.GL.HMatrix
import LambdaCubeWidget (loadPipeline,DynamicPipeline(..))
import Animator
import LoadMesh
import InfinitePlane
import MtlParser (ObjMaterial(..))
import Matrix
import qualified GPURing as GPU
import qualified VectorRing as Vector
import RingBuffer
import MaskableStream (AttributeKey,(@<-))
import SmallRing
import Camera


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

data RingPoint = RingPoint
    { rpPosition :: AttributeKey (GLVector 3 Float)
    , rpColor :: AttributeKey (GLVector 3 Float)
    }
    deriving Data

ringPointAttr :: String -> String
ringPointAttr ('r':'p':c:cs) = toLower c : cs

-- 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))
    , stDataPoints :: MV.MVector RealWorld Vector.Point
    , stDataRing   :: RingBuffer Vector.Point
    , stRingBuffer :: RingBuffer (GPU.Update RingPoint)
    , stPenDown    :: IORef Bool
    , stPlane      :: IORef (Maybe Plane)
    , stDragPlane  :: IORef (Maybe (Vector Float,Plane))
    , stRecentPts  :: IORef (Giver (Vector Double))
    , stAngle      :: IORef Int
    }

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]

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

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" []

    let bufsize = 1000
    v <- MV.unsafeNew bufsize
    pts <- newRing bufsize (Vector.new v)
    ring <- newRing bufsize (GPU.new storage ringPointAttr bufsize)

    -- 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)])
    recentPts <- newIORef Give0
    angle <- newIORef 0

    let st = State
            { stAnimator     = tm
            , stCamera       = cam
            , stFullscreen   = toggle
            , stSkyboxes     = skyboxes
            , stSkybox       = skybox
            , stSkyTexture   = skytex
            , stDragFrom     = drag
            , stDataPoints   = v
            , stDataRing     = pts
            , stRingBuffer   = ring
            , stPenDown      = pendown
            , stPlane        = plane
            , stDragPlane    = dragPlane
            , stRecentPts    = recentPts
            , stAngle        = angle
            }
    -- _ <- 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)
    }

type SignalHandlerId = Foreign.C.Types.CULong

data Realized = Realized
    { stStorage  :: GLStorage
    , stRenderer :: GLRenderer
    , stState    :: State
    , stSigs     :: [SignalHandlerId] -- Signals attached by onRealize.
    }

new :: IO GLArea
new = do
    putStrLn "new!"
    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" Lines $ do
            "position"  @: Attribute_V3F
            "color"     @: 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

        {-
        let pipeline = pipeline0 { dynamicPipeline = (dynamicPipeline pipeline0) 
                                    { targets = fmap nocolorv (targets $ dynamicPipeline pipeline0) } }
            nocolorv (RenderTarget v) = RenderTarget (fmap nocolor v)
            nocolor (TargetItem LC.Color (Just (Framebuffer LC.Color))) = TargetItem LC.Color Nothing
            nocolor x = x -}

        -- putStrLn $ ppShow (dynamicPipeline pipeline)
        mapM_ (putStrLn . ppShow) (targets $ dynamicPipeline pipeline)
        {-
        RenderTarget
          { renderTargets =
              [ TargetItem { targetSemantic = Depth , targetRef = Just (Framebuffer Depth) }
              , TargetItem { targetSemantic = Color , targetRef = Just (Framebuffer Color) }
              ]
          }
        -}

        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 (onCreateContext g)
            return g

onUnrealize :: MeshSketch -> IO ()
onUnrealize mm = do
    putStrLn "onUnrealize!"
    m <- readIORef (mmRealized mm)
    forM_ m $ \st -> do
        forM_ (stSigs st) $ \sig -> do
            signalHandlerDisconnect (mmWidget mm) sig
        LC.disposeRenderer (stRenderer st)
        LC.disposeStorage (stStorage st)
        -- lcDestroyState lc x
        writeIORef (mmRealized mm) Nothing

onRealize :: MeshData -> Pipeline -> PipelineSchema -> MeshSketch -> IO ()
onRealize mesh pipeline schema mm = do
    putStrLn "onRealize!"
    onUnrealize mm
    setupGLDebugging
    storage <- LC.allocStorage schema
    -- do fbo <- GL.get $ GL.bindFramebuffer GL.DrawFramebuffer
    --    putStrLn $ "allocRenderer fbo = " ++ show fbo
    renderer <- LC.allocRenderer pipeline
    compat <- LC.setStorage renderer storage -- check schema compatibility
    -- putStrLn $ "setStorage compat = " ++ show compat
    x <- uploadState mesh (mmWidget mm) storage
    let r = Realized
            { stStorage  = storage
            , stRenderer = renderer
            , stState    = x
            , stSigs     = []
            }
        w = mmWidget mm
    set w [ #canFocus := True ] -- For keyboard events.
    widgetAddEvents w
        [ EventMaskPointerMotionMask
        , EventMaskButtonPressMask
        , EventMaskButtonReleaseMask
        , EventMaskTouchMask
        , EventMaskScrollMask
        , EventMaskKeyPressMask -- , EventMaskKeyReleaseMask
        ]
    sige <- on w #event  $ \ev -> do gLAreaMakeCurrent w
                                     gLAreaAttachBuffers w
                                     onEvent w r ev
    sigr <- on w #render $ onRender w r
    sigs <- on w #resize $ onResize w r

    writeIORef (mmRealized mm) $ Just r { stSigs = [sige,sigr,sigs] }

onRender :: w -> Realized -> GLContext -> IO Bool
onRender w realized gl = do
    -- putStrLn "onRender!"
    r <- -- Patched lambdacube-gl: No longer need this hack.
         -- fixupRenderTarget (stRenderer realized)
         return (stRenderer realized)
    setUniforms gl (stStorage realized) (stState realized)
    -- do fbo <- GL.get $ GL.bindFramebuffer GL.DrawFramebuffer
    --    putStrLn $ "renderFrame fbo = " ++ show fbo
    LC.renderFrame r
    return True

onResize :: GLArea -> Realized -> Int32 -> Int32 -> IO ()
onResize glarea realized w h = do
    -- putStrLn "onResize!"
    -- 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

-- 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
                            -> Bool -- ^ True when press/release.
                            -> Double -> Double -> Vector Float -> IO (Vector Float)
pushRing w st endpt h k c = do
    plane <- readIORef (stPlane st)
    d <- worldCoordinates st h k plane
    Just win <- getWidgetWindow w
    mf <- front <$> readIORef (stRecentPts st)
    let hk = fromList [h,k]
        chk :: Vector Double -> IO (Vector Float) -> IO (Vector Float)
        chk stored act = if endpt || norm_2 (hk - stored) >= 2 then act else return d
    maybe id chk mf $ do
    g <- pushFront hk <$> readIORef (stRecentPts st)
    writeIORef (stRecentPts st) g
    let withTriple a b cc = do
            let û = unit $ a-b
                v̂ = unit $ b-cc
                δ = norm_1 $ (a-b)^2
                dt = det $ fromRows [û,v̂]
                x = dot û v̂
                uv = û + v̂
                θ = atan2 (uv!0) (uv!1)
                n = round $ θ/(pi/12)
            m <- readIORef (stAngle st)
            let isSpecial = x<0.3 -- || δ<0.5
            go <- if (m /= n || isSpecial) then do
                        bb <- worldCoordinates st (b!0) (b!1) plane
                        updateBack (stDataRing st) (Vector.Point (b!0) (b!1))
                        updateBack (stRingBuffer st) $ \RingPoint{..} -> do
                            rpPosition @<- bb
                            rpColor @<- if isSpecial then yellow
                                                     else if dt<0 then blue else red
                        writeIORef (stAngle st) n
                        -- sz <- readIORef (rSize $ stRingBuffer st)
                        -- putStrLn $ "pushBack" ++ show (sz,isSpecial,dt)
                        return True
                  else do
                    -- sz <- readIORef (rSize $ stRingBuffer st)
                    -- putStrLn $ "updateBack " ++ show sz
                    return False
            aa <- worldCoordinates st (a!0) (a!1) plane
            bool updateBack pushBack go (stDataRing st) (Vector.Point (a!0) (a!1))
            bool updateBack pushBack go (stRingBuffer st) $ \RingPoint{..} -> do
                rpPosition @<- aa
                rpColor    @<- yellow
        withEndpt = do
            pushBack (stDataRing st) (Vector.Point h k)
            pushBack (stRingBuffer st) $ \RingPoint{..} -> do
                rpPosition @<- d
                rpColor @<- yellow -- white
    if endpt then do
        withEndpt
        -- putStrLn $ "EndVector.Point: " ++ show d
    else do
        fromMaybe withEndpt $ take3 withTriple g
    windowInvalidateRect win Nothing False
    return d

white,red,yellow,blue :: Vector Float
white  = fromList [1,1,1]
yellow = fromList [1,1,0]
blue   = fromList [0,0,1]
red    = fromList [1,0,0]

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 False h k blue
                        -- put (etype,(h,k),d)
                        return ()
                _ -> 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
                    putStrLn "Pen Down!"
                    writeIORef (stPenDown st) True
                    writeIORef (stAngle st) 0
                    writeIORef (stRecentPts st) Give0
                    clearRing (stRingBuffer st)
                    d <- pushRing w st True h k red
                    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 True h k red
                    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

onCreateContext :: IsWidget a => a -> IO (Maybe GLContext)
onCreateContext w = do
    putStrLn "onCreateContext!"
    mwin <- widgetGetWindow w
    forM mwin $ \win -> windowCreateGlContext win