strictly formatting changes

cabal.project

@@ -1,5 +1,6 @@
 packages:
          ./
 
+profiling: True
 -- package repa
 --         ghc-options: -fincomplete-uni-patterns

flake.lock

@@ -91,7 +91,6 @@
         "flake-utils": "flake-utils",
         "haskell-flake": "haskell-flake",
         "nixpkgs": "nixpkgs",
-        "systems": "systems_2",
         "treefmt-nix": "treefmt-nix"
       }
     },
@@ -110,21 +109,6 @@
         "type": "github"
       }
     },
-    "systems_2": {
-      "locked": {
-        "lastModified": 1681028828,
-        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
-        "owner": "nix-systems",
-        "repo": "default",
-        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
-        "type": "github"
-      },
-      "original": {
-        "owner": "nix-systems",
-        "repo": "default",
-        "type": "github"
-      }
-    },
     "treefmt-nix": {
       "inputs": {
         "nixpkgs": [

flake.nix

@@ -2,7 +2,6 @@
   description = "srid/haskell-template: Nix template for Haskell projects";
   inputs = {
     nixpkgs.url = "github:nixos/nixpkgs/nixos-unstable";
-    systems.url = "github:nix-systems/default";
     flake-utils.url = "github:numtide/flake-utils";
     flake-parts.url = "github:hercules-ci/flake-parts";
     haskell-flake.url = "github:srid/haskell-flake";

fourmolu.yaml

@@ -1,17 +1,16 @@
 # Generated from web app, for more information, see: https://fourmolu.github.io/config/
 indentation: 4
 column-limit: none
-function-arrows: trailing
+function-arrows: leading
-comma-style: leading
+comma-style: trailing
 import-export-style: diff-friendly
 indent-wheres: false
-record-brace-space: false
+record-brace-space: true
 newlines-between-decls: 1
 haddock-style: multi-line
-haddock-style-module: null
+haddock-style-module: single-line
 let-style: auto
 in-style: right-align
 single-constraint-parens: always
 unicode: never
-respectful: true
+respectful: false
-single-deriving-parens: always

image-triangles.cabal

@@ -101,8 +101,8 @@ executable image-triangles
   -- Base language which the package is written in.
   default-language:    Haskell2010
   ghc-options:
-                -- "-fprof-auto"
+                -fprof-auto
-                -threaded
+                -- -threaded
-               "-with-rtsopts= -N"
+                "-with-rtsopts=-p"
               -- -prof
 --               -fexternal-interpreter

src/Main.hs

@@ -40,7 +40,7 @@ import System.Random.SplitMix
 import Triangles (getTriangleAverageRGB)
 import qualified Triangles as Tri
 
-toColour :: Fractional a => Co.Color (Co.SRGB Co.Linear) a -> Colour a
+toColour :: (Fractional a) => Co.Color (Co.SRGB Co.Linear) a -> Colour a
 toColour (Co.ColorSRGB r g b) = CL.rgb r g b
 
 corners :: [(Double, Double)]
@@ -57,7 +57,7 @@ genImage image dimensionsVec minDistance gen =
         . mconcat
         . map drawVoroniRegion
         . sortOn shapeCircumference
-        . withStrategy (parListChunk 50 rdeepseq)
+        . withStrategy (parListChunk 200 rdeepseq)
         . map (uncurry Tri.voroniDiagramCorners)
         $ voroni
   where
@@ -95,21 +95,25 @@ genImage image dimensionsVec minDistance gen =
     padding = (/ 10) <$> V2 1 1
 
     corners' :: [P2 Double]
-    corners' = map (p2 . Bi.first (/ widthHeightRatio) . unp2 . (.-^ ((/ 2) <$> padding))) . MDS.randomPoints ((mkP2 widthHeightRatio 1) .+^ padding) (minDistance * widthHeightRatio) $ gen
+    corners' =
+        map (p2 . Bi.first (/ widthHeightRatio) . unp2 . (.-^ ((/ 2) <$> padding)))
+            . MDS.randomPoints ((mkP2 widthHeightRatio 1) .+^ padding) (minDistance * widthHeightRatio)
+            $ gen
 
 deriving instance Generic (CL.RGB a)
-deriving instance NFData a => NFData (CL.RGB a)
+
+deriving instance (NFData a) => NFData (CL.RGB a)
 
 toDimensionVector :: (Ma.Size r, Fractional a) => Ma.Array r Ma.Ix2 e -> V2 a
 toDimensionVector image =
-    p2 (fromIntegral $ cols, fromIntegral $ rows) .-. p2 (0.0, 0.0)
+    p2 (fromIntegral cols, fromIntegral rows) .-. p2 (0.0, 0.0)
   where
     (M.Sz2 rows cols) = Ma.size image
 
 data CLIOptions = CLIOptions
-    { input :: FilePath
+    { input :: FilePath,
-    , output :: FilePath
+      output :: FilePath,
-    , minDistance :: Double
+      minDistance :: Double
     }
     deriving (Generic)
 

src/MinDistanceSample.hs

@@ -21,7 +21,7 @@ randomPolarCoord gen = do
     distance <- uniformRM (1, 2) gen
     pure $ view (from r2PolarIso) (distance, angle @@ turn)
 
-randomPoints :: RandomGen r => Point V2 Double -> Double -> r -> [Point V2 Double]
+randomPoints :: (RandomGen r) => Point V2 Double -> Double -> r -> [Point V2 Double]
 randomPoints dims minDistance gen' = runStateGen_ gen' randomPointsM
   where
     randomPointsM gen = do
@@ -37,7 +37,7 @@ randomPoints dims minDistance gen' = runStateGen_ gen' randomPointsM
         bucketSize :: Double
         bucketSize = minDistance / (sqrt 2)
 
-        addPointToGrid grid p = M.insert (floor <$> p) (p) grid
+        addPointToGrid grid p = M.insert (floor <$> p) p grid
 
         randomValueFrom xs = (xs NE.!!) <$> uniformRM (0, pred . length $ xs) gen
 
@@ -45,13 +45,10 @@ randomPoints dims minDistance gen' = runStateGen_ gen' randomPointsM
         randomPointsRec (x : xs') grid = do
             startingPoint <- randomValueFrom xs
             newPoint <- L.find isValidPoint <$> candidates startingPoint
-            randomPointsRec (prependIfJust newPoint $ (if My.isJust newPoint then x : xs' else xsWithout startingPoint)) . gridPlus $ newPoint
+            case newPoint of
+                Just newPoint' -> randomPointsRec (newPoint' : x : xs') (addPointToGrid grid newPoint')
+                Nothing -> randomPointsRec (xsWithout startingPoint) grid
           where
-            prependIfJust (Just a) xs = a : xs
-            prependIfJust Nothing xs = xs
-
-            gridPlus = maybe grid (addPointToGrid grid)
-
             xs :: NE.NonEmpty (Point V2 Double)
             xs = x NE.:| xs'
 
@@ -68,7 +65,7 @@ randomPoints dims minDistance gen' = runStateGen_ gen' randomPointsM
 
             isValidPoint :: Point V2 Double -> Bool
             isValidPoint p =
-                (Ix.inRange gridBounds (floor <$> p))
+                (Ix.inRange gridBounds . fmap floor $ p)
                     && ( all ((>= 1) . abs . norm . (p .-.))
                             . My.mapMaybe ((grid M.!?) . fmap floor . (p .-^))
                             $ unitVectorsAround

src/Triangles.hs

@@ -34,7 +34,7 @@ import Diagrams.TwoD.Segment.Bernstein (listToBernstein)
 import qualified Graphics.Color.Space as Co
 import System.Random
 
-toColour :: Fractional a => Co.Color (Co.SRGB Co.Linear) a -> Colour a
+toColour :: (Fractional a) => Co.Color (Co.SRGB Co.Linear) a -> Colour a
 toColour (Co.ColorSRGB r g b) = CL.rgb r g b
 
 -- from -0.05 to 1.05 so there aren't missing/elongated triangles at the edges
@@ -48,7 +48,7 @@ randomPoints = map (bimap toZeroToOneTuple toZeroToOneTuple) . randomRs ((0 :: W
     toZeroToOneTuple x = ((fromIntegral x / (fromIntegral (maxBound :: Word))) * (1 + (2 * borderSize))) - borderSize
 
 combinations :: (Ord b, Floating b, NFData b) => [P2 b] -> [(P2 b, P2 b)]
-combinations xs =
+combinations =
     sortOn (abs . uncurry distanceA)
         . S.toList -- deduplicate
         . S.fromList
@@ -58,19 +58,13 @@ combinations xs =
         . map (\(x : xs) -> take 10 . sortOn (abs . uncurry distanceA) . map (x,) $ xs)
         . init -- last output of tails is empty list
         . tails
-        $ xs
-  where
-    xsLen = length xs
 
 toPlanarGraph :: forall n. (NFData n, Floating n, Ord n) => [P2 n] -> [(Point V2 n, Point V2 n)]
-toPlanarGraph points =
+toPlanarGraph =
     removeIntersections
         . sortOn (abs . uncurry distanceA)
         . combinations
-        $ points
   where
-    numPoints = length points
-
     removeIntersections :: [(Point V2 n, Point V2 n)] -> [(Point V2 n, Point V2 n)]
     removeIntersections = foldl' addIfNoIntersection []
 
@@ -82,17 +76,17 @@ toPlanarGraph points =
       where
         sharedEndPoint = (< 4) . length . nub $ [fst l1, snd l1, fst l2, snd l2]
 
-toLocatedTrail :: TrailLike a => Point (V a) (N a) -> Point (V a) (N a) -> Located a
+toLocatedTrail :: (TrailLike a) => Point (V a) (N a) -> Point (V a) (N a) -> Located a
 toLocatedTrail p1 p2 = fromVertices [p1, p2] `at` p1
 
-withinShape :: RealFloat v => Point V2 v -> [Point V2 v] -> Point V2 v -> Bool
+withinShape :: (RealFloat v) => Point V2 v -> [Point V2 v] -> Point V2 v -> Bool
 withinShape pointInShape verticies candidate = all ((< quarterTurn) . fmap abs . uncurry signedAngleBetweenDirs) $ zip (shapeDirections pointInShape) (shapeDirections candidate)
   where
     shapeDirections p = map (dirBetween p) verticies
 
 sortOnAngle center = sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween center)
 
-voroniDiagramCorners :: RealFloat n => Point V2 n -> [Point V2 n] -> [Point V2 n]
+voroniDiagramCorners :: (RealFloat n) => Point V2 n -> [Point V2 n] -> [Point V2 n]
 voroniDiagramCorners center midpoints =
     sortOnAngle center
         . filter isValidMidpoint
@@ -119,8 +113,8 @@ voroniDiagramCorners center midpoints =
                 . rotateBy (1 / 4)
                 $ dirBetween midpoint center
 
-findVoroniDiagram :: RealFloat n => [(Point V2 n, Point V2 n)] -> [(Point V2 n, [Point V2 n])]
+findVoroniDiagram :: (RealFloat n) => [(Point V2 n, Point V2 n)] -> [(Point V2 n, [Point V2 n])]
-findVoroniDiagram edges =
+findVoroniDiagram =
     M.toList
         . M.mapWithKey
             ( \key ->
@@ -128,13 +122,11 @@ findVoroniDiagram edges =
                     . map (pointBetween key)
                     . S.toList
             )
-        $ adjacencyMap
+        . adjacencyMapOf
   where
-    adjacencyMap = adjacencyMapOf edges
-
     pointBetween p0 p1 = p0 .+^ ((p1 .-. p0) ^/ 2)
 
-findTriangles :: Ord b => [(b, b)] -> S.Set (S.Set b)
+findTriangles :: (Ord b) => [(b, b)] -> S.Set (S.Set b)
 findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap
   where
     threeCyclesOf node =
@@ -150,26 +142,26 @@ adjacencyMapOf edges = M.fromListWith S.union . map (second S.singleton) $ (edge
   where
     edgesReversed = map (\(a, b) -> (b, a)) edges
 
-triangleAdjacencyMap :: Ord b => S.Set (S.Set b) -> M.Map b (S.Set (S.Set b))
+triangleAdjacencyMap :: (Ord b) => S.Set (S.Set b) -> M.Map b (S.Set (S.Set b))
 triangleAdjacencyMap s = M.fromListWith S.union . concatMap (\s' -> map (,S.singleton s') . S.toList $ s') $ S.toList s
 
 getPointsInTriangle :: p -> S.Set (P2 Int) -> [(Int, Int)]
 getPointsInTriangle image pts =
     S.toList . S.unions . map S.fromList $
-        [ ptsBtween (makeLine p1 p3) (makeLine p1 p2)
+        [ ptsBtween (makeLine p1 p3) (makeLine p1 p2),
-        , ptsBtween (makeLine p1 p3) (makeLine p2 p3)
+          ptsBtween (makeLine p1 p3) (makeLine p2 p3),
-        , ptsBtween (makeLine p1 p2) (makeLine p2 p3)
+          ptsBtween (makeLine p1 p2) (makeLine p2 p3)
         ]
   where
     [p1, p2, p3] = sortOn fst . map unp2 . S.toList $ pts
 
 blendEqually :: (Ord a, Floating a) => [Colour a] -> Colour a
-blendEqually colors = C.affineCombo (zip (repeat fraction) colors) $ C.white
+blendEqually colors = C.affineCombo (map (fraction,) colors) C.white
   where
     fraction = 1.0 / (fromIntegral . length $ colors)
 
 voroniRegionAverageColor :: (Integral a, Integral b) => Ma.Image Ma.S (Co.SRGB 'Co.Linear) Double -> (a, b) -> [P2 Double] -> Colour Double
-voroniRegionAverageColor image (x', y') verticies =
+voroniRegionAverageColor image (x', y') =
     blendEqually
         . concatMap (getColorsInTriangle image (x', y'))
         . filter ((== 3) . S.size)
@@ -177,19 +169,16 @@ voroniRegionAverageColor image (x', y') verticies =
         . tails
         . L.nub
         . map scaleToImageCoords
-        $ verticies
   where
     scaleToImageCoords :: P2 Double -> P2 Int
-    scaleToImageCoords p = fmap round $ p2 ((fromIntegral x' * p ^. _x), fromIntegral y' * p ^. _y)
+    scaleToImageCoords p = round <$> p2 (fromIntegral x' * p ^. _x, fromIntegral y' * p ^. _y)
 
     scaleToUnitCoords :: P2 Int -> P2 Double
     scaleToUnitCoords p = p2 ((fromIntegral x' / (fromIntegral $ p ^. _x)), fromIntegral y' / (fromIntegral $ p ^. _y))
 
 getColorsInTriangle :: Ma.Image Ma.S (Co.SRGB 'Co.Linear) Double -> (a, b) -> S.Set (P2 Int) -> [Colour Double]
-getColorsInTriangle image (x', y') triangle = pixels
+getColorsInTriangle image (x', y') triangle = mapMaybe index' points
   where
-    pixels = mapMaybe index' points
-
     points :: [(Int, Int)]
     points = getPointsInTriangle image triangle
 
@@ -215,15 +204,15 @@ range' :: Int -> Int -> [Int]
 range' a b = [(min a b) .. (max a b)]
 
 yAt :: LineMXB -> Int -> Int
-yAt (LineMXB{m = m, b = b}) x = round $ (m * (fromIntegral x)) + b
+yAt (LineMXB {..}) x = round $ (m * (fromIntegral x)) + b
 
 makeLine :: (Int, Int) -> (Int, Int) -> LineMXB
 makeLine (x1, y1) (x2, y2) =
     LineMXB
-        { m = slope
+        { m = slope,
-        , b = (fromIntegral y1) - (slope * (fromIntegral x1))
+          b = (fromIntegral y1) - (slope * (fromIntegral x1)),
-        , startX = min x1 x2
+          startX = min x1 x2,
-        , endX = max x1 x2
+          endX = max x1 x2
         }
   where
     slope =
@@ -232,9 +221,9 @@ makeLine (x1, y1) (x2, y2) =
             else fromIntegral . ceiling $ ((10.0 :: Double) ** 100.0)
 
 data LineMXB = LineMXB
-    { m :: Rational
+    { m :: Rational,
-    , b :: Rational
+      b :: Rational,
-    , startX :: Int
+      startX :: Int,
-    , endX :: Int
+      endX :: Int
     }
     deriving (Show, Ord, Eq)