The Orrery

Main.elm

-- ## An Elm-entary visualisation
-- by _Tom Harding_

module Main exposing (..)

-- This project uses a few dependencies. To anyone who's written any
-- amount of Elm before, the only stranger is `AnimationFrame`, from
-- the `elm-lang/animation-frame` package. This lets us subscribe to
-- the browser's RAF API. Everything else should be fairly obvious:
-- `Html` / `Svg` for our view, `Http` / `Json.Decode` for the AJAX
-- request, and `Time` for our orbit.

import AnimationFrame
import Html
import Http
import Json.Decode as Decode
import Svg
import Svg.Attributes exposing (..)
import Time exposing (inMinutes, Time)

-- We can't use the `beginnerProgram` because of the need for both
-- subscriptions _and_ commands, so we opt for the next easiest thing.
-- _Perhaps_ against convention, I tend to put one-line declarations
-- (e.g. `subscriptions`) directly in the `Html.program` call - it
-- looks prettier to me... _Sorry, Evan!_

main =
    Html.program
        { init          = init
        , subscriptions = \_ -> AnimationFrame.times Tick
        , update        = update
        , view          = view
        }

-- The model for this visualisation is **recursive**: a system is a
-- body and its _moons_, all of which are systems themselves. However,
-- this means we have an **infinitely-nesting** type, so we have to
-- use sidestep this with a new `type Moons` to get a solid alias.

type alias System =
    { colour : String
    , orbit  : Float
    , radius : Float
    , speed  : Float
    , moons  : Moons
    }

-- Of course, aside from a little extra destructuring, this doesn't
-- change the capability of the type _at all_.

type Moons
    = Moons (List System)

-- The model is then just the current `Time` (from our subscription)
-- and _maybe_ a `System`. If the AJAX response hasn't come back yet,
-- or an error occurred during the lifecycle, our `System` is
-- `Nothing`, and we can show something other than an empty sky.

type alias Model =
    { time   : Time
    , system : Maybe System
    }

-- The initial command is the AJAX request: when this completes, the
-- model will hold the returned JSON **or lack thereof**. I think this
-- whole `Cmd` approach is really neat: our IO actions end up handled
-- in _exactly_ the same way as our user interactions.

init =
    ( { time = 0, system = Nothing }
    , Http.send Register
        << Http.get "./system.json"
        <| planetify
    )

-- When we get the AJAX response, we need to map it into a **data
-- type**: in our case, the `System` type. In Elm, we do this with a
-- `Json.Decoder`. Here, we use a decoder that can recursively
-- deconstruct the JSON to match our type. It also validates our JSON
-- response at the same time!
--
-- We need to use the `Decode.map` and `Decode.lazy` functions to
-- avoid that pesky infinite type: the `Moons` type will be populated
-- by a second map that occurs _lazily_.

planetify : Decode.Decoder System
planetify =
    Decode.map5 System
        (Decode.field "colour" Decode.string)
        (Decode.field "orbit"  Decode.float )
        (Decode.field "radius" Decode.float )
        (Decode.field "speed"  Decode.float )
        (Decode.field "moons" << Decode.map Moons
                              << Decode.lazy
                              <| \_ -> Decode.list planetify)

-- There are really only two things that happen in this visualisation:
-- the `Time` updates (for the next animation frame), and the AJAX
-- response _correctly or otherwise_.

type Msg
    = Tick Time
    | Register (Result Http.Error System)

-- Consequently, the handlers for these two cases are _very_ simple.
-- Any `Time` update simply updates the model, and any server `Result`
-- is recorded. As mentioned before, I have converted the `Result` to
-- `Maybe` so I can encode "the response has not yet been received" in
-- the same way as "the request failed" and "the response is invalid".
-- _Don't be fooled: this is pure laziness on my part_.

update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
    case msg of
        Tick time ->
            ( { model | time = time }, Cmd.none )

        Register result ->
            ( { model | system = Result.toMaybe result }
            , Cmd.none
            )

-- A coordinate is represented as `( x, y )`. If I weren't going for
-- brevity, some operations would be helpful (e.g. `add`).

type alias Coordinate =
    ( Float, Float )

-- In the first iteration of this code, there was no ordering on the
-- `Svg` elements. This looked odd when satellites didn't go _behind_
-- a parent body (e.g. when the moon's orbit is at the "back" of the
-- diagram), so I picked a configuration where this didn't happen. A
-- few weeks later, however, I felt ashamed of myself, and fixed it.
--
-- So, now, we generate inspectable (thus easily orderable) records,
-- and convert them to `SVG` later on. I think this turns out quite
-- neatly, though it's perhaps the result of staring for too long at
-- `Free` structures and interpreters.

type Renderable
    = Orbit
        { x      : Float
        , y      : Float
        , radius : Float
        }

    | Planet
        { x      : Float
        , y      : Float
        , radius : Float
        , colour : String
        }

