cleanup + parralellism, not working yet

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

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

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 :: [Point V2 Double] -> Colour Double -> Diagram SVG
-makeTriangle verts col opacity_ = fromVertices verts
+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)

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)]
+combinations :: (Floating b, Foldable (Diff p), Affine p, Ord b, Ord (p b),
--- toPlanarGraph :: [P2 Double] -> [Located (Path V2 Double)]
+ NFData (p b)) => [p b] -> [(p b, p b)]
--- 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 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