parallelism

ChangeLog.md

@@ -1,3 +0,0 @@
-# Changelog for image-triangles
-
-## Unreleased changes

LICENSE

@@ -1,4 +1,4 @@
-Copyright Jack Wines (c) 2018
+Copyright (c) 2018, Jack Wines
 
 All rights reserved.
 

image-triangles.cabal

@@ -57,10 +57,11 @@ executable image-triangles
   other-extensions:    TupleSections
 
   -- Other library packages from which modules are imported.
-  build-depends:       base, random, hip, colour, diagrams-lib, diagrams-svg
+  build-depends:       base, random, hip, colour, diagrams-lib, diagrams-svg, parallel
 
   -- Directories containing source files.
   hs-source-dirs:      src
 
   -- Base language which the package is written in.
   default-language:    Haskell2010
+  ghc-options: -threaded -O3 

project.nix

@@ -1,5 +1,5 @@
 { mkDerivation, base, colour, diagrams-lib, diagrams-svg, hip
-, random, stdenv
+, parallel, random, stdenv
 }:
 mkDerivation {
   pname = "image-triangles";
@@ -8,7 +8,7 @@ mkDerivation {
   isLibrary = false;
   isExecutable = true;
   executableHaskellDepends = [
-    base colour diagrams-lib diagrams-svg hip random
+    base colour diagrams-lib diagrams-svg hip parallel random
   ];
   license = stdenv.lib.licenses.bsd3;
 }

src/Main.hs

@@ -8,24 +8,22 @@ import qualified Graphics.Image.ColorSpace as G
 import qualified Data.Colour.SRGB as C
 import Diagrams.Backend.SVG.CmdLine
 import Diagrams.Prelude
-
+import Data.List
+import Control.Parallel.Strategies
 
 
 genList = map mkStdGen . randoms
 
-singleTriangle image gen = reflectY . Ren.makeTriangle (Ren.toPointList dims t) $ col
+
+renderTri image t = reflectY . Ren.makeTriangle (Ren.toPointList dims t) $ col
     where
-        t = Tri.getRandomTriangle gen image
-        col = Tri.getTriangleAverageRGB image $ t
         dims = (cols image, rows image)
+        col = Tri.getTriangleAverageRGB image $ t
 
 main :: IO ()
 main = do
     image <- readImageRGB VU "sierra.jpg"
     gen <- getStdGen
-    print gen
-    let t = Tri.getRandomTriangle gen image
-    let col = Tri.getTriangleAverageRGB image t
-    print col
     let dims = (cols image, rows image)
-    mainWith . mconcat . take 50 . map (singleTriangle image) . genList $ gen
+    let triangleList = sortOn Tri.area . withStrategy (parListChunk 50 rseq) . take 50 . map (Tri.getRandomTriangle image) . genList $ gen
+    mainWith . mconcat . map (renderTri image) $ triangleList

src/Render.hs

@@ -9,7 +9,12 @@ import Diagrams.Backend.SVG.CmdLine
 
 
 makeTriangle :: [Point V2 Double] -> Colour Double -> Diagram SVG
-makeTriangle verts col = fromVertices verts # mapLoc closeLine # strokeLocLoop #fc col # lw 0 # opacity 0.2
+makeTriangle verts col = fromVertices verts
+                       # mapLoc closeLine
+                       # strokeLocLoop 
+                       # fc col
+                       # lw 0
+                       # opacity 0.2
 
 
 -- tupleFromIntegral :: (Int, Int) -> (Int, Int) -> (Double, Double)

src/Triangles.hs

@@ -14,16 +14,27 @@ import System.Random
 import qualified Data.Colour.SRGB as C
 import qualified Data.Colour as C
 import qualified Graphics.Image.ColorSpace as G
+import Data.List
 
 type Image_ = Image VU RGB Double
 type Pixel_ = Pixel RGB Double
 type Point = (Int, Int)
 type Triangle = (Point, Point, Point)
 
+area :: Triangle -> Double
+area (p1, p2, p3) = ccArea . swapForCounterClockwise . sortOn fst $ [p1, p2, p3]
+    where
+        swapForCounterClockwise [a, b, c] = if snd a < snd b
+                                               then [a, b, c]
+                                               else [b, a, c]
+        ccArea [(x1, y1), (x2, y2), (x3, y3)] = 
+            (fromIntegral (x1 * y2 + x2 * y3 + x3 * y1
+                         - x1 * y3 - x2 * y1 - x3 - y2)) / 2.0
+
 getRandomPixel :: StdGen -> Image_ -> (Int, Int)
 getRandomPixel gen image =
-    ( getCoord gen  . rows $ image
+    ( getCoord gen  . pred . rows $ image
-    , getCoord gen' . cols $ image)
+    , getCoord gen' . pred . cols $ image)
     where
         getCoord :: StdGen -> Int -> Int
         getCoord gen = fst . (flip randomR) gen . (1,)
@@ -32,8 +43,8 @@ getRandomPixel gen image =
 
 first3 (a : b : c : _) = (a, b, c)
 
-getRandomTriangle :: StdGen -> Image_ -> Triangle
+getRandomTriangle :: Image_ -> StdGen -> Triangle
-getRandomTriangle gen image =
+getRandomTriangle image gen =
     first3
     . map (\x -> getRandomPixel x image)
     . iterate (snd . next) $ gen

test/Spec.hs

@@ -1,2 +0,0 @@
-main :: IO ()
-main = putStrLn "Test suite not yet implemented"