From e52a6ae6404e288e41ef4b76f4917db583a9fca9 Mon Sep 17 00:00:00 2001 From: Jack Wines Date: Sun, 4 Feb 2024 04:11:11 -0800 Subject: [PATCH] formatting and dead code elimination in Triangles.hs --- src/Triangles.hs | 306 ++++++++++++++++++++++++----------------------- 1 file changed, 159 insertions(+), 147 deletions(-) diff --git a/src/Triangles.hs b/src/Triangles.hs index 55e1a2e..b8b6830 100644 --- a/src/Triangles.hs +++ b/src/Triangles.hs @@ -1,236 +1,248 @@ module Triangles where -import System.Random -import Data.Ratio -import qualified Debug.Trace -import qualified Data.Colour.SRGB.Linear as C +import Control.Arrow import Control.Parallel.Strategies import qualified Data.Colour as C +import qualified Data.Colour.Names as C import Data.Colour.SRGB.Linear (Colour) +import qualified Data.Colour.SRGB.Linear as C +import Data.Fixed +import qualified Data.Function as F +import Data.List +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe +import Data.Ratio +import qualified Data.Set as S import Data.Vector.Generic.Base (Vector) import Data.Vector.Generic.Mutable (MVector) -import Data.List -import Data.Maybe import qualified Data.Vector.Unboxed as Vec -import Data.Fixed 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 Data.List as L -import qualified Data.Function as F -import qualified Diagrams.TwoD.Path.IntersectionExtras as I -import Diagrams.Trail (trailPoints) -import qualified Graphics.Image as H import Debug.Trace (traceShow) -import qualified Data.Colour.Names as C +import qualified Debug.Trace import qualified Debug.Trace as D +import Diagrams.Prelude +import Diagrams.Trail (trailPoints) +import Diagrams.TwoD +import qualified Diagrams.TwoD.Path.IntersectionExtras as I import Diagrams.TwoD.Segment.Bernstein (listToBernstein) +import qualified Graphics.Image as H +import System.Random type Image_ = Vec.Vector Pixel_ type Pixel_ = Colour Double toSRGBTuple :: Pixel_ -> (Double, Double, Double) toSRGBTuple = srgb' . C.toRGB - where - srgb' (C.RGB {C.channelRed = red, C.channelGreen = green, C.channelBlue = blue}) = (red, green, blue) + where + srgb' (C.RGB{C.channelRed = red, C.channelGreen = green, C.channelBlue = blue}) = (red, green, blue) fromSRGBTuple :: (Double, Double, Double) -> Pixel_ fromSRGBTuple (r, g, b) = C.rgb r g b -derivingUnbox "Pixel_" - [t| Pixel_ -> (Double, Double, Double)|] - [| toSRGBTuple |] - [| fromSRGBTuple |] +derivingUnbox + "Pixel_" + [t|Pixel_ -> (Double, Double, Double)|] + [|toSRGBTuple|] + [|fromSRGBTuple|] -- from -0.05 to 1.05 so there aren't missing/elongated triangles at the edges randomPoints :: StdGen -> [(Double, Double)] randomPoints = map (bimap toZeroToOneTuple toZeroToOneTuple) . randomRs ((0 :: Word, 0 :: Word), (maxBound, maxBound)) - where - toZeroToOneTuple :: Word -> Double - toZeroToOneTuple x = ((fromIntegral x / (fromIntegral (maxBound :: Word))) * 1.2) - 0.1 + where + toZeroToOneTuple :: Word -> Double + toZeroToOneTuple x = ((fromIntegral x / (fromIntegral (maxBound :: Word))) * 1.2) - 0.1 combinations :: (Ord b, Floating b, NFData b) => [P2 b] -> [(P2 b, P2 b)] combinations xs = sortOn (abs . uncurry distanceA) - . S.toList . S.fromList - . filter (uncurry (/=)) - . sortOn (abs . uncurry distanceA) - . concatMap (\(x:xs) -> map (x,) xs) - . init . tails $ xs - where - edgeLengthThreshold = 10 + . S.toList + . S.fromList + . filter (uncurry (/=)) + . sortOn (abs . uncurry distanceA) + . concatMap (\(x : xs) -> map (x,) xs) + . init + . tails + $ xs + where + edgeLengthThreshold = 10 -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 = - removeIntersections . - combinations $ points - where - numPoints = length points + removeIntersections + . combinations + $ points + where + numPoints = length points - removeIntersections :: [(Point V2 n, Point V2 n)] -> [(Point V2 n, Point V2 n)] - removeIntersections = foldl' addIfNoIntersection [] + removeIntersections :: [(Point V2 n, Point V2 n)] -> [(Point V2 n, Point V2 n)] + removeIntersections = foldl' addIfNoIntersection [] + addIfNoIntersection xs x + | all (noIntersection x) xs = x : xs + | otherwise = xs - addIfNoIntersection xs x | all (noIntersection x) xs = x:xs - | otherwise = xs - - noIntersection l1 l2 = sharedEndPoint || (null $ intersectPointsT (uncurry toLocatedTrail l1) (uncurry toLocatedTrail l2)) - where - sharedEndPoint = (< 4) . length . nub $ [fst l1, snd l1, fst l2, snd l2] + noIntersection l1 l2 = sharedEndPoint || (null $ intersectPointsT (uncurry toLocatedTrail l1) (uncurry toLocatedTrail l2)) + where + 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 p1 p2 = fromVertices [p1, p2] `at` p1 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) - where - shapeDirections p = map (dirBetween p) verticies - + where + shapeDirections p = map (dirBetween p) verticies sortOnAngle center = sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween center) -voroniDiagramCorners center midpoints -- = midpoints - = sortOnAngle center . filter isValidMidpoint . concat $ [intersectPointsT l0 l1 | l0 <- tangentTrails, l1 <- tangentTrails] - where +voroniDiagramCorners :: RealFloat n => Point V2 n -> [Point V2 n] -> [Point V2 n] +voroniDiagramCorners center midpoints = + sortOnAngle center + . filter isValidMidpoint + . concat + $ [intersectPointsT l0 l1 | l0 <- tangentTrails, l1 <- tangentTrails] + 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 - where - isNonObtuseMidpoint m = -- traceShow ((dirBetween m center, dirBetween m candidate), (candidate, m)) . - lessThanQuarterTurn . normalizeAngle $ angleBetweenDirs (dirBetween m center) (dirBetween m candidate) - - tangentTrail midpoint = fromVertices $ [midpoint .-^ tangentVec, midpoint .+^ tangentVec] - where - -- implicitly uses the unit vector as an infinitely long vector - tangentVec = scale 8 . - fromDirection . rotateBy (1 / 4) $ dirBetween midpoint center + isValidMidpoint candidate = all isNonObtuseMidpoint . filter (/= candidate) $ midpoints + where + isNonObtuseMidpoint m = + lessThanQuarterTurn . normalizeAngle $ angleBetweenDirs (dirBetween m center) (dirBetween m candidate) + tangentTrail midpoint = fromVertices [midpoint .-^ tangentVec, midpoint .+^ tangentVec] + where + -- implicitly uses the unit vector as an infinitely long vector + tangentVec = + scale 8 + . fromDirection + . rotateBy (1 / 4) + $ dirBetween midpoint center findVoroniDiagram :: RealFloat n => [(Point V2 n, Point V2 n)] -> [(Point V2 n, [Point V2 n])] findVoroniDiagram edges = M.toList - . M.mapWithKey (\key -> L.sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween key) . map (pointBetween key) . - S.toList) - $ adjacencyMap - where - adjacencyMap = adjacencyMapOf edges + . M.mapWithKey + ( \key -> + L.sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween key) + . map (pointBetween key) + . S.toList + ) + $ adjacencyMap + where + 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 edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap - where + where + 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) - 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) - - adjacencyMap = adjacencyMapOf edges + adjacencyMap = adjacencyMapOf edges adjacencyMapOf edges = M.fromListWith S.union . map (second S.singleton) $ (edges ++ edgesReversed) - where - edgesReversed = map (\(a, b) -> (b, a)) edges + where + edgesReversed = map (\(a, b) -> (b, a)) edges 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 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, p3] = sortOn fst . map (\(y, x) -> (x,y)) . map unp2 . S.toList $ pts +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, p3] = sortOn fst . map (\(y, x) -> (x, y)) . map unp2 . S.toList $ pts blendEqually colors = C.affineCombo (zip (repeat fraction) colors) $ C.blue - where - fraction = 1.0 / (fromIntegral . length $ colors) + where + fraction = 1.0 / (fromIntegral . length $ colors) --- voroniRegionAverageColor :: Image_ -> (Int, Int) -> (P2 Int, [P2 Int]) -> C.Colour Double -voroniRegionAverageColor image (x', y') verticies - = blendEqually - . concatMap (getColorsInTriangle image (x', y')) - . filter ((== 3) . S.size) - . map (S.fromList . take 3) - . tails - . L.nub - . map scaleToImageCoords - $ verticies +voroniRegionAverageColor image (x', y') verticies = + blendEqually + . concatMap (getColorsInTriangle image (x', y')) + . filter ((== 3) . S.size) + . map (S.fromList . take 3) + . tails + . L.nub + . map scaleToImageCoords + $ verticies + where + scaleToImageCoords :: P2 Double -> P2 Int + scaleToImageCoords p = fmap round $ p2 ((fromIntegral x' * p ^. _x), fromIntegral y' * p ^. _y) - where + scaleToUnitCoords :: P2 Int -> P2 Double + scaleToUnitCoords p = p2 ((fromIntegral x' / (fromIntegral $ p ^. _x)), fromIntegral y' / (fromIntegral $ p ^. _y)) - scaleToImageCoords :: P2 Double -> P2 Int - scaleToImageCoords p = fmap round $ p2 ((fromIntegral x' * p ^. _x), fromIntegral y' * p ^. _y) - - scaleToUnitCoords :: P2 Int -> P2 Double - 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 - where + where + pixels :: [Pixel_] + pixels = mapMaybe index' points - pixels :: [Pixel_] - pixels = mapMaybe index' points + points :: [(Int, Int)] + points = getPointsInTriangle image triangle - points :: [(Int, Int)] - points = getPointsInTriangle image triangle + index' :: (Int, Int) -> Maybe Pixel_ + index' (y, x) + | y >= y' = Nothing + | x >= x' = Nothing + | y < 0 = Nothing + | x < 0 = Nothing + | otherwise = image Vec.!? ((y * x') + x) - index' :: (Int, Int) -> Maybe Pixel_ - index' (y, x) - | y >= y' = Nothing - | x >= x' = Nothing - | y < 0 = Nothing - | x < 0 = Nothing - | 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 - ptsBtween :: LineMXB -> LineMXB -> [(Int, Int)] ptsBtween l1 l2 = concatMap rasterLine . noSingletons $ [startingX .. endingX] - where - startingX = max (startX l1) (startX l2) - endingX = min (endX l1) (endX l2) + where + startingX = max (startX l1) (startX l2) + endingX = min (endX l1) (endX l2) - rasterLine x = map (\y -> (y, x)) $ range' (yAt l1 x) (yAt l2 x) + rasterLine x = map (\y -> (y, x)) $ range' (yAt l1 x) (yAt l2 x) noSingletons :: [a] -> [a] noSingletons [x] = [] -noSingletons l = l +noSingletons l = l range' :: Int -> Int -> [Int] range' a b = [(min a b) .. (max a b)] yAt :: LineMXB -> Int -> Int -yAt (LineMXB {m = m, b = b}) x = round $ (m * (fromIntegral x)) + b +yAt (LineMXB{m = m, b = b}) x = round $ (m * (fromIntegral x)) + b makeLine :: (Int, Int) -> (Int, Int) -> LineMXB -makeLine (y1, x1) (y2, x2) = LineMXB { - m = slope, - b = (fromIntegral y1) - (slope * (fromIntegral x1)), - startX = min x1 x2, - endX = max x1 x2 - } - where - slope = if x1 /= x2 - then (fromIntegral $ y1 - y2) % (fromIntegral $ x1 - x2) - else fromIntegral . ceiling $ ((10.0 :: Double) ** 100.0) +makeLine (y1, x1) (y2, x2) = + LineMXB + { m = slope + , b = (fromIntegral y1) - (slope * (fromIntegral x1)) + , startX = min x1 x2 + , endX = max x1 x2 + } + where + slope = + if x1 /= x2 + then (fromIntegral $ y1 - y2) % (fromIntegral $ x1 - x2) + else fromIntegral . ceiling $ ((10.0 :: Double) ** 100.0) data LineMXB = LineMXB - { - m :: Rational, - b :: Rational, - startX :: Int, - endX :: Int - } deriving (Show, Ord, Eq) + { m :: Rational + , b :: Rational + , startX :: Int + , endX :: Int + } + deriving (Show, Ord, Eq)