multiplesprings.elm

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


-- Play with this value and hot swap the code
gravity = 
  { x = 1 
  , y = -9.8
  }
--



type alias Body a = 
  { position  : a
  , velocity  : a
  , mass      : Float
  , force     : a
  }
  
mapBody : (a -> b) -> Body a -> Body b
mapBody f body = 
  { body | position <- f body.position
         , velocity <- f body.velocity
         , force    <- f body.force
  }
  
mapBody2 : (a -> b -> c) -> Body a -> Body b -> Body c
mapBody2 f bodyA bodyB = 
  { position = f bodyA.position bodyB.position 
  , velocity = f bodyA.velocity bodyB.velocity
  , mass = (bodyA.mass + bodyB.mass) / 2
  , force = f bodyA.force bodyB.force
  }
  
type alias Spring a = 
  { stiffness : Float 
  , damping   : Float 
  , position  : a 
  }
  
mapSpring : (a -> b) -> Spring a -> Spring b
mapSpring f spring = 
  { spring | position <- f spring.position }
  

mapSpring2 : (a -> b -> c) -> Spring a -> Spring b -> Spring c
mapSpring2 f springA springB = 
  { stiffness = (springA.stiffness + springB.stiffness) / 2
  , damping   = (springA.damping + springB.damping) / 2
  , position  = f springA.position springB.position
  }
  
type alias Focus big small =
  { get : big -> small
  , update : (small -> small) -> big -> big
  }

applyForceNested : Focus a Float -> a -> Body a -> Body a 
applyForceNested focus force body = 
  let 
      nestedForce = 
        focus.get force
        
      nestedBody = 
        mapBody focus.get body
        
      newBody = 
        applyForce nestedForce nestedBody
        
  in 
      mapBody2 (always >> focus.update) newBody body
      
      
applyForceMany : List (Focus a Float) -> a -> Body a -> Body a
applyForceMany foci force body = 
  case foci of 
    [] -> 
      body
      
    f :: fs -> 
      body 
      |> applyForceNested f force
      |> applyForceMany fs force

applyForce : Float -> Body Float -> Body Float
applyForce force body = 
  { body | force <- force + body.force }
  
  
attach : Spring Float -> Body Float -> Body Float
attach spring body = 
  let
      springForce = 
        -spring.stiffness * (body.position - spring.position)
          
      dampingForce = 
        -spring.damping * body.velocity  
        
      force = 
        (springForce + dampingForce) / 1000
  in 
      applyForce force body
  
  
attachNested : Focus a Float -> Spring a -> Body a -> Body a
attachNested focus spring body = 
  let 
      nestedSpring = 
        mapSpring focus.get spring
        
      nestedBody = 
        mapBody focus.get body
        
      newBody = 
        attach nestedSpring nestedBody
  in 
      mapBody2 (always >> focus.update) newBody body
      
      
attachMany : List (Focus a Float) -> Spring a -> Body a -> Body a 
attachMany foci spring body = 
  case foci of 
    [] ->
      body
      
    f :: fs -> 
      body
      |> attachNested f spring 
      |> attachMany fs spring
  
epsilon = 0.0001
      
      
animateNested : Focus a Float -> Float -> Body a -> Body a 
animateNested focus dt body = 
  let 
      nestedBody = 
        mapBody focus.get body
        
      newBody = 
        animate dt nestedBody
        
  in 
      mapBody2 (always >> focus.update) newBody body
     
   
   
animateMany : List (Focus a Float) -> Float -> Body a -> Body a
animateMany foci dt body = 
  case foci of 
    [] -> 
      body 
      
    f :: fs ->
      body
      |> animateNested f dt
      |> animateMany fs dt
      
animate : Float -> Body Float -> Body Float
animate dt body = 
  let 
      deltaTime = 
        dt / 1000
        
      force = 
        body.force * 1000
        
      acceleration = 
        force / body.mass
        
      velocity = 
        body.velocity + deltaTime * acceleration 
        
      position = 
        body.position + deltaTime * body.velocity
        
  in 
      { body | position <- position 
             , velocity <- velocity
             , force    <- 0
      }
  

-----------------
type alias Vector = 
  { x : Float , y : Float }
      
      
x : Focus Vector Float
x = 
  { get = .x
  , update = \f v -> { v | x <- f v.x }
  }
  
y : Focus Vector Float
y = 
  { get = .y
  , update = \f v -> { v | y <- f v.y }
  }
-----------------

type alias State = 
  { springs : List (Spring Vector)
  , body : Body Vector 
  }
  
initial : State
initial = 
  let 
      makeSpring pos = 
        { stiffness = 170 
        , damping = 10 
        , position = pos
        }
        
      spring1 = 
        { x = -100
        , y = -100
        }
        
      spring2 = 
        { x = 100
        , y = -100
        }
        
      spring3 = 
        { x = 100
        , y = 100
        }
        
      spring4 = 
        { x = -100
        , y = 100
        }
        
      springs = 
        List.map makeSpring 
          [ spring1
          , spring2 
          , spring3
          , spring4
          ]
        
      body = 
        { position = { x = 0, y = 100 }
        , mass = 10
        , velocity = { x = 0, y = 0 }
        , force = { x = 0, y = 0 }
        }
  in 
      { springs = springs 
      , body = body 
      }
  
  
type Action 
  = NextFrame Float
  
  
update : Action -> State -> State 
update action state = 
  case action of 
    NextFrame frame -> 
      let   
          withSprings = 
            List.foldl (attachMany [x,y]) state.body state.springs
            
          body = 
            withSprings
            |> applyForceMany [x, y] gravity
            |> animateMany [x, y] frame
            
      in 
          { state | body <- body }



view : State -> Element 
view state = 
  let 
      forms = 
        let 
            drawSpring spring = 
              rect 20 10
              |> filled Color.gray
              |> move (spring.position.x, spring.position.y)
              
            springs = 
              List.map drawSpring state.springs
              
            body = 
              circle 10
              |> filled Color.red
              |> move (state.body.position.x, state.body.position.y)
              
            drawCord spring = 
              segment (spring.position.x, spring.position.y) (state.body.position.x, state.body.position.y)
              |> traced (solid Color.black)
              
            cords = 
              List.map drawCord state.springs
              
        in 
            body :: springs ++ cords
  in 
      collage 400 400 forms 
        
        
actions = 
  Signal.map NextFrame (Time.fps 60)
  
  
main =   
  Signal.map view 
    (Signal.foldp update initial actions)