brillo-algorithms (empty) → 1.13.3
raw patch · 6 files changed
+578/−0 lines, 6 filesdep +basedep +brillodep +containers
Dependencies added: base, brillo, containers, ghc-prim
Files
- Brillo/Algorithms/RayCast.hs +95/−0
- Brillo/Data/Extent.hs +203/−0
- Brillo/Data/Quad.hs +23/−0
- Brillo/Data/QuadTree.hs +200/−0
- LICENSE +22/−0
- brillo-algorithms.cabal +35/−0
+ Brillo/Algorithms/RayCast.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}++-- | Various ray casting algorithms.+module Brillo.Algorithms.RayCast (+ castSegIntoCellularQuadTree,+ traceSegIntoCellularQuadTree,+)+where++import Brillo.Data.Extent+import Brillo.Data.Picture+import Brillo.Data.Quad+import Brillo.Data.QuadTree+import Data.Function+import Data.List+++{-| The quadtree contains cells of unit extent (NetHack style).+ Given a line segement (P1-P2) through the tree, get the cell+ closest to P1 that intersects the segment, if any.+-}++---+-- TODO: This currently uses a naive algorithm. It just calls+-- `traceSegIntoCellularQuadTree` and sorts the results+-- to get the one closest to P1. It'd be better to do a+-- proper walk over the tree in the direction of the ray.+--+castSegIntoCellularQuadTree+ :: forall a+ . Point+ -- ^ (P1) Starting point of seg.+ -> Point+ -- ^ (P2) Final point of seg.+ -> Extent+ -- ^ Extent convering the whole tree.+ -> QuadTree a+ -- ^ The tree.+ -> Maybe (Point, Extent, a)+ -- ^ Intersection point, extent of cell, value of cell (if any).+castSegIntoCellularQuadTree p1 p2 extent tree+ | cells@(_ : _) <- traceSegIntoCellularQuadTree p1 p2 extent tree+ , c : _ <- sortBy ((compareDistanceTo p1) `on` (\(a, _, _) -> a)) cells =+ Just c+ | otherwise =+ Nothing+++compareDistanceTo :: Point -> Point -> Point -> Ordering+compareDistanceTo p0 p1 p2 =+ let d1 = distance p0 p1+ d2 = distance p0 p2+ in compare d1 d2+++distance :: Point -> Point -> Float+distance (x1, y1) (x2, y2) =+ let xd = x2 - x1+ yd = y2 - y1+ in sqrt (xd * xd + yd * yd)+++{-| The quadtree contains cells of unit extent (NetHack style).+ Given a line segment (P1-P2) through the tree, return the list of cells+ that intersect the segment.+-}+traceSegIntoCellularQuadTree+ :: forall a+ . Point+ -- ^ (P1) Starting point of seg.+ -> Point+ -- ^ (P2) Final point of seg.+ -> Extent+ -- ^ Extent covering the whole tree.+ -> QuadTree a+ -- ^ The tree.+ -> [(Point, Extent, a)]+ -- ^ Intersection point, extent of cell, value of cell.+traceSegIntoCellularQuadTree p1 p2 extent tree =+ case tree of+ TNil -> []+ TLeaf a ->+ case intersectSegExtent p1 p2 extent of+ Just pos -> [(pos, extent, a)]+ Nothing -> []+ TNode nw ne sw se+ | touchesSegExtent p1 p2 extent ->+ concat+ [ traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent NW extent) nw+ , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent NE extent) ne+ , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent SW extent) sw+ , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent SE extent) se+ ]+ _ -> []
+ Brillo/Data/Extent.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE PatternGuards #-}++{-| Represents an integral rectangular area of the 2D plane.+ Using `Int`s (instead of `Float`s) for the bounds means we can safely+ compare extents for equality.+-}+module Brillo.Data.Extent (+ Extent,+ Coord,+ makeExtent,+ takeExtent,+ squareExtent,+ sizeOfExtent,+ isUnitExtent,+ coordInExtent,+ pointInExtent,+ centerCoordOfExtent,+ cutQuadOfExtent,+ quadOfCoord,+ pathToCoord,+ intersectSegExtent,+ touchesSegExtent,+)+where++import Brillo.Data.Point+import Brillo.Data.Quad+import Brillo.Geometry.Line+import Data.Maybe+++{-| A rectangular area of the 2D plane.+ We keep the type abstract to ensure that invalid extents cannot be+ constructed.+-}+data Extent+ = Extent Int Int Int Int+ deriving (Eq, Show)+++-- | An integral coordinate.+type Coord =+ (Int, Int)+++{-| Construct an extent.+ The north value must be > south, and east > west, else `error`.+-}+makeExtent+ :: Int+ -- ^ y max (north)+ -> Int+ -- ^ y min (south)+ -> Int+ -- ^ x max (east)+ -> Int+ -- ^ x min (west)+ -> Extent+makeExtent n s e w+ | n >= s+ , e >= w =+ Extent n s e w+ | otherwise =+ error "Brillo.Geometry.Extent.makeExtent: invalid extent"+++-- | Take the NSEW components of an extent.+takeExtent :: Extent -> (Int, Int, Int, Int)+takeExtent (Extent n s e w) =+ (n, s, e, w)+++-- | A square extent of a given size.+squareExtent :: Int -> Extent+squareExtent i =+ Extent i 0 i 0+++-- | Get the width and height of an extent.+sizeOfExtent :: Extent -> (Int, Int)+sizeOfExtent (Extent n s e w) =+ (e - w, n - s)+++-- | Check if an extent is a square with a width and height of 1.+isUnitExtent :: Extent -> Bool+isUnitExtent extent =+ sizeOfExtent extent == (1, 1)+++-- | Check whether a coordinate lies inside an extent.+coordInExtent :: Extent -> Coord -> Bool+coordInExtent (Extent n s e w) (x, y) =+ x >= w+ && x < e+ && y >= s+ && y < n+++-- | Check whether a point lies inside an extent.+pointInExtent :: Extent -> Point -> Bool+pointInExtent (Extent n s e w) (x, y) =+ let n' = fromIntegral n+ s' = fromIntegral s+ e' = fromIntegral e+ w' = fromIntegral w+ in x >= w'+ && x <= e'+ && y >= s'+ && y <= n'+++-- | Get the coordinate that lies at the center of an extent.+centerCoordOfExtent :: Extent -> (Int, Int)+centerCoordOfExtent (Extent n s e w) =+ ( w + (e - w) `div` 2+ , s + (n - s) `div` 2+ )+++-- | Cut one quadrant out of an extent.+cutQuadOfExtent :: Quad -> Extent -> Extent+cutQuadOfExtent quad (Extent n s e w) =+ let hheight = (n - s) `div` 2+ hwidth = (e - w) `div` 2+ in case quad of+ NW -> Extent n (s + hheight) (e - hwidth) w+ NE -> Extent n (s + hheight) e (w + hwidth)+ SW -> Extent (n - hheight) s (e - hwidth) w+ SE -> Extent (n - hheight) s e (w + hwidth)+++-- | Get the quadrant that this coordinate lies in, if any.+quadOfCoord :: Extent -> Coord -> Maybe Quad+quadOfCoord extent coord =+ listToMaybe $+ filter (\q -> coordInExtent (cutQuadOfExtent q extent) coord) $+ allQuads+++-- | Constuct a path to a particular coordinate in an extent.+pathToCoord :: Extent -> Coord -> Maybe [Quad]+pathToCoord extent coord+ | isUnitExtent extent =+ Just []+ | otherwise =+ do+ quad <- quadOfCoord extent coord+ rest <- pathToCoord (cutQuadOfExtent quad extent) coord+ return $ quad : rest+++{-| If a line segment (P1-P2) intersects the outer edge of an extent then+ return the intersection point, that is closest to P1, if any.+ If P1 is inside the extent then `Nothing`.++ @+ P2+ /+ ----/-+ | / |+ + |+ /------+ /+ P1+ @+-}+intersectSegExtent :: Point -> Point -> Extent -> Maybe Point+intersectSegExtent p1@(x1, y1) p2 (Extent n' s' e' w')+ -- starts below extent+ | y1 < s+ , Just pos <- intersectSegHorzSeg p1 p2 s w e =+ Just pos+ -- starts above extent+ | y1 > n+ , Just pos <- intersectSegHorzSeg p1 p2 n w e =+ Just pos+ -- starts left of extent+ | x1 < w+ , Just pos <- intersectSegVertSeg p1 p2 w s n =+ Just pos+ -- starts right of extent+ | x1 > e+ , Just pos <- intersectSegVertSeg p1 p2 e s n =+ Just pos+ -- must be starting inside extent.+ | otherwise =+ Nothing+ where+ n = fromIntegral n'+ s = fromIntegral s'+ e = fromIntegral e'+ w = fromIntegral w'+++{-| Check whether a line segment's endpoints are inside an extent, or if it+ intersects with the boundary.+-}+touchesSegExtent :: Point -> Point -> Extent -> Bool+touchesSegExtent p1 p2 extent =+ pointInExtent extent p1+ || pointInExtent extent p2+ || isJust (intersectSegExtent p1 p2 extent)
+ Brillo/Data/Quad.hs view
@@ -0,0 +1,23 @@+module Brillo.Data.Quad (+ Quad (..),+ allQuads,+)+where+++-- | Represents a Quadrant in the 2D plane.+data Quad+ = -- | North West+ NW+ | -- | North East+ NE+ | -- | South West+ SW+ | -- | South East+ SE+ deriving (Show, Eq, Enum)+++-- | A list of all quadrants. Same as @[NW .. SE]@.+allQuads :: [Quad]+allQuads = [NW .. SE]
+ Brillo/Data/QuadTree.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE RankNTypes #-}++{-| A QuadTree can be used to recursively divide up 2D space into quadrants.+ The smallest division corresponds to an unit `Extent`, so the total depth+ of the tree will depend on what sized `Extent` you start with.+-}+module Brillo.Data.QuadTree (+ QuadTree (..),+ emptyTree,+ emptyNode,+ takeQuadOfTree,+ liftToQuad,+ insertByPath,+ insertByCoord,+ lookupNodeByPath,+ lookupByPath,+ lookupByCoord,+ flattenQuadTree,+ flattenQuadTreeWithExtents,+)+where++import Brillo.Data.Extent+import Brillo.Data.Quad+++-- | The quad tree structure.+data QuadTree a+ = -- | An empty node.+ TNil+ | -- | A leaf containint some value.+ TLeaf a+ | -- | A node with four children.+ TNode+ (QuadTree a)+ (QuadTree a) -- NW NE+ (QuadTree a)+ (QuadTree a) -- SW SE+ deriving (Show)+++-- | A `TNil` tree.+emptyTree :: QuadTree a+emptyTree = TNil+++-- | A node with `TNil`. for all its branches.+emptyNode :: QuadTree a+emptyNode = TNode TNil TNil TNil TNil+++{-| Get a quadrant from a node.+ If the tree does not have an outer node then `Nothing`.+-}+takeQuadOfTree+ :: Quad+ -> QuadTree a+ -> Maybe (QuadTree a)+takeQuadOfTree quad tree =+ case tree of+ TNil -> Nothing+ TLeaf{} -> Nothing+ TNode nw ne sw se ->+ case quad of+ NW -> Just nw+ NE -> Just ne+ SW -> Just sw+ SE -> Just se+++{-| Apply a function to a quadrant of a node.+ If the tree does not have an outer node then return the original tree.+-}+liftToQuad+ :: Quad+ -> (QuadTree a -> QuadTree a)+ -> QuadTree a+ -> QuadTree a+liftToQuad quad f tree =+ case tree of+ TNil -> tree+ TLeaf{} -> tree+ TNode nw ne sw se ->+ case quad of+ NW -> TNode (f nw) ne sw se+ NE -> TNode nw (f ne) sw se+ SW -> TNode nw ne (f sw) se+ SE -> TNode nw ne sw (f se)+++{-| Insert a value into the tree at the position given by a path.+ If the path intersects an existing `TLeaf` then return the original tree.+-}+insertByPath :: [Quad] -> a -> QuadTree a -> QuadTree a+insertByPath [] x _ =+ TLeaf x+insertByPath (q : qs) x tree =+ case tree of+ TNil -> liftToQuad q (insertByPath qs x) emptyNode+ TLeaf{} -> tree+ TNode{} -> liftToQuad q (insertByPath qs x) tree+++{-| Insert a value into the node containing this coordinate.+ The node is created at maximum depth, corresponding to an unit `Extent`.+-}+insertByCoord :: Extent -> Coord -> a -> QuadTree a -> Maybe (QuadTree a)+insertByCoord extent coord x tree =+ do+ path <- pathToCoord extent coord+ return $ insertByPath path x tree+++-- | Lookup a node based on a path to it.+lookupNodeByPath+ :: [Quad]+ -> QuadTree a+ -> Maybe (QuadTree a)+lookupNodeByPath [] tree =+ Just tree+lookupNodeByPath (q : qs) tree =+ case tree of+ TNil -> Nothing+ TLeaf{} -> Nothing+ TNode{} ->+ case takeQuadOfTree q tree of+ Nothing -> Nothing+ Just quad -> lookupNodeByPath qs quad+++-- | Lookup an element based given a path to it.+lookupByPath :: [Quad] -> QuadTree a -> Maybe a+lookupByPath path tree =+ case lookupNodeByPath path tree of+ Just (TLeaf x) -> Just x+ _ -> Nothing+++-- | Lookup a node if a tree given a coordinate which it contains.+lookupByCoord+ :: forall a+ . Extent+ -- ^ Extent that covers the whole tree.+ -> Coord+ -- ^ Coordinate of the value of interest.+ -> QuadTree a+ -> Maybe a+lookupByCoord extent coord tree =+ do+ path <- pathToCoord extent coord+ lookupByPath path tree+++-- | Flatten a QuadTree into a list of its contained values, with coordinates.+flattenQuadTree+ :: forall a+ . Extent+ -- ^ Extent that covers the whole tree.+ -> QuadTree a+ -> [(Coord, a)]+flattenQuadTree extentInit treeInit =+ flatten' extentInit treeInit+ where+ flatten' extent tree =+ case tree of+ TNil -> []+ TLeaf x ->+ let (_, s, _, w) = takeExtent extent+ in [((w, s), x)]+ TNode{} -> concat $ map (flattenQuad extent tree) allQuads++ flattenQuad extent tree quad = do+ let extent' = cutQuadOfExtent quad extent+ case takeQuadOfTree quad tree of+ Nothing -> []+ Just tree' -> flatten' extent' tree'+++-- | Flatten a QuadTree into a list of its contained values, with extents.+flattenQuadTreeWithExtents+ :: forall a+ . Extent+ -- ^ Extent that covers the whole tree.+ -> QuadTree a+ -> [(Extent, a)]+flattenQuadTreeWithExtents extentInit treeInit =+ flatten' extentInit treeInit+ where+ flatten' extent tree =+ case tree of+ TNil -> []+ TLeaf x ->+ [(extent, x)]+ TNode{} -> concat $ map (flattenQuad extent tree) allQuads++ flattenQuad extent tree quad = do+ let extent' = cutQuadOfExtent quad extent+ case takeQuadOfTree quad tree of+ Nothing -> []+ Just tree' -> flatten' extent' tree'
+ LICENSE view
@@ -0,0 +1,22 @@+MIT License++Copyright (c) 2010-2024 The Gloss Development Team,+Copyright (c) 2024-2025 The Brillo Development Team++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ brillo-algorithms.cabal view
@@ -0,0 +1,35 @@+cabal-version: 3.0+name: brillo-algorithms+version: 1.13.3+license: MIT+license-file: LICENSE+author: Ben Lippmeier, Adrian Sieber+maintainer: brillo@ad-si.com+build-type: Simple+stability: stable+category: Graphics+homepage: https://github.com/ad-si/Brillo+description:+ Data structures and algorithms for working with 2D graphics.++synopsis:+ Data structures and algorithms for working with 2D graphics.++source-repository head+ type: git+ location: https://github.com/ad-si/Brillo++library+ default-language: GHC2021+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.14+ , containers >=0.5 && <0.7+ , ghc-prim++ ghc-options: -O2 -Wall+ exposed-modules:+ Brillo.Algorithms.RayCast+ Brillo.Data.Extent+ Brillo.Data.Quad+ Brillo.Data.QuadTree