Skip to content

Instantly share code, notes, and snippets.

@i-am-tom
Created December 11, 2016 12:36
Show Gist options
  • Save i-am-tom/229afcf287bf870ac76b5a909cdcfb81 to your computer and use it in GitHub Desktop.
Save i-am-tom/229afcf287bf870ac76b5a909cdcfb81 to your computer and use it in GitHub Desktop.
The Orrery
-- ## 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
{ "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": []
}
]
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment