hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

refactor ruler subdivision handling

Browse source
This commit is contained in:
sheaf 2020-09-08 22:20:46 +02:00
parent 07c789ccc3
commit dc6602bb79
2 changed files with 79 additions and 61 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
MetaBrush.cabal
View file

@ -55,6 +55,7 @@ common common
-fwarn-incomplete-uni-patterns
-fwarn-missing-deriving-strategies
-fno-warn-unticked-promoted-constructors
-fno-show-valid-hole-fits
library

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

@ -1,16 +1,19 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Render.Rulers
( renderRuler )
where
-- base
import Control.Arrow
( first )
import Control.Monad
( when )
import Data.Fixed
@ -19,6 +22,10 @@ import Data.Foldable
( for_, traverse_, toList )
import Data.Int
( Int32 )
import Data.List.NonEmpty
( NonEmpty(..) )
import qualified Data.List.NonEmpty as NonEmpty
( reverse )
-- acts
import Data.Act
@ -175,54 +182,55 @@ renderRuler
renderTicks :: Cairo.Render ()
renderTicks = case actionOrigin of
ViewportOrigin -> pure ()
RulerOrigin ruler -> case ruler of
RulerCorner -> pure ()
TopRuler -> do
let
spacing, subdivs, subsubdivs, start :: Double
( spacing, subdivs, subsubdivs ) = tickSpacing ( 60 / zoomFactor )
start = truncateWith spacing left
setTickRenderContext
traverse_ renderTickV
[ Tick { .. }
| i <- [ 0, 1 .. 1 + ( right - left ) / spacing ]
, j <- [ 0, 1 .. subdivs - 1 ]
, k <- if spacing / ( subdivs * subsubdivs ) < 4 / zoomFactor
then [ 0 ]
else [ 0, 1 .. subsubdivs - 1 ]
, let
tickPosition = start + spacing * ( i + ( j + k / subsubdivs ) / subdivs )
, let tickSize
| j == 0 && k == 0 = 12
| k == 0 = 6
| otherwise = 3
, let tickHasLabel
| j == 0 && k == 0 = True
| otherwise = False
]
LeftRuler -> do
let
spacing, subdivs, subsubdivs, start :: Double
( spacing, subdivs, subsubdivs ) = tickSpacing ( 60 / zoomFactor )
start = truncateWith spacing top
setTickRenderContext
traverse_ renderTickH
[ Tick { .. }
| i <- [ 0, 1 .. 1 + ( bottom - top ) / spacing ]
, j <- [ 0, 1 .. subdivs - 1 ]
, k <- if spacing / ( subdivs * subsubdivs ) < 4 / zoomFactor
then [ 0 ]
else [ 0, 1 .. subsubdivs - 1 ]
, let
tickPosition = start + spacing * ( i + ( j + k / subsubdivs ) / subdivs )
, let tickSize
| j == 0 && k == 0 = 12
| k == 0 = 6
| otherwise = 3
, let tickHasLabel
| j == 0 && k == 0 = True
| otherwise = False
]
RulerOrigin ruler ->
let
smallSpacing, bigSpacing :: Double
subdivs, displayedSubdivs :: [ Int ]
( bigSpacing, subdivs ) = tickSpacing ( 60 / zoomFactor )
smallSpacing = bigSpacing / fromIntegral ( product displayedSubdivs )
displayedSubdivs = dropTightTicks subdivs
dropTightTicks :: [ Int ] -> [ Int ]
dropTightTicks = go 1
where
go :: Double -> [Int] -> [Int]
go _ [] = []
go s ( x : xs )
| s' > threshold
= []
| otherwise
= x : go s' xs
where
s', threshold :: Double
s' = s * fromIntegral x
threshold = 0.25 * bigSpacing * zoomFactor
increasingSubdivs :: NonEmpty ( Int, ( Double, Bool ) )
increasingSubdivs = NonEmpty.reverse $ ( 1, ( 15, True ) ) :| zip displayedSubdivs [ ( 8, False ), ( 6, False ), ( 4, False ) ]
in case ruler of
RulerCorner -> pure ()
TopRuler -> do
let
start :: Double
start = truncateWith bigSpacing left
setTickRenderContext
traverse_ renderTickV $
[ Tick { .. }
| ( i :: Int ) <- [ 0, 1 .. ceiling ( ( right - start ) / smallSpacing ) ]
, let
( tickSize, tickHasLabel ) = subdivAt i increasingSubdivs
tickPosition = start + fromIntegral i * smallSpacing
]
LeftRuler -> do
let
start :: Double
start = truncateWith bigSpacing top
setTickRenderContext
traverse_ renderTickH $
[ Tick { .. }
| ( i :: Int ) <- [ 0, 1 .. ceiling ( ( bottom - start ) / smallSpacing ) ]
, let
( tickSize, tickHasLabel ) = subdivAt i increasingSubdivs
tickPosition = start + fromIntegral i * smallSpacing
]
renderTickV, renderTickH :: Tick -> Cairo.Render ()
renderTickV ( Tick { .. } ) = do
@ -278,14 +286,23 @@ renderGuide ( Colours {..} ) zoom ( Guide { guidePoint = Point2D x y, guideNorma
Cairo.restore
tickSpacing :: Double -> ( Double, Double, Double )
tickSpacing :: Double -> ( Double, [ Int ] )
tickSpacing d
| d <= 1 = ( 1, 4, 5 )
| d <= 2 = ( 2, 2, 10 )
| d <= 5 = ( 5, 5, 4 )
| d <= 1 = ( 1, cycle [ 2, 5 ] )
| d <= 2 = ( 2, 2 : cycle [ 2, 5 ] )
| d <= 5 = ( 5, cycle [ 5, 2 ] )
| otherwise
= case tickSpacing ( 0.1 * d ) of
( sp, sub, subsub ) -> ( 10 * sp, sub, subsub )
= first ( 10 * ) $ tickSpacing ( 0.1 * d )
subdivAt :: Int -> NonEmpty ( Int, d ) -> d
subdivAt _ ( ( _, d ) :| [] ) = d
subdivAt i ( ( t, d ) :| ( nxt : nxts ) )
| r == 0
= subdivAt q ( nxt :| nxts )
| otherwise
= d
where
( q, r ) = i `divMod` t
truncateWith :: Double -> Double -> Double
truncateWith m x = x - ( x `mod'` m )