diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 9883f2a..2a67f47 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -114,7 +114,6 @@ executable MetaBrush , MetaBrush.Context , MetaBrush.Document , MetaBrush.Document.Draw - , MetaBrush.Document.Guide , MetaBrush.Document.Selection , MetaBrush.Document.Serialise , MetaBrush.Document.SubdivideStroke diff --git a/assets/theme.css b/assets/theme.css index a6d30ea..42c0fb4 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -58,7 +58,7 @@ color: rgb(0,0,0); } .pointHover { - color: rgb(225,225,225); + color: rgb(231, 172, 83); } .pointSelected { color: rgb(252,237,120); diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index f72abf9..3846e29 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -95,13 +95,11 @@ import MetaBrush.Context , updateTitle ) import MetaBrush.Document - ( Document(..), Guide(..) - , PointData(..), FocusState(..) - ) + ( Document(..), PointData(..), FocusState(..) ) import MetaBrush.Document.Draw ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary ) -import MetaBrush.Document.Guide - ( selectGuide, addGuide ) +import MetaBrush.Document + ( Guide(..), selectedGuide, addGuide ) import MetaBrush.Document.Selection ( SelectionMode(..), selectionMode , selectAt, selectRectangle @@ -695,7 +693,7 @@ instance HandleAction MouseClick where when showGuides do let mbGuide :: Maybe Guide - mbGuide = selectGuide pos doc + mbGuide = selectedGuide pos doc guideAction :: GuideAction guideAction | Just guide <- mbGuide diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 8262ce1..3f507a0 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -3,26 +3,43 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} module MetaBrush.Document - ( AABB(..) + ( AABB(..), mkAABB , Document(..), emptyDocument - , Stroke(..), Guide(..) + , Stroke(..) , PointData(..), BrushPointData(..) - , FocusState(..) + , FocusState(..), Hoverable(..), HoverContext(..) , _selection, _brush + , Guide(..) + , addGuide, selectedGuide ) where -- base +import Data.Semigroup + ( Arg(..), Min(..), ArgMin ) import GHC.Generics ( Generic ) +-- acts +import Data.Act + ( Act + ( (•) ) + , Torsor + ( (-->) ) + ) + -- containers import Data.Map.Strict ( Map ) +import qualified Data.Map.Strict as Map + ( insert ) import qualified Data.Map.Strict as Map ( empty ) import Data.Sequence @@ -38,6 +55,10 @@ import Data.Generics.Product.Typed import Control.Lens ( Lens' ) +-- stm +import Control.Concurrent.STM + ( STM ) + -- text import Data.Text ( Text ) @@ -45,10 +66,14 @@ import Data.Text -- MetaBrush import Math.Bezier.Stroke ( StrokePoint(..) ) +import Math.Module + ( Inner((^.^)), squaredNorm, quadrance ) import Math.Vector2D ( Point2D(..), Vector2D(..) ) +import MetaBrush.UI.Viewport + ( Ruler(..) ) import MetaBrush.Unique - ( Unique ) + ( UniqueSupply, Unique, freshUnique ) -------------------------------------------------------------------------------- @@ -57,6 +82,16 @@ data AABB { topLeft, botRight :: !( Point2D Double ) } deriving stock Show +mkAABB :: Point2D Double -> Point2D Double -> AABB +mkAABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) = AABB ( Point2D xmin ymin ) ( Point2D xmax ymax ) + where + ( xmin, xmax ) + | x1 > x2 = ( x2, x1 ) + | otherwise = ( x1, x2 ) + ( ymin, ymax ) + | y1 > y2 = ( y2, y1 ) + | otherwise = ( y1, y2 ) + data Document = Document { displayName :: !Text @@ -79,14 +114,6 @@ data Stroke } deriving stock ( Show, Generic ) -data Guide - = Guide - { guidePoint :: !( Point2D Double ) -- ^ point on the guide line - , guideNormal :: !( Vector2D Double ) -- ^ /normalised/ normal vector of the guide - , guideUnique :: Unique - } - deriving stock ( Show, Generic ) - data PointData = PointData { pointState :: FocusState @@ -105,6 +132,15 @@ data FocusState | Selected deriving stock ( Show, Eq ) +instance Semigroup FocusState where + Selected <> _ = Selected + Normal <> s = s + _ <> Selected = Selected + s <> Normal = s + _ <> _ = Hover +instance Monoid FocusState where + mempty = Normal + _selection :: HasType FocusState pt => Lens' ( StrokePoint pt ) FocusState _selection = field' @"pointData" . typed @FocusState @@ -123,3 +159,100 @@ emptyDocument docName unique = , strokes = [] , guides = Map.empty } + +-------------------------------------------------------------------------------- + +data HoverContext + = MouseHover !( Point2D Double ) + | RectangleHover !AABB + deriving stock Show + +instance Act ( Vector2D Double ) HoverContext where + v • MouseHover p = MouseHover ( v • p ) + v • RectangleHover ( AABB p1 p2 ) = RectangleHover ( AABB ( v • p1 ) ( v • p2 ) ) + +instance Act ( Vector2D Double ) ( Maybe HoverContext ) where + (•) v = fmap ( v • ) + +class Hoverable a where + hovered :: Maybe HoverContext -> Double -> a -> FocusState + +instance Hoverable ( Point2D Double ) where + hovered Nothing _ _ = Normal + hovered ( Just ( MouseHover p ) ) zoom q + | quadrance @( Vector2D Double ) p q * zoom ^ ( 2 :: Int ) < 16 + = Hover + | otherwise + = Normal + hovered ( Just ( RectangleHover ( AABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) ) ) ) _ ( Point2D x y ) + | x >= x1 && x <= x2 && y >= y1 && y <= y2 + = Hover + | otherwise + = Normal + +-------------------------------------------------------------------------------- +-- Guides. + +data Guide + = Guide + { guidePoint :: !( Point2D Double ) -- ^ point on the guide line + , guideNormal :: !( Vector2D Double ) -- ^ /normalised/ normal vector of the guide + , guideFocus :: !FocusState + , guideUnique :: Unique + } + deriving stock ( Show, Generic ) + +-- | Try to select a guide at the given document coordinates. +selectedGuide :: Point2D Double -> Document -> Maybe Guide +selectedGuide c ( Document { zoomFactor, guides } ) = + \case { Min ( Arg _ g ) -> g } <$> foldMap ( selectGuide_maybe c zoomFactor ) guides + +selectGuide_maybe :: Point2D Double -> Double -> Guide -> Maybe ( ArgMin Double Guide ) +selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } ) + | sqDist * zoom ^ ( 2 :: Int ) < 4 + = Just ( Min ( Arg sqDist guide ) ) + | otherwise + = Nothing + where + t :: Double + t = ( c --> p ) ^.^ n + sqDist :: Double + sqDist = t ^ ( 2 :: Int ) / squaredNorm n + +-- | Add new guide after a mouse drag from a ruler area. +addGuide :: UniqueSupply -> Ruler -> Point2D Double -> Document -> STM Document +addGuide uniqueSupply ruler p = ( field' @"guides" ) insertNewGuides + where + insertNewGuides :: Map Unique Guide -> STM ( Map Unique Guide ) + insertNewGuides gs = case ruler of + RulerCorner + -> do + uniq1 <- freshUnique uniqueSupply + uniq2 <- freshUnique uniqueSupply + let + guide1, guide2 :: Guide + guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 } + guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, guideUnique = uniq2 } + pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs ) + TopRuler + -> do + uniq1 <- freshUnique uniqueSupply + let + guide1 :: Guide + guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 } + pure ( Map.insert uniq1 guide1 gs ) + LeftRuler + -> do + uniq2 <- freshUnique uniqueSupply + let + guide2 :: Guide + guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, guideUnique = uniq2 } + pure ( Map.insert uniq2 guide2 gs ) + +instance Hoverable Guide where + hovered ( Just ( MouseHover c ) ) zoom guide + | Just _ <- selectGuide_maybe c zoom guide + = Hover + | otherwise + = Normal + hovered _ _ _ = Normal diff --git a/src/app/MetaBrush/Document/Guide.hs b/src/app/MetaBrush/Document/Guide.hs deleted file mode 100644 index 9f5d195..0000000 --- a/src/app/MetaBrush/Document/Guide.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} - -module MetaBrush.Document.Guide - ( selectGuide, addGuide ) - where - --- base -import Data.Semigroup - ( Arg(..), Min(..), ArgMin ) - --- acts -import Data.Act - ( Torsor((-->)) ) - --- containers -import Data.Map.Strict - ( Map ) -import qualified Data.Map.Strict as Map - ( insert ) - --- generic-lens -import Data.Generics.Product.Fields - ( field' ) - --- stm -import Control.Concurrent.STM - ( STM ) - --- MetaBrush -import Math.Module - ( Inner((^.^)), squaredNorm ) -import Math.Vector2D - ( Point2D(..), Vector2D(..) ) -import MetaBrush.Document - ( Document(..), Guide(..) - ) -import MetaBrush.UI.Viewport - ( Ruler(..) ) -import MetaBrush.Unique - ( UniqueSupply, Unique, freshUnique ) - --------------------------------------------------------------------------------- - --- | Try to select a guide at the given document coordinates. -selectGuide :: Point2D Double -> Document -> Maybe Guide -selectGuide c ( Document { zoomFactor, guides } ) = \case { Min ( Arg _ g ) -> g } <$> foldMap f guides - where - f :: Guide -> Maybe ( ArgMin Double Guide ) - f guide@( Guide { guidePoint = p, guideNormal = n } ) - | sqDist * zoomFactor ^ ( 2 :: Int ) < 4 - = Just ( Min ( Arg sqDist guide ) ) - | otherwise - = Nothing - where - t :: Double - t = ( c --> p ) ^.^ n - sqDist :: Double - sqDist = t ^ ( 2 :: Int ) / squaredNorm n - --- | Add new guide after a mouse drag from a ruler area. -addGuide :: UniqueSupply -> Ruler -> Point2D Double -> Document -> STM Document -addGuide uniqueSupply ruler p = ( field' @"guides" ) insertNewGuides - where - insertNewGuides :: Map Unique Guide -> STM ( Map Unique Guide ) - insertNewGuides gs = case ruler of - RulerCorner - -> do - uniq1 <- freshUnique uniqueSupply - uniq2 <- freshUnique uniqueSupply - let - guide1, guide2 :: Guide - guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideUnique = uniq1 } - guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideUnique = uniq2 } - pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs ) - TopRuler - -> do - uniq1 <- freshUnique uniqueSupply - let - guide1 :: Guide - guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideUnique = uniq1 } - pure ( Map.insert uniq1 guide1 gs ) - LeftRuler - -> do - uniq2 <- freshUnique uniqueSupply - let - guide2 :: Guide - guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideUnique = uniq2 } - pure ( Map.insert uniq2 guide2 gs ) diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index 41df02e..9570b96 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -120,8 +120,8 @@ import Math.Vector2D ( Point2D(..), Vector2D(..) ) import MetaBrush.Document ( Document(..) - , Stroke(..) , Guide(..) + , Stroke(..) , PointData(..) , BrushPointData(..) , FocusState(..) @@ -336,16 +336,18 @@ decodeStroke uniqueSupply = do encodeGuide :: Applicative f => JSON.Encoder f Guide -encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) -> +encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal, guideFocus } ) -> JSON.Encoder.atKey' "point" ( encodePoint2D encodeDouble ) guidePoint . JSON.Encoder.atKey' "normal" ( encodeVector2D encodeDouble ) guideNormal + . JSON.Encoder.atKey' "focus" encodeFocusState guideFocus decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide decodeGuide uniqueSupply = do guidePoint <- JSON.Decoder.atKey "point" ( decodePoint2D decodeDouble ) guideNormal <- JSON.Decoder.atKey "normal" ( decodeVector2D decodeDouble ) + guideFocus <- JSON.Decoder.atKey "focus" decodeFocusState guideUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) - pure ( Guide { guidePoint, guideNormal, guideUnique } ) + pure ( Guide { guidePoint, guideNormal, guideFocus, guideUnique } ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index bec0632..e2dc812 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module MetaBrush.Render.Document ( renderDocument, blankRender ) @@ -74,8 +75,9 @@ import MetaBrush.Asset.Colours import MetaBrush.Context ( HoldAction(..), PartialPath(..) ) import MetaBrush.Document - ( Document(..) + ( Document(..), mkAABB , Stroke(..), FocusState(..) + , HoverContext(..), Hoverable(..) , PointData(..), BrushPointData(..) , _selection ) @@ -91,7 +93,7 @@ import MetaBrush.Util data Renders a = Renders { renderPath, renderStrokes, renderBrushes - , renderCPts, renderCLines, renderPPts :: a + , renderCLines, renderCPts, renderPPts :: a } deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 ) deriving Applicative @@ -129,12 +131,13 @@ renderDocument let renderSelectionRect :: Cairo.Render () - renderSelectionRect + mbHoverContext :: Maybe HoverContext + ( renderSelectionRect, mbHoverContext ) | Just ( SelectionHold p0 ) <- mbHoldEvent , Just p1 <- mbMousePos - = drawSelectionRectangle cols zoomFactor p0 p1 + = ( drawSelectionRectangle cols zoomFactor p0 p1, Just $ RectangleHover ( mkAABB p0 p1 ) ) | otherwise - = pure () + = ( pure (), MouseHover <$> mbMousePos ) modifiedStrokes :: [ Stroke ] modifiedStrokes @@ -173,18 +176,18 @@ renderDocument | otherwise = strokes doc - for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols params mode zoomFactor ) + for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mbHoverContext params mode zoomFactor ) renderSelectionRect Cairo.restore pure () -renderStroke :: Colours -> FitParameters -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render () -renderStroke cols@( Colours { brush } ) params mode zoom ( Stroke { strokePoints = pts, strokeVisible } ) +renderStroke :: Colours -> Maybe HoverContext -> FitParameters -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render () +renderStroke cols@( Colours { brush } ) mbHoverContext params mode zoom ( Stroke { strokePoints = pts, strokeVisible } ) | strokeVisible - = renderStrokePoints cols mode zoom - ( when ( mode == Brush ) . renderBrushShape ( cols { path = brush } ) ( 1.5 * zoom ) ) + = renderStrokePoints cols mode mbHoverContext zoom + ( when ( mode == Brush ) . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) ) pts *> Compose blank { renderStrokes = drawStroke cols ( stroke params pts ) } | otherwise @@ -197,13 +200,13 @@ renderStroke cols@( Colours { brush } ) params mode zoom ( Stroke { strokePoints renderStrokePoints :: forall d . ( Show d, HasType FocusState d ) - => Colours -> Mode -> Double + => Colours -> Mode -> Maybe HoverContext -> Double -> ( StrokePoint d -> Compose Renders Cairo.Render () ) -> Seq ( StrokePoint d ) -> Compose Renders Cairo.Render () -renderStrokePoints _ _ _ _ Empty = pure () -renderStrokePoints cols mode zoom renderSubcontent ( pt0 :<| pts ) = - Compose blank { renderPPts = when ( mode == Path ) $ drawPoint cols zoom pt0 } +renderStrokePoints _ _ _ _ _ Empty = pure () +renderStrokePoints cols mode mbHover zoom renderSubcontent ( pt0 :<| pts ) = + Compose blank { renderPPts = when ( mode == Path ) $ drawPoint cols mbHover zoom pt0 } *> renderSubcontent pt0 *> go pt0 pts where @@ -215,7 +218,7 @@ renderStrokePoints cols mode zoom renderSubcontent ( pt0 :<| pts ) = | PathPoint {} <- p1 = Compose blank { renderPPts - = when ( mode == Path ) $ drawPoint cols zoom p1 + = when ( mode == Path ) $ drawPoint cols mbHover zoom p1 , renderPath = unless ( mode == Meta ) $ drawLine cols zoom p0 p1 } @@ -231,9 +234,9 @@ renderStrokePoints cols mode zoom renderSubcontent ( pt0 :<| pts ) = drawLine cols zoom p0 p1 drawLine cols zoom p1 p2 , renderCPts - = when ( mode == Path ) $ drawPoint cols zoom p1 + = when ( mode == Path ) $ drawPoint cols mbHover zoom p1 , renderPPts - = when ( mode == Path ) $ drawPoint cols zoom p2 + = when ( mode == Path ) $ drawPoint cols mbHover zoom p2 , renderPath = unless ( mode == Meta ) $ drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 } ) } @@ -252,10 +255,10 @@ renderStrokePoints cols mode zoom renderSubcontent ( pt0 :<| pts ) = drawLine cols zoom p2 p3 , renderCPts = when ( mode == Path ) do - drawPoint cols zoom p1 - drawPoint cols zoom p2 + drawPoint cols mbHover zoom p1 + drawPoint cols mbHover zoom p2 , renderPPts - = when ( mode == Path ) $ drawPoint cols zoom p3 + = when ( mode == Path ) $ drawPoint cols mbHover zoom p3 , renderPath = unless ( mode == Meta ) $ drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 } ) } @@ -265,29 +268,31 @@ renderStrokePoints cols mode zoom renderSubcontent ( pt0 :<| pts ) = *> go p3 ps go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 :<| ps ) -renderBrushShape :: Colours -> Double -> StrokePoint PointData -> Compose Renders Cairo.Render () -renderBrushShape cols zoom pt = +renderBrushShape :: Colours -> Maybe HoverContext -> Double -> StrokePoint PointData -> Compose Renders Cairo.Render () +renderBrushShape cols mbHoverContext zoom pt = let x, y :: Double Point2D x y = coords pt brushPts :: Seq ( StrokePoint BrushPointData ) brushPts = brushShape ( pointData pt ) + mbHoverContext' :: Maybe HoverContext + mbHoverContext' = Vector2D (-x) (-y) • mbHoverContext in toAll do Cairo.save Cairo.translate x y - *> renderStrokePoints cols Path zoom ( const $ pure () ) brushPts + *> renderStrokePoints cols Path mbHoverContext' zoom ( const $ pure () ) brushPts *> Compose blank { renderPPts = drawCross cols zoom } *> toAll Cairo.restore -drawPoint :: HasType FocusState d => Colours -> Double -> StrokePoint d -> Cairo.Render () -drawPoint ( Colours {..} ) zoom pt@( PathPoint { coords = Point2D x y } ) +drawPoint :: HasType FocusState d => Colours -> Maybe HoverContext -> Double -> StrokePoint d -> Cairo.Render () +drawPoint ( Colours {..} ) mbHover zoom pt@( PathPoint { coords = Point2D x y } ) = do let hsqrt3 :: Double hsqrt3 = sqrt 0.75 selectionState :: FocusState - selectionState = view _selection pt + selectionState = view _selection pt <> hovered mbHover zoom ( Point2D x y ) Cairo.save Cairo.translate x y @@ -303,8 +308,8 @@ drawPoint ( Colours {..} ) zoom pt@( PathPoint { coords = Point2D x y } ) Cairo.setLineWidth 1.0 case selectionState of - Normal -> withRGBA pathPointOutline Cairo.setSourceRGBA - _ -> withRGBA pathPoint Cairo.setSourceRGBA + Selected -> withRGBA pathPoint Cairo.setSourceRGBA + _ -> withRGBA pathPointOutline Cairo.setSourceRGBA Cairo.strokePreserve case selectionState of @@ -315,11 +320,11 @@ drawPoint ( Colours {..} ) zoom pt@( PathPoint { coords = Point2D x y } ) Cairo.restore -drawPoint ( Colours {..} ) zoom pt@( ControlPoint { coords = Point2D x y } ) +drawPoint ( Colours {..} ) mbHover zoom pt@( ControlPoint { coords = Point2D x y } ) = do let selectionState :: FocusState - selectionState = view _selection pt + selectionState = view _selection pt <> hovered mbHover zoom ( Point2D x y ) Cairo.save Cairo.translate x y @@ -329,8 +334,8 @@ drawPoint ( Colours {..} ) zoom pt@( ControlPoint { coords = Point2D x y } ) Cairo.setLineWidth 1.0 case selectionState of - Normal -> withRGBA controlPointOutline Cairo.setSourceRGBA - _ -> withRGBA controlPoint Cairo.setSourceRGBA + Selected -> withRGBA controlPoint Cairo.setSourceRGBA + _ -> withRGBA controlPointOutline Cairo.setSourceRGBA Cairo.strokePreserve case selectionState of diff --git a/src/app/MetaBrush/Render/Rulers.hs b/src/app/MetaBrush/Render/Rulers.hs index 40132d9..a7f8d7f 100644 --- a/src/app/MetaBrush/Render/Rulers.hs +++ b/src/app/MetaBrush/Render/Rulers.hs @@ -48,7 +48,7 @@ import qualified GI.Cairo.Render as Cairo -- lens import Control.Lens - ( over ) + ( set, over ) -- MetaBrush import Math.Vector2D @@ -60,11 +60,15 @@ import MetaBrush.Asset.Colours import MetaBrush.Context ( HoldAction(..), GuideAction(..) ) import MetaBrush.Document - ( Document(..), Guide(..) ) + ( Document(..), FocusState(..), Hoverable(..), HoverContext(..) + , Guide(..) + ) import MetaBrush.UI.Coordinates ( toViewportCoordinates ) import MetaBrush.UI.Viewport ( Ruler(..) ) +import MetaBrush.Unique + ( unsafeUnique ) import MetaBrush.Util ( withRGBA ) @@ -91,25 +95,37 @@ renderRuler let translate :: Point2D Double -> Point2D Double translate = ( ( mousePos0 --> mousePos :: Vector2D Double ) • ) - in toList ( Map.adjust ( over ( field' @"guidePoint" ) translate ) guideUnique guides ) + in toList + $ Map.adjust + ( over ( field' @"guidePoint" ) translate . set ( field' @"guideFocus" ) Selected ) + guideUnique + guides CreateGuide ruler -> let addNewGuides :: [ Guide ] -> [ Guide ] addNewGuides gs = case ruler of RulerCorner - -> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideUnique = undefined } - : Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideUnique = undefined } + -> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideFocus = Selected, guideUnique = unsafeUnique 0 } + : Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideFocus = Selected, guideUnique = unsafeUnique 1 } : gs LeftRuler - -> Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideUnique = undefined } + -> Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideFocus = Selected, guideUnique = unsafeUnique 2 } : gs TopRuler - -> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideUnique = undefined } + -> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideFocus = Selected, guideUnique = unsafeUnique 3 } : gs in addNewGuides ( toList guides ) | otherwise = toList guides + mbHoverContext :: Maybe HoverContext + mbHoverContext + | Just mp@( Point2D x y ) <- mbMousePos + , x <= left || y <= top -- only hover guides from within ruler area + = Just ( MouseHover mp ) + | otherwise + = Nothing + Cairo.save Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight ) additionalAdjustment @@ -119,7 +135,7 @@ renderRuler -- Render tick marks. renderTicks -- Render guides. - when showGuides ( for_ modifiedGuides ( renderGuide cols zoomFactor ) ) + when showGuides ( for_ modifiedGuides ( renderGuide cols mbHoverContext zoomFactor ) ) -- Render mouse cursor indicator. for_ mbMousePos \ ( Point2D mx my ) -> case actionOrigin of @@ -254,8 +270,8 @@ renderRuler Cairo.stroke when tickHasLabel do if tickPosition < 0 - then Cairo.translate -14 8 - else Cairo.translate -14 12 + then Cairo.translate -14.5 6.5 + else Cairo.translate -14.5 10.5 for_ ( show $ round @_ @Int tickPosition ) \ char -> do Cairo.moveTo 0 0 Cairo.showText [char] @@ -270,21 +286,25 @@ data Tick } deriving stock Show -renderGuide :: Colours -> Double -> Guide -> Cairo.Render () -renderGuide ( Colours {..} ) zoom ( Guide { guidePoint = Point2D x y, guideNormal = Vector2D nx ny } ) = do +renderGuide :: Colours -> Maybe HoverContext -> Double -> Guide -> Cairo.Render () +renderGuide ( Colours {..} ) mbHoverContext zoom + gd@( Guide { guidePoint = Point2D x y, guideNormal = Vector2D nx ny, guideFocus } ) + = do - Cairo.save - Cairo.translate x y - Cairo.scale ( 1 / zoom ) ( 1 / zoom ) + Cairo.save + Cairo.translate x y + Cairo.scale ( 1 / zoom ) ( 1 / zoom ) - Cairo.setLineWidth 1 - withRGBA guide Cairo.setSourceRGBA + Cairo.setLineWidth 1 + case guideFocus <> hovered mbHoverContext zoom gd of + Normal -> withRGBA guide Cairo.setSourceRGBA + _ -> withRGBA pointHover Cairo.setSourceRGBA - Cairo.moveTo ( 1e5 * ny ) ( -1e5 * nx ) - Cairo.lineTo ( -1e5 * ny ) ( 1e5 * nx ) - Cairo.stroke + Cairo.moveTo ( 1e5 * ny ) ( -1e5 * nx ) + Cairo.lineTo ( -1e5 * ny ) ( 1e5 * nx ) + Cairo.stroke - Cairo.restore + Cairo.restore tickSpacing :: Double -> ( Double, [ Int ] ) tickSpacing d