Add save/restore through the URL

elm.json

@@ -6,6 +6,7 @@
     "elm-version": "0.19.1",
     "dependencies": {
         "direct": {
+            "chelovek0v/bbase64": "1.0.1",
             "elm/browser": "1.0.2",
             "elm/core": "1.0.5",
             "elm/html": "1.0.0",
@@ -14,13 +15,17 @@
             "elm/url": "1.0.0",
             "elm-community/array-extra": "2.6.0",
             "elm-community/html-extra": "3.4.0",
+            "elm-community/list-extra": "8.7.0",
             "elm-community/maybe-extra": "5.3.0",
-            "elm-community/string-extra": "4.0.1"
+            "elm-community/string-extra": "4.0.1",
+            "elm-toulouse/cbor": "1.1.0"
         },
         "indirect": {
+            "elm/bytes": "1.0.8",
             "elm/regex": "1.0.0",
             "elm/time": "1.0.0",
-            "elm/virtual-dom": "1.0.3"
+            "elm/virtual-dom": "1.0.3",
+            "elm-toulouse/float16": "1.0.1"
         }
     },
     "test-dependencies": {

src/Main.elm

@@ -6,10 +6,15 @@ import Stickers exposing (Sticker, StickerContent(..), viewSticker)
 
 import Array exposing (Array, get, set)
 import Array.Extra as Array
+import Base64.Encode as B64E
+import Base64.Decode as B64D
 import Browser
 import Browser.Dom exposing (focus, getViewport, Viewport)
-import Browser.Navigation exposing (Key)
+import Browser.Navigation exposing (Key, pushUrl)
 import Browser.Events exposing (onMouseMove, onMouseUp, onResize)
+import Cbor exposing (CborItem(..))
+import Cbor.Encode as CE
+import Cbor.Decode as CD
 import Html exposing (Attribute, button, div, h3, input, Html, section, text)
 import Html.Attributes exposing (class, disabled, id, style, value)
 import Html.Attributes.Extra as Attributes exposing (attributeIf)
@@ -19,7 +24,10 @@ import Html.Events.Extra exposing (onEnter)
 import Html.Lazy exposing (lazy, lazy2)
 import Json.Decode as D
 import List exposing (map, singleton)
+import List.Extra exposing (elemIndex, getAt)
+import Maybe exposing (andThen)
 import Maybe.Extra exposing (isJust)
+import Result exposing (toMaybe)
 import String exposing (fromInt, isEmpty)
 import String.Extra exposing (isBlank)
 import Svg exposing (path, Svg, svg)
@@ -52,12 +60,10 @@ type alias Model =
   { columns: Array Column
   , heldTile: Maybe HeldTile
   , mousePos: (Int, Int)
+  , browserKey: Key
   }
 
-type alias Column =
+type alias Column = { tiles: Array Tile }
-  { name: String
-  , tiles: Array Tile
-  }
 
 type alias Tile =
   { text: String
@@ -74,25 +80,17 @@ blankTile = { text = "", stickers = [] }
 
 init : () -> Url -> Key -> (Model, Cmd Msg)
 init flags url browserKey =
-  { columns =
+  let
-    [ { name = "Into"
+    m =
-      , tiles = Array.empty
+      case load browserKey url of
-      }
+        Just model -> model
-    , { name = "Willing"
+        Nothing ->
-      , tiles = Array.empty
+          { columns = Array.repeat 4 (Column Array.empty)
-      }
+          , mousePos = (200, 200)
-    , { name = "Maybe"
+          , heldTile = Nothing
-      , tiles = Array.empty
+          , browserKey = browserKey
-      }
+          }
-    , { name = "No"
+  in m |> withoutCmd
-      , tiles = Array.empty
-      }
-    ]
-    |> Array.fromList
-  , mousePos = (200, 200)
-  , heldTile = Nothing
-  }
-    |> withoutCmd
 
 subscriptions : Model -> Sub Msg
 subscriptions model =
@@ -140,7 +138,7 @@ viewFloatyTile (mouseX, mouseY) { tile, hoveredColumnIndex } =
 viewHoverTile = div [id "hover-tile"] []
 
 viewColumn : Maybe HeldTile -> Int -> Column -> Html Msg
-viewColumn heldOverTile columnIndex {name, tiles} =
+viewColumn heldOverTile columnIndex {tiles} =
   let
       isTileHeld = isJust heldOverTile
       tileCount = Array.length tiles
@@ -163,11 +161,19 @@ viewColumn heldOverTile columnIndex {name, tiles} =
       ]
       ( ( h3
            []
-           [text name]
+           [text <| columnIndexToName columnIndex]
         ) :: tilesList
           ++ [ viewAddTile isTileHeld columnIndex tileCount ]
       )
 
+columnIndexToName : Int -> String
+columnIndexToName i = case i of
+  0 -> "Into"
+  1 -> "Willing"
+  2 -> "Maybe"
+  3 -> "No"
+  _ -> "Too Many Columns"
+
 viewTile : Bool -> Int -> Int -> Tile -> Html Msg
 viewTile isTileHeld columnIndex tileIndex tile =
   div
@@ -313,7 +319,7 @@ update msg model = case Debug.log "UPDATE" msg of
     (modColumnInPage columnIndex << modTileInColumn tileIndex)
       (updateTileText newText)
       model
-      |> withoutCmd
+      |> withSaveCmd
   AddTile columnIndex ->
     modColumnInPage columnIndex
       addTileToColumn
@@ -323,7 +329,7 @@ update msg model = case Debug.log "UPDATE" msg of
     modColumnInPage columnIndex
       (removeTileFromColumn tileIndex)
       model
-      |> withoutCmd
+      |> withSaveCmd
   HeldOverNewTile columnIndex tileIndex -> case model.heldTile of
     Nothing -> model |> withoutCmd
     Just oldHeldTileInfo ->
@@ -374,4 +380,76 @@ update msg model = case Debug.log "UPDATE" msg of
             model
         in
           { modelWithTileInserted | heldTile = Nothing }
-          |> withoutCmd
+          |> withSaveCmd
+
+withSaveCmd : Model -> (Model, Cmd Msg)
+withSaveCmd model = (model, save model)
+
+andSaveCmd : (Model, Cmd Msg) -> (Model, Cmd Msg)
+andSaveCmd (model, cmd) = (model, Cmd.batch [cmd, save model])
+
+save : Model -> Cmd Msg
+save model =
+  saveModel model
+  |> CE.encode
+  |> B64E.bytes
+  |> B64E.encode
+  |> (++) "#"
+  |> pushUrl model.browserKey
+
+load : Key -> Url -> Maybe Model
+load key url =
+  url.fragment
+  |> andThen (B64D.decode B64D.bytes >> toMaybe)
+  |> andThen (CD.decode (loadModel key))
+
+
+saveModel : Model -> CE.Encoder
+saveModel { columns } =
+  Array.toList columns
+  |> map saveColumn
+  |> CE.sequence
+
+array4 a b c d = Array.fromList [a, b, c, d]
+
+loadModel : Key -> CD.Decoder Model
+loadModel key =
+  CD.map4 array4 loadColumn loadColumn loadColumn loadColumn
+  |> CD.map Model
+  |> CD.map ((|>) Nothing)
+  |> CD.map ((|>) (0, 0))
+  |> CD.map ((|>) key)
+
+saveColumn : Column -> CE.Encoder
+saveColumn { tiles } = CE.list saveTile (Array.toList tiles)
+
+loadColumn : CD.Decoder Column
+loadColumn =
+  CD.list loadTile
+  |> CD.map Array.fromList
+  |> CD.map Column
+
+saveTile : Tile -> CE.Encoder
+saveTile { text } =
+  case elemIndex text activities of
+    Just index -> CE.int index
+    Nothing -> CE.string text
+
+loadTile : CD.Decoder Tile
+loadTile =
+  CD.any
+  |> CD.andThen loadTileInner
+
+loadTileInner : CborItem -> CD.Decoder Tile
+loadTileInner item =
+  let
+    word =
+      case item of
+        CborInt i ->
+          case getAt i activities of
+            Just activity -> CD.succeed activity
+            Nothing -> CD.fail
+        CborString s -> CD.succeed s
+        _ -> CD.fail
+  in
+    CD.map (flip Tile []) word