Jack/image-triangles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

strictly formatting changes

Browse source
This commit is contained in:
Jack Wines 2024-04-18 02:54:07 -07:00
parent b5ae16ac59
commit b4ee69cd7f
No known key found for this signature in database
GPG key ID: 25B20640600571E6
8 changed files with 55 additions and 82 deletions
Download patch file Download diff file Expand all files Collapse all files

1
cabal.project
View file

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

16
flake.lock generated
View file

@ -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": [

1
flake.nix
View file

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

11
fourmolu.yaml
View file

@ -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
comma-style: leading
function-arrows: 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
single-deriving-parens: always
respectful: false

6
image-triangles.cabal
View file

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

22
src/Main.hs
View file

@ -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
, output :: FilePath
, minDistance :: Double
{ input :: FilePath,
output :: FilePath,
minDistance :: Double
}
deriving (Generic)
@ -117,7 +121,7 @@ instance ParseRecord CLIOptions
main :: IO ()
main = do
CLIOptions{..} <- getRecord "image options"
CLIOptions {..} <- getRecord "image options"
gen' <- getStdGen -- for consistency, swap with something like: pure . mkStdGen $ 2344
print gen'
image :: M.Image M.S (Co.SRGB 'Co.Linear) Double <- M.readImageAuto input

15
src/MinDistanceSample.hs
View file

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

65
src/Triangles.hs
View file

@ -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 edges =
findVoroniDiagram :: (RealFloat n) => [(Point V2 n, Point V2 n)] -> [(Point V2 n, [Point V2 n])]
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 p2 p3)
, ptsBtween (makeLine p1 p2) (makeLine p2 p3)
[ ptsBtween (makeLine p1 p3) (makeLine p1 p2),
ptsBtween (makeLine p1 p3) (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
, b = (fromIntegral y1) - (slope * (fromIntegral x1))
, startX = min x1 x2
, endX = max x1 x2
{ m = slope,
b = (fromIntegral y1) - (slope * (fromIntegral x1)),
startX = min 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
, b :: Rational
, startX :: Int
, endX :: Int
{ m :: Rational,
b :: Rational,
startX :: Int,
endX :: Int
}
deriving (Show, Ord, Eq)