Example under the New Record Entity Component System

NewRecordEntityComponentSystem.elm

import List (map, (::))
import Color (Color, rgb)
import Keyboard (arrows)
import Signal (Signal, (<~), foldp)
import Graphics.Collage (square, circle, move, filled, collage, Form)
import Graphics.Element (Element)

type alias Vector = {
    x : Float,
    y : Float
}

type Shape = Square | Circle

type Controls = ArrowControls

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


--- THE ENTITY TYPE ---
type alias Entity = {
    position : Maybe Vector,
    velocity : Maybe Vector,
    mass     : Maybe Float,
    scale    : Maybe Float,
    color    : Maybe Color,
    shape    : Maybe Shape,
    controls : Maybe Controls
}

--- DEFAULT ENTITY ---
-- used to construct other entities
entity : Entity 
entity = {
    position = Nothing,
    velocity = Nothing,
    mass     = Nothing,
    scale    = Nothing,
    color    = Nothing,
    shape    = Nothing,
    controls = Nothing}

--- Some Boilerplate to make things easier ---
position : Float -> Float -> Entity -> Entity 
position x y entity = 
    { entity | position <- Just (Vector x y)}
    
velocity : Float -> Float -> Entity -> Entity
velocity x y entity = 
    { entity | velocity <- Just (Vector x y)}
    
mass : Float -> Entity -> Entity
mass m entity = 
    { entity | mass <- Just m }
    
scale : Float -> Entity -> Entity
scale s entity = 
    { entity | scale <- Just s }
    
color : Int -> Int -> Int -> Entity -> Entity
color r g b entity = 
    { entity | color <- Just (rgb r g b) }
    
shape : Shape -> Entity -> Entity
shape s entity = 
    { entity | shape <- Just s }
    
controls : Controls -> Entity -> Entity
controls c entity = 
    { entity | controls <- Just c }
    
(<>) : Entity -> List (Entity -> Entity) -> Entity
(<>) entity updaters = 
    case updaters of 
        [] -> entity
        f :: fs -> (<>) (f entity) fs

--- End of boilerplate ---

-- red box controllable by player affect by gravity
redBox = 
    entity <> [
        position 0 0,
        velocity 10 0,
        mass 10,
        scale 10,
        color 255 0 0,
        shape Square,
        controls ArrowControls
    ]

-- blue box affected by gravity
blueBox = 
    entity <> [
        position 30 0,
        velocity 0 0,
        mass 30,
        scale 5,
        color 0 0 255,
        shape Square
    ]

-- green circle affected by gravity 
greenBall = 
    entity <> [
        position 100 0,
        velocity -10 10,
        mass 10,
        scale 20,
        color 0 255 0,
        shape Circle
    ]
 
-- unmoving black circle unaffected by gravity   
blackBall = 
    entity <> [
        position 10 100,
        scale 30,
        color 0 0 0,
        shape Circle
    ]

entities : List Entity
entities = [
    redBox, 
    blueBox, 
    greenBall,
    blackBall ]

--- Actions
moveEntity : Entity -> Entity 
moveEntity entity = 
    case (entity.position, entity.velocity) of
        (Just pos, Just vel) -> 
            entity |> position (pos.x + vel.x) (pos.y + vel.y)
        _ -> entity
        

applyGravity : Float -> Entity -> Entity
applyGravity gravity entity = 
    case (entity.velocity, entity.mass) of
        (Just vel, Just m) ->
            entity |> velocity vel.x (vel.y + gravity / m)
        _ -> entity

applyInput : Input -> Entity -> Entity
applyInput {x,y} entity = 
    case (entity.velocity, entity.controls) of
        (Just vel, Just _) ->
            entity |> velocity (vel.x + toFloat x) (vel.y + toFloat y)
        _ -> entity
        
renderEntity : Entity -> Maybe Form
renderEntity entity = 
    case (entity.position, entity.scale, entity.shape, entity.color) of
        (Just pos, Just scl, Just shp, Just col) ->
            case shp of 
                Square -> 
                    Just <| move (pos.x, pos.y) <| filled col (square scl)
                Circle ->
                    Just <| move (pos.x, pos.y) <| filled col (circle scl)
        _ -> Nothing
        
render : List Entity -> Element 
render entities = collage 400 400
    (filterJusts (map renderEntity entities))
    
updateEntity : Input -> Entity -> Entity
updateEntity input entity = 
    entity <> [
        applyGravity gravity,
        applyInput input,
        moveEntity
    ]
    
update : Input -> List Entity -> List Entity
update input = map (updateEntity input)

input : Signal Input 
input = accumulateInput arrows

gravity : Float
gravity = -0.5

main : Signal Element
main = render <~ foldp update entities input


accumulateInput : Signal Input -> Signal Input
accumulateInput = 
    let add p q = {x = p.x + q.x, y = p.y + q.y}
        origin  = {x = 0, y = 0}
    in foldp add origin
    
filterJusts : List (Maybe a) -> List a
filterJusts list = 
    case list of
        [] -> []
        x :: xs ->
            case x of
                Nothing -> filterJusts xs
                Just just -> just :: filterJusts xs