Commit a66f3f8a authored by Cédric F.'s avatar Cédric F.

Switch to canvas implementation

parent 02a7dcf4
/elm-stuff/
/elm.js
/lifechart.js
module BasicsExtra exposing (..)
roundTo : Int -> Float -> Float
roundTo precision float =
let
factor =
toFloat (10 ^ precision)
in
(float * factor |> round |> toFloat) / factor
roundToPadded : Int -> Float -> String
roundToPadded precision float =
let
intLength =
1 + logBase 10 float |> truncate
string =
roundTo precision float |> toString
totalLength =
if toFloat (truncate float) == float then
intLength
else
intLength + 1 + precision
in
string |> String.padRight totalLength '0'
module DateExtra exposing (..)
import Date exposing (Date)
import String
unsafeFromString : String -> Date
unsafeFromString string =
case Date.fromString string of
Ok date ->
date
Err msg ->
Debug.crash <| "unsafeFromString: " ++ string
fromStringWithFallback : String -> Date -> Date
fromStringWithFallback string fallback =
case Date.fromString string of
Ok date ->
date
Err _ ->
fallback
toISOString : Date -> String
toISOString date =
let
year =
Date.year date
month =
Date.month date
day =
Date.day date
in
String.join "-"
[ String.padLeft 4 '0' <| toString year
, String.padLeft 2 '0' <| toString (monthToInt month)
, String.padLeft 2 '0' <| toString day
]
monthToInt : Date.Month -> Int
monthToInt month =
case month of
Date.Jan ->
1
Date.Feb ->
2
Date.Mar ->
3
Date.Apr ->
4
Date.May ->
5
Date.Jun ->
6
Date.Jul ->
7
Date.Aug ->
8
Date.Sep ->
9
Date.Oct ->
10
Date.Nov ->
11
Date.Dec ->
12
AGPLv3+
Lifechart
Copyright (C) 2015-2016 Cédric Félizard
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Affero General Public License for more details.
You should have received a copy of the GNU Affero General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
module Lifechart exposing (main)
import Navigation
import Time
import Lifechart.Model as Model
import Lifechart.Update exposing (init, update)
import Lifechart.View exposing (view)
main : Program Never Model.Model Model.Msg
main =
Navigation.program Model.NewUrl
{ init = init
, update = update
, view = view
, subscriptions = subscriptions
}
subscriptions : Model.Model -> Sub Model.Msg
subscriptions model =
Time.every Time.second Model.Tick
module Lifechart.Model exposing (..)
import Date exposing (Date)
import Color exposing (Color)
import Time exposing (Time)
import Navigation
import DateExtra
type alias Model =
{ dateOfBirth : Date
, kidUntil : Int
, oldFrom : Int
, lifeExpectancy : Int
, events : List Event
, newEventOpen : Bool
, newEvent : Event
, modalOpen : Bool
, now : Time
}
type alias JsonModel =
{ dateOfBirth : Date
, kidUntil : Int
, oldFrom : Int
, lifeExpectancy : Int
, events : List Event
}
type alias Event =
{ from : Date
, to : Date
, color : Color
, label : String
}
initialModel : Model
initialModel =
{ dateOfBirth = DateExtra.unsafeFromString "1988-07-14"
, kidUntil = 18
, oldFrom = 70
, lifeExpectancy = 80
, events = []
, newEventOpen = False
, newEvent = initialEvent
, modalOpen = False
, now = 0
}
mergeJsonModel : JsonModel -> Model
mergeJsonModel jsonModel =
{ initialModel
| dateOfBirth = jsonModel.dateOfBirth
, kidUntil = jsonModel.kidUntil
, oldFrom = jsonModel.oldFrom
, lifeExpectancy = jsonModel.lifeExpectancy
, events = jsonModel.events
}
mergeModel : Model -> Model -> Model
mergeModel newModel baseModel =
{ newModel
| newEventOpen = baseModel.newEventOpen
, newEvent = baseModel.newEvent
, modalOpen = baseModel.modalOpen
, now = baseModel.now
}
initialEvent : Event
initialEvent =
{ from = Date.fromTime 0
, to = Date.fromTime 0
, color = Color.black
, label = ""
}
fallbackColor : Color
fallbackColor =
Color.red
type NewEventField
= EventFrom
| EventTo
| EventColor
| EventLabel
type Msg
= Tick Time
| NewUrl Navigation.Location
| NewDateOfBirth String
| NewLifeExpectancy String
| ToggleNewEvent
| UpdateNewEvent NewEventField String
| SaveNewEvent
| NewConfig String
| ToggleModal
deathDate : Model -> Date
deathDate model =
partialDate model (Date.year model.dateOfBirth + model.lifeExpectancy)
partialDate : Model -> Int -> Date
partialDate model year =
DateExtra.unsafeFromString <|
String.join "-"
[ toString year
, toString <| DateExtra.monthToInt <| Date.month model.dateOfBirth
, toString <| Date.day model.dateOfBirth
]
module Lifechart.Serializer
exposing
( serialize
, serializeJson
, deserialize
, deserializeJson
)
import Color exposing (Color)
import Color.Convert
import Date exposing (Date)
import DateExtra
import Json.Decode as Decode
import Json.Encode as Encode
import Base64
import Lifechart.Model exposing (..)
serialize : Model -> String
serialize model =
case Base64.encode (serializeJson model) of
Err _ ->
""
Ok string ->
string
deserialize : String -> Result String Model
deserialize base64 =
case Base64.decode base64 of
Err error ->
Err error
Ok json ->
deserializeJson json
serializeJson : Model -> String
serializeJson model =
Encode.encode 2 <|
Encode.object
[ ( "date-of-birth", encodeDate model.dateOfBirth )
, ( "life-expectancy", Encode.int model.lifeExpectancy )
, ( "kid-until", Encode.int model.kidUntil )
, ( "old-from", Encode.int model.oldFrom )
, ( "events", Encode.list <| List.map encodeEvent model.events )
]
jsonDecoder : Decode.Decoder JsonModel
jsonDecoder =
Decode.map5 JsonModel
(Decode.field "date-of-birth" dateDecoder)
(Decode.field "kid-until" Decode.int)
(Decode.field "old-from" Decode.int)
(Decode.field "life-expectancy" Decode.int)
(Decode.field "events" <| Decode.list eventDecoder)
deserializeJson : String -> Result String Model
deserializeJson json =
case
Decode.decodeString jsonDecoder json
of
Err error ->
Err error
Ok jsonModel ->
Ok (mergeJsonModel jsonModel)
encodeEvent : Event -> Encode.Value
encodeEvent event =
Encode.object
[ ( "from", encodeDate event.from )
, ( "to", encodeDate event.to )
, ( "color", encodeColor event.color )
, ( "label", Encode.string event.label )
]
eventDecoder : Decode.Decoder Event
eventDecoder =
Decode.map4 Event
(Decode.field "from" dateDecoder)
(Decode.field "to" dateDecoder)
(Decode.field "color" colorDecoder)
(Decode.field "label" Decode.string)
encodeDate : Date -> Encode.Value
encodeDate date =
Encode.string <| DateExtra.toISOString date
dateDecoder : Decode.Decoder Date.Date
dateDecoder =
Decode.string
|> Decode.andThen
(\string ->
case Date.fromString string of
Ok date ->
Decode.succeed date
Err error ->
Decode.fail error
)
encodeColor : Color -> Encode.Value
encodeColor color =
Encode.string <| Color.Convert.colorToHex color
colorDecoder : Decode.Decoder Color
colorDecoder =
Decode.string
|> Decode.andThen
(\hex ->
Color.Convert.hexToColor hex
|> Maybe.withDefault fallbackColor
|> Decode.succeed
)
module Lifechart.Update exposing (init, update)
import Navigation
import DateExtra
import Color.Convert
import Lifechart.Model exposing (..)
import Lifechart.Serializer as Serializer
init : Navigation.Location -> ( Model, Cmd Msg )
init location =
let
model =
decodeModel location
|> Result.toMaybe
|> Maybe.withDefault initialModel
in
( model, Cmd.none )
update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
case msg of
Tick time ->
( { model | now = time }, Cmd.none )
NewUrl location ->
let
urlModel =
decodeModel location
|> Result.toMaybe
|> Maybe.withDefault model
newModel =
mergeModel urlModel model
in
( newModel, Cmd.none )
NewDateOfBirth string ->
let
date =
DateExtra.fromStringWithFallback string model.dateOfBirth
newModel =
{ model | dateOfBirth = date }
in
( newModel, updateUrl newModel )
NewLifeExpectancy string ->
let
value =
case String.toInt string of
Ok int ->
clamp 1 500 int
Err _ ->
1
newModel =
{ model | lifeExpectancy = value }
in
( newModel, updateUrl newModel )
ToggleNewEvent ->
( { model | newEventOpen = not model.newEventOpen }, Cmd.none )
UpdateNewEvent field value ->
let
event =
model.newEvent
-- TODO: this is kinda gross, is there a better way?
newEvent =
case field of
EventFrom ->
{ event | from = DateExtra.fromStringWithFallback value event.from }
EventTo ->
{ event | to = DateExtra.fromStringWithFallback value event.to }
EventColor ->
{ event | color = Color.Convert.hexToColor value |> Maybe.withDefault fallbackColor }
EventLabel ->
{ event | label = value }
in
( { model | newEvent = newEvent }, Cmd.none )
SaveNewEvent ->
let
events =
List.append model.events [ model.newEvent ]
newModel =
{ model | events = events, newEventOpen = False }
in
( newModel, updateUrl newModel )
NewConfig json ->
let
jsonModel =
Serializer.deserializeJson json
|> Result.toMaybe
|> Maybe.withDefault model
newModel =
mergeModel jsonModel model
in
( newModel, updateUrl newModel )
ToggleModal ->
( { model | modalOpen = not model.modalOpen }, Cmd.none )
decodeModel : Navigation.Location -> Result String Model
decodeModel location =
let
dataWithoutHash =
String.dropLeft 1 location.hash
in
if String.isEmpty dataWithoutHash then
Ok initialModel
else
Serializer.deserialize dataWithoutHash
updateUrl : Model -> Cmd Msg
updateUrl model =
let
base64 =
Serializer.serialize model
url =
"#" ++ base64
in
Navigation.newUrl url
module Lifechart.View exposing (view)
import Html exposing (..)
import Html.Attributes exposing (..)
import Lifechart.Model exposing (..)
import Lifechart.View.Canvas as Canvas
import Lifechart.View.Controls as Controls
view : Model -> Html Msg
view model =
if model.now == 0 then
h1 [ class "text-xs-center" ] [ text "Loading..." ]
else
div []
[ Controls.modal model
, div [ class "row" ]
[ div [ class "col-xs-6" ] [ Controls.controls model ]
, div [ class "col-xs-6" ] [ Canvas.canvas model ]
]
]
module Lifechart.View.Canvas exposing (canvas)
import Html exposing (..)
import Collage exposing (Form, LineStyle)
import Element exposing (Element)
import Text exposing (Text)
import Color exposing (Color)
import Date exposing (Date)
import Time exposing (Time)
import DateExtra
import Lifechart.Model exposing (..)
lineHeight : number
lineHeight =
16
canvasHeight : number -> Float
canvasHeight lifeExpectancy =
lifeExpectancy * (weekWidth + weekBorder * 2)
canvasWidth : number
canvasWidth =
indexWidth + 52 * (weekWidth + weekBorder * 2) + legendWidth
indexWidth : number
indexWidth =
60
legendWidth : number
legendWidth =
20
weekWidth : number
weekWidth =
9
weekBorder : number
weekBorder =
1
oneDay : number
oneDay =
86400 * 1000
oneWeek : number
oneWeek =
oneDay * 7
canvas : Model -> Html Msg
canvas model =
let
height =
lineHeight * 2 + canvasHeight model.lifeExpectancy
grid =
Collage.group (years model)
|> Collage.moveX (-canvasWidth / 2)
|> Collage.moveY (height / 2)
theLegend =
legend model
|> Collage.moveX (canvasWidth / 2 - legendWidth + lineHeight)
in
Collage.collage canvasWidth (ceiling height) [ grid, theLegend ]
|> Element.toHtml
legend : Model -> Form
legend model =
let
makeText text =
Text.fromString text
|> Collage.text
|> Collage.rotate (degrees -90)
( textOffset, markOffset ) =
( 11, 6 )
( kidUntil, oldFrom, lifeExpectancy ) =
( toFloat model.kidUntil
, toFloat model.oldFrom
, toFloat model.lifeExpectancy
)
maxKidUntil =
Basics.min lifeExpectancy kidUntil
kid =
makeText "kid"
|> Collage.moveY
(canvasHeight ((lifeExpectancy - maxKidUntil) / 2) - textOffset)
kidMark =
Collage.rect 10 1
|> Collage.filled Color.black
|> Collage.moveX -2
|> Collage.moveY
(canvasHeight (lifeExpectancy / 2 - kidUntil) - markOffset)
maxOldFrom =
Basics.min lifeExpectancy oldFrom
productive =
if maxOldFrom - kidUntil < 8 then
makeText ""
else
makeText "productive years"
|> Collage.moveY
(canvasHeight (lifeExpectancy / 2 - (kidUntil + maxOldFrom) / 2) - textOffset)
oldMark =
Collage.rect 10 1
|> Collage.filled Color.black
|> Collage.moveX -2
|> Collage.moveY
-(canvasHeight (oldFrom - lifeExpectancy / 2) + markOffset)
old =
if lifeExpectancy - oldFrom < 1 then
makeText ""
else
makeText "old"
|> Collage.moveY
-(canvasHeight ((lifeExpectancy + oldFrom) / 2 - lifeExpectancy / 2) + textOffset)
in
Collage.group [ kid, kidMark, productive, oldMark, old ]
years : Model -> List Form
years model =
let
makeYear i =
Collage.group (year model i)
|> Collage.moveY
((toFloat -i - 1) * (weekWidth + weekBorder * 2) - lineHeight)
in
weekIndexes :: (List.range 0 model.lifeExpectancy |> List.map makeYear)
weekIndexes : Form
weekIndexes =
let
makeIndex i =
Text.fromString (toString i)
|> Collage.text
|> Collage.moveX (toFloat i * (weekWidth + weekBorder * 2))
in
List.range 1 52
|> List.filter (\i -> i % 2 /= 0)
|> List.map makeIndex
|> Collage.group
|> Collage.move ( indexWidth, -10 )
year : Model -> Int -> List Form
year model index =
let
year =
Date.year model.dateOfBirth + index
paddedIndex =
String.padLeft 2 '0' (toString index)
label =
Text.fromString (toString year ++ " / " ++ paddedIndex)
|> Collage.text
|> Collage.move ( 32, 2 )
makeWeek i =
week model index i