458 lines
12 KiB
Elm
458 lines
12 KiB
Elm
module Main exposing (main)
|
|
|
|
import FunkyFunktions exposing (..)
|
|
import Presets exposing (activities)
|
|
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, 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)
|
|
import Html.Extra exposing (viewMaybe)
|
|
import Html.Events exposing (onBlur, onClick, onInput, onMouseDown, onMouseEnter, onMouseLeave)
|
|
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 (dropLeft, fromInt, isEmpty, replace, toLower)
|
|
import String.Extra exposing (isBlank)
|
|
import Svg exposing (path, Svg, svg)
|
|
import Svg.Attributes exposing (d, fill, height, stroke, viewBox, width)
|
|
import Svg.Events exposing (on)
|
|
import Task
|
|
import Url exposing (Url)
|
|
|
|
main = Browser.application
|
|
{ init = init
|
|
, view = view
|
|
, update = update
|
|
, onUrlChange = constant Noop
|
|
, onUrlRequest = constant Noop
|
|
, subscriptions = subscriptions
|
|
}
|
|
|
|
type Msg
|
|
= Noop
|
|
| Click Int Int Int Int
|
|
| SetTileText Int Int String
|
|
| AddTile Int
|
|
| PruneTile Int Int
|
|
| HeldOverNewTile Int Int
|
|
| NewMousePos Int Int
|
|
| StartDrag Int Int Tile Int Int
|
|
| StopDrag
|
|
|
|
type alias Model =
|
|
{ columns: Array Column
|
|
, heldTile: Maybe HeldTile
|
|
, mousePos: (Int, Int)
|
|
, browserKey: Key
|
|
}
|
|
|
|
type alias Column = { tiles: Array Tile }
|
|
|
|
type alias Tile =
|
|
{ text: String
|
|
, stickers: List Sticker
|
|
}
|
|
|
|
type alias HeldTile =
|
|
{ hoveredColumnIndex: Int
|
|
, hoveredTileIndex: Int
|
|
, tile: Tile
|
|
}
|
|
|
|
blankTile = { text = "", stickers = [] }
|
|
|
|
init : () -> Url -> Key -> (Model, Cmd Msg)
|
|
init flags url browserKey =
|
|
let
|
|
m =
|
|
case load browserKey url of
|
|
Just model -> model
|
|
Nothing ->
|
|
{ columns = Array.repeat 4 (Column Array.empty)
|
|
, mousePos = (200, 200)
|
|
, heldTile = Nothing
|
|
, browserKey = browserKey
|
|
}
|
|
in m |> withoutCmd
|
|
|
|
subscriptions : Model -> Sub Msg
|
|
subscriptions model =
|
|
if (isJust model.heldTile)
|
|
then
|
|
Sub.batch
|
|
[ onMouseMove <|
|
|
D.map2 NewMousePos
|
|
(D.field "pageX" D.int)
|
|
(D.field "pageY" D.int)
|
|
, onMouseUp <| D.succeed StopDrag
|
|
]
|
|
else Sub.none
|
|
|
|
|
|
view : Model -> Browser.Document Msg
|
|
view {columns, heldTile, mousePos} =
|
|
[ lazy2 viewColumns heldTile columns
|
|
, lazy viewWordbank activities
|
|
, viewMaybe (viewFloatyTile mousePos) heldTile
|
|
]
|
|
|> Browser.Document "meow!"
|
|
|
|
viewColumns : Maybe HeldTile -> Array Column -> Html Msg
|
|
viewColumns heldTile columns =
|
|
Array.indexedMap (viewColumn heldTile) columns
|
|
|> Array.map (singleton >> div [])
|
|
|> Array.toList
|
|
|> section
|
|
[ class "columns"
|
|
]
|
|
|
|
|
|
viewFloatyTile : (Int, Int) -> HeldTile -> Html Msg
|
|
viewFloatyTile (mouseX, mouseY) { tile, hoveredColumnIndex } =
|
|
div
|
|
[ style "top" (mouseY |> String.fromInt |> flip (++) "px")
|
|
, style "left" (mouseX |> String.fromInt |> flip (++) "px")
|
|
, id "floaty-tile"
|
|
, class ((++) "hovering-" <| String.fromInt <| 1 + hoveredColumnIndex)
|
|
]
|
|
[ viewTile False -1 -1 tile ]
|
|
|
|
|
|
viewHoverTile = div [id "hover-tile"] []
|
|
|
|
viewColumn : Maybe HeldTile -> Int -> Column -> Html Msg
|
|
viewColumn heldOverTile columnIndex {tiles} =
|
|
let
|
|
isTileHeld = isJust heldOverTile
|
|
tileCount = Array.length tiles
|
|
onlyTrueActivityTiles = Array.indexedMap (viewTile isTileHeld columnIndex) tiles
|
|
trueActivityTilesPlusHoverTile = case heldOverTile of
|
|
Nothing -> onlyTrueActivityTiles
|
|
Just {hoveredColumnIndex, hoveredTileIndex} ->
|
|
if hoveredColumnIndex == columnIndex
|
|
then
|
|
Array.insertAt
|
|
hoveredTileIndex
|
|
viewHoverTile
|
|
onlyTrueActivityTiles
|
|
else onlyTrueActivityTiles
|
|
tilesList = Array.toList trueActivityTilesPlusHoverTile
|
|
in
|
|
div
|
|
[ class "column"
|
|
, attributeIf isTileHeld (onMouseLeave <| HeldOverNewTile -1 -1)
|
|
]
|
|
( ( h3
|
|
[]
|
|
[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
|
|
[ class "tile"
|
|
-- , on "click" <| (
|
|
-- D.map2 (Click columnIndex tileIndex)
|
|
-- (D.field "layerX" D.int)
|
|
-- (D.field "layerY" D.int)
|
|
-- )
|
|
, attributeIf isTileHeld (onMouseEnter <| HeldOverNewTile columnIndex tileIndex)
|
|
]
|
|
[ viewGrip 24 columnIndex tileIndex tile
|
|
, input
|
|
[ value tile.text
|
|
, onInput (SetTileText columnIndex tileIndex)
|
|
, attributeIf (isBlank tile.text) <| onBlur (PruneTile columnIndex tileIndex)
|
|
, attributeIf (isBlank tile.text) (id "new-tile")
|
|
, onEnter (AddTile columnIndex)
|
|
]
|
|
[]
|
|
, svg
|
|
[ Svg.Attributes.class "tile-stickers"
|
|
, height "64"
|
|
, width "320"
|
|
, style "user-select" "none"
|
|
]
|
|
(map viewSticker tile.stickers)
|
|
]
|
|
|
|
viewGrip : Int -> Int -> Int -> Tile -> Html Msg
|
|
viewGrip size colIndx tileIndx tile =
|
|
svg
|
|
[ viewBox "0 0 103.4 103.4"
|
|
, width <| String.fromInt size
|
|
, height <| String.fromInt size
|
|
, Svg.Attributes.class "drag-gripper"
|
|
, on "mousedown" <| (
|
|
D.map2 (StartDrag colIndx tileIndx tile)
|
|
(D.field "pageX" D.int)
|
|
(D.field "pageY" D.int)
|
|
)
|
|
]
|
|
[ path
|
|
[ d gripPath
|
|
, fill "currentColor"
|
|
, stroke "none"
|
|
]
|
|
[]
|
|
]
|
|
|
|
gripPath = "m17.697 3.3505e-8a17.698 17.698 0 0 0-17.697 17.697 17.698 17.698 0 0 0 17.697 17.699 17.698 17.698 0 0 0 17.699-17.699 17.698 17.698 0 0 0-17.699-17.697zm68 0a17.698 17.698 0 0 0-17.697 17.697 17.698 17.698 0 0 0 17.697 17.699 17.698 17.698 0 0 0 17.699-17.699 17.698 17.698 0 0 0-17.699-17.697zm-68 68a17.698 17.698 0 0 0-17.697 17.697 17.698 17.698 0 0 0 17.697 17.699 17.698 17.698 0 0 0 17.699-17.699 17.698 17.698 0 0 0-17.699-17.697zm68 0a17.698 17.698 0 0 0-17.697 17.697 17.698 17.698 0 0 0 17.697 17.699 17.698 17.698 0 0 0 17.699-17.699 17.698 17.698 0 0 0-17.699-17.697z"
|
|
|
|
viewAddTile : Bool -> Int -> Int -> Html Msg
|
|
viewAddTile isTileHeld columnIndex tileCount =
|
|
button
|
|
[ class "add-tile"
|
|
, class "tile"
|
|
, onClick (AddTile columnIndex)
|
|
, attributeIf isTileHeld (onMouseEnter <| HeldOverNewTile columnIndex tileCount)
|
|
]
|
|
[ text "+" ]
|
|
|
|
viewWordbank : List String -> Html Msg
|
|
viewWordbank wordlist =
|
|
section
|
|
[ id "word-bank"
|
|
]
|
|
(map viewMiniTile wordlist)
|
|
|
|
viewMiniTile : String -> Html Msg
|
|
viewMiniTile word =
|
|
div
|
|
[ class "tile"
|
|
, class "mini-tile"
|
|
]
|
|
[ viewGrip 16 -1 -1 { text = word, stickers = [] }
|
|
, input
|
|
[ value word
|
|
, disabled True
|
|
]
|
|
[]
|
|
]
|
|
|
|
addStickerToTile : Sticker -> Tile -> Tile
|
|
addStickerToTile sticker tile =
|
|
{ tile | stickers = sticker :: tile.stickers }
|
|
|
|
addTileToColumn : Column -> Column
|
|
addTileToColumn column =
|
|
{ column | tiles = Array.push blankTile column.tiles }
|
|
|
|
isTileEmpty : Tile -> Bool
|
|
isTileEmpty = .text >> isEmpty
|
|
|
|
updateTileText : String -> Tile -> Tile
|
|
updateTileText text tile =
|
|
{ tile | text = text }
|
|
|
|
removeTileFromColumn : Int -> Column -> Column
|
|
removeTileFromColumn tileIndex column =
|
|
{ column | tiles =
|
|
Array.removeAt
|
|
tileIndex
|
|
column.tiles
|
|
}
|
|
|
|
insertTileToColumn : Int -> Tile -> Column -> Column
|
|
insertTileToColumn tileIndex tile column =
|
|
{ column | tiles =
|
|
Array.insertAt
|
|
tileIndex
|
|
tile
|
|
column.tiles
|
|
}
|
|
|
|
modTileInColumn : Int -> (Tile -> Tile) -> Column -> Column
|
|
modTileInColumn tileIndex f column =
|
|
{ column | tiles =
|
|
Array.update
|
|
tileIndex
|
|
f
|
|
column.tiles
|
|
}
|
|
|
|
modColumnInPage : Int -> (Column -> Column) -> Model -> Model
|
|
modColumnInPage columnIndex f model =
|
|
{ model | columns =
|
|
Array.update
|
|
columnIndex
|
|
f
|
|
model.columns
|
|
}
|
|
|
|
update : Msg -> Model -> (Model, Cmd Msg)
|
|
update msg model = case Debug.log "UPDATE" msg of
|
|
Noop -> (model, Cmd.none)
|
|
Click columnIndex tileIndex x y ->
|
|
(modColumnInPage columnIndex << modTileInColumn tileIndex)
|
|
(addStickerToTile <| Sticker (TextSticker "red" "<3") "Into This" x y)
|
|
model
|
|
|> withoutCmd
|
|
SetTileText columnIndex tileIndex newText ->
|
|
(modColumnInPage columnIndex << modTileInColumn tileIndex)
|
|
(updateTileText newText)
|
|
model
|
|
|> withSaveCmd
|
|
AddTile columnIndex ->
|
|
modColumnInPage columnIndex
|
|
addTileToColumn
|
|
model
|
|
|> withCmd (Task.attempt (constant Noop) (focus "new-tile"))
|
|
PruneTile columnIndex tileIndex ->
|
|
modColumnInPage columnIndex
|
|
(removeTileFromColumn tileIndex)
|
|
model
|
|
|> withSaveCmd
|
|
HeldOverNewTile columnIndex tileIndex -> case model.heldTile of
|
|
Nothing -> model |> withoutCmd
|
|
Just oldHeldTileInfo ->
|
|
let
|
|
newTileIndex =
|
|
if oldHeldTileInfo.hoveredColumnIndex /= columnIndex
|
|
then tileIndex
|
|
else if oldHeldTileInfo.hoveredTileIndex == tileIndex
|
|
then tileIndex + 1
|
|
else tileIndex
|
|
in
|
|
{ model
|
|
| heldTile =
|
|
Just
|
|
{ oldHeldTileInfo
|
|
| hoveredColumnIndex = columnIndex
|
|
, hoveredTileIndex = newTileIndex
|
|
}
|
|
}
|
|
|> withoutCmd
|
|
NewMousePos x y ->
|
|
{ model | mousePos = (x, y) }
|
|
|> withoutCmd
|
|
StartDrag colIndx tileIndx tile mouseX mouseY ->
|
|
let
|
|
modelWithTileRemoved =
|
|
modColumnInPage colIndx
|
|
(removeTileFromColumn tileIndx)
|
|
model
|
|
in
|
|
{ modelWithTileRemoved
|
|
| heldTile = Just
|
|
{ hoveredColumnIndex = colIndx
|
|
, hoveredTileIndex = tileIndx
|
|
, tile = tile
|
|
}
|
|
, mousePos = (mouseX, mouseY)
|
|
}
|
|
|> withoutCmd
|
|
StopDrag ->
|
|
case model.heldTile of
|
|
Nothing -> model |> withoutCmd
|
|
Just {hoveredColumnIndex, hoveredTileIndex, tile} ->
|
|
let
|
|
modelWithTileInserted =
|
|
modColumnInPage hoveredColumnIndex
|
|
(insertTileToColumn hoveredTileIndex tile)
|
|
model
|
|
in
|
|
{ modelWithTileInserted | heldTile = Nothing }
|
|
|> 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
|
|
|> dropLeft 1
|
|
|> replace "=" ""
|
|
|> (++) "#"
|
|
|> pushUrl model.browserKey
|
|
|
|
load : Key -> Url -> Maybe Model
|
|
load key url =
|
|
url.fragment
|
|
|> Maybe.map ((++) "g")
|
|
|> 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 (toLower 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 |