packages feed

gloss-examples (empty) → 1.0.0.0

raw patch · 25 files changed

+1532/−0 lines, 25 filesdep +basedep +containersdep +ghc-primsetup-changed

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

Files

+ Clock/Main.hs view
@@ -0,0 +1,92 @@++-- A fractal consisting of circles and lines which looks a bit like+--	the workings of a clock.+import Graphics.Gloss++main+ =	animateInWindow+ 		"Clock"+		(600, 600)+		(20, 20)+		black+		frame+++-- Build the fractal, scale it so it fits in the window+-- and rotate the whole thing as time moves on.+frame :: Float -> Picture+frame	time+ 	= Color white+	$ Scale 120 120+	$ Rotate (time * 2*pi)+	$ clockFractal 5 time+		++-- The basic fractal consists of three circles offset from the origin+-- as follows.+--+--   	   1+--         |+--         .+--       /   \+--      2     3+--+-- The direction of rotation switches as n increases.+-- Components at higher iterations also spin faster.+--+clockFractal :: Int -> Float -> Picture+clockFractal 0 s	= Blank+clockFractal n s	= Pictures [circ1, circ2, circ3, lines]+ where+ 	-- y offset from origin to center of circle 1.+	a	= 1 / sin (2 * pi / 6)++	-- x offset from origin to center of circles 2 and 3.+ 	b	= a * cos (2 * pi / 6)++	nf	= fromIntegral n+	rot	= if n `mod` 2 == 0+			then   50 * s * (log (1 + nf))+			else (-50 * s * (log (1 + nf)))++	-- each element contains a copy of the (n-1) iteration contained+	--	within a larger circle, and some text showing the time since +	--	the animation started.+	--+	circNm1 +	 = Pictures+		[ circle 1 50+		, Scale (a/2.5) (a/2.5) $ clockFractal (n-1) s+		, if n > 2+		    then Color cyan	+				$ Translate (-0.15) 1+				$ Scale 0.001 0.001 +				$ Text (show s) +		    else Blank+		]++	circ1	= Translate 0 a		$ Rotate rot	circNm1+	circ2 	= Translate 1 (-b)	$ Rotate (-rot)	circNm1+	circ3	= Translate (-1) (-b)	$ Rotate rot	circNm1+	+	-- join each iteration to the origin with some lines.+	lines	+	 = Pictures+		[ Line [(0, 0), ( 0,  a)]+		, Line [(0, 0), ( 1, -b)]+		, Line [(0, 0), (-1, -b)] ]+++-- Make a circle of radius r consisting of n lines.+circle :: Float -> Float -> Picture+circle r n+ 	= Scale r r+	$ Line (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]+
+ Easy/Main.hs view
@@ -0,0 +1,3 @@++import Graphics.Gloss+main = displayInWindow "My Window" (200, 200) (10, 10) white (Circle 80)
+ Eden/Cell.hs view
@@ -0,0 +1,38 @@+module Cell where++import Graphics.Gloss++data Cell +	= Cell	Point    -- centre+             	Float    -- radius+		Int	+              	deriving Show++-- Produce a new cell of a certain relative radius at a certain angle.+-- 	The factor argument is in the range [0..1] so spawned cells are+-- 	smaller than their parent.+-- The check whether it fits in the community is elsewhere.+offspring :: Cell -> Float -> Float -> Cell+offspring (Cell (x,y) r gen) alpha factor +	= Cell 	(x + (childR+r) * cos alpha, y + (childR+r) * sin alpha) +		childR +		(gen + 1)++    	where childR = factor * r++-- Do two cells overlap?         +-- Used to decide if newly spawned cells can join the community.+overlap :: Cell -> Cell -> Bool+overlap (Cell (x1,y1) r1 _) (Cell (x2,y2) r2 _) +	= centreDist < (r1 + r2) * 0.999+    	where 	centreDist = sqrt(xdiff*xdiff + ydiff*ydiff)+          	xdiff = x1 - x2+          	ydiff = y1 - y2++render :: Cell -> Picture+render (Cell (x,y) r gen) + = let 	z	= fromIntegral gen * 0.1+	color	= makeColor 0.0 z 0.5 1.0+   in	Color color+		$ Translate x y+		$ Circle r
+ Eden/Community.hs view
@@ -0,0 +1,55 @@+module Community where++import Cell+import Graphics.Gloss++type Community = [Cell]++-- does a (newly spawned) cell fit in the community?+-- that is, does it overlap with any others?+fits :: Cell -> Community -> Bool+fits cell cells +	= not $ any (overlap cell) cells++-- For each member of a community, produce one offspring+-- The lists of Floats are the (random) parameters that determine size+-- and location of each offspring.+spawn :: Community -> [Float] -> [Float] -> [Cell]+spawn 	= zipWith3 offspring++-- Given a collection of cells (one spawned by each member of the+-- community) check if it fits, and if so add it to the community.+-- That check must include new cells that have been added to the+-- community in this process.+survive :: [Cell] -> Community -> Community+survive [] comm = comm+survive (cell:cells) comm+	| fits cell comm  = survive cells (cell:comm)+	| otherwise       = survive cells comm++-- The next generation of a community+generation :: Community ->  [Float] -> [Float] -> Community+generation comm angles scales +	= survive (spawn comm angles scales) comm++render :: Community -> Picture+render comm +	= Pictures $ map Cell.render comm++initial :: Community+initial = [Cell (0,0) 50 0]+++-- thread the random lists for testing outside IO()+--+life :: Community -> [Float] -> [Float] -> (Community, [Float], [Float])+life comm randomAngles randomScales =+    (generation comm angles scales, randomAngles', randomScales')+    where population = length comm+          (angles, randomAngles') = splitAt population randomAngles+          (scales, randomScales') = splitAt population randomScales++evolution :: Community -> [Float] -> [Float] -> [Community]+evolution comm randomAngles randomScales = comm1 : comms+    where (comm1, ras, rss) = life comm randomAngles randomScales+          comms = evolution comm1 ras rss
+ Eden/Main.hs view
@@ -0,0 +1,21 @@++-- Adapted from ANUPlot version by Clem Baker-Finch+module Main where+import World+import Graphics.Gloss+import System.Random++-- varying prng sequence+main + = do 	gen <- getStdGen+	simulateInWindow+		"Eden"          -- window name+		(800, 600)      -- window size+		(10, 10)	-- window position+		(greyN 0.1)	-- background color+		2               -- number of steps per second+		(genesis' gen)  -- initial world+		render          -- function to convert world to a Picture+		evolve          -- function to step the world one iteration++
+ Eden/World.hs view
@@ -0,0 +1,47 @@+module World where+++import Graphics.Gloss+import System.Random+import Community+import Cell++maxSteps	= 30++-- The World consists of a Community and a random number generator.+-- (The RNG is a model of chaos or hand-of-god.)+data World +	= World Community StdGen Int+	deriving (Show)++-- The initial world+genesis :: World+genesis +	= World [Cell (0,0) 30 0] (mkStdGen 1023) 0++-- Seeding the prng means every run is identical.+-- To get different runs, need to use gen <- getStdGen in main :: IO()+-- and pass gen in as an argument.  Edit Main.hs accordingly.+genesis' :: StdGen -> World+genesis' gen +	= World [Cell (0,0) 30 0] gen 0+++-- Consume some random numbers to advance the simulation+evolve :: ViewPort -> Float -> World -> World+evolve vp step world@(World comm gen steps) +	| steps < maxSteps	+	= let	(genThis, genNext) = split gen+          	(genA, genS)       = split genThis+          	angles             = randomRs (0.0, 2*pi) genA+          	scales             = randomRs (0.7, 0.9) genS+    	  in  	World (generation comm angles scales) genNext (steps + 1)++	| otherwise+	= world++-- Converting the world to a picture is just converting the community component+render :: World -> Picture+render (World comm gen steps) +	= Color (makeColor 0.3 0.3 0.6 1.0)+	$ Community.render comm
+ Flake/Main.hs view
@@ -0,0 +1,50 @@++-- | Snowflake Fractal.+--	Based on ANUPlot code by Clem Baker-Finch.+--+import Graphics.Gloss++main =	displayInWindow+       		"Snowflake"+       		(500, 500)+       		(20,  20)+		black+       		(picture 3)+++-- Fix a starting edge length of 360+edge = 360 :: Float+++-- Move the fractal into the center of the window and colour it nicely+picture :: Int -> Picture+picture degree +	= Color aquamarine+	$ Translate (-edge/2) (-edge * sqrt 3/6)+	$ snowflake degree+	++-- The fractal function+side :: Int -> Picture+side 0 = Line [(0, 0), (edge, 0)]+side n + = let	newSide = Scale (1/3) (1/3) +		$ side (n-1)+   in	Pictures+		[ newSide+		, Translate (edge/3) 0 			  $ Rotate 60    newSide +		, Translate (edge/2) (-(edge * sqrt 3)/6) $ Rotate (-60) newSide +		, Translate (2 * edge/3) 0		  $ newSide ]+++-- Put 3 together to form the snowflake+snowflake :: Int -> Picture+snowflake n + = let	oneSide	= side n+   in 	Pictures+		[ oneSide +		, Translate edge 0 			$ Rotate (-120) $ oneSide+		, Translate (edge/2) (edge * sqrt 3/2)	$ Rotate 120	$ oneSide]+++
+ Hello/Main.hs view
@@ -0,0 +1,16 @@++-- | Display "Hello World" in a window.+--+import Graphics.Gloss++main 	= displayInWindow +		"Hello World" 		-- window title+		(400, 150) 		-- window size+		(10, 10) 		-- window position+		white			-- background color+		picture			-- picture to display++picture	+	= Translate (-170) (-20) 	-- shift the text to the middle of the window+	$ Scale 0.5 0.5			-- display it half the original size+	$ Text "Hello World"		-- text to display
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright (c) 2010 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.
+ Lifespan/Cell.hs view
@@ -0,0 +1,36 @@+module Cell where++import Graphics.Gloss++data Cell = Cell Point    -- centre+                 Float    -- radius+                 Int      -- remaining lifetime+                 deriving Show++-- Produce a new cell of a certain relative radius at a certain angle.+-- The factor argument is in the range [0..1] so spawned cells are+-- smaller than their parent.+-- The check whether it fits in the community is elsewhere.+offspring :: Cell -> Float -> Float -> Int -> Cell+offspring (Cell (x,y) r _) alpha factor lifespan =+    Cell (x + (childR+r) * cos alpha, y + (childR+r) * sin alpha)+         childR +         lifespan+    where childR = factor * r++-- Do two cells overlap?         +-- Used to decide if newly spawned cells can join the community.+overlap :: Cell -> Cell -> Bool+overlap (Cell (x1,y1) r1 _) (Cell (x2,y2) r2 _) = centreDist < (r1 + r2) *0.999+    where centreDist = sqrt(xdiff*xdiff + ydiff*ydiff)+          xdiff = x1 - x2+          ydiff = y1 - y2++-- thickness of circle is determined by lifespan+render :: Cell -> Picture+render (Cell (x,y) r life) +	= Color (makeColor 0.6 z 0.6 1.0)+	$ Translate x y+	$ ThickCircle (r - thickness / 2) thickness+	where	z 		= fromIntegral life * 0.12+		thickness	= fromIntegral life
+ Lifespan/Community.hs view
@@ -0,0 +1,58 @@+module Community where++import Cell+import Graphics.Gloss++type Community = [Cell]++-- does a (newly spawned) cell fit in the community?+-- that is, does it overlap with any others?+fits :: Cell -> Community -> Bool+fits cell cells = not $ any (overlap cell) cells++-- For each member of a community, produce one offspring+-- The lists of Floats are the (random) parameters that determine size++-- and location of each offspring.+spawn :: Community -> [Float] -> [Float] -> [Int] -> [Cell]+spawn = zipWith4 offspring++zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]+zipWith4 f [] _ _ _ = []+zipWith4 f _ [] _ _ = []+zipWith4 f _ _ [] _ = []+zipWith4 f _ _ _ [] = []+zipWith4 f (b:bs) (c:cs) (d:ds) (e:es) =+    f b c d e : zipWith4 f bs cs ds es+++-- Given a collection of cells (one spawned by each member of the+-- community) check if it fits, and if so add it to the community.+-- That check must include new cells that have been added to the+-- community in this process.+survive :: [Cell] -> Community -> Community+survive [] comm = comm+survive (cell:cells) comm+    | fits cell comm  = survive cells (cell:comm)+    | otherwise       = survive cells comm++age :: Community -> Community+age [] = []+age (Cell c r 0 : cells) = age cells+age (Cell c r life : cells) = Cell c r (life-1) : age cells+++-- The next generation of a community+generation :: Community ->  [Float] -> [Float] -> Community+generation comm angles scales =+    survive (spawn comm angles scales (repeat 5)) (age comm)++render :: Community -> Picture+render comm +	= Pictures +	$ map Cell.render comm++initial :: Community+initial = [Cell (0,0) 50 5]++
+ Lifespan/Main.hs view
@@ -0,0 +1,22 @@++-- Adapted from ANUPlot version by Clem Baker-Finch+module Main where+import World+import Graphics.Gloss+import System.Random++-- varying prng sequence+main + = do 	gen <- getStdGen+	simulateInWindow+		"Lifespan"          -- window name+		(800, 600)      -- window size+		(10, 10)	-- window position+		(greyN 0.1)	-- background color+		2               -- number of steps per second+		(genesis' gen)  -- initial world+		render          -- function to convert world to a Picture+		evolve          -- function to step the world one iteration+++
+ Lifespan/World.hs view
@@ -0,0 +1,43 @@+module World where++import Graphics.Gloss+import System.Random+import Community+import Cell++stepsMax	= 20++-- The World consists of a Community and a random number generator.+-- (The RNG is a model of chaos or hand-of-god.)+data World +	= World Community StdGen Int+        deriving (Show)++-- The initial world+genesis :: World+genesis +	= World [Cell (0,0) 50 5] (mkStdGen 1023) 0++-- Seeding the prng means every run is identical.+-- To get different runs, need to use gen <- getStdGen in main :: IO()+-- and pass gen in as an argument.  Edit Main.hs accordingly.+genesis' :: StdGen -> World+genesis' gen +	= World [Cell (0,0) 50 5] gen 0++-- Consume some random numbers to advance the simulation+evolve :: ViewPort -> Float -> World -> World+evolve _ _ world@(World comm gen step) + 	| step > stepsMax	= world+	| otherwise+	= World (generation comm angles scales) genNext (step + 1)+    	where	(genThis, genNext) = split gen+          	(genA, genS)       = split genThis+		angles             = randomRs (0.0, 2*pi) genA+		scales             = randomRs (0.7, 0.9) genS++-- Converting the world to a picture is just converting the community component+render :: World -> Picture+render (World comm gen _) +	= Color (makeColor 0.3 0.3 0.6 1.0)+	$ Community.render comm
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Styrene/Actor.hs view
@@ -0,0 +1,73 @@++module Actor where++-- | 2D position on the screen.+type Position	= (Float, Float)++-- | Force and velocity vectors.+type Force	= (Float, Float)+type Velocity	= (Float, Float)++-- | Time in seconds+type Time	= Float++-- | Radius of a bead+type Radius	= Float++-- | Each actor has its own unique index.+type Index	= Int++-- | The actors in the world.+data Actor+	= Wall 	!Index 		-- ^ unique index of this actor+		!Position 	-- ^ wall starting point+		!Position	-- ^ wall ending point++	| Bead 	!Index 		-- ^ unique index of this actor +		!Int 		-- ^ whether the bead is stuck+		!Radius 	-- ^ radius of bead+		!Position 	-- ^ position of bead+		!Velocity	-- ^ velocity of bead++	deriving Show++-- | Equality and ordering of actors will consider their index only.+--	We need Ord so we can put them in Maps and Sets.+instance Eq Actor where+ a1 == a2	= actorIx a1 == actorIx a2+	+instance Ord Actor where+ compare a1 a2	= compare (actorIx a1) (actorIx a2)++-- | Check whether an actor is a bead.+isBead :: Actor -> Bool+isBead (Bead _ _ _ _ _)	= True+isBead _		= False+++-- | Check whether an actor is a wall.+isWall :: Actor -> Bool+isWall (Wall _ _ _)	= True+isWall _		= False+++-- | Take the index of an actor+actorIx :: Actor -> Index+actorIx actor+ = case actor of+	Wall ix _ _	-> ix+ 	Bead ix _ _ _ _	-> ix+++-- | Set the index of an actor+actorSetIndex :: Actor -> Index -> Actor+actorSetIndex actor ix+ = case actor of+ 	Bead _ m r pos vel 	-> Bead ix m r pos vel +	Wall _ p1 p2		-> Wall ix p1 p2+++-- | Set whether a bead is stuck+actorSetMode :: Int -> Actor -> Actor+actorSetMode m (Bead ix _ r p v)+	= Bead ix m r p v
+ Styrene/Advance.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE PatternGuards #-}++-- | Advance the world to the next time step.+module Advance where+import World+import Contact+import QuadTree+import Collide+import Actor+import Config++import Graphics.Gloss.Geometry+import Graphics.Gloss.ViewPort+import Graphics.Gloss.Picture	(Point)++import Data.List+import qualified Data.Map	as Map+import qualified Data.Set	as Set+import Data.Set			(Set)+import Data.Map			(Map)+++-- Advance -------------------------------------------------------------------------------------------++-- | Advance all the actors in this world by a certain time.+advanceWorld +	:: ViewPort 		-- ^ current viewport+	-> Time 		-- ^ time to advance them for.+	-> World 		-- ^ the world to advance.+	-> World 		-- ^ the new world.++advanceWorld viewport time (World actors tree)+ = let	+ 	rot		= viewPortRotate viewport+	force		= rotateV (degToRad $ negate rot) (0, negate gravityCoeff)++	-- move all the actors +	actors_moved	= Map.map (moveActor_free time force) actors+      +      	-- find contacts in the world+	(contacts, tree')	+		= findContacts (World actors_moved tree)++	-- apply contacts to each pair of actors+	actors_bounced	+		= Set.fold +			(applyContact time force) +			actors_moved+			contacts++   in	World actors_bounced tree'+++-- Move two actors which are known to be in contact.+applyContact +	:: Time 		-- ^ time step+	-> Force 		-- ^ ambient force on the actors+	-> (Index, Index) 	-- ^ indicies of the the two actors in contact+	-> Map Index Actor 	-- ^ the old world+	-> Map Index Actor	-- ^ the new world++applyContact time force (ix1, ix2) actors+ = let	-- use the indicies to lookup the data for each actor from the map+	Just a1	= Map.lookup ix1 actors+ 	Just a2	= Map.lookup ix2 actors+	+	resultActors+		-- handle a collision between bead and a wall+		| Bead _ _ r1 p1 v1	<- a1+		, Wall{}		<- a2+		= let	a1'		= collideBeadWall a1 a2+		  in	Map.insert ix1 a1' actors+		+		-- handle a collision between two beads+		| Bead ix1 m1 r1 p1 v1	<- a1+		, Bead ix2 m2 r2 p2 v2	<- a2+		= let	+			(a1', a2')+				-- if one of the beads is stuck then do a safer, static collision.+				--	with this method the beads don't transfer energy into each other+				--	so there is less of a chance of lots of beads being crushed together+				--	if there are many in the same place.+				| m1 >= beadStuckCount || m2 >= beadStuckCount+				= let 	a1'	= collideBeadBead_static a1 a2+			  		a2'	= collideBeadBead_static a2 a1+			  	  in	(a1', a2')++				-- otherwise do the real elastic collision+				--	this is much more realistic.+				| otherwise+				= collideBeadBead_elastic a1 a2++			-- write the new data for the actors back into the map+		  in	Map.insert ix1 a1'+		   $ 	Map.insert ix2 a2' actors+	  +   in	resultActors		+	++-- | Move a bead which isn't in contact with anything else.+moveActor_free +	:: Time 		-- ^ time to move it for+	-> Force 		-- ^ ambient force on the actor during this time+	-> Actor 		-- ^ the bead to move+	-> Actor		-- ^ the new bead++moveActor_free time force actor+	-- move a bead+	| Bead ix stuck radius pos vel	<- actor+	= let 	-- assume all beads have the same mass.+		beadMass	= 1+		+		-- calculate the new position and velocity of the bead.+		pos'		= (pos + time  `mulSV` vel)+		vel'		= (vel + (time / beadMass) `mulSV` force)++		-- if the bead is travelling slowly then set it as being stuck.+		stuck'		+		 | magV vel' < 20+		 = min beadStuckCount (stuck + 1)++		 | otherwise				+		 = max 0 (stuck - 2)++	  in  Bead ix stuck' radius pos' vel'++	-- walls don't move+	| Wall{}			<- actor+	= actor
+ Styrene/Collide.hs view
@@ -0,0 +1,166 @@+-- | Physics for bead bouncing.+module Collide where+import World+import Actor+import Graphics.Gloss.Picture	(Point)+import Graphics.Gloss.Geometry++-- Config -----------------------------------------------------------------------------------------+-- How bouncy the beads are+--	at 0.2 and they look like melting plastic.+--	at 0.8 and they look like bouncy rubber balls.+--	at > 1 and they gain energy with each bounce and escape the box.+--+beadBeadLoss	= 0.95+beadWallLoss	= 0.8+++-- | Move a bead which is in contact with a wall.+collideBeadWall+	:: Actor	-- ^ the bead +	-> Actor	-- ^ the wall that bead is in contact with+	-> Actor	-- ^ the new bead++collideBeadWall+	bead@(Bead ix _ radius pBead vIn@(velX, velY))+	wall@(Wall _ pWall1 pWall2)++ = let	-- Take the collision point as being the point on the wall which is + 	-- closest to the bead's center.+	pCollision	= closestPointOnLine pWall1 pWall2 pBead+ +	-- then do a static, non energy transfering collision.+  in	collideBeadPoint_static +		bead +		pCollision+		beadWallLoss+++-- | Move two beads which have bounced into each other.+collideBeadBead_elastic+	:: Actor -> Actor+	-> (Actor, Actor)++collideBeadBead_elastic+	bead1@(Bead ix1 mode1 r1 p1 v1)	+	bead2@(Bead ix2 mode2 r2 p2 v2)++ = let	mass1	= 1+	mass2	= 1++	-- the axis of collision (towards p2)+	vCollision@(cX, cY)	= normaliseV (p2 - p1)+	vCollisionR		= (cY, -cX)+	+	-- the velocity component of each bead along the axis of collision+	s1	= dotV v1 vCollision+	s2	= dotV v2 vCollision++	-- work out new velocities along the collision+	s1'	= (s1 * (mass1 - mass2) + 2 * mass2 * s2) / (mass1 + mass2)+	s2'	= (s2 * (mass2 - mass1) + 2 * mass1 * s1) / (mass1 + mass2)+	+	-- the velocity components at right angles to the collision+	--	there is no friction in the collision so these don't change+	k1	= dotV v1 vCollisionR+	k2	= dotV v2 vCollisionR+	+	-- new bead velocities+	v1'	= mulSV s1' vCollision + mulSV k1 vCollisionR+	v2'	= mulSV s2' vCollision + mulSV k2 vCollisionR++	v1_slow	= mulSV beadBeadLoss v1'+	v2_slow	= mulSV beadBeadLoss v2'++	-- work out the point of collision+	u1	= r1 / (r1 + r2)+	u2	= r2 / (r1 + r2)++	pCollision	+		= p1 + mulSV u1 (p2 - p1)++	-- place the beads just next to each other so they are no longer overlapping.+	p1'	= pCollision - (r1 + 0.001) `mulSV` vCollision+	p2'	= pCollision + (r2 + 0.001) `mulSV` vCollision++	bead1'	= Bead ix1 mode1 r1 p1' v1_slow+	bead2'	= Bead ix2 mode2 r2 p2' v2_slow++   in 	(bead1', bead2')+++collideBeadBead_static+	:: Actor -> Actor +	-> Actor+	+collideBeadBead_static+	bead1@(Bead ix1 _ radius1 pBead1 _)+	bead2@(Bead ix2 _ radius2 pBead2 _)++ = let	-- Take the collision point as being between the center's of the two beads. +	-- For beads which have the same radius the collision point is half way between+	-- their centers and u == 0.5+	u		= radius1 / (radius1 + radius2)+	pCollision	= pBead1 + mulSV u (pBead2 - pBead1)+		+	bead1'		= collideBeadPoint_static+		  		bead1+				pCollision+				beadBeadLoss+   in	bead1'+++-- | Move a bead which has collided with something.+collideBeadPoint_static+	:: Actor	-- ^ the bead which collided with something+	-> Point	-- ^ the point of collision (should be near the bead's surface)+	-> Float	-- ^ velocity scaling factor (how much to slow the bead down after the collision)+	-> Actor++collideBeadPoint_static+	bead@(Bead ix mode radius pBead vIn)	+	pCollision+	velLoss+ = let+	-- take a normal vector from the wall to the bead.+	--	this vector is at a right angle to the wall.+	vNormal		= normaliseV (pBead - pCollision)+	+	-- the bead at pBead is overlapping with what it collided with, but we don't want that.+	-- 	place the bead so it's surface is just next to the point of collision.+	pBead_new	= pCollision + (radius + 0.01) `mulSV` vNormal++	-- work out the angle of incidence for the bounce.+	--	this is the angle between the surface normal and+	--	the direction of travel for the bead.+	aInc		= angleVV vNormal (negate vIn)++	-- aInc2 is the angle between the wall /surface/ and+	--	the direction of travel.+	aInc2		= (pi / 2) - aInc++	-- take the determinant between the surface normal and the direction of travel.+	--	This will tell us what direction the bead hit the wall. +	--	The diagram shows the sign of the determinant for the four possiblities.+	--+	--           \ +ve                                -ve /+	--            \                                      /+	--             \/                                  \/+	--   pWall1 ---------- pWall2           pWall1 ---------- pWall2+	--             /\                                  /\+	--            /                                      \+ 	--           / -ve                                +ve \+	--+	determinant	= detV vIn vNormal++	-- Use the determinant to rotate the bead's velocity vector for the bounce.+	vOut		+	 | determinant > 0	= rotateV (2 * aInc2) vIn+	 | otherwise		= rotateV (negate (2 * aInc2)) vIn++	-- Slow down the bead when it hits the wall+	vSlow		= velLoss `mulSV` vOut++	bead1_new	= Bead ix mode radius pBead_new vSlow++   in  	bead1_new
+ Styrene/Config.hs view
@@ -0,0 +1,46 @@++module Config where+import Graphics.Gloss++-- Number of simulation steps per second of time.+simResolution :: Int+simResolution		= 300++-- How strongly the beads are pulled down to the bottom of the screen.+--	If this is too high wrt the simResoution then the simulation+--	will be unstable and beads will escape the box.+gravityCoeff :: Float+gravityCoeff		= 300++-- Whether to draw velocity vectors on beads.+showBeadVelocity	= False++-- Colors of things.+beadColor 		= makeColor 0.5 0.5 1.0 1.0+beadOutlineColor	= makeColor 1.0 1.0 1.0 1.0+nodeColor		= makeColor 0.2 0.8 0.2 0.1+leafColor		= makeColor 0.8 0.2 0.2 0.1++-- The maximum depth of the quad tree.+treeMaxDepth :: Int+treeMaxDepth		= 4++-- Size of quadtree. Should be > boxSize.+treeSize :: Float+treeSize		= 300++-- Size of bead box.+boxSize :: Float+boxSize			= 280++-- Bead setup.+beadRadius, beadSpace, beadCountX, beadCountY, beadBoxSize :: Float++beadRadius		= 5+beadSpace		= 1+beadBoxSize		= 2 * beadRadius + beadSpace+beadCountX		= 20+beadCountY		= 10++beadStuckCount :: Int+beadStuckCount		= 20
+ Styrene/Contact.hs view
@@ -0,0 +1,132 @@+{-# OPTIONS -fglasgow-exts #-}++-- | Find actors in the world that are in contact with each other.+module Contact where+import World+import QuadTree+import Actor+import Graphics.Gloss.Picture		(Point)+import Graphics.Gloss.Geometry.Line+import Data.Maybe+import Data.List+import GHC.Exts+import GHC.Prim+import Data.Map				(Map)+import Data.Set				(Set)+import qualified Data.Set		as Set+import qualified Data.Map		as Map+++-- Find all pairs of actors in the world that are in contact with each other.+findContacts +	:: World +	-> ( Set (Index, Index)		-- ^ a set of all pairs of actors that are in contact.+	   , QuadTree Actor)		-- ^ also return the quadtree so we can draw it in the window.+	   +findContacts (World actors _)+ = let	+	-- the initial tree has no actors in it and has a+	--	size of 300 (with is half the width of the box).+   	treeInit	= treeZero 300++	-- insert all the actors into the quadtree.+	tree'		= Map.fold insertActor treeInit actors++	-- the potential contacts are lists of actors+	--	that _might_ be in contact.+	potentialContacts+			= treeElems tree'++	-- filter the lists of potential contacts to determine the actors+	--	which are _actually_ in contact.+	contactSet	= makeContacts potentialContacts+	+   in 	(contactSet, tree')+  	++-- | Make add all these test pairs to a map+--	normalise so the actor with the lowest ix is first in the pair.++makeContacts :: [[Actor]] -> Set (Index, Index)+makeContacts contactLists+ 	= makeContacts' Set.empty contactLists ++makeContacts' acc xx+ = case xx of+	-- no more potentials to add, return the current contact set+	[]	-> acc++	-- add pairs of actors that are actually in contact to the contact set+	(list : lists)+	 	-> makeContacts' (makeTests acc list) lists+	+makeTests acc []		= acc+makeTests acc (x:xs)+	= makeTests (makeTests1 acc x xs) xs+	+makeTests1 acc a1 []		= acc+makeTests1 acc a1 (a2 : as)+	| inContact a1 a2+	= let	k1		= actorIx a1+		k2		= actorIx a2+		contact		= (min k1 k2, max k1 k2)+		acc'		= Set.insert contact acc+	  in	makeTests1 acc' a1 as+	+	| otherwise+	= makeTests1 acc a1 as+	++-- See if these two actors are in contact+inContact :: Actor -> Actor -> Bool+inContact a1 a2+	| isBead a1 && isWall a2	= inContact_beadWall a1 a2+	| isWall a1 && isBead a2	= inContact_beadWall a2 a1+	| isBead a1 && isBead a2	= inContact_beadBead a1 a2+	| otherwise			= False+++-- | Check whether a bead is in contact with a wall.+inContact_beadWall :: Actor -> Actor -> Bool+inContact_beadWall +	bead@(Bead ix mode radius pBead _) +	wall@(Wall _  pWall1 pWall2)++ = let	-- work out the point on the infinite line between pWall1 and pWall2+	--	which is closest to the bead.+ 	pClosest	= closestPointOnLine pWall1 pWall2 pBead++	-- the distance between the bead center and pClosest +	--	needs to be less than the bead radius for them to touch.+	!(F# radius#)	= radius+	closeEnough	= distancePP_contact pBead pClosest `ltFloat#` radius#++	-- uParam gives where pClosest is relative to the endponts of the wall+	uParam		= closestPointOnLine_param pWall1 pWall2 pBead++	-- pClosest needs to lie on the line segment between pWal1 and pWall2+	inSegment	= uParam >= 0 && uParam <= 1++   in	closeEnough && inSegment+++-- | Check whether a bead is in concat with another bead.+inContact_beadBead :: Actor -> Actor -> Bool+inContact_beadBead +	bead1@(Bead ix1 _ radius1 pBead1 _) +	bead2@(Bead ix2 _ radius2 pBead2 _)+ =let 	!dist#	  = distancePP_contact pBead1 pBead2+	!(F# rad) = radius1 + radius2+   in	(dist# `ltFloat#` rad ) && (dist# `gtFloat#` 0.1#)+++-- | Return the distance between these two points.+{-# INLINE distancePP_contact #-}+distancePP_contact :: Point -> Point -> Float#+distancePP_contact (F# x1, F# y1) (F# x2, F# y2)+	= sqrtFloat# (xd2 `plusFloat#` yd2)+	where	!xd	= x2 `minusFloat#` x1+		!xd2	= xd `timesFloat#` xd++		!yd	= y2 `minusFloat#` y1+		!yd2	= yd `timesFloat#` yd
+ Styrene/Main.hs view
@@ -0,0 +1,114 @@++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]
+ Styrene/QuadTree.hs view
@@ -0,0 +1,90 @@++module QuadTree +	( QuadTree(..)+	, treeZero+	, treeInsert+	, treeElems )+where+import Graphics.Gloss.Picture	(Point)++data QuadTree a+	-- Nil cells take up space in the world, but don't contain any elements.+	--	They can be at any depth in the tree.+	= QNil	!Point		-- cell center point +		!Float		-- cell size++	-- Leaf cells are the only ones that contain elements.+	--	They are always at the bottom of the tree.+	| QLeaf !Point		-- cell center point +		!Float 		-- cell size+		![a]		-- elements in this cell++	-- Node cells contain more sub-trees+	| QNode	!Point		-- cell center point+		!Float		-- cell size+		!(QuadTree a) !(QuadTree a)	-- NW NE+		!(QuadTree a) !(QuadTree a)	-- SW SE+		+	deriving (Eq, Show)+++-- Initial -----------------------------------------------------------------------------------------+treeZero size+	= QNil (0, 0) size++-- Quadrant ----------------------------------------------------------------------------------------++-- | Insert an element with a bounding box into the tree+treeInsert +	:: Int		-- ^ maximum depth to place a leaf+	-> Int		-- ^ current depth+	-> Point	-- ^ bottom left of bounding box of new element+	-> Point	-- ^ top right of bounding box of new element+	-> a		-- ^ element to insert into tree+	-> QuadTree a	-- ^ current tree+	-> QuadTree a++treeInsert depthMax depth p0@(x0, y0) p1@(x1, y1) a tree+ = case tree of+ 	QNode p@(x, y) size tNW tNE tSW tSE+	 -> let	+	 +	 	tNW'	| y1 > y && x0 < x	= treeInsert depthMax (depth + 1) p0 p1 a tNW+			| otherwise		= tNW++		tNE'	| y1 > y && x1 > x	= treeInsert depthMax (depth + 1) p0 p1 a tNE+			| otherwise		= tNE++		tSW'	| y0 < y && x0 < x	= treeInsert depthMax (depth + 1) p0 p1 a tSW+			| otherwise		= tSW++		tSE'	| y0 < y && x1 > x	= treeInsert depthMax (depth + 1) p0 p1 a tSE+			| otherwise		= tSE+	 	+	    in	QNode p size tNW' tNE' tSW' tSE'+		+	QLeaf p@(x, y) size elems+	 | depth >= depthMax+	 -> QLeaf p size (a : elems)+	 +	QNil p@(x, y) size+	 | depth >= depthMax+	 -> QLeaf p size [a]+	 +	 | otherwise+	 -> treeInsert depthMax depth p0 p1 a+	 	(let s2	= size / 2+		 in  QNode p size +	 		(QNil (x - s2, y + s2) s2) (QNil (x + s2, y + s2) s2)+			(QNil (x - s2, y - s2) s2) (QNil (x + s2, y - s2) s2))+++-- flatten a quadtree into a list of its elements.+treeElems :: QuadTree a -> [[a]]+treeElems tree + = case tree of+ 	QNode _ _ tNW tNE tSW tSE+	 -> treeElems tNW ++ treeElems tNE ++ treeElems tSW ++ treeElems tSE+	+	QLeaf _ _ elems	 -> [elems]+	QNil{}		 -> []
+ Styrene/World.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE PatternGuards #-}++-- The world contains a map of all the actors, along with the current+--	quadtree so we can also draw it on the screen.+module World where++import QuadTree+import Actor+import Config++import qualified Data.Map	as Map+import Data.Map			(Map)++-- The world ---------------------------------------------------------------------------------------+data World	+	= World (Map Index Actor)	-- actors+		(QuadTree Actor)	-- tree++-- | The initial world+worldInit :: World+worldInit	+  	= World actorMapInit treeInit++actorMapInit	+	= Map.fromList +	$ map (\a -> (actorIx a, a))+	$ (walls ++ beads)++treeInit = treeZero treeSize+++-- Walls ------------------+walls :: [Actor]+walls	= zipWith actorSetIndex (box ++ splitter) [10000 ..]++box :: [Actor]+box+ = let 	bs	= boxSize+   in	[ Wall  0 (- bs, -bs) (bs, -bs)		-- bot+ 	, Wall  0 (- bs,  bs) (bs,  bs)		-- top++ 	, Wall  0 (- bs, -bs) (-bs, bs)		-- left+ 	, Wall  0 (  bs, -bs) ( bs, bs)] 	-- right++splitter :: [Actor]+splitter+ =	[ Wall	0 (-15, -100) (-200, 0) + 	, Wall  0 ( 15, -100) ( 200, 0) ]+++-- Beads ------------------+beads :: [Actor]+beads	+ = let	-- beads start off with their index just set to 0+	beads_raw+		= [Bead 0 0 beadRadius (beadPos ix iy) (0, 0)+			| ix <- [0 .. beadCountX - 1]+			, iy <- [0 .. beadCountY - 1 ] ]+	+	-- set the unique index on the beads before returning them+   in	zipWith actorSetIndex beads_raw [0..]+			 +beadPos ix iy	+ = 	( (ix * beadBoxSize) - (beadBoxSize * beadCountX / 2)+	, (iy * beadBoxSize)  )+++-- QuadTree ----------------------------------------------------------------------------------------++-- | insert an actor into the tree+insertActor :: Actor -> QuadTree Actor -> QuadTree Actor++insertActor actor tree+	-- insert a bead into the tree+	| bead@(Bead ix _ radius pos@(x, y) vel) 	<- actor+	= let+		-- the bottom left and top right of the bead's bounding box.+		p0	= (x - radius, y - radius)+ 		p1	= (x + radius, y + radius)++   	  in	treeInsert treeMaxDepth 0 p0 p1 bead tree++	| wall@(Wall ix (x0, y0) (x1, y1))		<- actor+	= let+		-- the bottom left and top right of the wall's bounding box.+		p0	= (min x0 x1, min y0 y1)+ 		p1	= (max x0 x1, max y0 y1)+   	+	  in	treeInsert treeMaxDepth 0 p0 p1 wall tree+
+ Tree/Main.hs view
@@ -0,0 +1,58 @@++-- | Tree Fractal.+--	Based on ANUPlot code by Clem Baker-Finch.+--	+import Graphics.Gloss++main =  animateInWindow+		"Tree"+		(500, 650) +		(20,  20)+		black+		(picture 4)+++-- The picture is a tree fractal, graded from brown to green+picture :: Int -> Float -> Picture	+picture degree time+	= Translate 0 (-300)+	$ tree degree time (dim $ dim brown)+++-- Basic stump shape+stump :: Color -> Picture+stump color +	= Color color+	$ Polygon [(30,0), (15,300), (-15,300), (-30,0)]+++-- Make a tree fractal.+tree 	:: Int 		-- Fractal degree+	-> Float	-- time+	-> Color 	-- Color for the stump+	-> Picture++tree 0 time color = stump color+tree n time color + = let	smallTree +		= Rotate (sin time)+		$ Scale 0.5 0.5 +		$ tree (n-1) (- time) (greener color)+   in	Pictures+		[ stump color+		, Translate 0 300 $ smallTree+		, Translate 0 240 $ Rotate 20	 smallTree+		, Translate 0 180 $ Rotate (-20) smallTree+		, Translate 0 120 $ Rotate 40 	 smallTree+		, Translate 0  60 $ Rotate (-40) smallTree ]+		++-- A starting colour for the stump+brown :: Color+brown =  makeColor8 139 100 35  255+++-- Make this color a little greener+greener :: Color -> Color+greener c = mixColors 1 10 green c+
+ Zen/Main.hs view
@@ -0,0 +1,68 @@++-- A nifty animated fractal of a tree, superimposed on a background +--	of three red rectangles.+import Graphics.Gloss+import Graphics.Gloss.Shapes++main :: IO ()+main + = 	animateInWindow +		"Zen" +		(800, 600) +		(5, 5)+		(greyN 0.2)+		frame	+++-- Produce one frame of the animation.+frame :: Float -> Picture+frame timeS+ = Pictures	+ 	-- the red rectangles+	[ Translate 0 150 	backRec+	, Translate 0 0		backRec+	, Translate 0 (-150)	backRec++	-- the tree+ 	, Translate 0 (-150) $	treeFrac 7 timeS+	]+++-- One of the red backing rectangles, with a white outline.+backRec :: Picture+backRec	+ = Pictures+	[ Color red 	(rectangleSolid 400 100)+ 	, Color white	(rectangleWire  400 100) ]+++-- The color for the outline of the tree's branches.+treeOutline :: Color+treeOutline	= makeColor 0.3 0.3 1.0 1.0+++-- The color for the shading of the tree's branches.+--	The Alpha here is set to 0.5 so the branches are partly transparent.+treeColor :: Color+treeColor	= makeColor 0.0 1.0 0.0 0.5+++-- The tree fractal.+--	The position of the branches changes depending on the animation time+--	as well as the iteration number of the fractal.+treeFrac :: Int -> Float -> Picture+treeFrac 0 timeS = Blank+treeFrac n timeS+ = Pictures+	[ Color treeColor 	$ rectangleUpperSolid 20 300+	, Color treeOutline	$ rectangleUpperWire  20 300+ 	, Translate 0 30+		$ Rotate  (200 * sin timeS / (fromIntegral n) )+		$ Scale   0.9 0.9 +		$ treeFrac (n-1) timeS++	, Translate 0 70+		$ Rotate  (-200 * sin timeS / (fromIntegral n))+		$ Scale	  0.8 0.8 +		$ treeFrac (n-1) timeS+	]
+ gloss-examples.cabal view
@@ -0,0 +1,70 @@+Name:                gloss-examples+Version:             1.0.0.0+License:             MIT+License-file:        LICENSE+Author:              Ben Lippmeier+Maintainer:          gloss@ouroborus.net+Build-Type:          Simple+Cabal-Version:       >=1.8+Stability:           experimental+Category:            Graphics+Description:         +	Examples using the gloss graphics library.+	A mixed bag of fractals, particle simulations and cellular automata.++Synopsis:            Examples using the gloss library++Executable gloss-easy+  Build-depends: base >= 3 && < 5, gloss >= 1.0 && < 1.1+  Main-is: Easy/Main.hs+  ghc-options: -O2++Executable gloss-clock+  Build-depends: base >= 3 && < 5, gloss >= 1.0 && < 1.1+  Main-is: Clock/Main.hs+  ghc-options: -O2++Executable gloss-eden+  Build-depends: base >= 3 && < 5, gloss >= 1.0 && < 1.1, random > 1.0 && < 2.0+  Main-is: Main.hs+  other-modules: Cell Community World+  hs-source-dirs: Eden+  ghc-options: -O2++Executable gloss-flake+  Build-depends: base >= 3 && < 5, gloss >= 1.0 && < 1.1+  Main-is: Flake/Main.hs+  ghc-options: -O2++Executable gloss-hello+  Build-depends: base >= 3 && < 5, gloss >= 1.0 && < 1.1+  Main-is: Hello/Main.hs+  ghc-options: -O2++Executable gloss-lifespan+  Build-depends: base >= 3 && < 5, gloss >= 1.0 && < 1.1, random > 1.0 && < 2.0+  Main-is: Main.hs+  other-modules: Cell Community World+  hs-source-dirs: Lifespan+  ghc-options: -O2++Executable gloss-styrene+  Build-depends: +        base            >= 3 && < 5,+        gloss           >= 1.0 && < 1.1,+        containers      >= 0.0 && < 1.0,+        ghc-prim        >= 0.2 && < 1.0+  Main-is: Main.hs+  other-modules: Actor Advance Collide Config Contact QuadTree World+  hs-source-dirs: Styrene+  ghc-options: -O2++Executable gloss-tree+  Build-depends: base >= 3 && < 5, gloss >= 1.0 && < 1.1+  Main-is: Tree/Main.hs+  ghc-options: -O2++Executable gloss-zen+  Build-depends: base >= 3 && < 5, gloss >= 1.0 && < 1.1+  Main-is: Zen/Main.hs+  ghc-options: -O2