Monadic springs

monadicsprings.elm

import Html exposing (Html)
import Html.Attributes
import Time
import Mouse
import Signal
 
-----------
 
infixl 2 =>
(=>) = (,)
 
 
----------------
 
type alias Vector = 
  { x : Float , y : Float }
  
  
type alias State = Vector  
 
initial = 
  let 
      spring = makeSpring 0.3 0.8
  in 
      map2 Vector spring spring
  
  
type Action 
  = MoveTo Vector 
  | NextFrame Float
  
 
 
update : Action -> Spring State -> Spring State 
update action spring = 
  case action of 
    NextFrame frameRate -> 
      let 
          x = map .x spring 
          y = map .y spring 
          
          newX = animate frameRate x
          newY = animate frameRate y
      in 
          map2 Vector newX newY
          
    
    MoveTo destination -> 
      { spring | destination <- destination }
          
 
 
view : State -> Html
view ball = 
  let 
      containerStyle = 
          [ "position" => "absolute"
          , "top"      => toString ball.y ++ "px"
          , "left"     => toString ball.x ++ "px"
          , "width"    => "30px"
          , "height"   => "30px"
          , "border-radius" => "50%"
          , "background-color" => "red"
          ]
  in 
      Html.div 
          [ Html.Attributes.style containerStyle ]
          []
 
 
---------------------
 
mouse : Signal Action 
mouse = 
  Signal.map (\(x,y) -> MoveTo { x = toFloat x , y = toFloat y } ) Mouse.position
    
    
frame : Signal Action 
frame = 
  Signal.map (\time -> NextFrame (time / 100)) (Time.fps 60)
 
 
actions = 
  Signal.merge mouse frame
 
 
main = 
  Signal.map (current >> view)
    (Signal.foldp update initial actions)
 
 
---------------------
 
type alias Spring a = 
  { stiffness   : Float 
  , friction    : Float 
  , position    : a 
  , velocity    : a 
  , destination : a 
  }
 
 
makeSpring : Float -> Float -> Spring Float 
makeSpring stiffness friction = 
  { stiffness   = stiffness
  , friction    = friction 
  , position    = 0
  , velocity    = 0
  , destination = 0
  }
 
current : Spring a -> a 
current {position} = position
 
map : (a -> b) -> Spring a -> Spring b 
map f spring = 
  { spring | position    <- f spring.position 
           , velocity    <- f spring.velocity
           , destination <- f spring.destination 
  }
    
map2 : (a -> b -> c) -> Spring a -> Spring b -> Spring c 
map2 f springA springB = 
  { stiffness   = (springA.stiffness + springB.stiffness) / 2
  , friction    = (springA.friction + springB.friction) / 2
  , position    = f springA.position springB.position 
  , velocity    = f springA.velocity springB.velocity 
  , destination = f springA.destination springB.destination 
  }
  
  
andMap : Spring (a -> b) -> Spring a -> Spring b  
andMap = 
  map2 (<|)
  
  
flatten : Spring (Spring a) -> Spring a 
flatten {position} = position


flatMap : (a -> Spring b) -> Spring a -> Spring b
flatMap f = 
  map f >> flatten
  
andThen : Spring a -> (a -> Spring b) -> Spring b
andThen = 
  flip flatMap
  
 
epsilon = 0.0001
 
animate : Float -> Spring Float -> Spring Float 
animate frameRate spring = 
  let 
      fspring = -spring.stiffness * (spring.position - spring.destination)
      
      fdamper = -spring.friction * spring.velocity
      
      a = fspring + fdamper
      
      newX = spring.position + spring.velocity * frameRate
      newV = spring.velocity + a * frameRate 
      
  in 
      if 
          abs (newV - spring.velocity) < epsilon && abs (newX - spring.position) < epsilon
      then 
          { spring | position <- spring.destination 
                   , velocity <- 0
          }
      else 
          { spring | position <- newX
                   , velocity <- newV
          }
 
--------------------