mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
add hover indicator for points and guides
This commit is contained in:
parent
dc6602bb79
commit
0a978b7c59
|
@ -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
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
|
@ -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 } )
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue