Quasi-Full expression of Entity Component System in Elm

QuasiFullECS.elm

import Color (Color, rgb)
import Graphics.Collage (..)
import Graphics.Element (Element)
import List ((::), map)
import Signal (Signal, foldp, (<~), sampleOn)
import Keyboard (arrows)
import Time (millisecond, every)

--------------------------

filterJusts : List (Maybe a) -> List a
filterJusts list = 
  case list of 
    [] -> []
    first :: rest ->
      case first of
        Just x  -> x :: filterJusts rest
        Nothing -> filterJusts rest


-------------------------

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

-------------------------

-- Entity type
-- An entity is an object with a bunch of components
type alias Entity = {
  position : Maybe Vector,
  velocity : Maybe Vector,
  scale    : Maybe Float,
  color    : Maybe Color
}

-- Here, the type component tries to capture
-- the fact that the goal of a component is to modify
-- or update an entity
-- As such, it is modeled as a function from Entity to Entity
type alias Component = Entity -> Entity

-- The world is modeled simply as a list of entities 
type alias World = List Entity

-- An action is a function that modifies an entity
-- given some input and the current state of the world
type alias Action = Input -> World -> Entity -> Entity

-- A renderer is a function that turns the world into an element
-- This could be a canvas (collage) renderer,
-- or a WebGL renderer or even a CSS or SVG renderer
-- In this example, we use a canvas (collage) renderer
type alias Renderer = World -> Element

-- An updater is a function that updates the world given
-- some input. This function usually just calls all the
-- defined actions in the system
type alias Updater = Input -> World -> World

-- Default entity : No Components
entity : Entity
entity = {
  position = Nothing,
  velocity = Nothing,
  scale    = Nothing,
  color    = Nothing }
  
-- The following are shorthands to make it easier
-- to create or update components
position : Float -> Float -> Component
position x y entity =
  { entity | position <- Just (Vector x y) }

velocity : Float -> Float -> Component
velocity x y entity = 
  { entity | velocity <- Just (Vector x y) }

scale : Float -> Component
scale s entity = 
  { entity | scale <- Just s }
  
color : Int -> Int -> Int -> Component
color r g b entity = 
  { entity | color <- Just (rgb r g b) }
  
-- This function seems weird but in fact it 
-- helps make the creation of entities real easy
(<>) : Entity -> List Component -> Entity
(<>) entity components = 
  case components of 
    [] -> entity
    f :: fs -> (<>) (f entity) fs

------------------------------

-- A blue entity
player : Entity
player = 
  entity <> [
    position 0 0,
    velocity 0 0,
    scale 10,
    color 0 0 255
  ]

-- A red entity
enemy : Entity
enemy = 
  entity <> [
    position 30 30,
    scale 10,
    color 255 0 0
  ]
  
-- The world: the list of all entities in the system
world : World
world = [player, enemy]

------------------------------
-- Function to render an entity
-- Depends on: 
--    - position component
--    - scale component
--    - color component
renderEntity : Entity -> Maybe Form
renderEntity entity = 
  case (entity.position, entity.scale, entity.color) of
    (Just pos, Just scl, Just col) -> Just <|
      move (pos.x, pos.y) <|
      filled col <|
      square scl
      
    _ -> Nothing
    

-- Function to render world
renderWorld : World -> List Form
renderWorld = filterJusts << map renderEntity

-------------------------------
-- Renders the world onto the canvas by calling collage
collageRenderer : Renderer
collageRenderer = collage 400 400 << renderWorld

-------------------------------
-- The Input type. Exactly the Keyboard arrows.
type alias Input = { x : Int, y : Int }

-- Function to accumulate all past inputs into one
accumulateInput : Signal Input -> Signal Input
accumulateInput = 
  let add p q = Input (p.x + q.x) (p.y + q.y)
      origin  = Input 0 0
  in foldp add origin
 
-- helper function to map a function on ints to an input
mapInput : (Int -> Int) -> Input -> Input
mapInput f input = 
  Input (f input.x) (f input.y)

-- The input. Gets the keyboard arrows. 
-- Clamps all values between -2 and 2.
input : Signal Input
input = 
  sampleOn (every ((1000/60) * millisecond))
           (mapInput (clamp -2 2) <~ accumulateInput arrows)
           
--------------------------------
-- Action to move an entity 
-- Depends on:
--    - position component
--    - velocity component
moveEntity : Action
moveEntity input world entity = 
  case (entity.position, entity.velocity) of 
    (Just pos, Just vel) ->
      entity <> [
        position (pos.x + vel.x) (pos.y + vel.y)
      ]
     
    _ -> entity
    

      
-- Action to apply the keyboard input
-- onto an entity
-- Depends on : 
--     - velocity component
applyInput : Action
applyInput input world entity = 
  case entity.velocity of
    Just vel -> 
      entity <> [
        velocity (clamp -2 2 (toFloat input.x))
                 (clamp -2 2 (toFloat input.y))
      ]
    
    _ -> entity
    
---------------------------------
-- Function to update an entity given: 
--     - A list of actions
--     - Input
--     - World state
updateEntity : List Action -> Input -> World -> Entity -> Entity
updateEntity actions input world entity = 
  case actions of 
    [] -> entity
    f :: fs -> updateEntity fs input world (f input world entity) 

-- Function to update a world given : 
--     - A list of actions
--     - Input
updateWorld : List Action -> Input -> World -> World
updateWorld actions input world = 
  map (updateEntity actions input world) world
  
----------------------------------
-- THE UPDATE FUNCTION
-- It just updates the world with the given actions
updater : Updater
updater = updateWorld [applyInput, moveEntity]

----------------------------------
-- The Game Loop! 
-- Gets the input, updates the world, then renders the world
gameLoop : Renderer -> Updater -> Signal Input -> World -> Signal Element
gameLoop renderer updater input world = 
  renderer <~ foldp updater world input

-- THE MAIN FUNCTION
main : Signal Element
main = gameLoop collageRenderer updater input world