mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-27 17:34:08 +00:00
refactor ruler subdivision handling
This commit is contained in:
parent
07c789ccc3
commit
dc6602bb79
|
@ -55,6 +55,7 @@ common common
|
||||||
-fwarn-incomplete-uni-patterns
|
-fwarn-incomplete-uni-patterns
|
||||||
-fwarn-missing-deriving-strategies
|
-fwarn-missing-deriving-strategies
|
||||||
-fno-warn-unticked-promoted-constructors
|
-fno-warn-unticked-promoted-constructors
|
||||||
|
-fno-show-valid-hole-fits
|
||||||
|
|
||||||
library
|
library
|
||||||
|
|
||||||
|
|
|
@ -1,16 +1,19 @@
|
||||||
{-# LANGUAGE BlockArguments #-}
|
{-# LANGUAGE BlockArguments #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE NegativeLiterals #-}
|
{-# LANGUAGE NegativeLiterals #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
module MetaBrush.Render.Rulers
|
module MetaBrush.Render.Rulers
|
||||||
( renderRuler )
|
( renderRuler )
|
||||||
where
|
where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
|
import Control.Arrow
|
||||||
|
( first )
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( when )
|
( when )
|
||||||
import Data.Fixed
|
import Data.Fixed
|
||||||
|
@ -19,6 +22,10 @@ import Data.Foldable
|
||||||
( for_, traverse_, toList )
|
( for_, traverse_, toList )
|
||||||
import Data.Int
|
import Data.Int
|
||||||
( Int32 )
|
( Int32 )
|
||||||
|
import Data.List.NonEmpty
|
||||||
|
( NonEmpty(..) )
|
||||||
|
import qualified Data.List.NonEmpty as NonEmpty
|
||||||
|
( reverse )
|
||||||
|
|
||||||
-- acts
|
-- acts
|
||||||
import Data.Act
|
import Data.Act
|
||||||
|
@ -175,54 +182,55 @@ renderRuler
|
||||||
renderTicks :: Cairo.Render ()
|
renderTicks :: Cairo.Render ()
|
||||||
renderTicks = case actionOrigin of
|
renderTicks = case actionOrigin of
|
||||||
ViewportOrigin -> pure ()
|
ViewportOrigin -> pure ()
|
||||||
RulerOrigin ruler -> case ruler of
|
RulerOrigin ruler ->
|
||||||
RulerCorner -> pure ()
|
let
|
||||||
TopRuler -> do
|
smallSpacing, bigSpacing :: Double
|
||||||
let
|
subdivs, displayedSubdivs :: [ Int ]
|
||||||
spacing, subdivs, subsubdivs, start :: Double
|
( bigSpacing, subdivs ) = tickSpacing ( 60 / zoomFactor )
|
||||||
( spacing, subdivs, subsubdivs ) = tickSpacing ( 60 / zoomFactor )
|
smallSpacing = bigSpacing / fromIntegral ( product displayedSubdivs )
|
||||||
start = truncateWith spacing left
|
displayedSubdivs = dropTightTicks subdivs
|
||||||
setTickRenderContext
|
dropTightTicks :: [ Int ] -> [ Int ]
|
||||||
traverse_ renderTickV
|
dropTightTicks = go 1
|
||||||
[ Tick { .. }
|
where
|
||||||
| i <- [ 0, 1 .. 1 + ( right - left ) / spacing ]
|
go :: Double -> [Int] -> [Int]
|
||||||
, j <- [ 0, 1 .. subdivs - 1 ]
|
go _ [] = []
|
||||||
, k <- if spacing / ( subdivs * subsubdivs ) < 4 / zoomFactor
|
go s ( x : xs )
|
||||||
then [ 0 ]
|
| s' > threshold
|
||||||
else [ 0, 1 .. subsubdivs - 1 ]
|
= []
|
||||||
, let
|
| otherwise
|
||||||
tickPosition = start + spacing * ( i + ( j + k / subsubdivs ) / subdivs )
|
= x : go s' xs
|
||||||
, let tickSize
|
where
|
||||||
| j == 0 && k == 0 = 12
|
s', threshold :: Double
|
||||||
| k == 0 = 6
|
s' = s * fromIntegral x
|
||||||
| otherwise = 3
|
threshold = 0.25 * bigSpacing * zoomFactor
|
||||||
, let tickHasLabel
|
increasingSubdivs :: NonEmpty ( Int, ( Double, Bool ) )
|
||||||
| j == 0 && k == 0 = True
|
increasingSubdivs = NonEmpty.reverse $ ( 1, ( 15, True ) ) :| zip displayedSubdivs [ ( 8, False ), ( 6, False ), ( 4, False ) ]
|
||||||
| otherwise = False
|
in case ruler of
|
||||||
]
|
RulerCorner -> pure ()
|
||||||
LeftRuler -> do
|
TopRuler -> do
|
||||||
let
|
let
|
||||||
spacing, subdivs, subsubdivs, start :: Double
|
start :: Double
|
||||||
( spacing, subdivs, subsubdivs ) = tickSpacing ( 60 / zoomFactor )
|
start = truncateWith bigSpacing left
|
||||||
start = truncateWith spacing top
|
setTickRenderContext
|
||||||
setTickRenderContext
|
traverse_ renderTickV $
|
||||||
traverse_ renderTickH
|
[ Tick { .. }
|
||||||
[ Tick { .. }
|
| ( i :: Int ) <- [ 0, 1 .. ceiling ( ( right - start ) / smallSpacing ) ]
|
||||||
| i <- [ 0, 1 .. 1 + ( bottom - top ) / spacing ]
|
, let
|
||||||
, j <- [ 0, 1 .. subdivs - 1 ]
|
( tickSize, tickHasLabel ) = subdivAt i increasingSubdivs
|
||||||
, k <- if spacing / ( subdivs * subsubdivs ) < 4 / zoomFactor
|
tickPosition = start + fromIntegral i * smallSpacing
|
||||||
then [ 0 ]
|
]
|
||||||
else [ 0, 1 .. subsubdivs - 1 ]
|
LeftRuler -> do
|
||||||
, let
|
let
|
||||||
tickPosition = start + spacing * ( i + ( j + k / subsubdivs ) / subdivs )
|
start :: Double
|
||||||
, let tickSize
|
start = truncateWith bigSpacing top
|
||||||
| j == 0 && k == 0 = 12
|
setTickRenderContext
|
||||||
| k == 0 = 6
|
traverse_ renderTickH $
|
||||||
| otherwise = 3
|
[ Tick { .. }
|
||||||
, let tickHasLabel
|
| ( i :: Int ) <- [ 0, 1 .. ceiling ( ( bottom - start ) / smallSpacing ) ]
|
||||||
| j == 0 && k == 0 = True
|
, let
|
||||||
| otherwise = False
|
( tickSize, tickHasLabel ) = subdivAt i increasingSubdivs
|
||||||
]
|
tickPosition = start + fromIntegral i * smallSpacing
|
||||||
|
]
|
||||||
|
|
||||||
renderTickV, renderTickH :: Tick -> Cairo.Render ()
|
renderTickV, renderTickH :: Tick -> Cairo.Render ()
|
||||||
renderTickV ( Tick { .. } ) = do
|
renderTickV ( Tick { .. } ) = do
|
||||||
|
@ -278,14 +286,23 @@ renderGuide ( Colours {..} ) zoom ( Guide { guidePoint = Point2D x y, guideNorma
|
||||||
|
|
||||||
Cairo.restore
|
Cairo.restore
|
||||||
|
|
||||||
tickSpacing :: Double -> ( Double, Double, Double )
|
tickSpacing :: Double -> ( Double, [ Int ] )
|
||||||
tickSpacing d
|
tickSpacing d
|
||||||
| d <= 1 = ( 1, 4, 5 )
|
| d <= 1 = ( 1, cycle [ 2, 5 ] )
|
||||||
| d <= 2 = ( 2, 2, 10 )
|
| d <= 2 = ( 2, 2 : cycle [ 2, 5 ] )
|
||||||
| d <= 5 = ( 5, 5, 4 )
|
| d <= 5 = ( 5, cycle [ 5, 2 ] )
|
||||||
| otherwise
|
| otherwise
|
||||||
= case tickSpacing ( 0.1 * d ) of
|
= first ( 10 * ) $ tickSpacing ( 0.1 * d )
|
||||||
( sp, sub, subsub ) -> ( 10 * sp, sub, subsub )
|
|
||||||
|
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 :: Double -> Double -> Double
|
||||||
truncateWith m x = x - ( x `mod'` m )
|
truncateWith m x = x - ( x `mod'` m )
|
||||||
|
|
Loading…
Reference in a new issue