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]