diff options
Diffstat (limited to 'MeshSketch.hs')
-rw-r--r-- | MeshSketch.hs | 51 |
1 files changed, 29 insertions, 22 deletions
diff --git a/MeshSketch.hs b/MeshSketch.hs index a2e4cbe..837a43d 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs | |||
@@ -326,6 +326,22 @@ data Realized = Realized | |||
326 | , stSigs :: [SignalHandlerId] -- Signals attached by onRealize. | 326 | , stSigs :: [SignalHandlerId] -- Signals attached by onRealize. |
327 | } | 327 | } |
328 | 328 | ||
329 | invalidateGL :: MeshSketch -> IO () | ||
330 | invalidateGL mm = do | ||
331 | mwin <- widgetGetWindow (mmWidget mm) | ||
332 | forM_ mwin $ \win -> do | ||
333 | -- An explicit rectangle is invalidated in an attempt | ||
334 | -- to address an intermittent flickering of the groups pane. | ||
335 | -- It didn't eliminate the issue. But I'm leaving this in | ||
336 | -- case it helped. | ||
337 | (wd,ht) <- do wd <- windowGetWidth win | ||
338 | ht <- windowGetHeight win | ||
339 | return (wd,ht) | ||
340 | rect <- newZeroRectangle | ||
341 | setRectangleWidth rect wd | ||
342 | setRectangleHeight rect ht | ||
343 | windowInvalidateRect win (Just rect) False | ||
344 | |||
329 | -- | Assumes the executable is nested somewhere in the source tree like so: | 345 | -- | Assumes the executable is nested somewhere in the source tree like so: |
330 | -- | 346 | -- |
331 | -- <src-tree>/<dist>/build/.../<executable> | 347 | -- <src-tree>/<dist>/build/.../<executable> |
@@ -490,9 +506,7 @@ onLoadedMesh mm mmesh = do | |||
490 | forM_ mr $ \r -> do | 506 | forM_ mr $ \r -> do |
491 | x <- stateChangeMesh mesh mm (stStorage r) (stState r) | 507 | x <- stateChangeMesh mesh mm (stStorage r) (stState r) |
492 | writeIORef (mmRealized mm) $ Just r { stState = x } | 508 | writeIORef (mmRealized mm) $ Just r { stState = x } |
493 | mwin <- widgetGetWindow (mmWidget mm) | 509 | invalidateGL mm |
494 | forM_ mwin $ \win -> | ||
495 | windowInvalidateRect win Nothing False | ||
496 | return False | 510 | return False |
497 | 511 | ||
498 | onRealize :: Pipeline -> PipelineSchema -> MeshSketch -> IO () | 512 | onRealize :: Pipeline -> PipelineSchema -> MeshSketch -> IO () |
@@ -652,8 +666,8 @@ translate4 p = (4><4) | |||
652 | , 0 , 0 , 0 , 1 | 666 | , 0 , 0 , 0 , 1 |
653 | ] | 667 | ] |
654 | 668 | ||
655 | updateCameraRotation :: IsWidget a => a -> State -> Double -> Double -> IO () | 669 | updateCameraRotation :: IO () -> State -> Double -> Double -> IO () |
656 | updateCameraRotation w st h k = do | 670 | updateCameraRotation refresh st h k = do |
657 | m <- readIORef (stDragFrom st) | 671 | m <- readIORef (stDragFrom st) |
658 | forM_ m $ \(df0,cam) -> do | 672 | forM_ m $ \(df0,cam) -> do |
659 | let d̂ = camDirection cam -- forward | 673 | let d̂ = camDirection cam -- forward |
@@ -687,9 +701,7 @@ updateCameraRotation w st h k = do | |||
687 | , camScreenToWorld = Nothing | 701 | , camScreenToWorld = Nothing |
688 | } | 702 | } |
689 | writeIORef (stCamera st) cam' | 703 | writeIORef (stCamera st) cam' |
690 | mwin <- widgetGetWindow w | 704 | refresh |
691 | forM_ mwin $ \win -> | ||
692 | windowInvalidateRect win Nothing False | ||
693 | 705 | ||
694 | sanitizeCamera :: State -> IO () | 706 | sanitizeCamera :: State -> IO () |
695 | sanitizeCamera st = do | 707 | sanitizeCamera st = do |
@@ -828,7 +840,7 @@ onEvent mm realized ev = do | |||
828 | return () | 840 | return () |
829 | _ -> do | 841 | _ -> do |
830 | -- put (h,k) | 842 | -- put (h,k) |
831 | updateCameraRotation w st h k | 843 | updateCameraRotation (invalidateGL mm) st h k |
832 | return () | 844 | return () |
833 | Just (from,plane) -> do | 845 | Just (from,plane) -> do |
834 | -- doDragPlane | 846 | -- doDragPlane |
@@ -840,7 +852,7 @@ onEvent mm realized ev = do | |||
840 | writeIORef (stPlane st) $ Just $ plane G.// [(3,δ + plane!3)] | 852 | writeIORef (stPlane st) $ Just $ plane G.// [(3,δ + plane!3)] |
841 | mwin <- widgetGetWindow w | 853 | mwin <- widgetGetWindow w |
842 | forM_ mwin $ \win -> windowInvalidateRect win Nothing False | 854 | forM_ mwin $ \win -> windowInvalidateRect win Nothing False |
843 | putStrLn ("drag-plane " ++ show (δ,p)) | 855 | -- putStrLn ("drag-plane " ++ show (δ,p)) |
844 | -- end doDragPlane | 856 | -- end doDragPlane |
845 | 857 | ||
846 | EventTypeButtonPress -> do | 858 | EventTypeButtonPress -> do |
@@ -868,7 +880,7 @@ onEvent mm realized ev = do | |||
868 | cam <- readIORef (stCamera st) | 880 | cam <- readIORef (stCamera st) |
869 | let d = computeDirection cam h k | 881 | let d = computeDirection cam h k |
870 | writeIORef (stDragFrom st) $ Just (d,cam) | 882 | writeIORef (stDragFrom st) $ Just (d,cam) |
871 | put (etype,(h,k),d) | 883 | -- put (etype,(h,k),d) |
872 | return () | 884 | return () |
873 | else do | 885 | else do |
874 | mplane <- readIORef (stPlane st) | 886 | mplane <- readIORef (stPlane st) |
@@ -892,7 +904,7 @@ onEvent mm realized ev = do | |||
892 | windowInvalidateRect win Nothing False | 904 | windowInvalidateRect win Nothing False |
893 | -} | 905 | -} |
894 | _ -> do | 906 | _ -> do |
895 | updateCameraRotation w st h k | 907 | updateCameraRotation (invalidateGL mm) st h k |
896 | sanitizeCamera st | 908 | sanitizeCamera st |
897 | writeIORef (stDragFrom st) Nothing | 909 | writeIORef (stDragFrom st) Nothing |
898 | Just (from,plane) -> do | 910 | Just (from,plane) -> do |
@@ -904,9 +916,8 @@ onEvent mm realized ev = do | |||
904 | p <- worldCoordinates st h k (Just $ n̂ `G.snoc` (from `dot` n̂)) | 916 | p <- worldCoordinates st h k (Just $ n̂ `G.snoc` (from `dot` n̂)) |
905 | let δ = dot (p - from) (G.init plane) | 917 | let δ = dot (p - from) (G.init plane) |
906 | writeIORef (stPlane st) $ Just $ plane G.// [(3,δ + plane!3)] | 918 | writeIORef (stPlane st) $ Just $ plane G.// [(3,δ + plane!3)] |
907 | mwin <- widgetGetWindow w | 919 | invalidateGL mm |
908 | forM_ mwin $ \win -> windowInvalidateRect win Nothing False | 920 | -- putStrLn ("drag-plane " ++ show (δ,p)) |
909 | putStrLn ("drag-plane " ++ show (δ,p)) | ||
910 | -- end doDragPlane | 921 | -- end doDragPlane |
911 | 922 | ||
912 | 923 | ||
@@ -923,10 +934,8 @@ onEvent mm realized ev = do | |||
923 | , camWorldToScreen = Nothing | 934 | , camWorldToScreen = Nothing |
924 | , camScreenToWorld = Nothing | 935 | , camScreenToWorld = Nothing |
925 | } | 936 | } |
926 | mwin <- widgetGetWindow w | 937 | invalidateGL mm |
927 | forM_ mwin $ \win -> | 938 | -- put d |
928 | windowInvalidateRect win Nothing False | ||
929 | put d | ||
930 | return () | 939 | return () |
931 | 940 | ||
932 | EventTypeKeyPress -> do | 941 | EventTypeKeyPress -> do |
@@ -944,9 +953,7 @@ onEvent mm realized ev = do | |||
944 | "CubeMap" @= return skybox_id | 953 | "CubeMap" @= return skybox_id |
945 | writeIORef (stSkyTexture st) skybox_id | 954 | writeIORef (stSkyTexture st) skybox_id |
946 | put (skyboxNames (stSkyboxes st) !! idx) | 955 | put (skyboxNames (stSkyboxes st) !! idx) |
947 | mwin <- widgetGetWindow w | 956 | invalidateGL mm |
948 | forM_ mwin $ \win -> | ||
949 | windowInvalidateRect win Nothing False | ||
950 | return () | 957 | return () |
951 | KEY_F -> do | 958 | KEY_F -> do |
952 | put 'F' | 959 | put 'F' |