diff --git a/README.md b/README.md index e774410..90ae53d 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ # image-triangles ### examples -![Sierra mountians original](examples/sierra.jpg) -![Sierra mountians post-filter](examples/sierra-result.svg) +![Sierra mountains original](examples/sierra.jpg) +![Sierra mountains post-filter](examples/sierra-result.svg) ![Dog original](examples/luna.jpeg) ![Dog post-filter](examples/luna-result.svg) @@ -11,6 +11,5 @@ install [cabal & ghc](https://www.haskell.org/ghcup/) if you don't have them. ``` cabal update -# change input file name in Main.hs line 95-ish -cabal run image-triangles -- -o output.svg --height 1000 --width 1000 +cabal run image-triangles -- --cornerCount 800 --input examples/sierra.jpg --output output.svg ``` diff --git a/image-triangles.cabal b/image-triangles.cabal index 5c918d8..4c4db88 100644 --- a/image-triangles.cabal +++ b/image-triangles.cabal @@ -63,7 +63,9 @@ executable image-triangles MultiParamTypeClasses, OverloadedLabels, TypeFamilies, + TypeOperators, TupleSections, + DeriveGeneric, UndecidableInstances, RecursiveDo, RecordWildCards, @@ -83,6 +85,7 @@ executable image-triangles , linear , vector , containers + , optparse-generic -- Directories containing source files. diff --git a/src/Main.hs b/src/Main.hs index b877139..4504a68 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -18,7 +18,9 @@ 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 Triangles (getTriangleAverageRGB) +import Options.Generic import qualified Data.Colour.SRGB as CL data Options = Options { @@ -68,35 +70,36 @@ scalePointToImage (ymax, xmax) p = round <$> (p2 (fromIntegral xmax, fromIntegra -- derive Generic (RGB Double) -- genImage :: String -> IO (Diagram B) -genImage :: FilePath -> IO (QDiagram SVG V2 Double Any) -genImage name = do - let (Options {..}) = defaultOpts - gen' <- maybe getStdGen pure gen - print gen' - image <- Img.readImageRGB VU name - let img' = convImage image - let dimensions = (rows image, cols image) - let triangles = S.toList . Tri.findTriangles . Tri.toPlanarGraph . take 1000 . map p2 $ corners ++ Tri.randomPoints gen' - let triColors = map (getTriangleAverageRGB img' dimensions . S.map (scalePointToImage dimensions)) $ triangles - pure $ reflectY . mconcat $ withStrategy (parListChunk 1000 rseq) $ zipWith Ren.placeTri triangles triColors +-- genImage :: FilePath -> IO (QDiagram SVG V2 Double Any) +genImage image gen cornerCount = reflectY . mconcat $ withStrategy (parListChunk 1000 rseq) $ zipWith Ren.placeTri triangles triColors + where + img' = convImage image + dimensions = (rows image, cols image) + triangles = S.toList . Tri.findTriangles . Tri.toPlanarGraph . take cornerCount . map p2 $ corners ++ Tri.randomPoints gen + triColors = map (getTriangleAverageRGB img' dimensions . S.map (scalePointToImage dimensions)) $ triangles -- let progressList = withStrategy (parListChunk 500 rdeepseq) . map (/ (fromIntegral numTriangles)) $ [0.0 .. (fromIntegral numTriangles)] -- return $ center . reflectY . mconcat $ zipWith (renderTri img' dimensions) (genList gen'') progressList +toDimensionVector image = Diagrams.Prelude.dims $ p2 (fromIntegral $ rows image, fromIntegral $ cols image) .-. p2 (0.0, 0.0) +name = "examples/sierra.jpg" + +data CLIOptions = CLIOptions { + input :: FilePath, + output :: FilePath, + cornerCount :: Int + } deriving Generic + +instance ParseRecord CLIOptions main :: IO () main = do - gen <- getStdGen - -- let diagram :: (QDiagram SVG V2 Double Any) = mconcat . map (strokeLocTrail . uncurry Tri.toLocatedTrail) . Tri.toPlanarGraph . take 40 . map p2 $ corners ++ Tri.randomPoints gen - -- let diagram = mconcat . map Ren.toLine . Tri.toPlanarGraph $ [(0,0), (1,2), (0,1), (1,0)] - -- let diagram :: (QDiagram SVG V2 Double Any) = mconcat . map Ren.placeTri . S.toList . Tri.findTriangles . Tri.toPlanarGraph . take 15 . map p2 $ corners ++ Tri.randomPoints gen - diagram <- genImage "sierra.jpg" - mainWith diagram - --- cmdArgs <- Env.getArgs --- case cmdArgs of --- ["http"] -> putStrLn "here" --- _ -> mainWith genImage --- putStrLn "done" + CLIOptions{..} <- getRecord "image options" + let (Options {gen = gen}) = defaultOpts + gen' <- maybe getStdGen pure gen + print gen' + image <- Img.readImageRGB VU input + let diagram = genImage image gen' cornerCount + renderSVG output (toDimensionVector image) diagram diff --git a/src/Triangles.hs b/src/Triangles.hs index 6be4e89..52ea91f 100644 --- a/src/Triangles.hs +++ b/src/Triangles.hs @@ -54,8 +54,9 @@ randomPoints = randomRs ((0,0), (1, 1)) -- toPlanarGraph :: (V a ~ V2, TrailLike a) => [Point V2 (N a)] -> [(Point P2 Double, Point P2 Double)] toPlanarGraph :: (Floating b, Ord b) => [Point V2 b] -> [(Point V2 b, Point V2 b)] toPlanarGraph points = -- map (uncurry toLocatedTrail) . - removeIntersections . sortOn (uncurry distanceA) . filter (uncurry (/=)) $ (,) <$> points <*> points + removeIntersections . take ((numPoints * numPoints) `div` 3) . sortOn (uncurry distanceA) . filter (uncurry (/=)) $ (,) <$> points <*> points where + numPoints = length points removeIntersections = foldl' addIfNoIntersection [] @@ -73,7 +74,7 @@ findTriangles :: Ord b => [(b, b)] -> S.Set (S.Set b) findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap where - threeCyclesOf node = S.unions + threeCyclesOf node = S.filter ((==) 3 . S.size) . S.unions . S.map (\x -> S.map (\y -> S.fromList [node, x, y]) $ S.delete node . S.intersection originalNodeNeighbors . (M.!) adjacencyMap $ x) $ originalNodeNeighbors where originalNodeNeighbors = fromMaybe S.empty (adjacencyMap M.!? node) @@ -244,7 +245,7 @@ getTriangleAverageRGB image (y', x') triangle = blendEqually pixels where pixels :: [Pixel_] - pixels = catMaybes . map index' $ points + pixels = mapMaybe index' points points :: [(Int, Int)] points = getPointsInTriangle image triangle