From 6045708f49aafbe6028f9407fb760ce16f9c3374 Mon Sep 17 00:00:00 2001 From: Jack Wines Date: Sun, 22 Jan 2023 11:57:07 -0800 Subject: [PATCH] prior using diagrams's vectors and points throughout --- .gitignore | 3 ++- image-triangles.cabal | 21 ++++++++++++--- src/Main.hs | 15 ++++++++--- src/Render.hs | 7 +++++ src/Triangles.hs | 60 +++++++++++++++++++++++++++++++++++-------- 5 files changed, 88 insertions(+), 18 deletions(-) diff --git a/.gitignore b/.gitignore index 8bb3d02..90c56b9 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ .stack-work/* dist/* -*.svg \ No newline at end of file +*.svg +/dist-newstyle/ diff --git a/image-triangles.cabal b/image-triangles.cabal index 67ca024..9bd81a6 100644 --- a/image-triangles.cabal +++ b/image-triangles.cabal @@ -54,19 +54,34 @@ executable image-triangles other-modules: Render, Triangles -- LANGUAGE extensions used by modules in this package. - other-extensions: TupleSections + default-extensions: ScopedTypeVariables, + OverloadedStrings, + TemplateHaskell, + DataKinds, + FlexibleContexts, + FlexibleInstances, + MultiParamTypeClasses, + OverloadedLabels, + TypeFamilies, + TupleSections, + UndecidableInstances, + RecursiveDo, + RecordWildCards, + RankNTypes, + DuplicateRecordFields -- Other library packages from which modules are imported. build-depends: base , random , hip + , vector-th-unbox , colour , diagrams-lib , diagrams-svg , parallel , repa , vector - , vector-th-unbox + , scotty -- Directories containing source files. @@ -78,4 +93,4 @@ executable image-triangles -rtsopts -- -prof -- -fexternal-interpreter --- -fprof-auto +-- import Servant.Client diff --git a/src/Main.hs b/src/Main.hs index 0b026d2..c028741 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,6 +14,7 @@ import Control.Parallel.Strategies 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 data Options = Options { numTriangles :: Int, @@ -54,8 +55,6 @@ renderTri image dimensions gen progress = Ren.makeTriangle (Ren.toPointList dime area = max ((progress ** 2) * 0.2) 0.02 - - genImage :: String -> IO (Diagram B) genImage name = do let (Options {numTriangles = numTriangles, gen = gen'}) = defaultOpts @@ -70,4 +69,14 @@ genImage name = do return $ center . reflectY . mconcat $ zipWith (renderTri img' dimensions) (genList gen'') progressList main :: IO () -main = mainWith genImage +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 = mconcat . map Ren.toLine . Tri.toPlanarGraph $ [(0,0), (1,2), (0,1), (1,0)] + mainWith diagram + +-- cmdArgs <- Env.getArgs +-- case cmdArgs of +-- ["http"] -> putStrLn "here" +-- _ -> mainWith genImage +-- putStrLn "done" diff --git a/src/Render.hs b/src/Render.hs index bc08623..cd58589 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -27,4 +27,11 @@ 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] +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 diff --git a/src/Triangles.hs b/src/Triangles.hs index 8d712d4..17cdefe 100644 --- a/src/Triangles.hs +++ b/src/Triangles.hs @@ -9,6 +9,8 @@ module Triangles where import System.Random +import Data.Ratio +import qualified Debug.Trace import qualified Data.Colour.SRGB.Linear as C import qualified Data.Colour as C import Data.Colour.SRGB.Linear (Colour) @@ -19,7 +21,6 @@ import Data.Maybe import qualified Data.Vector.Unboxed as Vec import Data.Fixed import Data.Vector.Unboxed.Deriving - type Image_ = Vec.Vector Pixel_ type Pixel_ = Colour Double type Point = (Int, Int) @@ -38,10 +39,37 @@ derivingUnbox "Pixel_" [| toSRGBTuple |] [| fromSRGBTuple |] + +randomPoints :: (Int, Int) -> StdGen -> [(Int, Int)] +randomPoints (height, width) = randomRs ((0,0), (height, width)) + +toPlanarGraph :: [Point] -> [Line] +toPlanarGraph points = makePlanar . map (uncurry makeLine) . sortOn (uncurry distance) + $ concatMap (\x -> map (,x) points) points + where + 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 @@ -156,8 +184,8 @@ angle (y, x) (fromy, fromx) = atan2 y' x' x' = fromIntegral $ x - fromx getPointsInTriangle :: Image_ -> Triangle -> [Point] -getPointsInTriangle image (p1', p2', p3') = (ptsBtween (makeLine p1 p3) (makeLine p1 p2)) ++ - (ptsBtween (makeLine p1 p3) (makeLine p2 p3)) +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'] @@ -188,7 +216,6 @@ getTriangleAverageRGB image triangle (y', x') = blendEqually $ pixels | x < 0 = Nothing | otherwise = image Vec.!? ((y * x') + x) - ptsBtween :: Line -> Line -> [Point] ptsBtween l1 l2 = concatMap rasterLine . noSingletons $ [startingX .. endingX] where @@ -209,25 +236,36 @@ yAt (Line {m = m, b = b}) x = round $ (m * (fromIntegral x)) + 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 { - m = slope, + m = slope, b = (fromIntegral y1) - (slope * (fromIntegral x1)), startX = min x1 x2, endX = max x1 x2 } where - slope = (y1 - y2) `doubleDiv` (x1 - x2) - -doubleDiv a b = (fromIntegral a) / (fromIntegral b) + slope = if x1 /= x2 + then (fromIntegral $ y1 - y2) % (fromIntegral $ x1 - x2) + else fromIntegral . ceiling $ ((10.0 :: Double) ** 100.0) data Line = Line { - m :: Double, - b :: Double, + m :: Rational, + b :: Rational, startX :: Int, endX :: Int - } + } deriving (Show, Ord, Eq) isPointInTriangle :: Triangle -> Point -> Bool isPointInTriangle (v1, v2, v3) pt = not (has_neg && has_pos)