diff --git a/examples/luna-result.svg b/examples/luna-result.svg
index 18760df..400ec40 100644
--- a/examples/luna-result.svg
+++ b/examples/luna-result.svg
@@ -1,3 +1,3 @@
\ No newline at end of file
+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
\ No newline at end of file
diff --git a/examples/sierra-result.svg b/examples/sierra-result.svg
index 60e566b..0a6176b 100644
--- a/examples/sierra-result.svg
+++ b/examples/sierra-result.svg
@@ -1,3 +1,3 @@
\ No newline at end of file
+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
\ No newline at end of file
diff --git a/image-triangles.cabal b/image-triangles.cabal
index 4c4db88..b0e3527 100644
--- a/image-triangles.cabal
+++ b/image-triangles.cabal
@@ -86,6 +86,7 @@ executable image-triangles
, vector
, containers
, optparse-generic
+ , splitmix
-- Directories containing source files.
diff --git a/src/Main.hs b/src/Main.hs
index 4504a68..1e992ed 100644
--- a/src/Main.hs
+++ b/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
diff --git a/src/Render.hs b/src/Render.hs
index 3b057f2..c505785 100644
--- a/src/Render.hs
+++ b/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_
diff --git a/src/Triangles.hs b/src/Triangles.hs
index 52ea91f..d996b2c 100644
--- a/src/Triangles.hs
+++ b/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) .
- removeIntersections . take ((numPoints * numPoints) `div` 3) . sortOn (uncurry distanceA) . filter (uncurry (/=)) $ (,) <$> points <*> points
+toPlanarGraph 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 p2 p3)),
- (ptsBtween (makeLine p1 p2) (makeLine p2 p3))]
+ ptsBtween (makeLine p1 p3) (makeLine p1 p2),
+ ptsBtween (makeLine p1 p3) (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)