gloss-examples-1.0.0.0: Styrene/Main.hs

import Actor
import Advance
import QuadTree
import Contact
import Collide
import World
import Config

import Graphics.Gloss
import Graphics.Gloss.Geometry
import Graphics.Gloss.Shapes 

import qualified Data.Map	as Map
import Data.Map			(Map)

main 
  = 	simulateInWindow 
		"Polystyrene - right-click-drag rotates"
		(600, 600)	-- x and y size of window (in pixels).
		(10, 10)	-- position of window
		black		-- background color
		simResolution	-- simulation resolution  (number of steps to take for each second of time)
		worldInit	-- the initial world.
		drawWorld	-- a function to convert the world to a Picture.
		advanceWorld	-- a function to advance the world to the next simulation step.

-- Draw --------------------------------------------------------------------------------------------

-- | Draw this world as a picture.
drawWorld :: World -> Picture
drawWorld (World actors tree)
 = let 
	-- split the list of actors into beads and walls.
	--	this lets us draw all the beads at once without having to keep changing 
	--	the current color (which is a bit of a performance improvement)
	(beads, walls)	= splitActors $ Map.elems actors
   
	picBeads	= Color beadColor $ Pictures $ map drawActor beads
	picWalls	= Pictures $ map drawActor walls
	picTree		= drawQuadTree tree

   in 	Scale 0.8 0.8
	$ Pictures [picTree, picWalls, picBeads]


-- | Split actors into beads and walls
splitActors :: [Actor] -> ([Actor], [Actor])
splitActors as
	= splitActors' [] [] as

splitActors' accBeads accWalls []		
	= (accBeads, accWalls)

splitActors' accBeads accWalls (a : as) 	
 = case a of
 	Bead{}	-> splitActors' (a : accBeads) accWalls as
	Wall{}	-> splitActors' accBeads (a : accWalls) as


-- | Draw an actor as a picture.
drawActor :: Actor -> Picture 
drawActor actor 
 = case actor of
 	Bead ix mode radius p@(posX, posY) v@(velX, velY)
	 -> Translate posX posY $ Pictures [bead, vel]
	 where	bead 	= circleFilled radius 10
		vel	= if showBeadVelocity
				then Color red $ Line [(0, 0), mulSV 0.1 v]
				else Blank
{-		color
		 | mode >= beadStuckCount	= red
		 | otherwise			= beadColor
-}			
	Wall _ p1 p2
		-> Color (greyN 0.8) $ Line [p1, p2]


-- | Draw a quadtree as a picture
drawQuadTree :: QuadTree a -> Picture
drawQuadTree tree 
 = case tree of
	QNode p size tTL tTR tBL tBR
	 ->  Pictures
		[ drawQuadTree tTL 
		, drawQuadTree tTR
		, drawQuadTree tBL
		, drawQuadTree tBR
		, nodeBox p size nodeColor ]

	QLeaf p size elems
	 -> nodeBox p size leafColor
	 
	QNil (x0, y0) size
	 -> Blank

nodeBox p@(x0, y0) size color
 	= Color color
	$ Translate x0 y0
	$ rectangleWire (size*2) (size*2)


-- Make a circle of radius r consisting of n lines.
circleFilled :: Float -> Float -> Picture
circleFilled r n
 	= Scale r r
	$ Polygon (circlePoints n)
	
	
-- A list of n points spaced equally around the unit circle.
circlePoints :: Float -> [(Float, Float)]
circlePoints n
 =	map 	(\d -> (cos d, sin d))
		[0, 2*pi / n .. 2*pi]