prior using diagrams's vectors and points throughout

.gitignore

@@ -1,3 +1,4 @@
 .stack-work/*
 dist/*
 *.svg
+/dist-newstyle/

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

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"

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

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,6 +236,17 @@ 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,
@@ -217,17 +255,17 @@ makeLine (y1, x1) (y2, x2) = Line {
     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)