packages feed

gloss-examples 1.2.0.0 → 1.2.0.1

raw patch · 9 files changed

+557/−2 lines, 9 filesdep ~containersnew-component:exe:gloss-visibility

Dependency ranges changed: containers

Files

+ Visibility/Array.hs view
@@ -0,0 +1,7 @@++module Array+	( Array+	, module Data.Vector.Unboxed)+where+import Data.Vector.Unboxed+type Array	= Vector
+ Visibility/Draw.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE PatternGuards #-}+module Draw+	( drawState+	, drawWorld)+where+import State+import World+import Geometry.Segment+import Graphics.Gloss+import Graphics.Gloss.Geometry.Line+import qualified Array		as A+import Array			(Array)+import Data.Maybe+++drawState :: State -> Picture+drawState state+ 	| ModeDisplayWorld 	<- stateModeDisplay state+ 	= drawWorldWithViewPos +		(stateModeOverlay state)+		(stateViewPos     state) +		(stateTargetPos   state)+		(stateWorld       state)++	| ModeDisplayNormalised <- stateModeDisplay state+	= drawWorldWithViewPos +		(stateModeOverlay state)+		(0, 0) +		Nothing+		$ normaliseWorld (stateViewPos state)+		$ stateWorld state++	| otherwise+	= Blank+	++drawWorldWithViewPos :: ModeOverlay -> Point -> Maybe Point -> World -> Picture+drawWorldWithViewPos +	modeOverlay+	pView@(vx, vy) +	mTarget+	world+ = let	+	-- the world +	picWorld	= Color white+			$ drawWorld world++	-- view position indicator+	picView		= Color red+			$ Translate vx vy+			$ ThickCircle 2 4++	-- target position indicator+	picTargets+		| Just pTarget@(px, py) <- mTarget+		= let	picTarget	= Translate px py $ ThickCircle 2 4++			-- line between view and target pos+			picLine		= Line [pView, pTarget]+			+			picSegsHit	= Pictures+					$ [ Line [p1, p2]+						| (_, p1, p2)	<- A.toList $ worldSegments world+						, isJust $ intersectSegSeg p1 p2 pView pTarget ]+	   	  in	Color red $ Pictures [picTarget, picLine, picSegsHit]++		| otherwise+		= blank++	-- overlay+	picOverlay+		| ModeOverlayVisApprox	<- modeOverlay+		= drawVisGrid 10 pView world++		| otherwise+		= blank++   in	Pictures [picOverlay, picWorld, picView, picTargets]+++-- | Draw a grid of points showing what is visible from a view position+drawVisGrid :: Float -> Point -> World -> Picture+drawVisGrid cellSize pView world+ = let	+	visible pTarget	= not $ any isJust+			$ map (\(_, p1, p2) -> intersectSegSeg pView pTarget p1 p2)+			$ A.toList +			$ worldSegments world+			+	picGrid		= Pictures+			$ [ if visible (x, y) +				then Color (dim green) $ Translate x y $ rectangleSolid cellSize cellSize+				else Color (greyN 0.2) $ Translate x y $ rectangleSolid cellSize cellSize+				| x	<- [-400, -400 + cellSize .. 400]+				, y	<- [-400, -400 + cellSize .. 400] ]++   in	picGrid+++-- | Draw the segments in the world.+drawWorld :: World -> Picture+drawWorld world+	= drawSegments+	$ worldSegments world+++-- | Draw an array of segments.+drawSegments :: Array Segment -> Picture+drawSegments segments+	= Pictures+	$ map drawSegment+	$ A.toList +	$ segments+++-- | Draw a single segment.+drawSegment :: Segment -> Picture+drawSegment (_, (x1, y1), (x2, y2))+	= Line [(f x1, f y1), (f x2, f y2)]+	where	f	= fromRational . toRational+
+ Visibility/Geometry/Randomish.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE BangPatterns #-}++module Geometry.Randomish+ 	( randomishPoints +	, randomishInts+	, randomishDoubles)+where+import Data.Word+import qualified Array				as A+import qualified Data.Vector.Generic		as G+import qualified Data.Vector.Unboxed.Mutable	as MV+import Array					(Array)++-- | Some uniformly distributed points+randomishPoints+	:: Int			-- ^ seed+	-> Int			-- ^ number of points+	-> Float		-- ^ minimum coordinate+	-> Float		-- ^ maximum coordinate+        -> Array (Float, Float)++randomishPoints seed' n pointMin pointMax+ = let  pts      = randomishFloats (n*2) pointMin pointMax seed'+        xs       = G.slice 0 n pts+        ys       = G.slice n n pts+   in   A.zip xs ys+++-- | Use the "minimal standard" Lehmer generator to quickly generate some random+--   numbers with reasonable statistical properties. By "reasonable" we mean good+--   enough for games and test data, but not cryptography or anything where the+--   quality of the randomness really matters.+-- +--   From "Random Number Generators: Good ones are hard to find"+--   Stephen K. Park and Keith W. Miller.+--   Communications of the ACM, Oct 1988, Volume 31, Number 10.+--+randomishInts +	:: Int 			-- Length of vector.+	-> Int 			-- Minumum value in output.+	-> Int 			-- Maximum value in output.+	-> Int 			-- Random seed.	+	-> Array Int		-- Vector of random numbers.++randomishInts !len !valMin' !valMax' !seed'+	+ = let	-- a magic number (don't change it)+	multiplier :: Word64+	multiplier = 16807++	-- a merzenne prime (don't change it)+	modulus	:: Word64+	modulus	= 2^(31 :: Integer) - 1++	-- if the seed is 0 all the numbers in the sequence are also 0.+	seed	+	 | seed' == 0	= 1+	 | otherwise	= seed'++	!valMin	= fromIntegral valMin'+	!valMax	= fromIntegral valMax' + 1+	!range	= valMax - valMin++	{-# INLINE f #-}+	f x		= multiplier * x `mod` modulus+ in G.create +     $ do	+	vec		<- MV.new len++	let go !ix !x +	  	| ix == len	= return ()+		| otherwise+		= do	let x'	= f x+			MV.write vec ix $ fromIntegral $ (x `mod` range) + valMin+			go (ix + 1) x'++	go 0 (f $ f $ f $ fromIntegral seed)+	return vec+++-- | Generate some randomish doubles with terrible statistical properties.+--   This is good enough for test data, but not much else.+randomishDoubles +	:: Int			-- Length of vector+	-> Double		-- Minimum value in output+	-> Double		-- Maximum value in output+	-> Int			-- Random seed.+	-> Array Double		-- Vector of randomish doubles.++randomishDoubles !len !valMin !valMax !seed+ = let	range	= valMax - valMin++	mx	= 2^(30 :: Integer) - 1+	mxf	= fromIntegral mx+	ints	= randomishInts len 0 mx seed+	+   in	A.map (\n -> valMin + (fromIntegral n / mxf) * range) ints+++-- | Generate some randomish doubles with terrible statistical properties.+--   This is good enough for test data, but not much else.+randomishFloats+	:: Int			-- Length of vector+	-> Float		-- Minimum value in output+	-> Float		-- Maximum value in output+	-> Int			-- Random seed.+	-> Array Float		-- Vector of randomish doubles.++randomishFloats !len !valMin !valMax !seed+ = let	range	= valMax - valMin++	mx	= 2^(30 :: Integer) - 1+	mxf	= fromIntegral mx+	ints	= randomishInts len 0 mx seed+	+   in	A.map (\n -> valMin + (fromIntegral n / mxf) * range) ints
+ Visibility/Geometry/Segment.hs view
@@ -0,0 +1,82 @@++module Geometry.Segment+	( Segment+	, translateSegment+	, splitSegmentsOnY+	, splitSegmentsOnX+	, chooseSplitX)+where+import Graphics.Gloss+import Graphics.Gloss.Geometry.Line+import Data.Maybe+import Data.Function+import qualified Array		as A+import Array			(Array)++-- | A line segement in the 2D plane.+type Segment	= (Int, (Float, Float), (Float, Float))+++-- | Translate both endpoints of a segment.+translateSegment :: Float -> Float -> Segment -> Segment+translateSegment tx ty (n, (x1, y1), (x2, y2))+	= (n, (x1 + tx, y1 + ty), (x2 + tx, y2 + ty))+	++-- | Split segments that cross the line y = y0, for some y0.+splitSegmentsOnY :: Float -> Array Segment -> Array Segment+splitSegmentsOnY y0 segs+ = let	+	-- TODO: we only need to know IF the seg crosse the line here,+	--       not the actual intersection point. Do a faster test.+	(segsCross, segsOther)+		= A.unstablePartition +			(\(_, p1, p2) -> isJust $ intersectSegHorzLine p1 p2 y0)+			segs++	-- TODO: going via lists here is bad.+	splitCrossingSeg :: Segment -> Array Segment+	splitCrossingSeg (n, p1, p2)+	 = let	Just pCross	= intersectSegHorzLine p1 p2 y0+	   in	A.fromList [(n, p1, pCross), (n, pCross, p2)]+	+	-- TODO: vector append requires a copy.	+   in	segsOther A.++ (A.concat $ map splitCrossingSeg $ A.toList segsCross)+++-- | Split segments that cross the line x = x0, for some x0.+splitSegmentsOnX :: Float -> Array Segment -> Array Segment+splitSegmentsOnX x0 segs+ = let	+	-- TODO: we only need to know IF the seg crosse the line here,+	--       not the actual intersection point. Do a faster test.+	(segsCross, segsOther)+		= A.unstablePartition +			(\(_, p1, p2) -> isJust $ intersectSegVertLine p1 p2 x0)+			segs++	-- TODO: going via lists here is bad.+	splitCrossingSeg :: Segment -> Array Segment+	splitCrossingSeg (n, p1, p2)+	 = let	Just pCross	= intersectSegVertLine p1 p2 x0+	   in	A.fromList [(n, p1, pCross), (n, pCross, p2)]+	+	-- TODO: vector append requires a copy.	+   in	segsOther A.++ (A.concat $ map splitCrossingSeg $ A.toList segsCross)+++-- | Decide where to split the plane.+--   TODO: We're just taking the first point of the segment in the middle of the vector.+--	It might be better to base the split on:+--	 - the closest segment+--	 - the widest sgement+--	 - the one closes to the middle of the field.+--       - some combination of above.+--+chooseSplitX :: Array Segment -> Float+chooseSplitX segments+ = let	Just (_, (x1, _), _)	= segments A.!? (A.length segments `div` 2)+   in	x1+++
+ Visibility/Interface.hs view
@@ -0,0 +1,72 @@++module Interface+	( handleInput+	, stepState)+where+import State+import qualified Graphics.Gloss.Interface.Game	as G++-- Input ------------------------------------------------------------------------------------------+-- | Handle an input event.+handleInput :: G.Event -> State -> State++handleInput (G.EventKey key keyState _ (x, y)) state+	-- move the view position.+	| G.MouseButton G.LeftButton	<- key+	, G.Down			<- keyState+	= state	{ stateModeInterface	= ModeInterfaceMove +		, stateViewPos+			= ( fromRational $ toRational x+			  , fromRational $ toRational y) }++	-- set the target position.+	| G.MouseButton G.RightButton	<- key+	, G.Down			<- keyState+	= state	{ stateTargetPos+			= Just ( fromRational $ toRational x+			       , fromRational $ toRational y) }++	| G.MouseButton G.LeftButton	<- key+	, G.Up				<- keyState+	= state	{ stateModeInterface	= ModeInterfaceIdle }++handleInput (G.EventMotion (x, y)) state+	| stateModeInterface state == ModeInterfaceMove+	= state { stateViewPos+			= ( fromRational $ toRational x+			  , fromRational $ toRational y) }++-- t : Turn target indicator off.+handleInput (G.EventKey key keyState _ _) state+	| G.Char 't'			<- key+	, G.Down			<- keyState+	= state	{ stateTargetPos	= Nothing }++-- w : Display the whole world.+handleInput (G.EventKey key keyState _ _) state+	| G.Char 'w'			<- key+	, G.Down			<- keyState+	= state	{ stateModeDisplay	= ModeDisplayWorld }++-- n : Display the normalised world.+handleInput (G.EventKey key keyState _ _) state+	| G.Char 'n'			<- key+	, G.Down			<- keyState+	= state	{ stateModeDisplay	= ModeDisplayNormalised }++-- a : Toggle approximate visibility+handleInput (G.EventKey key keyState _ _) state+	| G.Char 'a'			<- key+	, G.Down			<- keyState+	= state { stateModeOverlay+			= case stateModeOverlay state of+				ModeOverlayVisApprox	-> ModeOverlayNone+				_			-> ModeOverlayVisApprox }	++handleInput _ state+	= state++-- Step -------------------------------------------------------------------------------------------+-- | Advance the state one iteration+stepState :: Float -> State -> State+stepState _ state = state
+ Visibility/Main.hs view
@@ -0,0 +1,34 @@++-- | Visibility on the 2D plane.+--   Uses an instance of Warnocks algorithm.+--   TODO: animate the line segments, make them spin and move around so we can see+--         that it's a dynamic visiblity algorithm -- not pre-computed.+--         Draw lines in random shades of color depending on the index.+--         Make a key to swap between rectangular and polar projections.+--         Allow viewpoint to be set with the mouse.+--+--  TODO:  To start with just do brute force visibility by dividing field into cells+--	   and doing vis based on center point of cell.+--++import Interface+import Draw+import State+import World+import Graphics.Gloss.Interface.Game++main :: IO ()+main+ = do	world		<- initialWorld+	let state	=  initialState world+	+	gameInWindow+		"Visibility"+		(800, 800)+		(10,  10)+		black+		100+		state+		drawState+		handleInput+		stepState
+ Visibility/State.hs view
@@ -0,0 +1,59 @@++-- | Game state+module State where+import Graphics.Gloss+import World+++-- | The game state.+data State+	= State+	{ stateWorld		:: World+	, stateModeInterface	:: ModeInterface+	, stateModeDisplay	:: ModeDisplay+	, stateModeOverlay	:: ModeOverlay+	, stateViewPos		:: Point +	, stateTargetPos	:: Maybe Point }+++-- | What mode the interface interaction is in.+data ModeInterface+	-- | We're not doing anything inparticular.+	= ModeInterfaceIdle++	-- | We're moving the view position.+	| ModeInterfaceMove+	deriving (Show, Eq)+++-- | What mode the display is in.+data ModeDisplay+	-- | Show the world in rectangular coordinates.+	= ModeDisplayWorld++	-- | Show the world normalised so the view position is at the origin.+	| ModeDisplayNormalised+	deriving (Show, Eq)+++-- | What overlay to display.+data ModeOverlay+	-- | No overlay+	= ModeOverlayNone+	+	-- | Brute force, approximate visibility+	| ModeOverlayVisApprox+	deriving (Show, Eq)+++-- | Initial game state.+initialState :: World -> State+initialState world+	= State+	{ stateWorld		= world+	, stateModeInterface	= ModeInterfaceIdle+	, stateModeDisplay	= ModeDisplayWorld+	, stateModeOverlay	= ModeOverlayVisApprox+	, stateViewPos		= (0, 0) +	, stateTargetPos	= Nothing }+
+ Visibility/World.hs view
@@ -0,0 +1,55 @@++module World+	( Segment+	, World(..)+	, initialWorld+	, normaliseWorld)+where+import Graphics.Gloss+import Geometry.Randomish+import Geometry.Segment+import qualified Array	as A+import Array		(Array)+++-- We keep this unpacked so we can use unboxed vector.+-- index, x1, y1, x2, y2+data World +	= World+	{ worldSegments	:: Array Segment }+++-- | Generate the initial world.+initialWorld :: IO World+initialWorld+ = do	let n		= 100+	let minZ	= -300+	let maxZ	= 300+	+	let minDelta	= -100+	let maxDelta	=  100+	+	let centers	= randomishPoints 1234 n minZ     maxZ+	let deltas	= randomishPoints 4321 n minDelta maxDelta++	let makePoint n' (cX, cY) (dX, dY)+			= (n', (cX, cY), (cX + dX, cY + dY))++	let segs	= A.zipWith3 makePoint (A.enumFromTo 0 (n - 1)) centers deltas+	+	return $ World segs+++-- | Normalise the world so that the given point is at the origin,+--   and split segements that cross the y=0 line.+normaliseWorld :: Point -> World -> World +normaliseWorld (px, py) world+ = let	segments_trans	= A.map (translateSegment (-px) (-py)) +			$ worldSegments world+			+	segments_split	= splitSegmentsOnY 0 segments_trans+			+   in	world { worldSegments = segments_split }+++
gloss-examples.cabal view
@@ -1,5 +1,5 @@ Name:                gloss-examples-Version:             1.2.0.0+Version:             1.2.0.1 License:             MIT License-file:        LICENSE Author:              Ben Lippmeier@@ -69,7 +69,7 @@   Build-depends:          base            == 4.*,         gloss           == 1.2.*,-        containers      == 0.3.*,+        containers      >= 0.3 && <= 0.5,         ghc-prim        == 0.2.*   Main-is: Main.hs   other-modules: Actor Advance Collide Config Contact QuadTree World@@ -114,4 +114,13 @@   Main-is: Main.hs   other-modules: Cell World State Data   hs-source-dirs: Occlusion+  ghc-options: -O2++Executable gloss-visibility+  Build-depends: +        base            == 4.*, +        gloss           == 1.2.*+  Main-is: Main.hs+  other-modules: Array Draw Interface State World Geometry.Randomish Geometry.Segment+  hs-source-dirs: Visibility    ghc-options: -O2