falling balls that follow a simple gravitational model

balls-gravity.elm

import Random (randomize)
import Color (rgb)
import Time (every, inSeconds, seconds)


-- Pos represents an x,y position in the plane
data Pos = Pos Int Int
-- Vel represents an x,y velocity
data Vel = Vel Int Int
-- First parameter is radius
data Ball = Ball Int Pos Vel Color Time

makeBall r p v c t = Ball r p v c t

-- initial position -> 
--computeNextPos init vel time =
--    let nextx = (fst init) + (fst vel) * time/1000
--        nexty = (snd init) + (snd vel) * time/1000
--    in 
--        Pos nextx nexty

computeNextPos init vel window time =
  let
    nextx = (fst init) + (fst vel) * time/1000
    nexty = (snd init) + (snd vel) * time/1000
    modPos = Pos (nextx `mod` (fst window)) 
                 (nexty `mod` (snd window))
    isEvenX = ((nextx `div` (fst window)) `mod` 2) == 0
    isEvenY = ((nexty `div` (snd window)) `mod` 2) == 0
  in
    Pos (if isEvenX then (fst modPos) else (fst window) - (fst modPos))
        (if isEvenY then (snd modPos) else (snd window) - (snd modPos))
        
-- computes the next ball based on aBall's properties.
-- w, h : the width/height of the window
-- t    : the time diference
next w h t aBall = case aBall of
  Ball r p v c t -> Ball r (computeNextPos p v (Pos w h) t)

-- computes the next ball for all balls in bs
nextBalls w h t bs = map (next w h t) bs

cs = timeof (fps 30)
cps = sampleOn Mouse.clicks Mouse.position

xyToPos (x,y) = Pos x y
xyToVel (x,y) = Vel x y

posSignal w h = 
  let positionInWin pos = fst pos <= w && snd pos <= h
  in keepIf positionInWin (0,0) cps

unaryVelSignal w h = randomize 10 30 (clickSignal w h)


velSignal w h = lift2 (,) (unaryVelSignal w h) (unaryVelSignal w h)
colorSignal = constant blue
radiusSignal = constant 10
timeSignal w h = sampleOn (posSignal w h) cs

newBallSignal w h = Ball <~ radiusSignal
                          ~ (lift xyToPos (posSignal w h))
                          ~ (lift xyToVel (velSignal w h))
                          ~ colorSignal
                          ~ (timeSignal w h)

newBallsSignal w h = foldp (::) [] (newBallSignal w h)

ballsSignal w h = lift2 (nextBalls w h) cs (newBallsSignal w h)


window w h = collage w h [
  outlined black $ rect w h,
  outlined black $ rect (w - 2) (h - 2)
  ]

drawBall ball = 
  let
    Ball rad pos vel col time = ball
    Pos x y = pos
  in 
    cirlce rad |> filled c
               |> move (x, y)                            

drawBalls w h bs = collage w h (map drawBall bs)

draw w h bs = flow down [
  layers [ window w h, drawBalls w h bs ],
  plainText "woo!",
  plainText bs
  ]

main' w h = lift (view w h) (ballsSignal w h)
main = main' 400 400