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 qualified GI.Gtk.Objects as Gtk
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 System.FilePath
import System.Directory
import Wavefront.Types
import Wavefront.Util



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,(@<-),updateCommands)
import SmallRing
import Camera
import FitCurves
import Bezier
import Mask

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


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

-- State created by uploadState.
data State = State
    { stAnimator     :: Animator
    , stWhirl        :: IORef (Maybe Int)
    , 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)
    , stCurveSpecial :: 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
    , stObjects      :: IORef [MaskableObject]
    , stMasks        :: IORef [Mask]
    }

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

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

stateChangeMesh :: MeshData -> MeshSketch -> GLStorage -> State -> IO State
stateChangeMesh obj mm storage st = do
    let glarea = mmWidget mm
    -- load OBJ geometry and material descriptions
    let workarea = BoundingBox (-2.5) (2.5) (-2.5) 2.5 (-2.5) (2.5)
        mtlLib = matLib obj
    ((objMesh,curveData),objscale) <- uploadOBJToGPU (Just workarea) obj
    putStrLn $ "Using object scale:\n" ++ show objscale
    -- load materials textures
    gpuMtlLib <- uploadMtlLib mtlLib
    -- add OBJ to pipeline input
    bufs <- addOBJToObjectArray storage "objects" objMesh gpuMtlLib
    let gs = Map.keys $ foldr (\a ms -> Map.union (groupMasks a) ms) Map.empty bufs
    forM_ gs $ \groupname -> do
        addToGroupsPane (mmListStore mm) True groupname
    writeIORef (stObjects st) bufs
    writeIORef (stMasks st) $ map (objSpan . maskableObject) bufs
    forM_ (take 1 $ curves curveData) $ \c -> do
        let mn = minimum $ curvePoints c
            mx = maximum $ curvePoints c
            bs = decomposeCurve (curvePt curveData) c
        mapM_ (putStrLn . show) bs
        clearRing (stRingBuffer st)
        forM_ bs $ \(BezierSegment [a,b,c,d]) -> do
            let cv = Bezier.Curve Nothing (vecLocation a)
                                          (vecLocation b)
                                          (vecLocation c)
                                          (vecLocation d)
                                          Nothing
                δ = 0.005 -- TODO
                range = Polygonization
                    { curveBufferID     = error "curveBufferID"
                    , curveStartIndex   = 0
                    , curveSegmentCount = ringCapacity (stRingBuffer st)
                    }
            r <- subdivideCurve δ cv range $ \_ _ v -> do
                RingBuffer.pushBack (stRingBuffer st) $ \RingPoint{..} -> do
                    rpPosition @<- v
                    rpColor @<- yellow
            putStrLn $ "Subdivided "++show (curveSegmentCount r)++" poly-lines."
            return ()
        {-
        RingBuffer.pushBack (stRingBuffer st) $ \RingPoint{..} -> do
            rpPosition @<- V3 0 0 (0::Float)
            rpColor @<- red -}
        return ()
    putStrLn $ "Returning from stateChangeMesh."
    return st

initializeState :: MeshSketch -> GLStorage -> IO State
initializeState mm storage = do
    let glarea = mmWidget mm
    objsRef <- newIORef []
    masksRef <- newIORef []
    -- 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 LineStrip "Curve" storage ringPointAttr bufsize)
    cpts <- newRing 100 (GPU.new PointList "Points" storage ringPointAttr 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)])
    recentPts <- newIORef Give0
    angle <- newIORef 0
    whirl <- newIORef Nothing
    let st = State
            { stAnimator     = tm
            , stWhirl        = whirl
            , stCamera       = cam
            , stFullscreen   = toggle
            , stSkyboxes     = skyboxes
            , stSkybox       = skybox
            , stSkyTexture   = skytex
            , stDragFrom     = drag
            , stDataPoints   = v
            , stDataRing     = pts
            , stRingBuffer   = ring
            , stCurveSpecial = cpts
            , stPenDown      = pendown
            , stPlane        = plane
            , stDragPlane    = dragPlane
            , stRecentPts    = recentPts
            , stAngle        = angle
            , stObjects      = objsRef
            , stMasks        = masksRef
            }
    return st

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

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            = ĵ <# 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
    , mmPaned       :: Gtk.Paned
    , mmGroupsPanel :: Gtk.TreeView
    , mmListStore   :: Gtk.ListStore
    , 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.
    }

-- | Assumes the executable is nested somewhere in the source tree like so:
--
--    <src-tree>/<dist>/build/.../<executable>
--
-- If a "build" directory was not found, an empty string is returned.
findSrcTree :: IO FilePath
findSrcTree = do
    exe <- getExecutablePath
    let ps = reverse . drop 2
                     . dropWhile (/="build")
                     . reverse
                     . splitDirectories
                     . takeDirectory $ exe
    return $ foldr (</>) "" ps

