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

add & apply fourmolu and dead code removal

Browse source
This commit is contained in:
Jack Wines 2024-02-04 04:08:31 -08:00
parent 37bfefdc69
commit 801b616f91
No known key found for this signature in database
GPG key ID: 25B20640600571E6
3 changed files with 86 additions and 170 deletions
Download patch file Download diff file Expand all files Collapse all files

14
flake.nix
View file

@ -74,13 +74,13 @@
programs.hlint.enable = true; programs.hlint.enable = true;
# We use fourmolu # We use fourmolu
# programs.ormolu.package = pkgs.haskellPackages.fourmolu; programs.ormolu.package = pkgs.haskellPackages.fourmolu;
# settings.formatter.ormolu = { settings.formatter.ormolu = {
# options = [ options = [
# "--ghc-opt" "--ghc-opt"
# "-XImportQualifiedPost" "-XImportQualifiedPost"
# ]; ];
# }; };
}; };
# Default package & app. # Default package & app.

176
src/Main.hs
View file

@ -1,51 +1,52 @@
module Main where module Main where
import qualified Triangles as Tri import qualified CircumCircle as CC
import Control.Arrow
import qualified Control.Monad as M
import qualified Control.Monad.Parallel as MP
import Control.Parallel.Strategies
import qualified Data.Colour as C
import qualified Data.Colour.Names as CN
import Data.Colour.RGBSpace (uncurryRGB)
import qualified Data.Colour.SRGB as CL
import qualified Data.Colour.SRGB.Linear as CL
import Data.List
import qualified Data.Map as M
import qualified Data.Maybe as My
import qualified Data.Set as S
import qualified Data.Vector.Unboxed as Vec
import Debug.Trace
import qualified Debug.Trace as DT
import qualified Debug.Trace as T
import qualified Diagrams as DP
import Diagrams.Backend.SVG
import Diagrams.Backend.SVG.CmdLine
import Diagrams.Prelude
import qualified Diagrams.Prelude as D
import GHC.Generics import GHC.Generics
import qualified Render as Ren
import Graphics.Image as Img hiding (map, zipWith) import Graphics.Image as Img hiding (map, zipWith)
import qualified Graphics.Image.ColorSpace as G
import qualified Graphics.Image.Interface as Int
import Options.Generic
import qualified Render as Ren
import qualified System.Environment as Env
import System.Random import System.Random
import System.Random.Internal import System.Random.Internal
import System.Random.SplitMix import System.Random.SplitMix
import qualified Graphics.Image.ColorSpace as G
import qualified Data.Colour.SRGB.Linear as CL
import Diagrams.Backend.SVG.CmdLine
import Diagrams.Prelude
import Debug.Trace
import Data.List
import Control.Parallel.Strategies
import qualified Control.Monad as M
import qualified Graphics.Image.Interface as Int
import qualified Data.Vector.Unboxed as Vec
import qualified Debug.Trace as DT
import qualified System.Environment as Env
import qualified Data.Map as M
import qualified Data.Set as S
import Diagrams.Backend.SVG
import qualified Data.Colour.Names as CN
import Triangles (getTriangleAverageRGB) import Triangles (getTriangleAverageRGB)
import Options.Generic import qualified Triangles as Tri
import qualified Data.Colour.SRGB as CL
import qualified Data.Colour as C
import qualified Data.Maybe as My
import Control.Arrow
import Data.Colour.RGBSpace (uncurryRGB)
import qualified Control.Monad.Parallel as MP
import qualified CircumCircle as CC
import qualified Debug.Trace as T
import qualified Diagrams as DP
import qualified Diagrams.Prelude as D
data Options = Options { data Options = Options
numPoints :: Int, { numPoints :: Int
gen :: Maybe StdGen , gen :: Maybe StdGen
} }
-- -- modify this to your liking -- -- modify this to your liking
defaultOpts = Options { defaultOpts =
numPoints = 10, Options
gen = Nothing { numPoints = 10
} , gen = Nothing
}
-- CL.rgb might be the wrong fn... -- CL.rgb might be the wrong fn...
tosRGB' :: (Ord b, Floating b) => Pixel G.RGB b -> CL.Colour b tosRGB' :: (Ord b, Floating b) => Pixel G.RGB b -> CL.Colour b
@ -56,95 +57,74 @@ convImage = Vec.map tosRGB' . Int.toVector
corners :: [(Double, Double)] corners :: [(Double, Double)]
corners = (,) <$> [0, 1] <*> [0, 1] corners = (,) <$> [0, 1] <*> [0, 1]
-- scalePointToImage :: (Int, Int) -> Point V2 Double -> Point V2 Int
-- scalePointToImage (ymax, xmax) p = round <$> (p2 (fromIntegral xmax, fromIntegral ymax) * p)
-- genImage :: Image VU G.RGB Double -> StdGen -> Int -> QDiagram B V2 Double Any
-- genImage image gen cornerCount =
-- scaleY widthHeightRatio
-- . reflectY
-- . rectEnvelope (mkP2 0 0) (1 ^& 1)
-- . mconcat
-- . map (uncurry Ren.placeTri . second (uncurryRGB CL.rgb))
-- . withStrategy (parListChunk 1000 rdeepseq)
-- $ My.mapMaybe (\tri -> (tri,) . CL.toRGB <$> triColor tri) triangles
-- where
-- widthHeightRatio = (fromIntegral $ fst dimensions) / ((fromIntegral $ snd dimensions) :: Double)
-- img' = convImage image
-- dimensions = Img.dims image
-- triangles = S.toList . Tri.findTriangles . withStrategy (parListChunk 1000 rdeepseq) . Tri.toPlanarGraph . take cornerCount . map p2 $ corners ++ Tri.randomPoints gen
-- triColor tri = getTriangleAverageRGB img' dimensions <$> (if S.size scaled == 3 then Just scaled else Nothing)
-- where
-- scaled = S.map (scalePointToImage dimensions) tri
shapeCircumference = Data.List.sum . map D.norm . loopOffsets . fromVertices shapeCircumference = Data.List.sum . map D.norm . loopOffsets . fromVertices
genImage' :: Image VU G.RGB Double -> StdGen -> Int -> QDiagram SVG V2 Double Any genImage' :: Image VU G.RGB Double -> StdGen -> Int -> QDiagram SVG V2 Double Any
genImage' image gen cornerCount = -- image gen cornerCount = genImage' image gen cornerCount =
scaleY widthHeightRatio scaleY widthHeightRatio
. reflectY . reflectY
. rectEnvelope (mkP2 0 0) (1 ^& 1) . rectEnvelope (mkP2 0 0) (1 ^& 1)
-- . atop visualizeGraph -- . atop visualizeGraph
. mconcat . mconcat
. map drawVoroniRegion . map drawVoroniRegion
-- . concatMap (\(center, shape) -> (zip shape (repeat $ circle 0.002))) . sortOn shapeCircumference
. sortOn shapeCircumference . withStrategy (parListChunk 50 rdeepseq)
. withStrategy (parListChunk 50 rdeepseq) . map (uncurry Tri.voroniDiagramCorners)
. map (uncurry Tri.voroniDiagramCorners) $ voroni
$ voroni where
where drawVoroniRegion shape =
lw 0
. fillColor (Tri.voroniRegionAverageColor img' dimensions shape)
. strokeLocLoop
. fromVertices
$ shape
drawVoroniRegion shape = lw 0 widthHeightRatio = (fromIntegral $ fst dimensions) / ((fromIntegral $ snd dimensions) :: Double)
. fillColor (Tri.voroniRegionAverageColor img' dimensions shape )
. strokeLocLoop . fromVertices $ shape
img' = convImage image
dimensions = Img.dims image
widthHeightRatio = (fromIntegral $ fst dimensions) / ((fromIntegral $ snd dimensions) :: Double) singleVoroni = last voroni
img' = convImage image visualizeGraph :: QDiagram SVG V2 Double Any
dimensions = Img.dims image visualizeGraph =
lc red
singleVoroni = last voroni . lw 1
. position
visualizeGraph :: QDiagram SVG V2 Double Any
visualizeGraph = lc red . lw 1 . position
. map (\(x0, x1) -> (x0,) . strokeLine $ (x0 ~~ x1)) . map (\(x0, x1) -> (x0,) . strokeLine $ (x0 ~~ x1))
. Tri.toPlanarGraph . Tri.toPlanarGraph
$ corners' $ corners'
voroni = -- take 14 . drop 24 . voroni =
Tri.findVoroniDiagram -- . withStrategy (parListChunk 1000 rdeepseq) Tri.findVoroniDiagram
. Tri.toPlanarGraph $ corners' . Tri.toPlanarGraph
$ corners'
corners' = take cornerCount . map p2 $ corners ++ Tri.randomPoints gen corners' = take cornerCount . map p2 $ corners ++ Tri.randomPoints gen
deriving instance Generic (CL.RGB a) deriving instance Generic (CL.RGB a)
deriving instance NFData a => NFData (CL.RGB a) deriving instance NFData a => NFData (CL.RGB a)
toDimensionVector :: (Int.BaseArray arr cs e, Fractional n) => Image arr cs e -> SizeSpec V2 n toDimensionVector :: (Int.BaseArray arr cs e, Fractional n) => Image arr cs e -> SizeSpec V2 n
toDimensionVector image = Diagrams.Prelude.dims $ p2 (fromIntegral $ cols image, fromIntegral $ rows image) .-. p2 (0.0, 0.0) toDimensionVector image = Diagrams.Prelude.dims $ p2 (fromIntegral $ cols image, fromIntegral $ rows image) .-. p2 (0.0, 0.0)
data CLIOptions = CLIOptions { data CLIOptions = CLIOptions
input :: FilePath, { input :: FilePath
output :: FilePath, , output :: FilePath
cornerCount :: Int , cornerCount :: Int
} deriving Generic }
deriving (Generic)
instance ParseRecord CLIOptions instance ParseRecord CLIOptions
main :: IO () main :: IO ()
main = do main = do
CLIOptions{..} <- getRecord "image options" CLIOptions{..} <- getRecord "image options"
let (Options {gen = gen}) = defaultOpts let (Options{gen = gen}) = defaultOpts
gen' <- getStdGen -- pure . mkStdGen $ 2344 gen' <- getStdGen -- pure . mkStdGen $ 2344
let gens :: [StdGen] = map fst . iterate (split . snd) . split $ gen' let gens :: [StdGen] = map fst . iterate (split . snd) . split $ gen'
print gen' print gen'
image <- Img.readImageRGB VU input image <- Img.readImageRGB VU input
-- let diagram = genImage image gen' cornerCount let nums = zip gens $ map show [0 .. 60]
let nums = zip gens $ map show [0..60]
let dimVector = toDimensionVector image let dimVector = toDimensionVector image
renderSVG output dimVector (genImage' image gen' cornerCount) renderSVG output dimVector (genImage' image gen' cornerCount)
-- MP.forM_ nums (\(gen'', x) -> renderCairo ("output/" ++ x ++ "-" ++ output) dimVector (genImage image gen'' cornerCount))

66
src/Triangles.hs
View file

@ -1,12 +1,3 @@
{-# LANGUAGE TupleSections, TypeFamilies, MultiParamTypeClasses, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
-- module Triangles
-- ( getRandomPixel
-- , getRandomTriangle
-- , getPointsInTriangle
-- , getTriangleAverageRGB
-- ) where
module Triangles where module Triangles where
import System.Random import System.Random
@ -37,11 +28,9 @@ import Debug.Trace (traceShow)
import qualified Data.Colour.Names as C import qualified Data.Colour.Names as C
import qualified Debug.Trace as D import qualified Debug.Trace as D
import Diagrams.TwoD.Segment.Bernstein (listToBernstein) import Diagrams.TwoD.Segment.Bernstein (listToBernstein)
-- import qualified Linear.Affine as L
type Image_ = Vec.Vector Pixel_ type Image_ = Vec.Vector Pixel_
type Pixel_ = Colour Double type Pixel_ = Colour Double
-- type Point = (Double, Double)
-- type Triangle = (Point, Point, Point)
toSRGBTuple :: Pixel_ -> (Double, Double, Double) toSRGBTuple :: Pixel_ -> (Double, Double, Double)
toSRGBTuple = srgb' . C.toRGB toSRGBTuple = srgb' . C.toRGB
@ -95,14 +84,6 @@ toPlanarGraph points =
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 toLocatedTrail p1 p2 = fromVertices [p1, p2] `at` p1
-- data VoroniRegion = VoroniRegion {
-- center :: P2 Double,
-- neighbors :: [P2 Double]
-- }
-- voroniDiagramCorners :: Point V2 Double -> [Point V2 Double] -> [Point V2 Double]
-- voroniDiagramCorners :: Point (V c) (N c) -> [Point V2 Double] -> c
-- voroniDiagramCorners :: forall t. (N t ~ Double, V t ~ V2, TrailLike t) => Point V2 Double -> [Point V2 Double] -> t
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) withinShape pointInShape verticies candidate = all ((< quarterTurn) . fmap abs . uncurry signedAngleBetweenDirs) $ zip (shapeDirections pointInShape) (shapeDirections candidate)
where where
@ -111,18 +92,13 @@ withinShape pointInShape verticies candidate = all ((< quarterTurn) . fmap abs .
sortOnAngle center = sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween center) sortOnAngle center = sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween center)
-- voroniDiagramCorners :: forall n . (Floating n, Real n, Show n) => Point V2 n -> [P2 n] -> [P2 n]
voroniDiagramCorners center midpoints -- = midpoints voroniDiagramCorners center midpoints -- = midpoints
= sortOnAngle center . filter isValidMidpoint . concat $ [intersectPointsT l0 l1 | l0 <- tangentTrails, l1 <- tangentTrails] = sortOnAngle center . filter isValidMidpoint . concat $ [intersectPointsT l0 l1 | l0 <- tangentTrails, l1 <- tangentTrails]
where where
lessThanQuarterTurn candidate = candidate <= (10001 / 40000) @@ turn || candidate >= (29999 / 40000) @@ turn lessThanQuarterTurn candidate = candidate <= (10001 / 40000) @@ turn || candidate >= (29999 / 40000) @@ turn
-- where
-- candidate' = (candidate ^. turn) - (fromIntegral . floor $ (candidate ^. turn))
-- candidateVertecies = sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween center) . concat $ [ intersectPointsT (tangentTrail x) (tangentTrail y) | x <- midpoints, y <- midpoints ]
tangentTrails = map tangentTrail midpoints tangentTrails = map tangentTrail midpoints
-- validMidpoints = sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween center) . filter isValidMidpoint $ midpoints
appendHead (x:xs) = xs ++ [x] appendHead (x:xs) = xs ++ [x]
@ -138,8 +114,6 @@ voroniDiagramCorners center midpoints -- = midpoints
fromDirection . rotateBy (1 / 4) $ dirBetween midpoint center fromDirection . rotateBy (1 / 4) $ dirBetween midpoint center
-- findVoroniDiagram :: (Ord (v n), Additive v, Fractional n) => [(Point v n, Point v n)] -> [[Point v n]]
-- findVoroniDiagram :: (Ord n, Ord (v n), Metric v, Floating n, R1 v, Real n, r) => [(Point v n, Point v n)] -> [[Point v n]]
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 edges =
M.toList M.toList
@ -149,20 +123,8 @@ findVoroniDiagram edges =
where where
adjacencyMap = adjacencyMapOf edges adjacencyMap = adjacencyMapOf edges
-- I'm not sure this part works
pointBetween p0 p1 = p0 .+^ ((p1 .-. p0) ^/ 2) pointBetween p0 p1 = p0 .+^ ((p1 .-. p0) ^/ 2)
-- filterNotInVoroniRegion :: RealFloat n => Point V2 n -> [Point V2 n] -> [Point V2 n] -> [Point V2 n]
-- filterNotInVoroniRegion center midpoints = id -- filter allowed
-- where
-- allowed point
-- = all ((< 0.25) . abs . (^. turn))
-- . zipWith signedAngleBetweenDirs midpointAngles
-- . map (dirBetween point) $ midpoints
-- midpointAngles = map (dirBetween center) midpoints
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 findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap
where where
@ -211,32 +173,6 @@ voroniRegionAverageColor image (x', y') verticies
scaleToUnitCoords :: P2 Int -> P2 Double scaleToUnitCoords :: P2 Int -> P2 Double
scaleToUnitCoords p = p2 ((fromIntegral x' / (fromIntegral $ p ^. _x)), fromIntegral y' / (fromIntegral $ p ^. _y)) scaleToUnitCoords p = p2 ((fromIntegral x' / (fromIntegral $ p ^. _x)), fromIntegral y' / (fromIntegral $ p ^. _y))
-- = blendEqually
-- . mapMaybe (index' . unp2)
-- . filter withinShape'
-- $ candidatePoints
-- where
-- withinShape' :: P2 Int -> Bool
-- withinShape' = withinShape center verticies . scaleToUnitCoords
-- candidatePoints = [p2 (x, y) | x <- [minX .. maxX], y <- [minY .. maxY]]
-- maxX = fst . unp2 $ maximumBy (compare `F.on` fst . unp2) verticies'
-- minX = fst . unp2 $ minimumBy (compare `F.on` fst . unp2) verticies'
-- maxY = snd . unp2 $ maximumBy (compare `F.on` snd . unp2) verticies'
-- minY = snd . unp2 $ minimumBy (compare `F.on` snd . unp2) verticies'
-- verticies' = map scaleToImageCoords verticies
-- index' :: (Int, Int) -> Maybe Pixel_
-- index' (y, x)
-- | y >= y' = Nothing
-- | x >= x' = Nothing
-- | y < 0 = Nothing
-- | x < 0 = Nothing
-- | otherwise = image Vec.!? ((y * x') + x)
getColorsInTriangle :: Image_ -> (Int, Int) -> S.Set (P2 Int) -> [C.Colour Double] getColorsInTriangle :: Image_ -> (Int, Int) -> S.Set (P2 Int) -> [C.Colour Double]
getColorsInTriangle image (x', y') triangle = pixels getColorsInTriangle image (x', y') triangle = pixels