gloss-algorithms (empty) → 1.9.2.1

raw patch · 7 files changed

+541/−0 lines, 7 filesdep +basedep +containersdep +ghc-primsetup-changed

Dependencies added: base, containers, ghc-prim, gloss

Files

• Graphics/Gloss/Algorithms/RayCast.hs +82/−0
• Graphics/Gloss/Data/Extent.hs +195/−0
• Graphics/Gloss/Data/Quad.hs +17/−0
• Graphics/Gloss/Data/QuadTree.hs +191/−0
• LICENSE +13/−0
• Setup.hs +2/−0
• gloss-algorithms.cabal +41/−0

@@ -0,0 +1,82 @@+{-# LANGUAGE PatternGuards, RankNTypes #-}++-- | Various ray casting algorithms.+module Graphics.Gloss.Algorithms.RayCast+	( castSegIntoCellularQuadTree+	, traceSegIntoCellularQuadTree)+where+import Graphics.Gloss.Data.Picture+import Graphics.Gloss.Data.Quad+import Graphics.Gloss.Data.Extent+import Graphics.Gloss.Data.QuadTree+import Data.List+import Data.Function+++-- | 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 ]+	+	_ -> []

@@ -0,0 +1,195 @@+{-# 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 Graphics.Gloss.Data.Extent+	( Extent+	, Coord+	, makeExtent+	, takeExtent+	, squareExtent+	, sizeOfExtent+	, isUnitExtent+	, coordInExtent+	, pointInExtent+	, centerCoordOfExtent+	, cutQuadOfExtent+	, quadOfCoord+	, pathToCoord+	, intersectSegExtent+	, touchesSegExtent)+where+import Graphics.Gloss.Data.Point+import Graphics.Gloss.Data.Quad+import Graphics.Gloss.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 "Graphics.Gloss.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)+

@@ -0,0 +1,17 @@++module Graphics.Gloss.Data.Quad+	( Quad(..)+	, allQuads)+where+	+-- | Represents a Quadrant in the 2D plane.+data Quad+	= NW 	-- ^ North West+	| NE 	-- ^ North East+	| SW 	-- ^ South West+	| SE	-- ^ South East+	deriving (Show, Eq, Enum)++-- | A list of all quadrants. Same as @[NW .. SE]@.+allQuads :: [Quad]+allQuads = [NW .. SE]

@@ -0,0 +1,191 @@+{-# 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 Graphics.Gloss.Data.QuadTree+	( QuadTree (..)+	, emptyTree+	, emptyNode+	, takeQuadOfTree+	, liftToQuad+	, insertByPath+	, insertByCoord+	, lookupNodeByPath+	, lookupByPath+	, lookupByCoord+	, flattenQuadTree+	, flattenQuadTreeWithExtents)+where+import Graphics.Gloss.Data.Quad+import Graphics.Gloss.Data.Extent++-- | 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{}+	 -> let Just quad	= takeQuadOfTree q tree+	    in  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+ 	 = 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.+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+ 	 = let	extent'		= cutQuadOfExtent quad extent+		Just tree'	= takeQuadOfTree quad tree+   	   in	flatten' extent' tree'++

@@ -0,0 +1,13 @@+Copyright (c) 2010-2014 Benjamin Lippmeier ++ 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+ condition:++ The above copyright notice and this permission notice shall be+ included in all copies or substantial portions of the Software.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,41 @@+Name:                gloss-algorithms+Version:             1.9.2.1+License:             MIT+License-file:        LICENSE+Author:              Ben Lippmeier+Maintainer:          benl@ouroborus.net+Build-Type:          Simple+Cabal-Version:       >=1.6+Stability:           stable+Category:            Graphics+Homepage:            http://gloss.ouroborus.net+Bug-reports:         gloss@ouroborus.net+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/benl23x5/gloss++Library+  Build-Depends: +        base       == 4.7.*,+        ghc-prim   == 0.3.*,+        containers == 0.5.*,+        gloss      == 1.9.2.*++  ghc-options:+        -O2 -Wall++  Exposed-modules:+        Graphics.Gloss.Algorithms.RayCast+        Graphics.Gloss.Data.Extent+        Graphics.Gloss.Data.Quad+        Graphics.Gloss.Data.QuadTree++  Extensions:+        DeriveDataTypeable+        PatternGuards