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

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

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