Elm Juggling Patterns

(Note: This was written for an older version of elm and only hacked into working after changes to the way Elm handles input.)

This Elm toy draws juggling patterns from siteswap notation. At the moment there is only a single style of throw to choose from, the standard cascade throw.

In the future I could imagine adding:

You can test the program in fullscreen here. Some siteswaps to try are: (3), (5), (4), (441), (50505), (552), (5551) and (55550).

module JuggleDrawings where

import Color exposing (..)
import Graphics.Collage exposing (..)
import Graphics.Element exposing (..)

import Graphics.Input
import Text
import Time

-----------------
--  Physics
-----------------

gravity = -500

integrate dt ball = { ball | x <- ball.x + dt * ball.xvel
                           , y <- ball.y + dt * ball.yvel
                           , yvel <- ball.yvel + dt * gravity }

-----------------
--  Throwing 
-----------------

beat = 2 -- number of throws per second

type Hand = Left | Right

swapHand hand = case hand of
    Left -> Right
    Right -> Left

type alias Ball = { x:Float , y:Float , xvel:Float , yvel:Float }
type alias TimedBall = (Ball,Float)

initialBall =
    let (x,y) = leftHand
    in {x = x,y = y,xvel = 0 , yvel = 0}

-- Given a start point, end point and a duration, return an initial position and velocity of the ball

throw : (Float,Float) -> (Float,Float) -> Float -> TimedBall
throw (x,y) (x',y') t =
    let xvel = (x'-x)/t
        yvel = (y'-y)/t - (gravity * t) / 2
    in ({ x=x , y=y , xvel=xvel , yvel=yvel },t)

---------------
--  Throws
---------------

-- Each style of throw takes a siteswap number and a starting hand and gives an initial ball
-- Throws are defined by their beginning and ending points

leftHandInner = (-60,-200)
leftHandOuter = (-160,-200)
rightHandInner = (60,-200)
rightHandOuter = (160,-200)

cascade : Int -> Hand -> TimedBall
cascade n hand =
    let duration = (toFloat n) / beat
    in if (n % 2 == 0)
        then
            case hand of
                Left  -> throw leftHandInner leftHandOuter duration
                Right -> throw rightHandInner rightHandOuter duration
        else
            case hand of
                Left  -> throw leftHandInner rightHandOuter duration
                Right -> throw rightHandInner leftHandOuter duration

-----------------
--  Siteswaps
-----------------

-- Input is a siteswap, a list of throws that alternate hands and cycles indefinitely
 
initialSiteswap = [cascade 5]

type SSEvent = SSTick Float | SSChange (List (Hand -> TimedBall))
ssEvents = Signal.mergeMany [ Signal.map SSTick (Time.fps beat) , Signal.map SSChange siteswap ]

-- Loops the siteswap, update it from the input and then extract the first ball every beat. 
-- This is a bit sketchy, sampling on 'fps beat' in different places, maybe it won't syncronise?

siteswapCycle =
    let step sig (l::list) =
        case sig of
            SSTick _ -> list ++ [l]
            SSChange newlist -> case newlist of
                [] -> initialSiteswap
                otherwise -> newlist
    in Signal.foldp step initialSiteswap ssEvents

alternateHands =
    let step sig acc =
        case acc of
            Left -> Right
            Right -> Left
    in Signal.foldp step Left (Time.fps beat)

throwSignal : Signal TimedBall
throwSignal = Signal.sampleOn alternateHands <| Signal.map2 (\h (x::xs) -> x h) alternateHands siteswapCycle

----------------
--  Signals
----------------

timeDeltas = Signal.map (\x -> x / 1000) (Time.fps 60)

-- Maintain a list of balls and step them using the physics
-- Cull the list if duration is over and add balls following the siteswap signal

stepBall dt (ball,t) = (integrate dt ball , t - dt)

type Event = Tick Float | Add TimedBall

stepBallList event ballList = 
    case event of
        Tick dt -> List.filter (\(_,t) -> t > 0) <| List.map (\x -> stepBall dt x) ballList
        Add ball -> ball :: ballList

events = Signal.mergeMany [ Signal.map Tick timeDeltas , Signal.map Add throwSignal ]

ballListSignal : Signal (List TimedBall)
ballListSignal = Signal.foldp stepBallList [] events

-------------------------
--  Siteswap Selection
-------------------------

throwStyles = [("Cascade",cascade)]
throwSpeeds = List.map2 (,) (List.map toString [0..9]) [0..9]

throwStyle : Signal.Mailbox (Int -> Hand -> TimedBall)
throwStyle = Signal.mailbox (cascade)

throwSpeed : Signal.Mailbox Int
throwSpeed = Signal.mailbox 0

type Update = Append | Clear
throwUpdate : Signal.Mailbox Update
throwUpdate = Signal.mailbox Clear

throwSelection = Signal.sampleOn throwUpdate.signal <| Signal.map3 (,,) throwUpdate.signal throwStyle.signal throwSpeed.signal

siteswapString =
    let step (update,_,n) list =
        case update of
            Append -> list ++ [n]
            Clear  -> []
    in Signal.foldp step [] throwSelection

siteswap =
    let step (update,f,n) list =
        case update of
            Append -> list ++ [f n]
            Clear  -> []
    in Signal.foldp step [] throwSelection

-------------------------
--  Rendering
-----------------------

leftHand = (-140,-200)
rightHand = (140,-200)

ballSize = 20

body : Element
body =
    let bodyColor = black
    in color gray <| collage 600 600 [ filled bodyColor <| polygon [(-100,0),(100,0),(60,-300),(-60,-300)] , move (0,80) <| filled bodyColor <| circle 60 , move (-140,-200) <| filled bodyColor <| circle 20 , move (140,-200) <| filled bodyColor <| circle 20 ]

renderBall : Color -> Ball -> Form
renderBall color ball = move (ball.x,ball.y) <| filled color <| circle ballSize

renderBallList : List TimedBall -> List Form
renderBallList = List.map (renderBall red) << List.map fst

renderJuggling renderedBalls = layers [ body , collage 600 600 renderedBalls ]

siteSwapSelectionBox ssText = color darkGray <| container 600 100 middle <| flow right
    [ container 120 60 middle <| Graphics.Input.dropDown (Signal.message throwStyle.address) throwStyles
    , container 120 60 middle <| Graphics.Input.dropDown (Signal.message throwSpeed.address) throwSpeeds
    , container 120 60 middle <| Graphics.Input.button (Signal.message throwUpdate.address Append) "Add"
    , container 120 60 middle <| Graphics.Input.button (Signal.message throwUpdate.address Clear) "Clear" ]
    `above` (container 480 40 middle <| ((Graphics.Element.leftAligned << Text.fromString) <| "Siteswap: " ++ toString ssText))

------------------------
--  Put it all Together
--------------------------

main = Signal.map2 above (Signal.map siteSwapSelectionBox siteswapString) (Signal.map (renderJuggling << renderBallList) ballListSignal)