diff --git a/src/CircumCircle.hs b/src/CircumCircle.hs deleted file mode 100644 index a59e44f..0000000 --- a/src/CircumCircle.hs +++ /dev/null @@ -1,65 +0,0 @@ -module CircumCircle where -import Diagrams.Prelude -import Triangles -import qualified Data.Set as S -import qualified Data.List as L -import Diagrams.TwoD -import Diagrams.Direction -import qualified Data.Colour.Names as CN -import Diagrams.Backend.SVG -import GHC.Generics -import Data.Maybe - -data Circle n = Circle { - loc :: P2 n, - radius :: n - } - -placeCircle :: Colour Double -> Circle Double -> Diagram B -placeCircle col (Circle{..}) = circle radius # translate (loc .-. origin) # lw 0 # fc col - --- placeCircle (Circle{loc = loc, radius = rad}) = circle rad $ fc blue -- # opacity .25 - -circumCircle :: (Ord a, Floating a) => S.Set (P2 a) -> Maybe (Circle a) -circumCircle pts = circumCircleFromLoc <$> loc - where - circumCircleFromLoc loc' = Circle loc' (magnitude $ p1 .-. loc') - - loc = listToMaybe $ intersectPointsT (mapLoc (fromOffsets. L.singleton . (^* circumfrence) . fromDir) bisectP1P2) - (mapLoc (fromOffsets. L.singleton . (^* circumfrence) . fromDir) bisectP2P3) - - bisectP1P2 = bisect p1 p2 - - bisectP2P3 = bisect p2 p3 - - [p1, p2, p3] = L.sortOn (snd . unp2) . S.toList $ pts - - circumfrence = sum . map magnitude $ [(p2 .-. p1), (p2 .-. p3), (p1 .-. p3)] - - --- circumDebug :: (Ord a, Floating a) => S.Set (P2 a) -> Maybe (Circle a) -circumDebug pts = (bisectP1P2, bisectP2P3) - where - circumCircleFromLoc loc' = Circle loc' (magnitude $ p1 .-. loc') - - loc = listToMaybe $ intersectPointsT (mapLoc (fromOffsets. L.singleton . fromDir) bisectP1P2) (mapLoc (fromOffsets. L.singleton . fromDir) bisectP1P2) - - bisectP1P2 = bisect p1 p2 - - bisectP2P3 = bisect p2 p3 - - [p1, p2, p3] = L.sortOn (snd . unp2) . S.toList $ pts - - circumfrence = 400 - - -magnitude :: Floating a => V2 a -> a -magnitude v = sqrt (x * x + y * y) - where - (x, y) = unr2 v - --- assumes x of p1 is smaller than x of p2 -bisect :: Floating n => Point V2 n -> Point V2 n -> Located (Direction V2 n) -bisect p1 p2 = at (rotateBy (1 / 4) $ dir bisectVec) (p1 .+^ bisectVec) - where - bisectVec = (p2 .-. p1) ^/ 2 diff --git a/src/Main.hs b/src/Main.hs index ce9d64d..fae1e4d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -28,7 +28,6 @@ import Graphics.Image as Img hiding (map, zipWith) import qualified Graphics.Image.ColorSpace as G import qualified Graphics.Image.Interface as Int import Options.Generic -import qualified Render as Ren import qualified System.Environment as Env import System.Random import System.Random.Internal @@ -79,7 +78,8 @@ genImage' image gen cornerCount = . fromVertices $ shape - widthHeightRatio = (fromIntegral $ fst dimensions) / ((fromIntegral $ snd dimensions) :: Double) + widthHeightRatio :: Double + widthHeightRatio = (fromIntegral . fst $ dimensions) / (fromIntegral . snd $ dimensions) img' = convImage image dimensions = Img.dims image diff --git a/src/Render.hs b/src/Render.hs deleted file mode 100644 index 059410e..0000000 --- a/src/Render.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Render where - -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 -> Diagram SVG --- makeTriangle :: (base-4.16.4.0:Data.Typeable.Internal.Typeable n, RealFloat n, --- Renderable (Path V2 n) b) => --- [Point V2 n] -> Colour Double -> QDiagram b V2 n Any -makeTriangle verts col = fromVertices verts - # mapLoc closeLine - # strokeLocLoop - # lc col - # fc col - # lw 1.0 - - --- tupleFromIntegral :: (Int, Int) -> (Int, Int) -> (Double, Double) -tupleFromIntegral (cols, rows) (a, b) = (fromIntegral b, fromIntegral a) - --- renderTriangle = makeTriangle (map p2 [(0.0,0.0), (0.1,0.1), (0.2,0.2)]) blue -placeTri tri = makeTriangle (S.toList tri) diff --git a/src/Triangles.hs b/src/Triangles.hs index b8b6830..5b2b1c8 100644 --- a/src/Triangles.hs +++ b/src/Triangles.hs @@ -46,21 +46,24 @@ derivingUnbox [|toSRGBTuple|] [|fromSRGBTuple|] +borderSize = 0.05 + -- 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 + 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 xs = sortOn (abs . uncurry distanceA) - . S.toList + . S.toList -- deduplicate . S.fromList . filter (uncurry (/=)) - . sortOn (abs . uncurry distanceA) - . concatMap (\(x : xs) -> map (x,) xs) + . concat + . withStrategy (parListChunk 50 rdeepseq) + . map (\(x : xs) -> take 15 . sortOn (abs . uncurry distanceA) . map (x,) $ xs) . init . tails $ xs @@ -70,6 +73,7 @@ combinations xs = toPlanarGraph :: forall n. (NFData n, Floating n, Ord n) => [P2 n] -> [(Point V2 n, Point V2 n)] toPlanarGraph points = removeIntersections + . sortOn (abs . uncurry distanceA) . combinations $ points where @@ -116,7 +120,7 @@ voroniDiagramCorners center midpoints = tangentTrail midpoint = fromVertices [midpoint .-^ tangentVec, midpoint .+^ tangentVec] where - -- implicitly uses the unit vector as an infinitely long vector + -- implicitly uses the unit vector * 8 as an infinitely long vector tangentVec = scale 8 . fromDirection @@ -165,7 +169,7 @@ getPointsInTriangle image pts = , ptsBtween (makeLine p1 p2) (makeLine p2 p3) ] where - [p1, p2, p3] = sortOn fst . map (\(y, x) -> (x, y)) . 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 where @@ -197,7 +201,7 @@ getColorsInTriangle image (x', y') triangle = pixels points = getPointsInTriangle image triangle index' :: (Int, Int) -> Maybe Pixel_ - index' (y, x) + index' (x, y) | y >= y' = Nothing | x >= x' = Nothing | y < 0 = Nothing @@ -213,7 +217,7 @@ ptsBtween l1 l2 = concatMap rasterLine . noSingletons $ [startingX .. endingX] 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 (x,) $ range' (yAt l1 x) (yAt l2 x) noSingletons :: [a] -> [a] noSingletons [x] = [] @@ -226,7 +230,7 @@ yAt :: LineMXB -> Int -> Int yAt (LineMXB{m = m, b = b}) x = round $ (m * (fromIntegral x)) + b makeLine :: (Int, Int) -> (Int, Int) -> LineMXB -makeLine (y1, x1) (y2, x2) = +makeLine (x1, y1) (x2, y2) = LineMXB { m = slope , b = (fromIntegral y1) - (slope * (fromIntegral x1))