diff --git a/flake.nix b/flake.nix index 0e4d0ce..908fd84 100644 --- a/flake.nix +++ b/flake.nix @@ -74,13 +74,13 @@ programs.hlint.enable = true; # We use fourmolu - # programs.ormolu.package = pkgs.haskellPackages.fourmolu; - # settings.formatter.ormolu = { - # options = [ - # "--ghc-opt" - # "-XImportQualifiedPost" - # ]; - # }; + programs.ormolu.package = pkgs.haskellPackages.fourmolu; + settings.formatter.ormolu = { + options = [ + "--ghc-opt" + "-XImportQualifiedPost" + ]; + }; }; # Default package & app. diff --git a/src/Main.hs b/src/Main.hs index 0147b20..ce9d64d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,51 +1,52 @@ 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 qualified Render as Ren 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.Internal 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 Options.Generic -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 +import qualified Triangles as Tri -data Options = Options { - numPoints :: Int, - gen :: Maybe StdGen - } +data Options = Options + { numPoints :: Int + , gen :: Maybe StdGen + } -- -- modify this to your liking -defaultOpts = Options { - numPoints = 10, - gen = Nothing - } +defaultOpts = + Options + { numPoints = 10 + , gen = Nothing + } -- CL.rgb might be the wrong fn... 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 = (,) <$> [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 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 - . reflectY - . rectEnvelope (mkP2 0 0) (1 ^& 1) - -- . atop visualizeGraph - . mconcat - . map drawVoroniRegion - -- . concatMap (\(center, shape) -> (zip shape (repeat $ circle 0.002))) - . sortOn shapeCircumference - . withStrategy (parListChunk 50 rdeepseq) - . map (uncurry Tri.voroniDiagramCorners) - $ voroni - where + . reflectY + . rectEnvelope (mkP2 0 0) (1 ^& 1) + -- . atop visualizeGraph + . mconcat + . map drawVoroniRegion + . sortOn shapeCircumference + . withStrategy (parListChunk 50 rdeepseq) + . map (uncurry Tri.voroniDiagramCorners) + $ voroni + where + drawVoroniRegion shape = + lw 0 + . fillColor (Tri.voroniRegionAverageColor img' dimensions shape) + . strokeLocLoop + . fromVertices + $ shape - drawVoroniRegion shape = lw 0 - . fillColor (Tri.voroniRegionAverageColor img' dimensions shape ) - . strokeLocLoop . fromVertices $ shape + widthHeightRatio = (fromIntegral $ fst dimensions) / ((fromIntegral $ snd dimensions) :: Double) + img' = convImage image + dimensions = Img.dims image - widthHeightRatio = (fromIntegral $ fst dimensions) / ((fromIntegral $ snd dimensions) :: Double) + singleVoroni = last voroni - img' = convImage image - dimensions = Img.dims image - - singleVoroni = last voroni - - visualizeGraph :: QDiagram SVG V2 Double Any - visualizeGraph = lc red . lw 1 . position + visualizeGraph :: QDiagram SVG V2 Double Any + visualizeGraph = + lc red + . lw 1 + . position . map (\(x0, x1) -> (x0,) . strokeLine $ (x0 ~~ x1)) . Tri.toPlanarGraph $ corners' - voroni = -- take 14 . drop 24 . - Tri.findVoroniDiagram -- . withStrategy (parListChunk 1000 rdeepseq) - . Tri.toPlanarGraph $ corners' + voroni = + Tri.findVoroniDiagram + . 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 NFData a => NFData (CL.RGB a) 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 { - input :: FilePath, - output :: FilePath, - cornerCount :: Int - } deriving Generic +data CLIOptions = CLIOptions + { input :: FilePath + , output :: FilePath + , cornerCount :: Int + } + deriving (Generic) instance ParseRecord CLIOptions main :: IO () main = do CLIOptions{..} <- getRecord "image options" - let (Options {gen = gen}) = defaultOpts + let (Options{gen = gen}) = defaultOpts gen' <- getStdGen -- pure . mkStdGen $ 2344 let gens :: [StdGen] = map fst . iterate (split . snd) . split $ gen' print gen' 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 renderSVG output dimVector (genImage' image gen' cornerCount) - -- MP.forM_ nums (\(gen'', x) -> renderCairo ("output/" ++ x ++ "-" ++ output) dimVector (genImage image gen'' cornerCount)) diff --git a/src/Triangles.hs b/src/Triangles.hs index c0ee4e8..55e1a2e 100644 --- a/src/Triangles.hs +++ b/src/Triangles.hs @@ -1,12 +1,3 @@ -{-# LANGUAGE TupleSections, TypeFamilies, MultiParamTypeClasses, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} --- module Triangles --- ( getRandomPixel --- , getRandomTriangle --- , getPointsInTriangle --- , getTriangleAverageRGB --- ) where - module Triangles where import System.Random @@ -37,11 +28,9 @@ import Debug.Trace (traceShow) import qualified Data.Colour.Names as C import qualified Debug.Trace as D import Diagrams.TwoD.Segment.Bernstein (listToBernstein) --- import qualified Linear.Affine as L + type Image_ = Vec.Vector Pixel_ type Pixel_ = Colour Double --- type Point = (Double, Double) --- type Triangle = (Point, Point, Point) toSRGBTuple :: Pixel_ -> (Double, Double, Double) 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 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 pointInShape verticies candidate = all ((< quarterTurn) . fmap abs . uncurry signedAngleBetweenDirs) $ zip (shapeDirections pointInShape) (shapeDirections candidate) where @@ -111,18 +92,13 @@ withinShape pointInShape verticies candidate = all ((< quarterTurn) . fmap abs . 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 = sortOnAngle center . filter isValidMidpoint . concat $ [intersectPointsT l0 l1 | l0 <- tangentTrails, l1 <- tangentTrails] where 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 - -- validMidpoints = sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween center) . filter isValidMidpoint $ midpoints appendHead (x:xs) = xs ++ [x] @@ -138,8 +114,6 @@ voroniDiagramCorners center midpoints -- = midpoints 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 edges = M.toList @@ -149,20 +123,8 @@ findVoroniDiagram edges = where adjacencyMap = adjacencyMapOf edges - -- I'm not sure this part works 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 edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap where @@ -211,32 +173,6 @@ voroniRegionAverageColor image (x', y') verticies scaleToUnitCoords :: P2 Int -> P2 Double 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 (x', y') triangle = pixels