diff --git a/.gitignore b/.gitignore
index 90c56b9..8795412 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,4 @@
.stack-work/*
dist/*
-*.svg
/dist-newstyle/
+/cabal.project.local
diff --git a/README.md b/README.md
index cb93931..e774410 100644
--- a/README.md
+++ b/README.md
@@ -1,46 +1,16 @@
# image-triangles
### examples
-
-
-
-
+
+
+
+
-### to build:
+### to run:
-make sure you have nix installed
-```
-curl https://nixos.org/nix/install | sh
-```
+install [cabal & ghc](https://www.haskell.org/ghcup/) if you don't have them.
```
-nix-build
-
+cabal update
+# change input file name in Main.hs line 95-ish
+cabal run image-triangles -- -o output.svg --height 1000 --width 1000
```
-run with
-```
-./result/bin/image-triangles -o output.svg
-```
-
-### to develop on:
-```
-cabal --enable-nix build
-```
-or
-```
-echo "nix: True" >> ~/.cabal/config
-cabal build
-```
-
-#### run with
-```
-./dist/build/image-triangles/image-triangles -o output.svg
-```
-
-### todo
-- [x] Confirm diagrams is rendering triangles in the correct places.
-- [x] Cache transformations to the colors library
-- [x] Hip has a map transformation. It also depends on the colours library, does it use it?
-- [x] In addition, hip has interfaces to arrays that support operations like map
-- [x] Check that hip colors are srgb
-- [ ] Think about opacity. What if everything was completely opaque? What should we do with areas that aren’t 100% covered at the end?
-- [ ] The diagram needs a final bounding box that's the size of the picture that it comes from.
diff --git a/examples/luna-result.svg b/examples/luna-result.svg
new file mode 100644
index 0000000..18760df
--- /dev/null
+++ b/examples/luna-result.svg
@@ -0,0 +1,3 @@
+
+
\ No newline at end of file
diff --git a/examples/luna.jpeg b/examples/luna.jpeg
new file mode 100644
index 0000000..4eef899
Binary files /dev/null and b/examples/luna.jpeg differ
diff --git a/examples/sierra-result.svg b/examples/sierra-result.svg
new file mode 100644
index 0000000..60e566b
--- /dev/null
+++ b/examples/sierra-result.svg
@@ -0,0 +1,3 @@
+
+
\ No newline at end of file
diff --git a/sierra.jpg b/examples/sierra.jpg
similarity index 100%
rename from sierra.jpg
rename to examples/sierra.jpg
diff --git a/image-triangles.cabal b/image-triangles.cabal
index 9bd81a6..5c918d8 100644
--- a/image-triangles.cabal
+++ b/image-triangles.cabal
@@ -80,8 +80,9 @@ executable image-triangles
, diagrams-svg
, parallel
, repa
+ , linear
, vector
- , scotty
+ , containers
-- Directories containing source files.
@@ -89,8 +90,10 @@ executable image-triangles
-- Base language which the package is written in.
default-language: Haskell2010
- ghc-options: -threaded
- -rtsopts
--- -prof
+ ghc-options:
+ -- "-fprof-auto"
+ -threaded
+ "-with-rtsopts= -N"
+ -- -prof
-- -fexternal-interpreter
-- import Servant.Client
diff --git a/sierraResult.png b/sierraResult.png
deleted file mode 100644
index bf0d0af..0000000
Binary files a/sierraResult.png and /dev/null differ
diff --git a/src/Main.hs b/src/Main.hs
index c028741..b877139 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,6 +1,7 @@
module Main where
import qualified Triangles as Tri
+import GHC.Generics
import qualified Render as Ren
import Graphics.Image as Img hiding (map, zipWith)
import System.Random
@@ -15,20 +16,24 @@ import qualified Graphics.Image.Interface as Int
import qualified Data.Vector.Unboxed as Vec
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 Triangles (getTriangleAverageRGB)
+import qualified Data.Colour.SRGB as CL
data Options = Options {
- numTriangles :: Int,
+ numPoints :: Int,
gen :: Maybe StdGen
}
--- modify this to your liking
+-- -- modify this to your liking
defaultOpts = Options {
- numTriangles = 5000,
+ numPoints = 10,
gen = Nothing
}
genList :: StdGen -> [StdGen]
-genList = map snd . iterate (split . fst) . split
+genList = map snd . iterate (split . fst) . split
-- CL.rgb might be the wrong fn...
tosRGB' :: (Ord b, Floating b) => Pixel G.RGB b -> CL.Colour b
@@ -36,43 +41,58 @@ tosRGB' (G.PixelRGB r g b) = CL.rgb r g b
convImage = Vec.map tosRGB' . Int.toVector
--- progress goes from 0 to 1 the farther we get along the process
--- note, 0 represents the topmost triangle
-renderTri :: Vec.Vector (Colour Double) -> (Int, Int) -> StdGen -> Double -> QDiagram SVG V2 Double Any
-renderTri image dimensions gen progress = Ren.makeTriangle (Ren.toPointList dimensions triangle) color opacity'
- where
+-- -- progress goes from 0 to 1 the farther we get along the process
+-- -- note, 0 represents the topmost triangle
+-- renderTri :: Vec.Vector (Colour Double) -> (Int, Int) -> StdGen -> Double -> QDiagram SVG V2 Double Any
+-- renderTri image dimensions gen progress = Ren.makeTriangle (Ren.toPointList dimensions triangle) color opacity'
+-- where
- triangle = Tri.getRandomTriangle image dimensions (Just area) gen
-
- color = Tri.getTriangleAverageRGB image triangle dimensions
-
- -- the following should be considered triangle shaders
- -- modify them to your liking, their outputs are expected to be in [0, 1]
- -- TODO: move these into a separate module
- -- opacity' = 0.4
- opacity' = 0.3 + ((1 - progress) * 0.5)
-
- area = max ((progress ** 2) * 0.2) 0.02
+-- triangle = Tri.getRandomTriangle image dimensions (Just area) gen
+-- color = Tri.getTriangleAverageRGB image triangle dimensions
-genImage :: String -> IO (Diagram B)
+-- -- the following should be considered triangle shaders
+-- -- modify them to your liking, their outputs are expected to be in [0, 1]
+-- -- TODO: move these into a separate module
+-- -- opacity' = 0.4
+-- opacity' = 0.3 + ((1 - progress) * 0.5)
+
+-- area = max ((progress ** 2) * 0.2) 0.02
+
+corners :: [(Double, Double)]
+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 name = do
- let (Options {numTriangles = numTriangles, gen = gen'}) = defaultOpts
- gen'' <- case gen' of
- Nothing -> getStdGen
- Just a -> return a
+ 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)
- print gen''
- let progressList = withStrategy (parListChunk 500 rdeepseq) . map (/ (fromIntegral numTriangles)) $ [0.0 .. (fromIntegral numTriangles)]
- return $ center . reflectY . mconcat $ zipWith (renderTri img' dimensions) (genList gen'') progressList
+ 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
+
+ -- let progressList = withStrategy (parListChunk 500 rdeepseq) . map (/ (fromIntegral numTriangles)) $ [0.0 .. (fromIntegral numTriangles)]
+ -- return $ center . reflectY . mconcat $ zipWith (renderTri img' dimensions) (genList gen'') progressList
+
+
+
main :: IO ()
main = do
gen <- getStdGen
- let diagram = mconcat . map Ren.toLine . Tri.toPlanarGraph . take 40 $ [(0,0), (3000,0), (0, 3000), (3000, 3000)] ++ Tri.randomPoints (3000, 3000) gen
+ -- 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
diff --git a/src/Render.hs b/src/Render.hs
index cd58589..3b057f2 100644
--- a/src/Render.hs
+++ b/src/Render.hs
@@ -6,14 +6,17 @@ import Diagrams.TrailLike
import qualified Triangles as Tri
import Diagrams.Prelude
import Diagrams.Backend.SVG.CmdLine
+import qualified Data.Set as S
+import qualified Data.Colour.Names as CN
makeTriangle :: [Point V2 Double] -> Colour Double -> Double -> Diagram SVG
makeTriangle verts col opacity_ = fromVertices verts
# mapLoc closeLine
# strokeLocLoop
+ # lc col
# fc col
- # lw 0
+ # lw 0.5
# opacity opacity_
@@ -24,14 +27,15 @@ tupleFromIntegral (cols, rows) (a, b) = (fromIntegral b, fromIntegral a)
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]
+-- 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))
+-- 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
diff --git a/src/Triangles.hs b/src/Triangles.hs
index 17cdefe..6be4e89 100644
--- a/src/Triangles.hs
+++ b/src/Triangles.hs
@@ -20,11 +20,17 @@ import Data.List
import Data.Maybe
import qualified Data.Vector.Unboxed as Vec
import Data.Fixed
-import Data.Vector.Unboxed.Deriving
+import Data.Vector.Unboxed.Deriving
+import Diagrams.TwoD
+import Diagrams.Prelude
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Control.Arrow
+-- import qualified Linear.Affine as L
type Image_ = Vec.Vector Pixel_
type Pixel_ = Colour Double
-type Point = (Int, Int)
-type Triangle = (Point, Point, Point)
+-- type Point = (Double, Double)
+-- type Triangle = (Point, Point, Point)
toSRGBTuple :: Pixel_ -> (Double, Double, Double)
toSRGBTuple = srgb' . C.toRGB
@@ -40,173 +46,209 @@ derivingUnbox "Pixel_"
[| fromSRGBTuple |]
-randomPoints :: (Int, Int) -> StdGen -> [(Int, Int)]
-randomPoints (height, width) = randomRs ((0,0), (height, width))
+randomPoints :: StdGen -> [(Double, Double)]
+randomPoints = randomRs ((0,0), (1, 1))
-toPlanarGraph :: [Point] -> [Line]
-toPlanarGraph points = makePlanar . map (uncurry makeLine) . sortOn (uncurry distance)
- $ concatMap (\x -> map (,x) points) points
+-- 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)]
+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
where
- makePlanar :: [Line] -> [Line]
- makePlanar = foldl addIfPlanar []
- addIfPlanar lines candidate = if any (intersects candidate) lines then lines else candidate : lines
+ removeIntersections = foldl' addIfNoIntersection []
-distance :: Point -> Point -> Double
-distance (x0, y0) (x1, y1) = sqrt $ (fromIntegral (x0 - x1) ** 2) + (fromIntegral (y0 - y1) ** 2)
+ addIfNoIntersection xs x = if all (noIntersection x) xs then (x:xs) else xs
-sharesCoords :: Triangle -> Bool
-sharesCoords ((x1, y1), (x2, y2), (x3, y3)) = ((/= 3) . length . nub $ [x1, x2, x3])
- || ((/= 3) . length . nub $ [y1, y2, y3])
+ noIntersection l1 l2 = (==) sharedEndPoint . length $ intersectPointsT (uncurry toLocatedTrail l1) (uncurry toLocatedTrail l2)
+ where
+ sharedEndPoint = (-) 4 . length . nub $ [fst l1, snd l1, fst l2, snd l2]
-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
+toLocatedTrail :: TrailLike a => Point (V a) (N a) -> Point (V a) (N a) -> Located a
+toLocatedTrail p1 p2 = fromVertices [p1, p2] `at` p1
+
+
+findTriangles :: Ord b => [(b, b)] -> S.Set (S.Set b)
+findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap
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
+ 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)
-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
+ adjacencyMap = M.fromListWith S.union . map (second S.singleton) $ (edges ++ edgesReversed)
+ edgesReversed = map (\(a, b) -> (b, a)) edges
-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
+pointsInTriangle tri = []
+ where
+ [fst, snd, thrd] = S.toList tri
-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,)
+ -- makePlanar :: [Line] -> [Line]
+ -- makePlanar = foldl addIfPlanar []
- gen' = snd . next $ gen
+ -- addIfPlanar lines candidate = if any (intersects candidate) lines then lines else candidate : lines
-first3 :: [a] -> (a, a, a)
-first3 (a : b : c : _) = (a, b, c)
+-- 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
+-- 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)
+-- 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))]
where
- p1 : p2' : _ = map (\x -> getRandomPixel x dims) genList
+ [p1, p2, p3] = sortOn fst . map (\(y, x) -> (x,y)) . map unp2 . S.toList $ pts
- p2 = case area of
- Nothing -> p2'
- Just a -> getP2 image gen1 p1 $ a * (fromIntegral $ (uncurry min) dims)
+ -- p1 = sortedPoints !! 0
+ -- p2 = sortedPoints !! 1
+ -- p3 = sortedPoints !! 2
-
- 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_ -> Triangle -> [Point]
-getPointsInTriangle image (p1', p2', p3') = (ptsBtween (makeLineUnsafe p1 p3) (makeLineUnsafe p1 p2)) ++
- (ptsBtween (makeLineUnsafe p1 p3) (makeLineUnsafe p2 p3))
- where
- sortedPoints = sortOn snd [p1', p2', p3']
-
- p1 = sortedPoints !! 0
- p2 = sortedPoints !! 1
- p3 = sortedPoints !! 2
-
-blendEqually colors = C.affineCombo (zip (repeat fraction) colors) $ C.black
+blendEqually colors = C.affineCombo (zip (repeat fraction) colors) $ C.black
where
fraction = 1.0 / (fromIntegral . length $ colors)
-getTriangleAverageRGB :: Image_ -> Triangle -> (Int, Int) -> C.Colour Double
-getTriangleAverageRGB image triangle (y', x') = blendEqually $ pixels
+getTriangleAverageRGB :: Image_ -> (Int, Int)-> S.Set (P2 Int) -> C.Colour Double
+getTriangleAverageRGB image (y', x') triangle = blendEqually pixels
where
pixels :: [Pixel_]
pixels = catMaybes . map index' $ points
- points :: [Point]
+ points :: [(Int, Int)]
points = getPointsInTriangle image triangle
-
+
-- I got so upset that I put this function in here instead of in general scope that I went to bed for the night.
index' :: (Int, Int) -> Maybe Pixel_
index' (y, x)
@@ -216,7 +258,7 @@ getTriangleAverageRGB image triangle (y', x') = blendEqually $ pixels
| x < 0 = Nothing
| otherwise = image Vec.!? ((y * x') + x)
-ptsBtween :: Line -> Line -> [Point]
+ptsBtween :: LineMXB -> LineMXB -> [(Int, Int)]
ptsBtween l1 l2 = concatMap rasterLine . noSingletons $ [startingX .. endingX]
where
startingX = max (startX l1) (startX l2)
@@ -227,28 +269,18 @@ ptsBtween l1 l2 = concatMap rasterLine . noSingletons $ [startingX .. endingX]
noSingletons :: [a] -> [a]
noSingletons [x] = []
noSingletons l = l
-
+
range' :: Int -> Int -> [Int]
range' a b = [(min a b) .. (max a b)]
-yAt :: Line -> Int -> Int
-yAt (Line {m = m, b = b}) x = round $ (m * (fromIntegral x)) + b
+yAt :: LineMXB -> Int -> Int
+yAt (LineMXB {m = m, b = b}) x = round $ (m * (fromIntegral x)) + b
--- y = mx + b
--- y - mx = b
+-- -- y = mx + b
+-- -- y - mx = b
-makeLineUnsafe :: Point -> Point -> Line
-makeLineUnsafe (y1, x1) (y2, x2) = Line {
- m = slope,
- b = (fromIntegral y1) - (slope * (fromIntegral x1)),
- startX = x1,
- endX = x2
- }
- where
- slope = (fromIntegral $ y1 - y2) / (fromIntegral $ x1 - x2)
-
-makeLine :: Point -> Point -> Line
-makeLine (y1, x1) (y2, x2) = Line {
+makeLine :: (Int, Int) -> (Int, Int) -> LineMXB
+makeLine (y1, x1) (y2, x2) = LineMXB {
m = slope,
b = (fromIntegral y1) - (slope * (fromIntegral x1)),
startX = min x1 x2,
@@ -259,7 +291,7 @@ makeLine (y1, x1) (y2, x2) = Line {
then (fromIntegral $ y1 - y2) % (fromIntegral $ x1 - x2)
else fromIntegral . ceiling $ ((10.0 :: Double) ** 100.0)
-data Line = Line
+data LineMXB = LineMXB
{
m :: Rational,
b :: Rational,
@@ -267,15 +299,15 @@ data Line = Line
endX :: Int
} deriving (Show, Ord, Eq)
-isPointInTriangle :: Triangle -> Point -> Bool
-isPointInTriangle (v1, v2, v3) pt = not (has_neg && has_pos)
- where
- d1 = sign pt v1 v2
- d2 = sign pt v2 v3
- d3 = sign pt v3 v1
+-- isPointInTriangle :: Triangle -> Point -> Bool
+-- isPointInTriangle (v1, v2, v3) pt = not (has_neg && has_pos)
+-- where
+-- d1 = sign pt v1 v2
+-- d2 = sign pt v2 v3
+-- d3 = sign pt v3 v1
- has_neg = (d1 < 0) || (d2 < 0) || (d3 < 0)
- has_pos = (d1 > 0) || (d2 > 0) || (d3 > 0)
+-- has_neg = (d1 < 0) || (d2 < 0) || (d3 < 0)
+-- has_pos = (d1 > 0) || (d2 > 0) || (d3 > 0)
- sign :: Point -> Point -> Point -> Int
- sign p1 p2 p3 = (fst p1 - fst p3) * (snd p2 - snd p3) - (fst p2 - fst p3) * (snd p1 - snd p3)
+-- sign :: Point -> Point -> Point -> Int
+-- sign p1 p2 p3 = (fst p1 - fst p3) * (snd p2 - snd p3) - (fst p2 - fst p3) * (snd p1 - snd p3)