Main.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Actor (Actor (..))
import Advance (advanceWorld)
import Config (beadColor, leafColor, nodeColor, showBeadVelocity, simResolution)
import QuadTree (QuadTree (..))
import World (World (..), worldInit)

import Brillo (
  Color,
  Display (InWindow),
  Picture (Blank, Color, Line, Pictures, Polygon, Scale, Translate),
  black,
  greyN,
  rectangleWire,
  red,
  simulate,
 )
import Brillo.Data.Vector (mulSV)

import Data.Map qualified as Map


main :: IO ()
main =
  simulate
    ( InWindow
        "Polystyrene - alt-left-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) = do
  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.)
    (theBeads, theWalls) = splitActors $ Map.elems actors

    picBeads = Color beadColor $ Pictures $ map drawActor theBeads
    picWalls = Pictures $ map drawActor theWalls
    picTree = drawQuadTree tree

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


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


splitActors' :: [Actor] -> [Actor] -> [Actor] -> ([Actor], [Actor])
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 (posX, posY) v -> do
      let
        bead = circleFilled radius 10
        vel =
          if showBeadVelocity
            then Color red $ Line [(0, 0), mulSV 0.1 v]
            else Blank
      Translate posX posY $ Pictures [bead, vel]
    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 :: (Float, Float) -> Float -> Color -> Picture
nodeBox (x0, y0) size colr =
  Color colr $
    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]