diff options
-rw-r--r-- | MeshSketch.hs | 68 | ||||
-rw-r--r-- | PointPrimitiveRing.hs | 6 | ||||
-rw-r--r-- | SmallRing.hs | 6 |
3 files changed, 61 insertions, 19 deletions
diff --git a/MeshSketch.hs b/MeshSketch.hs index 7cda3fc..6475d27 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs | |||
@@ -6,6 +6,7 @@ | |||
6 | {-# LANGUAGE OverloadedLabels #-} | 6 | {-# LANGUAGE OverloadedLabels #-} |
7 | {-# LANGUAGE OverloadedStrings #-} | 7 | {-# LANGUAGE OverloadedStrings #-} |
8 | {-# LANGUAGE RecordWildCards #-} | 8 | {-# LANGUAGE RecordWildCards #-} |
9 | {-# LANGUAGE NondecreasingIndentation #-} | ||
9 | module MeshSketch where | 10 | module MeshSketch where |
10 | 11 | ||
11 | import Codec.Picture as Juicy | 12 | import Codec.Picture as Juicy |
@@ -107,6 +108,7 @@ data State = State | |||
107 | , stPlane :: IORef (Maybe Plane) | 108 | , stPlane :: IORef (Maybe Plane) |
108 | , stDragPlane :: IORef (Maybe (Vector Float,Plane)) | 109 | , stDragPlane :: IORef (Maybe (Vector Float,Plane)) |
109 | , stRecentPts :: IORef (Giver (Vector Double)) | 110 | , stRecentPts :: IORef (Giver (Vector Double)) |
111 | , stAngle :: IORef Int | ||
110 | } | 112 | } |
111 | 113 | ||
112 | data Camera = Camera | 114 | data Camera = Camera |
@@ -232,6 +234,7 @@ uploadState obj glarea storage = do | |||
232 | pendown <- newIORef False | 234 | pendown <- newIORef False |
233 | plane <- newIORef $ Just (xzPlaneVector G.// [(3,-1)]) | 235 | plane <- newIORef $ Just (xzPlaneVector G.// [(3,-1)]) |
234 | recentPts <- newIORef Give0 | 236 | recentPts <- newIORef Give0 |
237 | angle <- newIORef 0 | ||
235 | 238 | ||
236 | let st = State | 239 | let st = State |
237 | { stAnimator = tm | 240 | { stAnimator = tm |
@@ -246,6 +249,7 @@ uploadState obj glarea storage = do | |||
246 | , stPlane = plane | 249 | , stPlane = plane |
247 | , stDragPlane = dragPlane | 250 | , stDragPlane = dragPlane |
248 | , stRecentPts = recentPts | 251 | , stRecentPts = recentPts |
252 | , stAngle = angle | ||
249 | } | 253 | } |
250 | -- _ <- addAnimation tm (whirlingCamera st) | 254 | -- _ <- addAnimation tm (whirlingCamera st) |
251 | 255 | ||
@@ -614,30 +618,54 @@ worldCoordinates st h k mplane = do | |||
614 | -- Write on the camDistance sphere. | 618 | -- Write on the camDistance sphere. |
615 | Nothing -> p + scale (camDistance cam) d̂ | 619 | Nothing -> p + scale (camDistance cam) d̂ |
616 | 620 | ||
617 | pushRing :: IsWidget w => w -> State -> Double -> Double -> Vector Float -> IO (Vector Float) | 621 | pushRing :: IsWidget w => w -> State -> Bool -> Double -> Double -> Vector Float -> IO (Vector Float) |
618 | pushRing w st h k c = do | 622 | pushRing w st endpt h k c = do |
619 | plane <- readIORef (stPlane st) | 623 | plane <- readIORef (stPlane st) |
620 | d <- worldCoordinates st h k plane | 624 | d <- worldCoordinates st h k plane |
621 | Just win <- getWidgetWindow w | 625 | Just win <- getWidgetWindow w |
622 | g <- pushFront (fromList [h,k]) <$> readIORef (stRecentPts st) | 626 | mf <- front <$> readIORef (stRecentPts st) |
627 | let hk = fromList [h,k] | ||
628 | chk :: Vector Double -> IO (Vector Float) -> IO (Vector Float) | ||
629 | chk stored act = if endpt || norm_2 (hk - stored) >= 2 then act else return d | ||
630 | maybe id chk mf $ do | ||
631 | g <- pushFront hk <$> readIORef (stRecentPts st) | ||
623 | writeIORef (stRecentPts st) g | 632 | writeIORef (stRecentPts st) g |
624 | with3 g $ \a b c -> do | 633 | if endpt then do |
634 | pushBack (stRingBuffer st) $ \RingPoint{..} -> do | ||
635 | rpColor @<- yellow -- white | ||
636 | rpPosition @<- d | ||
637 | windowInvalidateRect win Nothing False | ||
638 | putStrLn $ "EndPoint: " ++ show d | ||
639 | else with3 g $ \a b cc -> do | ||
625 | let û = unit $ a-b | 640 | let û = unit $ a-b |
626 | v̂ = unit $ b-c | 641 | v̂ = unit $ b-cc |
627 | δ = norm_1 $ (a-b)^2 | 642 | δ = norm_1 $ (a-b)^2 |
628 | d = det $ fromRows [û,v̂] | 643 | dt = det $ fromRows [û,v̂] |
629 | x = dot û v̂ | 644 | x = dot û v̂ |
630 | putStrLn $ "(d,x) = " ++ show (d,x) | 645 | uv = û + v̂ |
646 | θ = atan2 (uv!0) (uv!1) | ||
647 | n = round $ θ/(pi/6) | ||
648 | {- | ||
649 | putStrLn $ "(dt,x) = " ++ show (dt,x) | ||
631 | updateBack (stRingBuffer st) $ \RingPoint{..} -> do | 650 | updateBack (stRingBuffer st) $ \RingPoint{..} -> do |
632 | rpColor @<- if x < 0.3 || δ<0.5 then yellow | 651 | rpColor @<- if x < 0.3 || δ<0.5 then yellow |
633 | else if d<0 then blue else red | 652 | else if dt<0 then blue else red |
634 | pushBack (stRingBuffer st) $ \RingPoint{..} -> do | 653 | -} |
635 | rpPosition @<- d | 654 | m <- readIORef (stAngle st) |
636 | rpColor @<- c | 655 | let isSpecial = x<0.3 -- || δ<0.5 |
637 | windowInvalidateRect win Nothing False | 656 | when (m /= n || isSpecial) $ do |
657 | bb <- worldCoordinates st (b!0) (b!1) plane | ||
658 | pushBack (stRingBuffer st) $ \RingPoint{..} -> do | ||
659 | rpPosition @<- bb | ||
660 | rpColor @<- if isSpecial then yellow | ||
661 | else if dt<0 then blue else red | ||
662 | windowInvalidateRect win Nothing False | ||
663 | putStrLn $ "point: " ++ show bb | ||
664 | writeIORef (stAngle st) n | ||
638 | return d | 665 | return d |
639 | 666 | ||
640 | red,yellow,blue :: Vector Float | 667 | white,red,yellow,blue :: Vector Float |
668 | white = fromList [1,1,1] | ||
641 | yellow = fromList [1,1,0] | 669 | yellow = fromList [1,1,0] |
642 | blue = fromList [0,0,1] | 670 | blue = fromList [0,0,1] |
643 | red = fromList [1,0,0] | 671 | red = fromList [1,0,0] |
@@ -649,7 +677,7 @@ onEvent w realized ev = do | |||
649 | src <- get src #inputSource | 677 | src <- get src #inputSource |
650 | return src | 678 | return src |
651 | etype <- get ev #type | 679 | etype <- get ev #type |
652 | -- putStrLn $ "onEvent! " ++ show (etype,inputSource) | 680 | putStrLn $ "onEvent! " ++ show (etype,inputSource) |
653 | let put x = putStrLn (show inputSource ++ " " ++ show x) | 681 | let put x = putStrLn (show inputSource ++ " " ++ show x) |
654 | st = stState realized | 682 | st = stState realized |
655 | case etype of | 683 | case etype of |
@@ -664,9 +692,7 @@ onEvent w realized ev = do | |||
664 | Just InputSourcePen -> do | 692 | Just InputSourcePen -> do |
665 | isDown <- readIORef (stPenDown st) | 693 | isDown <- readIORef (stPenDown st) |
666 | when isDown $ do | 694 | when isDown $ do |
667 | -- TODO: Read prior two points and example the angle. | 695 | d <- pushRing w st False h k blue |
668 | -- If it is small, reclassify the prior point. | ||
669 | d <- pushRing w st h k blue | ||
670 | -- put (etype,(h,k),d) | 696 | -- put (etype,(h,k),d) |
671 | return () | 697 | return () |
672 | _ -> do | 698 | _ -> do |
@@ -694,8 +720,12 @@ onEvent w realized ev = do | |||
694 | if h < realToFrac (camWidth cam) * 0.9 then | 720 | if h < realToFrac (camWidth cam) * 0.9 then |
695 | case inputSource of | 721 | case inputSource of |
696 | Just InputSourcePen -> do | 722 | Just InputSourcePen -> do |
723 | putStrLn "Pen Down!" | ||
697 | writeIORef (stPenDown st) True | 724 | writeIORef (stPenDown st) True |
698 | d <- pushRing w st h k red | 725 | writeIORef (stAngle st) 0 |
726 | writeIORef (stRecentPts st) Give0 | ||
727 | clearRing (stRingBuffer st) | ||
728 | d <- pushRing w st True h k red | ||
699 | Just win <- getWidgetWindow w | 729 | Just win <- getWidgetWindow w |
700 | windowInvalidateRect win Nothing False | 730 | windowInvalidateRect win Nothing False |
701 | put (etype,(h,k),d) | 731 | put (etype,(h,k),d) |
@@ -722,7 +752,7 @@ onEvent w realized ev = do | |||
722 | Nothing -> case inputSource of | 752 | Nothing -> case inputSource of |
723 | Just InputSourcePen -> do | 753 | Just InputSourcePen -> do |
724 | writeIORef (stPenDown st) False | 754 | writeIORef (stPenDown st) False |
725 | d <- pushRing w st h k red | 755 | d <- pushRing w st True h k red |
726 | Just win <- getWidgetWindow w | 756 | Just win <- getWidgetWindow w |
727 | windowInvalidateRect win Nothing False | 757 | windowInvalidateRect win Nothing False |
728 | _ -> do | 758 | _ -> do |
diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs index c458421..54405e4 100644 --- a/PointPrimitiveRing.hs +++ b/PointPrimitiveRing.hs | |||
@@ -70,6 +70,12 @@ newRing storage sz toAttr = fix $ \retProxy -> do | |||
70 | updateRingCommands r | 70 | updateRingCommands r |
71 | return r | 71 | return r |
72 | 72 | ||
73 | clearRing :: Ring keys -> IO () | ||
74 | clearRing r = do | ||
75 | writeIORef (rBack r) 0 | ||
76 | writeIORef (rSize r) 0 | ||
77 | updateRingCommands r | ||
78 | |||
73 | updateRingCommands :: Ring keys -> IO () | 79 | updateRingCommands :: Ring keys -> IO () |
74 | updateRingCommands r = do | 80 | updateRingCommands r = do |
75 | back <- fromIntegral <$> readIORef (rBack r) | 81 | back <- fromIntegral <$> readIORef (rBack r) |
diff --git a/SmallRing.hs b/SmallRing.hs index d792899..f710393 100644 --- a/SmallRing.hs +++ b/SmallRing.hs | |||
@@ -30,6 +30,12 @@ pushFront a (Give1 f) = Give2 (\g -> f (g a)) | |||
30 | pushFront a (Give2 f) = Give3 (\g -> f (g a)) | 30 | pushFront a (Give2 f) = Give3 (\g -> f (g a)) |
31 | pushFront a (Give3 f) = f $ \b c _ -> Give3 $ \g -> g a b c | 31 | pushFront a (Give3 f) = f $ \b c _ -> Give3 $ \g -> g a b c |
32 | 32 | ||
33 | front :: Giver a -> Maybe a | ||
34 | front Give0 = Nothing | ||
35 | front (Give1 f) = f Just | ||
36 | front (Give2 g) = g (\x _ -> Just x) | ||
37 | front (Give3 h) = h (\x _ _ -> Just x) | ||
38 | |||
33 | take3 :: (a -> a -> a -> b) -> Giver a -> Maybe b | 39 | take3 :: (a -> a -> a -> b) -> Giver a -> Maybe b |
34 | take3 f (Give3 g) = Just (g f) | 40 | take3 f (Give3 g) = Just (g f) |
35 | take3 _ _ = Nothing | 41 | take3 _ _ = Nothing |