-- For now, we just put `Orbit` rings right at the back. This looks a
-- bit odd at times, and I think a better solution would be to split
-- up the `ellipse` into several arcs, (to order around other `Svg`s),
-- but that's one for another time.

ordering : Renderable -> Float
ordering object =
    case object of
        Planet { y } -> y
        _            -> negate 1 / 0

-- Converting a `Renderable` to an `Svg` is very straightforward, as
-- all the required information is stored within the `Renderable` type
-- already.
--
-- An easy modification to this app would be to allow user-defined
-- _camera tilt_ (i.e. configurable `skew`), and it could simply be
-- passed in as a parameter here.
--
-- It's perhaps worth pointing out that my `<<` and `<|` usage is a
-- direct mapping from Haskell's `.` and `$`. The `<<` could quite
-- easily be replaced with another `<|` of course, but it's just not
-- the way I'm used to doing things! _Old dogs, new tricks..._

toSvg : Renderable -> Svg.Svg Msg
toSvg renderable =
    case renderable of
        Orbit { x, y, radius } ->
            Svg.ellipse [ cx <| toString x
                        , cy <| toString y
                        , rx <| toString radius
                        , ry << toString <| 0.4 * radius
                        ] []

        Planet { x, y, radius, colour } ->
            Svg.circle [ cx    <| toString x
                       , cy    <| toString y
                       , r     <| toString radius
                       , style <| "fill:" ++ colour
                       ] []

-- See where those `Coordinate` functions would be useful?
--
-- I'll say now that **I don't like this function**: there's a pretty
-- obvious optimisation to be made here. What I would _really_ like
-- is a type of `Coordinate -> System -> List (Time -> Renderable)`,
-- or even `Time -> List Renderable`: in other words, we'd end up with
-- a list of bodies positioned with respect to each _recursive_ orbit
-- via _composed_ functions.
--
-- I haven't looked enough into Elm's compiler to know for certain,
-- but I would imagine that this could be compiled efficiently if we
-- ended up with `let .. in \time ->` as our general form. As `time`
-- is the only important variable here, we could pre-build all this at
-- the time of JSON receipt, and cut down on the calculations needed
-- at run-time. it's just a thought, really.
--
-- For small-ish `System` cases, this works fine, but I'm not really a
-- huge fan of the _good enough_ mentality, and I'm **certain** this
-- function has room for improvement. It certainly shouldn't need to
-- know the `skew` value to build view-independent coordinates.

toRenderables : Coordinate -> Time -> System -> List Renderable
toRenderables ( cx, cy ) time { orbit, colour, radius, speed, moons } =
    let
        ( cx_, cy_ ) =
            fromPolar (orbit, speed * inMinutes time)
                |> \( x, y ) -> ( cx + x, cy + 0.4 * y )

        ring =
            Orbit { x      = cx
                  , y      = cy
                  , radius = orbit
                  }

        planet =
            Planet { x      = cx_
                   , y      = cy_
                   , radius = radius
                   , colour = colour
                   }

        subrenderer =
            toRenderables ( cx_, cy_ ) time

        children =
            case moons of
                Moons ms ->
                    List.concatMap subrenderer ms
    in
        ring :: planet :: children

-- Finally, we have the **view** function: the entry point for all the
-- rendering process. This is nice and easy to understand, I hope: we
-- can display some cursory error to the user for when AJAX fails, and
-- otherwise kick off the animation.
--
-- Of course, I'd love to get `skew` into the `Model` so that it can
-- be configured (and then passed to the rest of the view logic at
-- render-time). Ooer.
--
-- That gets us to the end of the file! **All** the code for the top
-- visualisation (that isn't just imported library code) is here: it
-- really is that simple. _Elm is wonderful._

view : Model -> Html.Html Msg
view { time, system } =
    let
        container =
            Svg.svg [ viewBox "0 0 600 240" ]
    in
        case system of
            Nothing ->
                Html.div [] [ Html.text "What a quiet night..." ]

            Just data ->
                container << List.map toSvg
                          << List.sortBy ordering
                          << toRenderables ( 300.0, 120.0 ) time
                          <| data

system.json

{ "colour": "#FC0"
, "orbit": 0
, "radius": 30
, "speed": 0
, "moons":
  [
    { "colour": "#A00"
    , "orbit": 80
    , "radius": 10
    , "speed": 9
    , "moons": []
    }

  , { "colour": "#6C3"
    , "orbit": 160
    , "radius": 15
    , "speed": 5
    , "moons":
      [ { "colour": "#999"
        , "orbit": 40
        , "radius": 5
        , "speed": 11
        , "moons":
          [ { "colour": "#C3C"
            , "orbit": 15
            , "radius": 3
            , "speed": 17
            , "moons": []
            }
          ]
        }
      ]
    }
  , { "colour": "#3FF"
    , "orbit": 250
    , "radius": 10
    , "speed": 3
    , "moons": []
    }
  ]
}