Draw.hs

{-# LANGUAGE PatternGuards #-}
-- | Drawing the world as a gloss picture.
module Gloss.Draw
	(drawWorld)
where
import Common.World
import Common.Body
import Graphics.Gloss
import qualified Solver.ListBH.Solver		as L
import qualified Data.Vector.Unboxed		as V


-- | Radius of the circle representing each body.
pointSize :: Float
pointSize	= 4


-- | Draw the world, and optionally show the Barnes-Hut tree.
--   NOTE: We always show the list version tree, which might not be the one
--         that's actually being used to calculate the accelerations.
--         To display the other trees we'd have to write draw functions for them,
--         or functions to convert them to the list version.
--
drawWorld :: Bool -> World -> Picture
drawWorld shouldDrawTree world
 = let	picPoints	= Color (makeColor 1 1 1 0.4)
			$ Pictures 
			$ map drawBody
			$ V.toList 
			$ worldBodies world

   	picTree		= drawBHTree
			$ L.buildTree 
			$ map massPointOfBody
			$ V.toList 
			$ worldBodies world

   in	Pictures 
		[ if shouldDrawTree 
			then Color (makeColor 0.5 1.0 0.5 0.2) $ picTree
			else Blank
			
		, picPoints ]


-- | Draw a list version Barnes-Hut tree.
drawBHTree :: L.BHTree -> Picture
drawBHTree bht
 = drawBHTree' 0 bht

drawBHTree' depth bht
 = let	
	-- The bounding box
	L.Box left down right up	= L.bhTreeBox bht
	[left', down', right', up']	= map realToFrac [left, down, right, up]

	picCell		= lineLoop [(left', down'), (left', up'), (right', up'), (right', down')]


	-- Draw a circle with an area equal to the mass of the centroid.
	centroidX	= realToFrac $ L.bhTreeCenterX bht
	centroidY	= realToFrac $ L.bhTreeCenterY bht
	
	centroidMass	= L.bhTreeMass bht
	circleRadius	= realToFrac $ sqrt (centroidMass / pi)

	midX		= (left' + right') / 2
	midY		= (up'   + down')  / 2

	picCentroid	
	 | _:_	<- L.bhTreeBranch bht
	 , depth >= 1
	 = Color (makeColor 0.5 0.5 1.0 0.4)
		$  Pictures
			[ Line [(midX, midY), (centroidX, centroidY)]
			, Translate centroidX centroidY 
			$ ThickCircle
				(circleRadius * 4 / 2) 
				(circleRadius * 4) ]
			
	 | otherwise
	 = Blank

	-- The complete picture for this cell.
	picHere		= Pictures [picCentroid, picCell]
		
	-- Pictures of children.
	picSubs		= map (drawBHTree' (depth + 1))
			$ L.bhTreeBranch bht

   in	Pictures (picHere : picSubs)


-- | Draw a single body.
drawBody :: Body -> Picture
drawBody ((x, y, _), _, _)
	= drawPoint (x, y)


-- | Draw a point using a filled circle.
drawPoint :: (Double, Double) -> Picture
drawPoint (x, y)
	= Translate (realToFrac x) (realToFrac y) 
	$ ThickCircle (pointSize / 2) pointSize