findModule :: FilePath -> IO FilePath
findModule fn = do
    let checkPath action next = do
            path <- action
            let f = path </> fn
            found <- doesFileExist f
            if found then return f
                     else next
    foldr checkPath (return fn) [getExecutablePath,findSrcTree,getCurrentDirectory]

loadInitialMesh kont = do
    objName <- head . (++ ["cube.obj"]) <$> getArgs
    putStrLn $ "Loading object "++objName++"..."
    mobj <- loadOBJ objName
    putStrLn $ "Finished loading object "++objName++"."
    kont mobj

new :: IO Gtk.Paned
new = do
    putStrLn "new!"
    m <- do
        -- mpipeline <- (\s -> return (Right (DynamicPipeline savedPipeline (makeSchema s)))) $ do
        ppath <- findModule "hello_obj2.json"
        mpipeline <- loadPipeline ppath $ do
          defObjectArray "SkyCube" Triangles $ do
            "position"  @: Attribute_V3F
          defObjectArray "objects0" Triangles $ do
            "position"  @: Attribute_V4F
            "normal"    @: Attribute_V3F
            "uvw"       @: Attribute_V3F
          defObjectArray "objects1" Triangles $ do
            "position"  @: Attribute_V4F
            "normal"    @: Attribute_V3F
            "uvw"       @: Attribute_V3F
          defObjectArray "objects2" Triangles $ do
            "position"  @: Attribute_V4F
            "normal"    @: Attribute_V3F
            "uvw"       @: Attribute_V3F
          defObjectArray "plane" Triangles $ do
            "position"  @: Attribute_V4F
          defObjectArray "Curve" Lines $ do
            "position"  @: Attribute_V3F
            "color"     @: Attribute_V3F
          defObjectArray "Points" Points $ 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
            "specularReflectivity" @: V4F
        return mpipeline
    either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \pipeline -> do
        mapM_ (putStrLn . ppShow) (targets $ dynamicPipeline pipeline)
        ref <- newIORef Nothing
        g <- gLAreaNew
        (groups,liststore) <- newGroupsListWidget (\store itr b -> onMaskedGroup g ref store itr b)
        panes <- panedNew OrientationHorizontal
        let mm = MeshSketch g panes groups liststore ref
        gLAreaSetHasDepthBuffer g True
        st <- return g
        _ <- on g #realize       $ withCurrentGL g (onRealize (dynamicPipeline pipeline) (dynamicSchema pipeline) mm)
        _ <- on g #unrealize     $ onUnrealize mm
        _ <- on g #createContext $ nullableContext (onCreateContext g)
        panedPack1 panes g True True
        return panes

addToGroupsPane :: Gtk.ListStore -> Bool -> Text -> IO ()
addToGroupsPane liststore isEnabled groupName = do
    gvalue <- toGValue (Just groupName)
    gtrue <- toGValue isEnabled
    iter <- listStoreAppend liststore
    listStoreSet liststore iter [0,1] [gtrue,gvalue]

newGroupsListWidget changedListStore = do
    liststore <- listStoreNew [gtypeBoolean,gtypeString]
    treeView <- treeViewNewWithModel liststore
    treeViewSetHeadersVisible treeView False
    togc <- do
        togr <- cellRendererToggleNew
        togc <- treeViewColumnNew
        treeViewColumnPackStart togc togr False
        setCellRendererToggleActive togr True
        cellLayoutSetCellDataFunc togc togr $ Just $ \col cel store itr -> do
            Just c <- castTo CellRendererToggle cel
            gval <- treeModelGetValue store itr 0
            b <- fromGValue gval
            setCellRendererToggleActive c b
        onCellRendererToggleToggled togr $ \path -> do
            treepath <- treePathNewFromString path
            mitr <- treeModelGetIter liststore treepath
            forM_ mitr $ \itr -> do
                gval <- treeModelGetValue liststore itr 0
                b <- fromGValue gval
                notb <- toGValue (not b)
                listStoreSetValue liststore itr 0 notb
                changedListStore liststore itr (not b)
        return togc
    groupc <- do
        groupr <- cellRendererTextNew
        -- grey <- newZeroRGBA
        -- -- b <- rGBAParse grey "rgb(128,128,128)"
        -- setCellRendererTextBackgroundRgba groupr grey
        -- setCellRendererTextForegroundRgba groupr grey
        -- -- rGBAFree grey
        groupc <- treeViewColumnNew
        cellLayoutSetCellDataFunc groupc groupr $ Just $ \col cel store itr -> do
            Just c <- castTo CellRendererText cel
            gval <- treeModelGetValue store itr 1
            mtxt <- fromGValue gval
            case mtxt of Nothing  -> clearCellRendererTextText c
                         Just txt -> setCellRendererTextText c txt
        -- treeViewColumnSetTitle groupc "group"
        treeViewColumnPackStart groupc groupr False
        return groupc
    one <- treeViewAppendColumn treeView togc
    two <- treeViewAppendColumn treeView groupc
    -- addToGroupsPane liststore False "sample text"
    return (treeView,liststore)



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

