diff --git a/Graphics/Gloss/Algorithms/RayCast.hs b/Graphics/Gloss/Algorithms/RayCast.hs --- a/Graphics/Gloss/Algorithms/RayCast.hs +++ b/Graphics/Gloss/Algorithms/RayCast.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE PatternGuards, RankNTypes #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} -- | Various ray casting algorithms. module Graphics.Gloss.Algorithms.RayCast @@ -14,15 +15,15 @@ -- | The quadtree contains cells of unit extent (NetHack style). --- Given a line segement (P1-P2) through the tree, get the cell +-- 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 +-- 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 +-- 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 +-- +castSegIntoCellularQuadTree :: forall a . Point -- ^ (P1) Starting point of seg. -> Point -- ^ (P2) Final point of seg. @@ -34,10 +35,10 @@ | 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 @@ -45,38 +46,38 @@ in compare d1 d2 distance :: Point -> Point -> Float -distance (x1, y1) (x2, y2) +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 +-- Given a line segment (P1-P2) through the tree, return the list of cells -- that intersect the segment. --- -traceSegIntoCellularQuadTree +-- +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 + +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 + | 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 ] - + _ -> [] diff --git a/Graphics/Gloss/Data/Extent.hs b/Graphics/Gloss/Data/Extent.hs --- a/Graphics/Gloss/Data/Extent.hs +++ b/Graphics/Gloss/Data/Extent.hs @@ -41,7 +41,7 @@ -- | Construct an extent. -- The north value must be > south, and east > west, else `error`. -makeExtent +makeExtent :: Int -- ^ y max (north) -> Int -- ^ y min (south) -> Int -- ^ x max (east) @@ -51,7 +51,7 @@ makeExtent n s e w | n >= s, e >= w = Extent n s e w - + | otherwise = error "Graphics.Gloss.Geometry.Extent.makeExtent: invalid extent" @@ -94,7 +94,7 @@ s' = fromIntegral s e' = fromIntegral e w' = fromIntegral w - + in x >= w' && x <= e' && y >= s' && y <= n' @@ -108,7 +108,7 @@ -- | Cut one quadrant out of an extent. cutQuadOfExtent :: Quad -> Extent -> Extent -cutQuadOfExtent quad (Extent n s e w) +cutQuadOfExtent quad (Extent n s e w) = let hheight = (n - s) `div` 2 hwidth = (e - w) `div` 2 in case quad of @@ -116,22 +116,22 @@ 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 + = 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 + | isUnitExtent extent = Just [] - + | otherwise = do quad <- quadOfCoord extent coord rest <- pathToCoord (cutQuadOfExtent quad extent) coord @@ -149,17 +149,17 @@ -- | / | -- + | -- /------ --- / +-- / -- 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 @@ -169,7 +169,7 @@ | 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 @@ -178,7 +178,7 @@ -- must be starting inside extent. | otherwise = Nothing - + where n = fromIntegral n' s = fromIntegral s' e = fromIntegral e' diff --git a/Graphics/Gloss/Data/Quad.hs b/Graphics/Gloss/Data/Quad.hs --- a/Graphics/Gloss/Data/Quad.hs +++ b/Graphics/Gloss/Data/Quad.hs @@ -3,7 +3,7 @@ ( Quad(..) , allQuads) where - + -- | Represents a Quadrant in the 2D plane. data Quad = NW -- ^ North West diff --git a/Graphics/Gloss/Data/QuadTree.hs b/Graphics/Gloss/Data/QuadTree.hs --- a/Graphics/Gloss/Data/QuadTree.hs +++ b/Graphics/Gloss/Data/QuadTree.hs @@ -1,7 +1,7 @@ {-# 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 +-- 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 Graphics.Gloss.Data.QuadTree ( QuadTree (..) @@ -27,7 +27,7 @@ -- | 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 @@ -67,7 +67,7 @@ -- If the tree does not have an outer node then return the original tree. liftToQuad :: Quad - -> (QuadTree a -> QuadTree a) + -> (QuadTree a -> QuadTree a) -> QuadTree a -> QuadTree a liftToQuad quad f tree @@ -80,15 +80,15 @@ 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 @@ -112,7 +112,7 @@ lookupNodeByPath [] tree = Just tree - + lookupNodeByPath (q:qs) tree = case tree of TNil -> Nothing @@ -131,58 +131,58 @@ -- | Lookup a node if a tree given a coordinate which it contains. -lookupByCoord +lookupByCoord :: forall a . Extent -- ^ Extent that covers the whole tree. -> Coord -- ^ Coordinate of the value of interest. - -> QuadTree a + -> 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 +flattenQuadTree :: forall a . Extent -- ^ Extent that covers the whole tree. - -> QuadTree a + -> QuadTree a -> [(Coord, a)] - + flattenQuadTree extentInit treeInit = flatten' extentInit treeInit where flatten' extent tree = case tree of TNil -> [] - TLeaf x + TLeaf x -> let (_, s, _, w) = takeExtent extent in [((w, s), x)] TNode{} -> concat $ map (flattenQuad extent tree) allQuads - + flattenQuad extent tree quad = let extent' = cutQuadOfExtent quad extent Just tree' = takeQuadOfTree quad tree in flatten' extent' tree' --- | Flatten a QuadTree into a list of its contained values, with coordinates. +-- | Flatten a QuadTree into a list of its contained values, with extents. flattenQuadTreeWithExtents :: forall a . Extent -- ^ Extent that covers the whole tree. - -> QuadTree a + -> QuadTree a -> [(Extent, a)] - + flattenQuadTreeWithExtents extentInit treeInit = flatten' extentInit treeInit where flatten' extent tree = case tree of TNil -> [] - TLeaf x + TLeaf x -> [(extent, x)] TNode{} -> concat $ map (flattenQuad extent tree) allQuads - + flattenQuad extent tree quad = let extent' = cutQuadOfExtent quad extent Just tree' = takeQuadOfTree quad tree diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/gloss-algorithms.cabal b/gloss-algorithms.cabal --- a/gloss-algorithms.cabal +++ b/gloss-algorithms.cabal @@ -1,5 +1,5 @@ Name: gloss-algorithms -Version: 1.11.1.1 +Version: 1.12.0.0 License: MIT License-file: LICENSE Author: Ben Lippmeier @@ -17,18 +17,24 @@ Data structures and algorithms for working with 2D graphics. source-repository head - type: git - location: https://github.com/benl23x5/gloss + type: git + location: https://github.com/benl23x5/gloss +source-repository this + type: git + tag: v1.12.0.0 + location: https://github.com/benl23x5/gloss + Library - Build-Depends: - base >= 4.8 && < 4.10, - ghc-prim >= 0.4 && < 0.6, - containers == 0.5.*, - gloss == 1.11.* + Build-Depends: + base >= 4.8 && < 4.12 + , containers == 0.5.* + , ghc-prim + , gloss == 1.12.* ghc-options: - -O2 -Wall + -O2 + -Wall Exposed-modules: Graphics.Gloss.Algorithms.RayCast @@ -36,6 +42,4 @@ Graphics.Gloss.Data.Quad Graphics.Gloss.Data.QuadTree - Extensions: - DeriveDataTypeable - PatternGuards +-- vim: nospell