Faster now, allowing a greater number of corners

image-triangles.cabal

@@ -86,6 +86,7 @@ executable image-triangles
                      , vector
                      , containers
                      , optparse-generic
+                     , splitmix
 
 
   -- Directories containing source files.

src/Main.hs

@@ -5,6 +5,8 @@ import GHC.Generics
 import qualified Render    as Ren
 import Graphics.Image as Img hiding (map, zipWith)
 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
@@ -22,6 +24,7 @@ import Diagrams.Backend.SVG
 import Triangles (getTriangleAverageRGB)
 import Options.Generic
 import qualified Data.Colour.SRGB as CL
+import qualified Data.Maybe as My
 
 data Options = Options {
                     numPoints :: Int,
@@ -71,18 +74,21 @@ scalePointToImage (ymax, xmax) p = round <$> (p2 (fromIntegral xmax, fromIntegra
 
 -- genImage :: String -> IO (Diagram B)
 -- genImage :: FilePath -> IO (QDiagram SVG V2 Double Any)
-genImage image gen cornerCount = reflectY . mconcat $ withStrategy (parListChunk 1000 rseq) $ zipWith Ren.placeTri triangles triColors
+genImage image gen cornerCount = scaleY ((fromIntegral $ fst dimensions) / ((fromIntegral $ snd dimensions) :: Double)) . reflectY . mconcat $ My.mapMaybe (\tri -> Ren.placeTri tri <$> 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
-    triColors = map (getTriangleAverageRGB img' dimensions . S.map (scalePointToImage dimensions)) $ triangles
+
+    triColor tri = getTriangleAverageRGB img' dimensions <$> (if S.size scaled == 3 then Just scaled else Nothing)
+      where
+        scaled = S.map (scalePointToImage dimensions) tri
 
     -- 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)
+toDimensionVector image = Diagrams.Prelude.dims $  p2 (fromIntegral $ cols image, fromIntegral $ rows image) .-. p2 (0.0, 0.0)
 
 name = "examples/sierra.jpg"
 
@@ -98,7 +104,7 @@ main :: IO ()
 main = do
   CLIOptions{..} <- getRecord "image options"
   let (Options {gen = gen}) = defaultOpts
-  gen' <- maybe getStdGen pure gen
+  let gen' = StdGen {unStdGen = (seedSMGen 6839483548670845148 15931131216394744615)}
   print gen'
   image <- Img.readImageRGB VU input
   let diagram = genImage image gen' cornerCount

src/Render.hs

@@ -16,7 +16,7 @@ makeTriangle verts col opacity_ = fromVertices verts
     # strokeLocLoop 
     # lc col
     # fc col
-    # lw 0.5
+    # lw 1.0
     # opacity opacity_
 
 

src/Triangles.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TupleSections, TypeFamilies, MultiParamTypeClasses, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
 -- module Triangles
 -- ( getRandomPixel
 -- , getRandomTriangle
@@ -12,6 +13,7 @@ import System.Random
 import Data.Ratio
 import qualified Debug.Trace
 import qualified Data.Colour.SRGB.Linear as C
+import Control.Parallel.Strategies
 import qualified Data.Colour as C
 import Data.Colour.SRGB.Linear (Colour)
 import Data.Vector.Generic.Base (Vector)
@@ -47,14 +49,29 @@ derivingUnbox "Pixel_"
 
 
 randomPoints :: StdGen -> [(Double, Double)]
-randomPoints = randomRs ((0,0), (1, 1))
+randomPoints = map (bimap toZeroToOneTuple toZeroToOneTuple) . randomRs ((0 :: Word, 0 :: Word), (maxBound, maxBound))
+  where
+    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 xs =
+  sortOn (abs . uncurry distanceA)
+  . S.toList . S.fromList
+  . filter (uncurry (/=))
+  . concat . withStrategy (parListChunk 1000 rseq)
+  . 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 points = -- map (uncurry toLocatedTrail) .
+toPlanarGraph points =
-  removeIntersections . take ((numPoints * numPoints) `div` 3) . sortOn (uncurry distanceA) . filter (uncurry (/=)) $ (,) <$> points <*> points
+  removeIntersections . combinations $ points
   where
     numPoints = length points
 
@@ -74,7 +91,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.filter ((==) 3 . S.size) . S.unions
+    threeCyclesOf node =  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)
@@ -87,155 +104,14 @@ pointsInTriangle tri = []
     [fst, snd, thrd] = S.toList tri
 
 
-  --   makePlanar :: [Line] -> [Line]
-  --   makePlanar = foldl addIfPlanar []
-
-  --   addIfPlanar lines candidate = if any (intersects candidate) lines then lines else candidate : lines
-
--- distance :: Point -> Point -> Double
--- distance (x0, y0) (x1, y1) = sqrt $ (fromIntegral (x0 - x1) ** 2) + (fromIntegral (y0 - y1) ** 2)
-
--- -- sharesCoords :: Triangle -> Bool
--- -- sharesCoords ((x1, y1), (x2, y2), (x3, y3)) = ((/= 3) . length . nub $ [x1, x2, x3])
--- --                                            || ((/= 3) . length . nub $ [y1, y2, y3])
-
--- intersects :: Line -> Line -> Bool
--- intersects l1 l2 = case xIntersect of
---   Just x -> (x > (fromIntegral . startX $ l1) && x < (fromIntegral . endX $ l1)) &&
---             (x > (fromIntegral . startX $ l2) && x < (fromIntegral . endX $ l2))
---   Nothing -> False
---   where
---     xIntersect = if m l2 == m l1 || isVertical l1 || isVertical l2 then Nothing else Just $ (b l1 - b l2) / (m l2 - m l1)
-
--- isVertical :: Line -> Bool
--- isVertical (Line {..}) = m > 2000.0
-
--- shoelace :: [Point] -> Double
--- shoelace pts = halve . sum $ zipWith (*) (zipWith (+) xs' xs) (zipWith (-) ys' ys)
---     where
---         showme =  zipWith (*) (zipWith (+) xs' xs) (zipWith (-) ys' ys)
---         xs = map snd pts
---         ys = map fst pts
---         ys' = tail . cycle $ xs
---         xs' = tail . cycle $ ys
---         halve b =  (fromIntegral b) / 2.0
-
--- shoelace' :: [Point] -> Double
--- shoelace' [(y1, x1), (y2, x2), (y3, x3)] =  abs $ (* 0.5) . fromIntegral $ x1*y2 + x2*y3 + x3*y1 - x2*y1 - x3*y2 - x1*y3
-
--- area :: Triangle -> Double
--- area (p1, p2, p3) = shoelace' [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 -> (Int, Int) -> (Int, Int)
--- getRandomPixel gen (rows, cols) =
---     ( getCoord gen  . pred $ rows
---     , getCoord gen' . pred $ cols)
---     where
---         getCoord :: StdGen -> Int -> Int
---         getCoord gen = fst . (flip randomR) gen . (0,)
-
---         gen' = snd . next $ gen
-
--- first3 :: [a] -> (a, a, a)
--- first3 (a : b : c : _) = (a, b, c)
-
--- colorComp :: Image_ -> (Int, Int) -> (Int, Int)
--- colorComp img p1 p2 = comp ( p1)
-
--- getP2 :: Image_ -> StdGen -> (Int, Int) -> Double -> (Int, Int)
--- getP2 image gen (x0, y0) r' = (x0 + x, y0 + y)
---     where
---         r = max 2.0 r'
---         phi = fst . randomR (0.0, pi * 2) $ gen
---         phi' = map (\x -> (x + phi) `mod'` (2 * pi)) [0, pi / 2, pi, 3 * pi / 2]
---         x = round $ r * cos phi
---         y = round $ r * sin phi
-
-
--- getRandomTriangle :: Image_ -> (Int, Int) -> Maybe Double -> StdGen -> Triangle
--- getRandomTriangle image dims area gen = (p1, p2, p3)
---     where
---         p1 : p2' : _ = map (\x -> getRandomPixel x dims) genList
-
---         p2 = case area of
---                Nothing -> p2'
---                Just a -> getP2 image gen1 p1 $ a * (fromIntegral $ (uncurry min) dims)
-
-
---         gen0 : gen1 : genList = tail . iterate (snd . next) $ gen
-
---         p3 = getThirdPoint p1 p2 gen0 (pi / 10.0)
-
--- angleIntersect :: (Point, Double) -> (Point, Double) -> Point
--- angleIntersect ((y1, x1), angle1) ((y2, x2), angle2) = (round y3, round x3)
---     where
---         m1 :: Double
---         m1 = tan angle1
---         m2 :: Double
---         m2 = tan angle2
-
---         x3 = (b1 - b2) / (m2 - m1)
---         y3 = (m1 * x3) + b1
---         y3' = (m2 * x3) + b2
-
---         b1 :: Double
---         b1 = (fromIntegral y1) - (m1 * (fromIntegral x1))
---         b2 :: Double
---         b2 = (fromIntegral y2) - (m2 * (fromIntegral x2))
-
--- getThirdPoint :: Point -> Point -> StdGen -> Double -> Point
--- getThirdPoint p1 p2 gen tolerance = angleIntersect (p1, p1From2 + p1Angle) (p2, p2From1 - p2Angle)
---     where
-
---         showMe = [p1Angle, p2Angle, p3Angle]
-
---         p2From1 :: Double
---         p2From1 = angle p2 p1
-
---         p1From2 :: Double
---         p1From2 = angle p1 p2
-
---         p3Angle :: Double
---         p3Angle = fst $ randomR (thirdpi - tolerance, thirdpi + tolerance) gen
-
---         thirdpi :: Double
---         thirdpi = pi / 3.0
-
---         p2Angle :: Double
---         p2Angle = fst $ randomR (thirdpi - tolerance, p2Max) (snd . next $ gen)
-
---         p2Max :: Double
---         p2Max = {-min (pi - p3Angle - (thirdpi - tolerance))-} (thirdpi + tolerance)
-
---         p1Angle :: Double
---         p1Angle = pi - p3Angle - p2Angle
-
--- angle :: Point -> Point -> Double
--- angle (y, x) (fromy, fromx) = atan2 y' x'
---     where
---         y' = fromIntegral $ y - fromy
---         x' = fromIntegral $ x - fromx
-
--- getPointsInTriangle :: Image_ -> S.Set (Point V2 Int) -> [Point V2 Int]
 getPointsInTriangle :: p -> S.Set (P2 Int) -> [(Int, Int)]
 getPointsInTriangle image pts = S.toList . S.unions . map S.fromList $ [
-                                (ptsBtween (makeLine p1 p3) (makeLine p1 p2)),
+                                 ptsBtween (makeLine p1 p3) (makeLine p1 p2),
-                                (ptsBtween (makeLine p1 p3) (makeLine p2 p3)),
+                                 ptsBtween (makeLine p1 p3) (makeLine p2 p3),
-                                (ptsBtween (makeLine p1 p2) (makeLine p2 p3))]
+                                 ptsBtween (makeLine p1 p2) (makeLine p2 p3)]
     where
         [p1, p2, p3] = sortOn fst . map (\(y, x) -> (x,y)) . map unp2 . S.toList $ pts
 
-        -- p1 = sortedPoints !! 0
-        -- p2 = sortedPoints !! 1
-        -- p3 = sortedPoints !! 2
-
 blendEqually colors = C.affineCombo (zip (repeat fraction) colors) $ C.black
     where
         fraction = 1.0 / (fromIntegral . length $ colors)