diff options
author | Joe Crayne <joe@jerkface.net> | 2019-05-30 04:23:50 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-05-30 04:23:50 -0400 |
commit | b3d7ec251055a24d289d7e197d5d06bed30d79f2 (patch) | |
tree | 5672d129dbdfe7d42d27593c27abe84f9ecfbf0c | |
parent | 6487a71bf4a3192e7dc5720b81caaebe25e6af83 (diff) |
Added (non-gpu) vector of points for fitting curve.
-rw-r--r-- | MeshSketch.hs | 23 | ||||
-rw-r--r-- | VectorRing.hs | 39 |
2 files changed, 47 insertions, 15 deletions
diff --git a/MeshSketch.hs b/MeshSketch.hs index 89f6581..02c813d 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs | |||
@@ -12,6 +12,7 @@ module MeshSketch where | |||
12 | import Codec.Picture as Juicy | 12 | import Codec.Picture as Juicy |
13 | import Control.Concurrent | 13 | import Control.Concurrent |
14 | import Control.Monad | 14 | import Control.Monad |
15 | import Data.Bool | ||
15 | import Data.Data | 16 | import Data.Data |
16 | import Data.Word | 17 | import Data.Word |
17 | import Data.Function ((&)) | 18 | import Data.Function ((&)) |
@@ -24,8 +25,10 @@ import Data.Map.Strict (Map) | |||
24 | import qualified Data.Map.Strict as Map | 25 | import qualified Data.Map.Strict as Map |
25 | import qualified Data.Vector as V | 26 | import qualified Data.Vector as V |
26 | import qualified Data.Vector.Generic as G | 27 | import qualified Data.Vector.Generic as G |
28 | import qualified Data.Vector.Storable.Mutable as MV | ||
27 | import Foreign.Marshal.Array | 29 | import Foreign.Marshal.Array |
28 | import Foreign.Storable | 30 | import Foreign.Storable |
31 | import GHC.Exts (RealWorld) | ||
29 | import GI.Gdk | 32 | import GI.Gdk |
30 | import GI.GObject.Functions (signalHandlerDisconnect) | 33 | import GI.GObject.Functions (signalHandlerDisconnect) |
31 | import GI.Gdk.Objects | 34 | import GI.Gdk.Objects |
@@ -105,6 +108,8 @@ data State = State | |||
105 | , stSkybox :: IORef Int | 108 | , stSkybox :: IORef Int |
106 | , stSkyTexture :: IORef TextureCubeData | 109 | , stSkyTexture :: IORef TextureCubeData |
107 | , stDragFrom :: IORef (Maybe (Vector Float,Camera)) | 110 | , stDragFrom :: IORef (Maybe (Vector Float,Camera)) |
111 | , stDataPoints :: MV.MVector RealWorld Vector.Point | ||
112 | , stDataRing :: RingBuffer Vector.Point | ||
108 | , stRingBuffer :: RingBuffer (GPU.Update RingPoint) | 113 | , stRingBuffer :: RingBuffer (GPU.Update RingPoint) |
109 | , stPenDown :: IORef Bool | 114 | , stPenDown :: IORef Bool |
110 | , stPlane :: IORef (Maybe Plane) | 115 | , stPlane :: IORef (Maybe Plane) |
@@ -206,7 +211,10 @@ uploadState obj glarea storage = do | |||
206 | -- grid plane | 211 | -- grid plane |
207 | uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" [] | 212 | uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" [] |
208 | 213 | ||
209 | ring <- newRing 100 (GPU.new storage ringPointAttr 100) | 214 | let bufsize = 100 |
215 | v <- MV.unsafeNew bufsize | ||
216 | pts <- newRing bufsize (Vector.new v) | ||
217 | ring <- newRing bufsize (GPU.new storage ringPointAttr bufsize) | ||
210 | 218 | ||
211 | -- setup FrameClock | 219 | -- setup FrameClock |
212 | w <- toWidget glarea | 220 | w <- toWidget glarea |
@@ -246,6 +254,8 @@ uploadState obj glarea storage = do | |||
246 | , stSkybox = skybox | 254 | , stSkybox = skybox |
247 | , stSkyTexture = skytex | 255 | , stSkyTexture = skytex |
248 | , stDragFrom = drag | 256 | , stDragFrom = drag |
257 | , stDataPoints = v | ||
258 | , stDataRing = pts | ||
249 | , stRingBuffer = ring | 259 | , stRingBuffer = ring |
250 | , stPenDown = pendown | 260 | , stPenDown = pendown |
251 | , stPlane = plane | 261 | , stPlane = plane |
@@ -647,6 +657,7 @@ pushRing w st endpt h k c = do | |||
647 | let isSpecial = x<0.3 -- || δ<0.5 | 657 | let isSpecial = x<0.3 -- || δ<0.5 |
648 | go <- if (m /= n || isSpecial) then do | 658 | go <- if (m /= n || isSpecial) then do |
649 | bb <- worldCoordinates st (b!0) (b!1) plane | 659 | bb <- worldCoordinates st (b!0) (b!1) plane |
660 | updateBack (stDataRing st) (Vector.Point (b!0) (b!1)) | ||
650 | updateBack (stRingBuffer st) $ \RingPoint{..} -> do | 661 | updateBack (stRingBuffer st) $ \RingPoint{..} -> do |
651 | rpPosition @<- bb | 662 | rpPosition @<- bb |
652 | rpColor @<- if isSpecial then yellow | 663 | rpColor @<- if isSpecial then yellow |
@@ -654,22 +665,24 @@ pushRing w st endpt h k c = do | |||
654 | writeIORef (stAngle st) n | 665 | writeIORef (stAngle st) n |
655 | -- sz <- readIORef (rSize $ stRingBuffer st) | 666 | -- sz <- readIORef (rSize $ stRingBuffer st) |
656 | -- putStrLn $ "pushBack" ++ show (sz,isSpecial,dt) | 667 | -- putStrLn $ "pushBack" ++ show (sz,isSpecial,dt) |
657 | return pushBack | 668 | return True |
658 | else do | 669 | else do |
659 | -- sz <- readIORef (rSize $ stRingBuffer st) | 670 | -- sz <- readIORef (rSize $ stRingBuffer st) |
660 | -- putStrLn $ "updateBack " ++ show sz | 671 | -- putStrLn $ "updateBack " ++ show sz |
661 | return updateBack | 672 | return False |
662 | aa <- worldCoordinates st (a!0) (a!1) plane | 673 | aa <- worldCoordinates st (a!0) (a!1) plane |
663 | go (stRingBuffer st) $ \RingPoint{..} -> do | 674 | bool updateBack pushBack go (stDataRing st) (Vector.Point (a!0) (a!1)) |
675 | bool updateBack pushBack go (stRingBuffer st) $ \RingPoint{..} -> do | ||
664 | rpPosition @<- aa | 676 | rpPosition @<- aa |
665 | rpColor @<- yellow | 677 | rpColor @<- yellow |
666 | withEndpt = do | 678 | withEndpt = do |
679 | pushBack (stDataRing st) (Vector.Point h k) | ||
667 | pushBack (stRingBuffer st) $ \RingPoint{..} -> do | 680 | pushBack (stRingBuffer st) $ \RingPoint{..} -> do |
668 | rpPosition @<- d | 681 | rpPosition @<- d |
669 | rpColor @<- yellow -- white | 682 | rpColor @<- yellow -- white |
670 | if endpt then do | 683 | if endpt then do |
671 | withEndpt | 684 | withEndpt |
672 | -- putStrLn $ "EndPoint: " ++ show d | 685 | -- putStrLn $ "EndVector.Point: " ++ show d |
673 | else do | 686 | else do |
674 | fromMaybe withEndpt $ take3 withTriple g | 687 | fromMaybe withEndpt $ take3 withTriple g |
675 | windowInvalidateRect win Nothing False | 688 | windowInvalidateRect win Nothing False |
diff --git a/VectorRing.hs b/VectorRing.hs index 2ddac72..4362fa7 100644 --- a/VectorRing.hs +++ b/VectorRing.hs | |||
@@ -1,17 +1,36 @@ | |||
1 | module VectorRing where | 1 | module VectorRing where |
2 | 2 | ||
3 | import Data.Vector.Unboxed.Mutable | 3 | import Data.Vector.Storable.Mutable |
4 | import RingBuffer | 4 | import RingBuffer |
5 | 5 | ||
6 | import Foreign.Ptr | ||
7 | import Foreign.ForeignPtr | ||
8 | import Foreign.Storable | ||
9 | import GHC.Exts (RealWorld) | ||
10 | |||
11 | data Point = Point | ||
12 | { pointX :: Double | ||
13 | , pointY :: Double | ||
14 | } | ||
15 | deriving (Eq,Ord,Show) | ||
16 | |||
17 | instance Storable Point where | ||
18 | sizeOf _ = 2 * sizeOf (0::Double) | ||
19 | alignment _ = alignment (0::Double) | ||
20 | peek ptr = Point <$> peek (castPtr ptr) <*> peekElemOff (castPtr ptr) 1 | ||
21 | poke ptr (Point x y) = do poke (castPtr ptr) x | ||
22 | pokeElemOff (castPtr ptr) 1 y | ||
23 | |||
6 | -- | Typical usage: | 24 | -- | Typical usage: |
7 | -- | 25 | -- |
8 | -- > ringBuffer <- newRing capacity (VectorRing.new capacity) | 26 | -- > v <- unsafeNew capacity |
9 | new :: Unbox a => Int -> IO (TargetBuffer a) | 27 | -- > ringBuffer <- newRing capacity (VectorRing.new v) |
10 | new sz = do | 28 | new :: Storable a => MVector RealWorld a -> IO (TargetBuffer a) |
11 | v <- unsafeNew sz | 29 | new v = return TargetBuffer |
12 | return () :: IO () | 30 | { syncBuffer = \_ -> return () |
13 | return TargetBuffer | 31 | , updateBuffer = \i u -> write v i u |
14 | { syncBuffer = \_ -> return () | 32 | } |
15 | , updateBuffer = \i u -> write v i u | ||
16 | } | ||
17 | 33 | ||
34 | withData :: Storable a => MVector RealWorld a -> (Int -> Ptr a -> IO b) -> IO b | ||
35 | withData v f = let (fptr,len) = unsafeToForeignPtr0 v | ||
36 | in withForeignPtr fptr $ f len | ||