refactor ruler subdivision handling

MetaBrush.cabal

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

src/app/MetaBrush/Render/Rulers.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE NegativeLiterals    #-}
 {-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 
 module MetaBrush.Render.Rulers
@@ -11,6 +12,8 @@ module MetaBrush.Render.Rulers
   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,53 +182,54 @@ renderRuler
     renderTicks :: Cairo.Render ()
     renderTicks = case actionOrigin of
       ViewportOrigin -> pure ()
-      RulerOrigin ruler -> case ruler of
+      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
-            spacing, subdivs, subsubdivs, start :: Double
+              start :: Double
-            ( spacing, subdivs, subsubdivs ) = tickSpacing ( 60 / zoomFactor )
+              start = truncateWith bigSpacing left
-            start = truncateWith spacing left
             setTickRenderContext
-          traverse_ renderTickV
+            traverse_ renderTickV $
               [ Tick { .. }
-            | i <- [ 0, 1 .. 1 + ( right - left ) / spacing ]
+              | ( i :: Int ) <- [ 0, 1 .. ceiling ( ( right - start ) / smallSpacing ) ]
-            , 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 )
+                  ( tickSize, tickHasLabel ) = subdivAt i increasingSubdivs
-            , let tickSize
+                  tickPosition = start + fromIntegral i * smallSpacing
-                    | 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
+              start :: Double
-            ( spacing, subdivs, subsubdivs ) = tickSpacing ( 60 / zoomFactor )
+              start = truncateWith bigSpacing top
-            start = truncateWith spacing top
             setTickRenderContext
-          traverse_ renderTickH
+            traverse_ renderTickH $
               [ Tick { .. }
-            | i <- [ 0, 1 .. 1 + ( bottom - top ) / spacing ]
+              | ( i :: Int ) <- [ 0, 1 .. ceiling ( ( bottom - start ) / smallSpacing ) ]
-            , 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 )
+                  ( tickSize, tickHasLabel ) = subdivAt i increasingSubdivs
-            , let tickSize
+                  tickPosition = start + fromIntegral i * smallSpacing
-                    | j == 0 && k == 0 = 12
-                    | k == 0           = 6
-                    | otherwise        = 3
-            , let tickHasLabel
-                    | j == 0 && k == 0 = True
-                    | otherwise        = False
               ]
 
     renderTickV, renderTickH :: Tick -> Cairo.Render ()
@@ -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 <= 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
-  = 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 m x = x - ( x `mod'` m )