Jack/image-triangles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

formatting

Browse source
This commit is contained in:
Jack Wines 2024-02-12 14:08:08 -08:00
parent 2c2ad42325
commit 125762ea59
No known key found for this signature in database
GPG key ID: 25B20640600571E6
3 changed files with 197 additions and 199 deletions
Download patch file Download diff file Expand all files Collapse all files

115
src/Main.hs
View file

@ -3,7 +3,9 @@ module Main where
import Control.Arrow import Control.Arrow
import qualified Control.Monad as M import qualified Control.Monad as M
import qualified Control.Monad.Parallel as MP import qualified Control.Monad.Parallel as MP
import Control.Monad.Zip (MonadZip (mzipWith))
import Control.Parallel.Strategies import Control.Parallel.Strategies
import qualified Data.Bifunctor as Bi
import qualified Data.Colour as C import qualified Data.Colour as C
import qualified Data.Colour.Names as CN import qualified Data.Colour.Names as CN
import Data.Colour.RGBSpace (uncurryRGB) import Data.Colour.RGBSpace (uncurryRGB)
@ -15,6 +17,7 @@ import qualified Data.Maybe as My
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Vector.Unboxed as Vec import qualified Data.Vector.Unboxed as Vec
import Debug.Trace import Debug.Trace
import qualified Debug.Trace as D
import qualified Debug.Trace as DT import qualified Debug.Trace as DT
import qualified Debug.Trace as T import qualified Debug.Trace as T
import qualified Diagrams as DP import qualified Diagrams as DP
@ -26,6 +29,7 @@ import GHC.Generics
import Graphics.Image as Img hiding (map, zipWith) import Graphics.Image as Img hiding (map, zipWith)
import qualified Graphics.Image.ColorSpace as G import qualified Graphics.Image.ColorSpace as G
import qualified Graphics.Image.Interface as Int import qualified Graphics.Image.Interface as Int
import qualified MinDistanceSample as MDS
import Options.Generic import Options.Generic
import qualified System.Environment as Env import qualified System.Environment as Env
import System.Random import System.Random
@ -33,10 +37,6 @@ import System.Random.Internal
import System.Random.SplitMix import System.Random.SplitMix
import Triangles (getTriangleAverageRGB) import Triangles (getTriangleAverageRGB)
import qualified Triangles as Tri import qualified Triangles as Tri
import qualified MinDistanceSample as MDS
import Control.Monad.Zip (MonadZip(mzipWith))
import qualified Data.Bifunctor as Bi
import qualified Debug.Trace as D
-- CL.rgb might be the wrong fn... -- CL.rgb might be the wrong fn...
tosRGB' :: (Ord b, Floating b) => Pixel G.RGB b -> CL.Colour b tosRGB' :: (Ord b, Floating b) => Pixel G.RGB b -> CL.Colour b
@ -50,78 +50,77 @@ corners = (,) <$> [0, 1] <*> [0, 1]
shapeCircumference :: [Point V2 Double] -> Double shapeCircumference :: [Point V2 Double] -> Double
shapeCircumference = Data.List.sum . map D.norm . loopOffsets . fromVertices shapeCircumference = Data.List.sum . map D.norm . loopOffsets . fromVertices
genImage :: Image VU G.RGB Double -> Double -> StdGen -> QDiagram SVG V2 Double Any genImage :: Image VU G.RGB Double -> Double -> StdGen -> QDiagram SVG V2 Double Any
genImage image minDistance gen = genImage image minDistance gen =
scaleX widthHeightRatio scaleX widthHeightRatio
. reflectY . reflectY
. rectEnvelope (mkP2 0 0) (1 ^& 1) . rectEnvelope (mkP2 0 0) (1 ^& 1)
. mconcat . mconcat
. map drawVoroniRegion . map drawVoroniRegion
. sortOn shapeCircumference . sortOn shapeCircumference
. withStrategy (parListChunk 50 rdeepseq) . withStrategy (parListChunk 50 rdeepseq)
. map (uncurry Tri.voroniDiagramCorners) . map (uncurry Tri.voroniDiagramCorners)
$ voroni $ voroni
where where
drawVoroniRegion shape = drawVoroniRegion shape =
lw 0 lw 0
. fillColor (Tri.voroniRegionAverageColor img' dimensions shape) . fillColor (Tri.voroniRegionAverageColor img' dimensions shape)
. strokeLocLoop . strokeLocLoop
. fromVertices . fromVertices
$ shape $ shape
widthHeightRatio :: Double widthHeightRatio :: Double
widthHeightRatio = (fromIntegral . fst $ dimensions) / (fromIntegral . snd $ dimensions) widthHeightRatio = (fromIntegral . fst $ dimensions) / (fromIntegral . snd $ dimensions)
img' = convImage image img' = convImage image
dimensions = uncurry (flip (,)) . Img.dims $ image dimensions = uncurry (flip (,)) . Img.dims $ image
dimensionsVec = fromIntegral <$> uncurry V2 dimensions dimensionsVec = fromIntegral <$> uncurry V2 dimensions
singleVoroni = last voroni singleVoroni = last voroni
visualizeGraph :: QDiagram SVG V2 Double Any visualizeGraph :: QDiagram SVG V2 Double Any
visualizeGraph = visualizeGraph =
lc red lc red
. lw 1 . lw 1
. position . position
. map (\(x0, x1) -> (x0,) . strokeLine $ (x0 ~~ x1)) . map (\(x0, x1) -> (x0,) . strokeLine $ (x0 ~~ x1))
. Tri.toPlanarGraph . Tri.toPlanarGraph
$ corners' $ corners'
voroni = voroni =
Tri.findVoroniDiagram Tri.findVoroniDiagram
. Tri.toPlanarGraph . Tri.toPlanarGraph
$ corners' $ corners'
averageSideSize = (fromIntegral (uncurry (+) dimensions)) / 2
averageSideSize = (fromIntegral (uncurry (+) dimensions)) / 2 padding = (/) 10 . (*) widthHeightRatio <$> V2 1 1
padding = (/) 10 . (*) widthHeightRatio <$> V2 1 1 corners' :: [P2 Double]
corners' = map (p2 . Bi.first (/ widthHeightRatio) . unp2 . (.-^ ((/ 2) <$> padding))) . MDS.randomPoints ((mkP2 widthHeightRatio 1) .+^ padding) (minDistance * widthHeightRatio) $ gen
corners' :: [P2 Double]
corners' = map (p2 . Bi.first (/ widthHeightRatio) . unp2 . (.-^ ((/ 2) <$> padding))) . MDS.randomPoints ((mkP2 widthHeightRatio 1) .+^ padding) ( minDistance * widthHeightRatio) $ gen
deriving instance Generic (CL.RGB a) deriving instance Generic (CL.RGB a)
deriving instance NFData a => NFData (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 :: (Int.BaseArray arr cs e, Fractional n) => Image arr cs e -> SizeSpec V2 n
toDimensionVector image = toDimensionVector image =
Diagrams.Prelude.dims $ Diagrams.Prelude.dims $
p2 (fromIntegral $ cols image, fromIntegral $ rows image) .-. p2 (0.0, 0.0) p2 (fromIntegral $ cols image, fromIntegral $ rows image) .-. p2 (0.0, 0.0)
data CLIOptions = CLIOptions data CLIOptions = CLIOptions
{ input :: FilePath { input :: FilePath
, output :: FilePath , output :: FilePath
, minDistance :: Double , minDistance :: Double
} }
deriving (Generic) deriving (Generic)
instance ParseRecord CLIOptions instance ParseRecord CLIOptions
main :: IO () main :: IO ()
main = do main = do
CLIOptions{..} <- getRecord "image options" CLIOptions{..} <- getRecord "image options"
gen' <- getStdGen -- for consistency, swap with something like: pure . mkStdGen $ 2344 gen' <- getStdGen -- for consistency, swap with something like: pure . mkStdGen $ 2344
print gen' print gen'
image <- Img.readImageRGB VU input image <- Img.readImageRGB VU input
let dimVector = toDimensionVector image let dimVector = toDimensionVector image
renderSVG output dimVector (genImage image minDistance gen') renderSVG output dimVector (genImage image minDistance gen')

12
src/MinDistanceSample.hs
View file

@ -3,14 +3,14 @@ module MinDistanceSample where
import qualified Control.Monad as M import qualified Control.Monad as M
import qualified Data.Array as A import qualified Data.Array as A
import qualified Data.Bifunctor as B import qualified Data.Bifunctor as B
import qualified Data.Ix as Ix
import qualified Data.List as L import qualified Data.List as L
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as M
import qualified Data.Maybe as My import qualified Data.Maybe as My
import qualified Debug.Trace as D import qualified Debug.Trace as D
import Diagrams.Prelude import Diagrams.Prelude
import System.Random.Stateful import System.Random.Stateful
import qualified Data.Map.Strict as M
import qualified Data.Ix as Ix
k :: Int k :: Int
k = 10 k = 10
@ -68,6 +68,8 @@ randomPoints dims minDistance gen' = runStateGen_ gen' randomPointsM
isValidPoint :: Point V2 Double -> Bool isValidPoint :: Point V2 Double -> Bool
isValidPoint p = isValidPoint p =
(Ix.inRange gridBounds (floor <$> p)) && (all ((>= 1) . abs . norm . (p .-.)) (Ix.inRange gridBounds (floor <$> p))
. My.mapMaybe ((grid M.!?) . fmap floor . (p .-^)) && ( all ((>= 1) . abs . norm . (p .-.))
$ unitVectorsAround) . My.mapMaybe ((grid M.!?) . fmap floor . (p .-^))
$ unitVectorsAround
)

269
src/Triangles.hs
View file

@ -34,193 +34,190 @@ type Pixel_ = Colour Double
toSRGBTuple :: Pixel_ -> (Double, Double, Double) toSRGBTuple :: Pixel_ -> (Double, Double, Double)
toSRGBTuple = srgb' . C.toRGB toSRGBTuple = srgb' . C.toRGB
where where
srgb' (C.RGB{C.channelRed = red, C.channelGreen = green, C.channelBlue = blue}) = (red, green, blue) srgb' (C.RGB{C.channelRed = red, C.channelGreen = green, C.channelBlue = blue}) = (red, green, blue)
fromSRGBTuple :: (Double, Double, Double) -> Pixel_ fromSRGBTuple :: (Double, Double, Double) -> Pixel_
fromSRGBTuple (r, g, b) = C.rgb r g b fromSRGBTuple (r, g, b) = C.rgb r g b
derivingUnbox derivingUnbox
"Pixel_" "Pixel_"
[t|Pixel_ -> (Double, Double, Double)|] [t|Pixel_ -> (Double, Double, Double)|]
[|toSRGBTuple|] [|toSRGBTuple|]
[|fromSRGBTuple|] [|fromSRGBTuple|]
-- from -0.05 to 1.05 so there aren't missing/elongated triangles at the edges -- from -0.05 to 1.05 so there aren't missing/elongated triangles at the edges
borderSize = 0.05 borderSize = 0.05
randomPoints :: StdGen -> [(Double, Double)] randomPoints :: StdGen -> [(Double, Double)]
randomPoints = map (bimap toZeroToOneTuple toZeroToOneTuple) . randomRs ((0 :: Word, 0 :: Word), (maxBound, maxBound)) randomPoints = map (bimap toZeroToOneTuple toZeroToOneTuple) . randomRs ((0 :: Word, 0 :: Word), (maxBound, maxBound))
where where
toZeroToOneTuple :: Word -> Double toZeroToOneTuple :: Word -> Double
toZeroToOneTuple x = ((fromIntegral x / (fromIntegral (maxBound :: Word))) * (1 + (2 * borderSize))) - borderSize toZeroToOneTuple x = ((fromIntegral x / (fromIntegral (maxBound :: Word))) * (1 + (2 * borderSize))) - borderSize
combinations :: (Ord b, Floating b, NFData b) => [P2 b] -> [(P2 b, P2 b)] combinations :: (Ord b, Floating b, NFData b) => [P2 b] -> [(P2 b, P2 b)]
combinations xs = combinations xs =
sortOn (abs . uncurry distanceA) sortOn (abs . uncurry distanceA)
. S.toList -- deduplicate . S.toList -- deduplicate
. S.fromList . S.fromList
. filter (uncurry (/=)) . filter (uncurry (/=))
. concat . concat
. withStrategy (parListChunk 50 rdeepseq) . withStrategy (parListChunk 50 rdeepseq)
. map (\(x : xs) -> take 10 . sortOn (abs . uncurry distanceA) . map (x,) $ xs) . map (\(x : xs) -> take 10 . sortOn (abs . uncurry distanceA) . map (x,) $ xs)
. init -- last output of tails is empty list . init -- last output of tails is empty list
. tails . tails
$ xs $ xs
where where
xsLen = length xs
xsLen = length xs
toPlanarGraph :: forall n. (NFData n, Floating n, Ord n) => [P2 n] -> [(Point V2 n, Point V2 n)] toPlanarGraph :: forall n. (NFData n, Floating n, Ord n) => [P2 n] -> [(Point V2 n, Point V2 n)]
toPlanarGraph points = toPlanarGraph points =
removeIntersections removeIntersections
. sortOn (abs . uncurry distanceA) . sortOn (abs . uncurry distanceA)
. combinations . combinations
$ points $ points
where where
numPoints = length points numPoints = length points
removeIntersections :: [(Point V2 n, Point V2 n)] -> [(Point V2 n, Point V2 n)] removeIntersections :: [(Point V2 n, Point V2 n)] -> [(Point V2 n, Point V2 n)]
removeIntersections = foldl' addIfNoIntersection [] removeIntersections = foldl' addIfNoIntersection []
addIfNoIntersection xs x addIfNoIntersection xs x
| all (noIntersection x) xs = x : xs | all (noIntersection x) xs = x : xs
| otherwise = xs | otherwise = xs
noIntersection l1 l2 = sharedEndPoint || (null $ intersectPointsT (uncurry toLocatedTrail l1) (uncurry toLocatedTrail l2)) noIntersection l1 l2 = sharedEndPoint || (null $ intersectPointsT (uncurry toLocatedTrail l1) (uncurry toLocatedTrail l2))
where where
sharedEndPoint = (< 4) . length . nub $ [fst l1, snd l1, fst l2, snd l2] sharedEndPoint = (< 4) . length . nub $ [fst l1, snd l1, fst l2, snd l2]
toLocatedTrail :: TrailLike a => Point (V a) (N a) -> Point (V a) (N a) -> Located a toLocatedTrail :: TrailLike a => Point (V a) (N a) -> Point (V a) (N a) -> Located a
toLocatedTrail p1 p2 = fromVertices [p1, p2] `at` p1 toLocatedTrail p1 p2 = fromVertices [p1, p2] `at` p1
withinShape :: RealFloat v => Point V2 v -> [Point V2 v] -> Point V2 v -> Bool withinShape :: RealFloat v => Point V2 v -> [Point V2 v] -> Point V2 v -> Bool
withinShape pointInShape verticies candidate = all ((< quarterTurn) . fmap abs . uncurry signedAngleBetweenDirs) $ zip (shapeDirections pointInShape) (shapeDirections candidate) withinShape pointInShape verticies candidate = all ((< quarterTurn) . fmap abs . uncurry signedAngleBetweenDirs) $ zip (shapeDirections pointInShape) (shapeDirections candidate)
where where
shapeDirections p = map (dirBetween p) verticies shapeDirections p = map (dirBetween p) verticies
sortOnAngle center = sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween center) sortOnAngle center = sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween center)
voroniDiagramCorners :: RealFloat n => Point V2 n -> [Point V2 n] -> [Point V2 n] voroniDiagramCorners :: RealFloat n => Point V2 n -> [Point V2 n] -> [Point V2 n]
voroniDiagramCorners center midpoints = voroniDiagramCorners center midpoints =
sortOnAngle center sortOnAngle center
. filter isValidMidpoint . filter isValidMidpoint
. concat . concat
$ [intersectPointsT l0 l1 | l0 <- tangentTrails, l1 <- tangentTrails] $ [intersectPointsT l0 l1 | l0 <- tangentTrails, l1 <- tangentTrails]
where where
lessThanQuarterTurn candidate = candidate <= (10001 / 40000) @@ turn || candidate >= (29999 / 40000) @@ turn lessThanQuarterTurn candidate = candidate <= (10001 / 40000) @@ turn || candidate >= (29999 / 40000) @@ turn
tangentTrails = map tangentTrail midpoints tangentTrails = map tangentTrail midpoints
appendHead (x : xs) = xs ++ [x] appendHead (x : xs) = xs ++ [x]
isValidMidpoint candidate = all isNonObtuseMidpoint . filter (/= candidate) $ midpoints isValidMidpoint candidate = all isNonObtuseMidpoint . filter (/= candidate) $ midpoints
where where
isNonObtuseMidpoint m = isNonObtuseMidpoint m =
lessThanQuarterTurn . normalizeAngle $ angleBetweenDirs (dirBetween m center) (dirBetween m candidate) lessThanQuarterTurn . normalizeAngle $ angleBetweenDirs (dirBetween m center) (dirBetween m candidate)
tangentTrail midpoint = fromVertices [midpoint .-^ tangentVec, midpoint .+^ tangentVec] tangentTrail midpoint = fromVertices [midpoint .-^ tangentVec, midpoint .+^ tangentVec]
where where
-- implicitly uses the unit vector * 8 as an infinitely long vector -- implicitly uses the unit vector * 8 as an infinitely long vector
tangentVec = tangentVec =
scale 2 scale 2
. fromDirection . fromDirection
. rotateBy (1 / 4) . rotateBy (1 / 4)
$ dirBetween midpoint center $ dirBetween midpoint center
findVoroniDiagram :: RealFloat n => [(Point V2 n, Point V2 n)] -> [(Point V2 n, [Point V2 n])] findVoroniDiagram :: RealFloat n => [(Point V2 n, Point V2 n)] -> [(Point V2 n, [Point V2 n])]
findVoroniDiagram edges = findVoroniDiagram edges =
M.toList M.toList
. M.mapWithKey . M.mapWithKey
( \key -> ( \key ->
L.sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween key) L.sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween key)
. map (pointBetween key) . map (pointBetween key)
. S.toList . S.toList
) )
$ adjacencyMap $ adjacencyMap
where where
adjacencyMap = adjacencyMapOf edges adjacencyMap = adjacencyMapOf edges
pointBetween p0 p1 = p0 .+^ ((p1 .-. p0) ^/ 2) pointBetween p0 p1 = p0 .+^ ((p1 .-. p0) ^/ 2)
findTriangles :: Ord b => [(b, b)] -> S.Set (S.Set b) findTriangles :: Ord b => [(b, b)] -> S.Set (S.Set b)
findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap
where where
threeCyclesOf node = threeCyclesOf node =
S.unions S.unions
. S.map (\x -> S.map (\y -> S.fromList [node, x, y]) $ S.delete node . S.intersection originalNodeNeighbors . (M.!) adjacencyMap $ x) . S.map (\x -> S.map (\y -> S.fromList [node, x, y]) $ S.delete node . S.intersection originalNodeNeighbors . (M.!) adjacencyMap $ x)
$ originalNodeNeighbors $ originalNodeNeighbors
where where
originalNodeNeighbors = fromMaybe S.empty (adjacencyMap M.!? node) originalNodeNeighbors = fromMaybe S.empty (adjacencyMap M.!? node)
adjacencyMap = adjacencyMapOf edges adjacencyMap = adjacencyMapOf edges
adjacencyMapOf edges = M.fromListWith S.union . map (second S.singleton) $ (edges ++ edgesReversed) adjacencyMapOf edges = M.fromListWith S.union . map (second S.singleton) $ (edges ++ edgesReversed)
where where
edgesReversed = map (\(a, b) -> (b, a)) edges edgesReversed = map (\(a, b) -> (b, a)) edges
triangleAdjacencyMap :: Ord b => S.Set (S.Set b) -> M.Map b (S.Set (S.Set b)) triangleAdjacencyMap :: Ord b => S.Set (S.Set b) -> M.Map b (S.Set (S.Set b))
triangleAdjacencyMap s = M.fromListWith S.union . concatMap (\s' -> map (,S.singleton s') . S.toList $ s') $ S.toList s triangleAdjacencyMap s = M.fromListWith S.union . concatMap (\s' -> map (,S.singleton s') . S.toList $ s') $ S.toList s
getPointsInTriangle :: p -> S.Set (P2 Int) -> [(Int, Int)] getPointsInTriangle :: p -> S.Set (P2 Int) -> [(Int, Int)]
getPointsInTriangle image pts = getPointsInTriangle image pts =
S.toList . S.unions . map S.fromList $ 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 where
[p1, p2, p3] = sortOn fst . map unp2 . S.toList $ pts [p1, p2, p3] = sortOn fst . map unp2 . S.toList $ pts
blendEqually colors = C.affineCombo (zip (repeat fraction) colors) $ C.blue blendEqually colors = C.affineCombo (zip (repeat fraction) colors) $ C.blue
where where
fraction = 1.0 / (fromIntegral . length $ colors) fraction = 1.0 / (fromIntegral . length $ colors)
voroniRegionAverageColor image (x', y') verticies = voroniRegionAverageColor image (x', y') verticies =
blendEqually blendEqually
. concatMap (getColorsInTriangle image (x', y')) . concatMap (getColorsInTriangle image (x', y'))
. filter ((== 3) . S.size) . filter ((== 3) . S.size)
. map (S.fromList . take 3) . map (S.fromList . take 3)
. tails . tails
. L.nub . L.nub
. map scaleToImageCoords . map scaleToImageCoords
$ verticies $ verticies
where where
scaleToImageCoords :: P2 Double -> P2 Int scaleToImageCoords :: P2 Double -> P2 Int
scaleToImageCoords p = fmap round $ p2 ((fromIntegral x' * p ^. _x), fromIntegral y' * p ^. _y) scaleToImageCoords p = fmap round $ p2 ((fromIntegral x' * p ^. _x), fromIntegral y' * p ^. _y)
scaleToUnitCoords :: P2 Int -> P2 Double scaleToUnitCoords :: P2 Int -> P2 Double
scaleToUnitCoords p = p2 ((fromIntegral x' / (fromIntegral $ p ^. _x)), fromIntegral y' / (fromIntegral $ p ^. _y)) scaleToUnitCoords p = p2 ((fromIntegral x' / (fromIntegral $ p ^. _x)), fromIntegral y' / (fromIntegral $ p ^. _y))
getColorsInTriangle :: Image_ -> (Int, Int) -> S.Set (P2 Int) -> [C.Colour Double] getColorsInTriangle :: Image_ -> (Int, Int) -> S.Set (P2 Int) -> [C.Colour Double]
getColorsInTriangle image (x', y') triangle = pixels getColorsInTriangle image (x', y') triangle = pixels
where where
pixels :: [Pixel_] pixels :: [Pixel_]
pixels = mapMaybe index' points pixels = mapMaybe index' points
points :: [(Int, Int)] points :: [(Int, Int)]
points = getPointsInTriangle image triangle points = getPointsInTriangle image triangle
index' :: (Int, Int) -> Maybe Pixel_ index' :: (Int, Int) -> Maybe Pixel_
index' (x, y) index' (x, y)
| y >= y' = Nothing | y >= y' = Nothing
| x >= x' = Nothing | x >= x' = Nothing
| y < 0 = Nothing | y < 0 = Nothing
| x < 0 = Nothing | x < 0 = Nothing
| otherwise = image Vec.!? ((y * x') + x) | otherwise = image Vec.!? ((y * x') + x)
getTriangleAverageRGB :: Image_ -> (Int, Int) -> S.Set (P2 Int) -> C.Colour Double getTriangleAverageRGB :: Image_ -> (Int, Int) -> S.Set (P2 Int) -> C.Colour Double
getTriangleAverageRGB image (x', y') triangle = blendEqually $ getColorsInTriangle image (x', y') triangle getTriangleAverageRGB image (x', y') triangle = blendEqually $ getColorsInTriangle image (x', y') triangle
ptsBtween :: LineMXB -> LineMXB -> [(Int, Int)] ptsBtween :: LineMXB -> LineMXB -> [(Int, Int)]
ptsBtween l1 l2 = concatMap rasterLine . noSingletons $ [startingX .. endingX] ptsBtween l1 l2 = concatMap rasterLine . noSingletons $ [startingX .. endingX]
where where
startingX = max (startX l1) (startX l2) startingX = max (startX l1) (startX l2)
endingX = min (endX l1) (endX l2) endingX = min (endX l1) (endX l2)
rasterLine x = map (x,) $ range' (yAt l1 x) (yAt l2 x) rasterLine x = map (x,) $ range' (yAt l1 x) (yAt l2 x)
noSingletons :: [a] -> [a] noSingletons :: [a] -> [a]
noSingletons [x] = [] noSingletons [x] = []
@ -234,22 +231,22 @@ yAt (LineMXB{m = m, b = b}) x = round $ (m * (fromIntegral x)) + b
makeLine :: (Int, Int) -> (Int, Int) -> LineMXB makeLine :: (Int, Int) -> (Int, Int) -> LineMXB
makeLine (x1, y1) (x2, y2) = makeLine (x1, y1) (x2, y2) =
LineMXB LineMXB
{ m = slope { m = slope
, b = (fromIntegral y1) - (slope * (fromIntegral x1)) , b = (fromIntegral y1) - (slope * (fromIntegral x1))
, startX = min x1 x2 , startX = min x1 x2
, endX = max x1 x2 , endX = max x1 x2
} }
where where
slope = slope =
if x1 /= x2 if x1 /= x2
then (fromIntegral $ y1 - y2) % (fromIntegral $ x1 - x2) then (fromIntegral $ y1 - y2) % (fromIntegral $ x1 - x2)
else fromIntegral . ceiling $ ((10.0 :: Double) ** 100.0) else fromIntegral . ceiling $ ((10.0 :: Double) ** 100.0)
data LineMXB = LineMXB data LineMXB = LineMXB
{ m :: Rational { m :: Rational
, b :: Rational , b :: Rational
, startX :: Int , startX :: Int
, endX :: Int , endX :: Int
} }
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)