onLoadedMesh :: MeshSketch -> Either String MeshData -> IO Bool
onLoadedMesh mm mmesh = do
    case mmesh of
        Left e     -> putStrLn e
        Right mesh -> do
            mr <- readIORef (mmRealized mm)
            forM_ mr $ \r -> do
                x <- stateChangeMesh mesh mm (stStorage r) (stState r)
                writeIORef (mmRealized mm) $ Just r { stState = x }
                mwin <- widgetGetWindow (mmWidget mm)
                forM_ mwin $ \win ->
                    windowInvalidateRect win Nothing False
    return False

onRealize :: Pipeline -> PipelineSchema -> MeshSketch -> IO ()
onRealize 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 <- initializeState 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 mm r ev
    sigr <- on w #render $ onRender w r
    sigs <- on w #resize $ onResize w r

    do
        panedWin <- widgetGetWindow (mmPaned mm)
        widgetShow (mmGroupsPanel mm)
        panedPack2 (mmPaned mm) (mmGroupsPanel mm) True True
        forM_ panedWin $ \win -> do
            panedW <- windowGetWidth win
            panedSetPosition (mmPaned mm) (panedW * 8 `div` 10)
    -- widgetQueueAllocate (mmPaned mm)
    writeIORef (mmRealized mm) $ Just r { stSigs = [sige,sigr,sigs] }
    forkOS $ loadInitialMesh $ \mmesh -> do
        sid <- threadsAddIdle PRIORITY_DEFAULT_IDLE $ onLoadedMesh mm mmesh
        return ()
    return ()

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)
    return $ camWorldCoordinates cam h k mplane

fitCurves :: State -> IO ()
fitCurves st = do
    _ <- atomicModifyIORef' (stCamera st) projectionView
    cam <- readIORef (stCamera st)
    plane <- readIORef (stPlane st)
    mask <- ringMask (stDataRing st)
    let max_curve_pts = ringCapacity (stRingBuffer st)
        buf = rBuffer (stRingBuffer st)
        dta = stDataPoints st
    -- dta_cnt <- readIORef (rSize $ stDataRing st)
    -- when (dta_cnt > 4) $ do
    -- when (idx > 0) $
    midx <- fitCurve1 cam plane mask max_curve_pts buf dta
    forM_ midx $ \idx -> do
        putStrLn $ "idx = " ++ show idx
        -- syncBuffer buf $ \cnt -> [(0,max cnt $ fromIntegral idx)]
        writeIORef (rBack $ stRingBuffer st) idx
        writeIORef (rSize $ stRingBuffer st) idx
        syncRing (stRingBuffer st)


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
            bb <- worldCoordinates st (b!0) (b!1) plane
            go <- if (m /= n || isSpecial) then do
                        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
            when isSpecial $ do
                pushBack (stCurveSpecial st) $ \RingPoint{..} -> do
                    rpPosition @<- bb
                    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
    fitCurves st
    return d

onEvent :: MeshSketch -> Realized -> Event -> IO Bool
onEvent mm realized ev = do
    let w = mmWidget mm
    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
            widgetGrabFocus w
            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)
                    clearRing (stDataRing st)
                    clearRing (stCurveSpecial 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)
                        mwin <- widgetGetWindow w
                        forM_ mwin $ \win ->
                            windowInvalidateRect win Nothing False
                        return ()
                KEY_F -> do
                    put 'F'
                    stFullscreen st
                KEY_A -> do
                    mw <- readIORef (stWhirl st)
                    case mw of
                        Just w -> do removeAnimation (stAnimator st) w
                                     writeIORef (stWhirl st) Nothing
                        Nothing -> do w <- addAnimation (stAnimator st) (whirlingCamera st)
                                      writeIORef (stWhirl st) (Just w)
                _ -> 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

onMaskedGroup g ref store itr b = do
    gval <- treeModelGetValue store itr 1
    mtxt <- fromGValue gval
    let _ = mtxt :: Maybe Text
    putStrLn $ "Mask changed " ++ show (mtxt,b)
    mr <- readIORef ref
    forM_ ((,) <$> mr <*> mtxt) $ \(r,txt) -> do
        let st = stState r
        os <- readIORef (stObjects st) -- stObjects :: IORef [MaskableObject]
        ms <- readIORef (stMasks st) -- stMasks :: IORef [Mask]
        ms' <- forM (zip os ms) $ \(o,m) -> do
            let mmask = Map.lookup txt (groupMasks o)
                op = maybe id (flip $ bool maskSubtract maskPlus b) mmask
                m' = op m
                unmask (Mask is) = is
            updateCommands (stStorage r) (maskableObject o) (const $ unmask m')
            return m'
        writeIORef (stMasks st) ms'
        mwin <- widgetGetWindow g
        forM_ mwin $ \win -> windowInvalidateRect win Nothing False
    return ()