From 4beea73feaa37a0871d89365556c2e9ff4d9648c Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 3 Jun 2019 20:16:38 -0400 Subject: Started FitCurves module. --- FitCurves.hs | 46 ++++++++++++++++++++++++++++++++++++++ MeshSketch.hs | 67 +++++++++++++++++++++++--------------------------------- lambda-gtk.cabal | 2 +- 3 files changed, 74 insertions(+), 41 deletions(-) create mode 100644 FitCurves.hs diff --git a/FitCurves.hs b/FitCurves.hs new file mode 100644 index 0000000..8c73cfb --- /dev/null +++ b/FitCurves.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE RecordWildCards, DataKinds, DeriveDataTypeable #-} +module FitCurves where + +import Control.Monad +import Data.Data +import Data.Int +import Data.IORef +import qualified Data.Vector.Storable.Mutable as MV +import Foreign.Ptr +import Foreign.Storable +import GHC.Exts (RealWorld) +import Numeric.LinearAlgebra as Math hiding ((<>)) + +import Bezier +import Camera +import qualified GPURing as GPU +import LambdaCube.GL.Input.Type +import MaskableStream +import RingBuffer +import qualified VectorRing as Vector + ;import VectorRing (Point) +import LambdaCube.GL.HMatrix () + + +data RingPoint = RingPoint + { rpPosition :: AttributeKey (GLVector 3 Float) + , rpColor :: AttributeKey (GLVector 3 Float) + } + deriving Data + + +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] + +fitCurve1 :: Camera + -> Maybe Plane + -> (Int32 -> [(Int32, Int32)]) + -> Int + -> TargetBuffer (GPU.Update RingPoint) + -> MV.MVector RealWorld Vector.Point + -> IO (Maybe Int) +fitCurve1 cam plane mask max_curve_pts buf dta = do + return Nothing -- TODO diff --git a/MeshSketch.hs b/MeshSketch.hs index 1019d72..14b3ebc 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs @@ -68,7 +68,8 @@ import RingBuffer import MaskableStream (AttributeKey,(@<-)) import SmallRing import Camera - +import FitCurves +import Bezier prettyDebug :: GL.DebugMessage -> String prettyDebug (GL.DebugMessage src typ (GL.DebugMessageID mid) severity msg) = unwords ws @@ -89,13 +90,6 @@ setupGLDebugging = do 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 @@ -237,12 +231,6 @@ 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 @@ -258,7 +246,7 @@ 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 + { camUp = ĵ <# rot , camDirection = (scale (1/camDistance cam) $ fromList [-2,-2,-10]) <# rot , camWorldToScreen = Nothing , camScreenToWorld = Nothing @@ -571,25 +559,28 @@ worldCoordinates :: State -> Double -> Double -> Maybe (Vector Float) -> IO (Vec 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̂ + 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. @@ -647,14 +638,9 @@ pushRing w st endpt h k c = do else do fromMaybe withEndpt $ take3 withTriple g windowInvalidateRect win Nothing False + fitCurves st 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 @@ -710,6 +696,7 @@ onEvent w realized ev = do writeIORef (stAngle st) 0 writeIORef (stRecentPts st) Give0 clearRing (stRingBuffer st) + clearRing (stDataRing st) d <- pushRing w st True h k red Just win <- getWidgetWindow w windowInvalidateRect win Nothing False diff --git a/lambda-gtk.cabal b/lambda-gtk.cabal index a0c9fc3..86269e5 100644 --- a/lambda-gtk.cabal +++ b/lambda-gtk.cabal @@ -50,7 +50,7 @@ executable meshsketch other-modules: InfinitePlane LambdaCubeWidget GLWidget LambdaCube.Gtk TimeKeeper LoadMesh MtlParser Matrix LambdaCube.GL.HMatrix Animator MeshSketch CubeMap AttributeData GPURing MaskableStream - RingBuffer SmallRing VectorRing Camera + RingBuffer SmallRing VectorRing Camera Bezier FitCurves extensions: NondecreasingIndentation other-extensions: OverloadedLabels, OverloadedLists, OverloadedStrings build-depends: base, containers >=0.5 && <0.6, bytestring >=0.10 && <0.11, -- cgit v1.2.3