Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
data Graph = Graph
{ pointsLeft :: Set.Set (V2 Double)
-- ^ All the points in the whole graph left to be connected
, branches :: Set.Set LineSegment
-- ^ All branches we have found, connecting two points
, currentPoints :: [V2 Double]
-- ^ Points that are currently being processed
, maxDist :: Double
-- ^ Maximum distance a thing can be away from a thing
}
stepGraph :: Graph -> Generate Graph
stepGraph graph@Graph{..} = do
clearScreen
cairo $ drawGraph graph
renderProgress
pure $ Graph nextPointsLeft nextBranches (Set.toList nextPoints) maxDist
where
nextBranchesAndPoints :: [([LineSegment], [V2 Double])]
nextBranchesAndPoints = flip map currentPoints $ \point ->
let
circle = Circle maxDist point
connections = Set.toList $ Set.filter (circle `containsPoint`) pointsLeft
in (map (LineSegment point) connections, connections)
nextBranches = branches `Set.union` Set.fromList (concatMap fst nextBranchesAndPoints)
nextPoints = mconcat $ map (Set.fromList . snd) nextBranchesAndPoints
nextPointsLeft = pointsLeft Set.\\ nextPoints
graphify :: Graph -> Generate Graph
graphify graph = case currentPoints graph of
[] -> pure graph
_ -> do
nextGraph <- stepGraph graph
graphify nextGraph
drawGraph :: Graph -> Render ()
drawGraph Graph{..} = do
for_ currentPoints $ \currentPoint -> do
drawV2 0.3 currentPoint
setSourceHsv (HSV 0 1 1) *> stroke
for_ branches $ \segment -> do
drawLineSegment segment
setSourceHsv (HSV 0 0 0) *> stroke
clearScreen = fillScreenHsv (HSV 180 0.02 0.99)
renderSketch :: Generate ()
renderSketch = do
fillScreenHsv (HSV 180 0.02 0.99)
cairo $ setLineJoin LineJoinRound
cairo $ setLineCap LineCapRound
cairo $ setLineWidth 0.25
rect <- scaleRect 0.9 <$> getBoundingRect
points <- generatePoisson rect 1 30
startPoint <- uniform points
let
initialGraph = Graph
{ pointsLeft = Set.fromList points Set.\\ Set.singleton startPoint
, branches = Set.empty
, currentPoints = [startPoint]
, maxDist = 1 * 1.4
}
finalGraph <- graphify initialGraph
clearScreen
cairo $ drawGraph finalGraph
render :: IO ()
render = mainIOWith (\opts -> opts{ optWidth = 10 * 10, optHeight = 10 * 10 }) renderSketch
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment