hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

add hover indicator for points and guides

Browse source
This commit is contained in:
sheaf 2020-09-09 01:23:25 +02:00
parent dc6602bb79
commit 0a978b7c59
8 changed files with 245 additions and 179 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
MetaBrush.cabal
View file

@ -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

2
assets/theme.css
View file

@ -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);

10
src/app/MetaBrush/Action.hs
View file

@ -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

157
src/app/MetaBrush/Document.hs
View file

@ -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

91
src/app/MetaBrush/Document/Guide.hs
View file

@ -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 )

8
src/app/MetaBrush/Document/Serialise.hs
View file

@ -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 } )

93
src/app/MetaBrush/Render/Document.hs
View file

@ -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

62
src/app/MetaBrush/Render/Rulers.hs
View file

@ -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