From 3ceb4e996155ddf086929e8c4ddcab722b9781e5 Mon Sep 17 00:00:00 2001 From: Jack Wines Date: Fri, 3 Feb 2023 17:22:41 -0800 Subject: [PATCH] cleanup + parralellism, not working yet --- image-triangles.cabal | 4 +++- src/Main.hs | 20 +++++++++++++++++--- src/Render.hs | 21 +++------------------ src/Triangles.hs | 11 ++++------- 4 files changed, 27 insertions(+), 29 deletions(-) diff --git a/image-triangles.cabal b/image-triangles.cabal index b0e3527..77335f2 100644 --- a/image-triangles.cabal +++ b/image-triangles.cabal @@ -58,6 +58,7 @@ executable image-triangles OverloadedStrings, TemplateHaskell, DataKinds, + DeriveAnyClass, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, @@ -70,7 +71,8 @@ executable image-triangles RecursiveDo, RecordWildCards, RankNTypes, - DuplicateRecordFields + DuplicateRecordFields, + StandaloneDeriving -- Other library packages from which modules are imported. build-depends: base diff --git a/src/Main.hs b/src/Main.hs index 1e992ed..7ba76e4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -24,7 +24,10 @@ import Diagrams.Backend.SVG 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) data Options = Options { numPoints :: Int, @@ -70,15 +73,21 @@ 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) + -- derive Generic (RGB Double) -- genImage :: String -> IO (Diagram B) -- genImage :: FilePath -> IO (QDiagram SVG V2 Double Any) -genImage image gen cornerCount = scaleY ((fromIntegral $ fst dimensions) / ((fromIntegral $ snd dimensions) :: Double)) . reflectY . mconcat $ My.mapMaybe (\tri -> Ren.placeTri tri <$> triColor tri) triangles +genImage image gen cornerCount = + scaleY ((fromIntegral $ fst dimensions) / ((fromIntegral $ snd dimensions) :: Double)) + . reflectY . mconcat + . map (uncurry Ren.placeTri . second (uncurryRGB CL.rgb)) + . withStrategy (parListChunk 1000 rdeepseq) + $ My.mapMaybe (\tri -> (tri,) . CL.toRGB <$> triColor tri) triangles where img' = convImage image dimensions = (rows image, cols image) - triangles = S.toList . Tri.findTriangles . Tri.toPlanarGraph . take cornerCount . map p2 $ corners ++ Tri.randomPoints gen + 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 @@ -88,6 +97,11 @@ genImage image gen cornerCount = scaleY ((fromIntegral $ fst dimensions) / ((fro -- return $ center . reflectY . mconcat $ zipWith (renderTri img' dimensions) (genList gen'') progressList +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) name = "examples/sierra.jpg" @@ -104,7 +118,7 @@ main :: IO () main = do CLIOptions{..} <- getRecord "image options" let (Options {gen = gen}) = defaultOpts - let gen' = StdGen {unStdGen = (seedSMGen 6839483548670845148 15931131216394744615)} + gen' <- getStdGen print gen' image <- Img.readImageRGB VU input let diagram = genImage image gen' cornerCount diff --git a/src/Render.hs b/src/Render.hs index c505785..e83d134 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -10,32 +10,17 @@ import qualified Data.Set as S import qualified Data.Colour.Names as CN -makeTriangle :: [Point V2 Double] -> Colour Double -> Double -> Diagram SVG -makeTriangle verts col opacity_ = fromVertices verts +makeTriangle :: [Point V2 Double] -> Colour Double -> Diagram SVG +makeTriangle verts col = fromVertices verts # mapLoc closeLine # strokeLocLoop # lc col # fc col # lw 1.0 - # opacity opacity_ -- tupleFromIntegral :: (Int, Int) -> (Int, Int) -> (Double, Double) tupleFromIntegral (cols, rows) (a, b) = (fromIntegral b, fromIntegral a) --- tupleFromIntegral (cols, rows) (a, b) = ((a `divv` cols) , ((rows - b) `divv` rows)) - -divv :: Int -> Int -> Double -a `divv` b = (fromIntegral a) / (fromIntegral b) - --- toPointList :: (Int, Int) -> Tri.Triangle -> [Point V2 Double] --- toPointList dims (a, b, c) = map (p2 . tupleFromIntegral dims) [a, b, c] - --- toLine :: Tri.Line -> Diagram SVG --- toLine line = lw thin $ moveTo startPoint . strokeLine $ startPoint ~~ endPoint --- where --- startPoint = p2 (fromIntegral $ Tri.startX line, fromIntegral $ Tri.yAt line (Tri.startX line)) --- endPoint = p2 (fromIntegral $ Tri.endX line, fromIntegral $ Tri.yAt line (Tri.endX line)) - -- renderTriangle = makeTriangle (map p2 [(0.0,0.0), (0.1,0.1), (0.2,0.2)]) blue -placeTri tri col = makeTriangle (S.toList tri) col 1.0 +placeTri tri = makeTriangle (S.toList tri) diff --git a/src/Triangles.hs b/src/Triangles.hs index d996b2c..70943e4 100644 --- a/src/Triangles.hs +++ b/src/Triangles.hs @@ -54,22 +54,19 @@ randomPoints = map (bimap toZeroToOneTuple toZeroToOneTuple) . randomRs ((0 :: W toZeroToOneTuple :: Word -> Double toZeroToOneTuple x = (fromIntegral x / (fromIntegral (maxBound :: Word))) --- toPlanarGraph :: [Point P2 Double] -> [(Point P2 Double, Point P2 Double)] --- toPlanarGraph :: [P2 Double] -> [Located (Path V2 Double)] --- toPlanarGraph :: (V a ~ V2, TrailLike a) => [Point V2 (N a)] -> [(Point P2 Double, Point P2 Double)] - -combinations :: (Floating b, Foldable (Diff p), Affine p, Ord b, Ord (p b)) => [p b] -> [(p b, p b)] +combinations :: (Floating b, Foldable (Diff p), Affine p, Ord b, Ord (p b), + NFData (p b)) => [p b] -> [(p b, p b)] combinations xs = sortOn (abs . uncurry distanceA) . S.toList . S.fromList . filter (uncurry (/=)) - . concat . withStrategy (parListChunk 1000 rseq) + . concat . withStrategy (parListChunk 2000 rdeepseq) . map (\x -> take edgeLengthThreshold . sortOn (abs . uncurry distanceA) . map (\y -> (min x y, max x y)) $ xs) $ xs where edgeLengthThreshold = 45 -toPlanarGraph :: (Floating b, Ord b) => [Point V2 b] -> [(Point V2 b, Point V2 b)] +toPlanarGraph :: (NFData n, Floating n, Ord n) => [Point V2 n] -> [(Point V2 n, Point V2 n)] toPlanarGraph points = removeIntersections . combinations $ points where