diff options
Diffstat (limited to 'MeshSketch.hs')
-rw-r--r-- | MeshSketch.hs | 23 |
1 files changed, 18 insertions, 5 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 |