AE352.elm

import Color exposing (..)
import Debug
import Graphics.Collage exposing (..)
import Graphics.Element exposing (..)
import Keyboard
import Time exposing (..)
import Window
import Unicode exposing (..)

-- | Mass of sphere
mS : Float
mS = 1

-- | Mass of cuboid
mC : Float
mC = 1

-- | Length of rod
l : Float
l = 200

-- | Strength of gravity
γ : Float
γ = 0.1

-- | Friction coefficient per length
μ : Float
μ = -1t

-- MODEL

type alias Model = { x    : Float
                   , x'   : Float
                   , θ    : Float
                   , θ'   : Float
                   , keys : Keys
                   }

type alias Keys = { x: Int
                  , y: Int
                  }

initial : Model
initial = { x    = 0
          , x'   = 0.01
          , θ    = 3*pi/4
          , θ'   = 0
          , keys = { x = 0, y = 0 }
          }

-- UPDATE

update : (Float, Keys) -> Model -> Model
update (dt, keys) model = { model | keys = keys } |> physics dt

δ : Model -> Float
δ { x', θ, θ' } = let mSystem = mS + mC
                      numerator   = γ * sin θ + mS * μ * θ'
                      denominator = 2 * mSystem * x' *
                                    (l - x' * (θ' * cos θ' + 2 * sin θ'))
                                  - mS * l * (θ' * sin θ' - cos θ') ^ 2
                  in numerator / denominator
                     
x'' : Model -> Float
x'' m = mS * l * δ m * (m.θ' * sin m.θ' - cos m.θ')
        + toFloat m.keys.x

θ'' : Model -> Float
θ'' m = 2 * (mS + mC) * m.x' * δ m

physics : Float -> Model -> Model
physics dt model = { model | x   = model.x  + dt * model.x'
                           , x'  = model.x' + dt * x'' model
                           , θ   = model.θ  + dt * model.θ'
                           , θ'  = model.θ' + dt * θ'' model
                   }

-- VIEW

line : (Float, Float) -> (Float, Float) -> Form
line from to = traced defaultLine (segment from to)

view : (Int, Int) -> Model -> Element
view (w', h') m = let (w, h) = (toFloat w', toFloat h')

                      hanger = group [ line (0, 0) (0, l)
                                     , rect 10 10
                                       |> filled (rgb 100 0 0)
                                       |> moveY l
                                     ]
                             |> rotate m.θ

                      cart = rect 10 10 |> filled (rgb 0 100 0)

                      pendulum = group [ hanger, cart ]
                               |> moveX m.x

                      in collage w' h' [ move (-200, 400) (toForm (show m.x))
                                       , move (-200, 380) (toForm (show m.x'))
                                       , move (-200, 360) (toForm (show m.θ))
                                       , move (-200, 340) (toForm (show m.θ'))
                                       , move (-200, 320) (toForm (show m.keys))
                                       , pendulum ]


-- SIGNALS

main : Signal Element
main = Signal.map2 view Window.dimensions (Signal.foldp update initial input)


input : Signal (Float, Keys)
input = let delta = Signal.map (\t -> t/20) (fps 30)
            deltaArrows = Signal.map2 (,) delta Keyboard.arrows
        in Signal.sampleOn delta deltaArrows