677 lines
21 KiB
Elm
677 lines
21 KiB
Elm
module Main exposing (..)
|
|
|
|
import Browser
|
|
import Browser.Navigation as Nav
|
|
import Url
|
|
import Html exposing (..)
|
|
import Html.Attributes exposing (..)
|
|
import Html.Events exposing (..)
|
|
import Svg.Attributes
|
|
import Url.Parser as P exposing (Parser, (</>), oneOf, s)
|
|
import Set exposing (Set)
|
|
|
|
import Api
|
|
|
|
-- Main
|
|
|
|
main : Program () Model Msg
|
|
main =
|
|
Browser.application
|
|
{ init = init
|
|
, view = view
|
|
, update = update
|
|
, subscriptions = subscriptions
|
|
, onUrlChange = UrlChanged
|
|
, onUrlRequest = LinkClicked
|
|
}
|
|
|
|
-- Model
|
|
|
|
type alias Selection = Set Int
|
|
|
|
type alias State =
|
|
{ navKey : Nav.Key
|
|
, route : Route
|
|
, error : String
|
|
, menuOpen : Bool
|
|
, selection : Maybe Selection
|
|
, activeMode : Maybe ViewMode
|
|
}
|
|
|
|
type alias Model =
|
|
{ state : State
|
|
, player: Player
|
|
, claims : Claims
|
|
, notification : Maybe String
|
|
, loot: Maybe Loot
|
|
, groupLoot : Maybe Loot
|
|
, merchantItems : Maybe Loot
|
|
}
|
|
|
|
init : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg )
|
|
init flags url key =
|
|
let
|
|
route = case P.parse routeParser url of
|
|
Just r -> r
|
|
Nothing -> PlayerChest
|
|
in
|
|
( Model
|
|
(State key route "" False Nothing Nothing)
|
|
blankPlayer
|
|
[]
|
|
Nothing
|
|
Nothing
|
|
Nothing
|
|
Nothing
|
|
, fetchInitialData 0)
|
|
|
|
|
|
fetchInitialData : Int -> Cmd Msg
|
|
fetchInitialData playerId =
|
|
Cmd.batch
|
|
[ initPlayer playerId
|
|
, Cmd.map ApiMsg <| Api.fetchLoot Api.OfShop
|
|
, Cmd.map ApiMsg <| Api.fetchLoot Api.OfGroup
|
|
]
|
|
|
|
---
|
|
-- MODELS
|
|
---
|
|
|
|
-- Player
|
|
|
|
type alias Player =
|
|
{ id: Int
|
|
, name: String
|
|
, debt: Int
|
|
, wealth: Wealth
|
|
}
|
|
|
|
blankPlayer =
|
|
Player 0 "Loot-a-lot" 0 (Wealth 0 0 0 0)
|
|
|
|
|
|
initPlayer id =
|
|
Cmd.batch
|
|
[ Cmd.map ApiMsg <| Api.fetchPlayer id
|
|
, Cmd.map ApiMsg <| Api.fetchLoot (OfPlayer id)
|
|
, Cmd.map ApiMsg <| Api.fetchClaims id
|
|
]
|
|
|
|
type alias Wealth =
|
|
{ cp: Int
|
|
, sp: Int
|
|
, gp: Int
|
|
, pp: Int
|
|
}
|
|
|
|
-- Loot
|
|
|
|
type alias Loot = List Item
|
|
|
|
type alias Item =
|
|
{ id: Int
|
|
, name: String
|
|
, base_price: Int
|
|
}
|
|
|
|
-- Claims
|
|
|
|
type alias Claims = List Claim
|
|
|
|
type alias Claim =
|
|
{ id: Int
|
|
, player_id: Int
|
|
, loot_id: Int
|
|
}
|
|
|
|
-- UPDATE
|
|
|
|
type Msg
|
|
= LinkClicked Browser.UrlRequest
|
|
| UrlChanged Url.Url
|
|
| ApiMsg Api.Msg
|
|
| PlayerChanged Int
|
|
| LootViewItemSwitched Int
|
|
| ModeSwitched (Maybe ViewMode)
|
|
| ConfirmAction
|
|
| UndoLastAction
|
|
| ClearNotification
|
|
|
|
update : Msg -> Model -> ( Model, Cmd Msg )
|
|
update msg model =
|
|
case msg of
|
|
LinkClicked urlRequest ->
|
|
case urlRequest of
|
|
Browser.Internal url ->
|
|
( model, Nav.pushUrl model.state.navKey (Url.toString url) )
|
|
|
|
Browser.External href ->
|
|
( setError ("External request '" ++ href ++ "'") model
|
|
, Cmd.none )
|
|
|
|
UrlChanged url ->
|
|
let
|
|
route = P.parse routeParser url
|
|
state = model.state
|
|
in
|
|
case route of
|
|
Just page ->
|
|
{ model | state = { state | route = page }}
|
|
|> update (case page of
|
|
-- Directly enter add mode on NewLoot view
|
|
NewLoot -> ModeSwitched (Just Add)
|
|
other -> ModeSwitched Nothing
|
|
)
|
|
|
|
Nothing ->
|
|
( setError "Invalid route" model, Cmd.none )
|
|
|
|
PlayerChanged newId ->
|
|
( { model | player = blankPlayer }, initPlayer newId )
|
|
|
|
ApiMsg apiMsg -> case apiMsg of
|
|
GotActionResult response ->
|
|
case response of
|
|
Ok result ->
|
|
let
|
|
updates = Maybe.withDefault [] result.updates
|
|
notification = result.notification
|
|
errors = Maybe.withDefault "" result.errors
|
|
in
|
|
List.foldl applyUpdate model updates
|
|
|> setNotification notification
|
|
|> setError errors
|
|
|> update (ModeSwitched Nothing)
|
|
Err r -> (setError (Debug.toString r) model, Cmd.none)
|
|
|
|
GotPlayer result ->
|
|
case result of
|
|
Ok player ->
|
|
( { model | player = player }
|
|
, Cmd.none
|
|
)
|
|
Err error ->
|
|
( setError ("Fetching player... " ++ printError error) model
|
|
, Cmd.none
|
|
)
|
|
|
|
GotClaims id result ->
|
|
case result of
|
|
Ok claims -> ( { model | claims = List.filter (\c -> c.player_id == id) claims}, Cmd.none )
|
|
Err error -> ( setError ("Fetching claims..." ++ Debug.toString error) model, Cmd.none)
|
|
|
|
GotLoot dest result ->
|
|
case result of
|
|
Ok loot ->
|
|
( case dest of
|
|
Api.OfPlayer _ -> { model | loot = Just loot}
|
|
Api.OfGroup -> { model | groupLoot = Just loot}
|
|
Api.OfShop -> { model | merchantItems = Just loot}
|
|
, Cmd.none
|
|
)
|
|
Err error ->
|
|
( setError ("Fetching loot... " ++ printError error) model
|
|
, Cmd.none
|
|
)
|
|
|
|
LootViewItemSwitched id ->
|
|
let
|
|
state = model.state
|
|
in
|
|
( { model | state =
|
|
{ state | selection = Debug.log "new selection"
|
|
<| switchSelectionState id state.selection }}
|
|
, Cmd.none )
|
|
|
|
ModeSwitched newMode ->
|
|
let
|
|
state = model.state
|
|
in
|
|
( { model | state =
|
|
{ state | activeMode = newMode
|
|
, selection =
|
|
case newMode of
|
|
Nothing ->
|
|
Nothing
|
|
|
|
Just Grab -> -- Currently claimed object are initially selected
|
|
Just ( Set.fromList <| List.map (\c -> c.loot_id) model.claims)
|
|
|
|
Just others ->
|
|
Just Set.empty
|
|
}}
|
|
, Cmd.none )
|
|
|
|
ConfirmAction ->
|
|
let
|
|
currentMode = model.state.activeMode
|
|
in
|
|
(model, Cmd.map ApiMsg Api.sendRequest currentMode model)
|
|
|
|
UndoLastAction ->
|
|
(model, Cmd.map ApiMsg Api.undoLastAction model.player.id)
|
|
|
|
ClearNotification ->
|
|
( { model | notification = Nothing }, Cmd.none )
|
|
|
|
setNotification : Maybe String -> Model -> Model
|
|
setNotification notification model =
|
|
{ model | notification = notification }
|
|
|
|
targetItemsFor : ViewMode -> Model -> List Item
|
|
targetItemsFor mode model =
|
|
case mode of
|
|
Add -> []
|
|
Buy -> Maybe.withDefault [] model.merchantItems
|
|
Sell ->Maybe.withDefault [] model.loot
|
|
Grab -> Maybe.withDefault [] model.groupLoot
|
|
|
|
buildPayload : ViewMode -> Model -> E.Value
|
|
buildPayload mode model =
|
|
let
|
|
items = targetItemsFor mode model
|
|
|> List.filter (itemInSelection model.state.selection)
|
|
in
|
|
case mode of
|
|
Buy -> E.object
|
|
[ ( "items", items |> E.list (\i -> E.list identity [E.int i.id, E.null]))
|
|
, ("global_mod", E.null )
|
|
]
|
|
Sell -> E.object
|
|
[ ( "items", items |> E.list (\i -> E.list identity [E.int i.id, E.null]))
|
|
, ("global_mod", E.null )
|
|
]
|
|
Grab -> E.object
|
|
[ ( "items", items |> E.list (\i -> E.int i.id))
|
|
, ("global_mod", E.null )
|
|
]
|
|
Add -> E.object
|
|
[ ( "items", items |> E.list (\i -> E.int i.id))
|
|
, ("global_mod", E.null )
|
|
]
|
|
|
|
type DbUpdate
|
|
= ItemRemoved Item
|
|
| ItemAdded Item
|
|
| WealthUpdated Wealth
|
|
| ClaimAdded ()
|
|
| ClaimRemoved ()
|
|
|
|
-- DbUpdates always refer to the active player's loot
|
|
applyUpdate : DbUpdate -> Model -> Model
|
|
applyUpdate u model =
|
|
case u of
|
|
ItemRemoved item -> { model | loot = Just
|
|
<| List.filter (\i -> i.id /= item.id)
|
|
<| Maybe.withDefault [] model.loot }
|
|
ItemAdded item -> { model | loot = Just
|
|
<| item :: Maybe.withDefault [] model.loot }
|
|
WealthUpdated diff ->
|
|
let
|
|
player = model.player
|
|
wealth = player.wealth
|
|
in
|
|
{ model | player = { player | wealth =
|
|
(Wealth
|
|
(wealth.cp + diff.cp)
|
|
(wealth.sp + diff.sp)
|
|
(wealth.gp + diff.gp)
|
|
(wealth.pp + diff.pp)
|
|
)}}
|
|
ClaimAdded _ -> model
|
|
ClaimRemoved _ -> model
|
|
|
|
|
|
-- ERRORS
|
|
|
|
setError : String -> Model -> Model
|
|
setError error model =
|
|
let
|
|
state = model.state
|
|
in
|
|
{ model | state =
|
|
{ state | error = error }}
|
|
|
|
|
|
printError : Http.Error -> String
|
|
printError error =
|
|
case error of
|
|
Http.NetworkError -> "Le serveur ne répond pas"
|
|
_ -> "Erreur inconnue"
|
|
|
|
-- STATE Utils
|
|
|
|
switchSelectionState : Int -> Maybe Selection -> Maybe Selection
|
|
switchSelectionState id selection =
|
|
case selection of
|
|
Just s ->
|
|
Just <| case Set.member id s of
|
|
True -> Set.remove id s
|
|
False -> Set.insert id s
|
|
Nothing -> Debug.log "ignore switchSelectionState" Nothing
|
|
|
|
-- SUBSCRIPTIONS
|
|
--
|
|
subscriptions : Model -> Sub Msg
|
|
subscriptions _ =
|
|
Sub.none
|
|
|
|
|
|
---
|
|
-- VIEWS
|
|
---
|
|
|
|
type ViewMode
|
|
= Sell
|
|
| Buy
|
|
| Grab
|
|
| Add
|
|
|
|
canSelectIn : ViewMode -> Bool
|
|
canSelectIn mode =
|
|
case mode of
|
|
Sell -> True
|
|
Buy -> True
|
|
Grab -> True
|
|
Add -> False
|
|
|
|
actionButton msg t icon color =
|
|
button [ class <| "button level-item is-" ++ color
|
|
, onClick msg ]
|
|
[ span [ class "icon" ] [ i [ Svg.Attributes.class <| "fas fa-" ++ icon ] [] ]
|
|
, p [] [text t]
|
|
]
|
|
|
|
controlsWhenModeActive : ViewMode -> List (Html Msg)
|
|
controlsWhenModeActive mode =
|
|
[ actionButton (ConfirmAction) "Valider" "check" "primary"
|
|
, actionButton (ModeSwitched Nothing) "Annuler" "times" "danger"
|
|
]
|
|
|
|
controlsWhenRoute : Route -> List (Html Msg)
|
|
controlsWhenRoute route =
|
|
case route of
|
|
PlayerChest -> [actionButton (ModeSwitched (Just Sell)) "Vendre" "coins" "danger"]
|
|
GroupLoot -> [actionButton (ModeSwitched (Just Grab)) "Demander" "praying-hands" "primary"]
|
|
Merchant -> [actionButton (ModeSwitched (Just Buy)) "Acheter" "coins" "success"]
|
|
NewLoot -> [actionButton (ModeSwitched (Just Add)) "Nouveau loot" "plus" "primary"]
|
|
|
|
view : Model -> Browser.Document Msg
|
|
view model =
|
|
let
|
|
-- What do we show inside the chest ?
|
|
(header, shownLoot) =
|
|
case model.state.route of
|
|
PlayerChest ->
|
|
("Mon coffre", Maybe.withDefault [] model.loot)
|
|
GroupLoot ->
|
|
("Coffre de groupe", Maybe.withDefault [] model.groupLoot)
|
|
Merchant ->
|
|
("Marchand", Maybe.withDefault [] model.merchantItems)
|
|
NewLoot ->
|
|
("Nouveau trésor :)", [] )
|
|
|
|
{- Dynamic renderers for ViewMode
|
|
|
|
Header controls are inserted in the PlayerBar
|
|
and rowControls to the right side of every item rows
|
|
-}
|
|
(headerControls, rowControls) =
|
|
case model.state.activeMode of
|
|
Just mode ->
|
|
( controlsWhenModeActive mode, Just (rowControlsForMode mode isSelected))
|
|
Nothing -> -- Buttons to enter mode
|
|
( actionButton UndoLastAction "Annuler action" "backspace" "danger"
|
|
:: controlsWhenRoute model.state.route
|
|
-- Claim controls for Group chest
|
|
, case model.state.route of
|
|
GroupLoot -> Just (renderIfClaimed <| itemInClaims model.claims)
|
|
_ -> Nothing
|
|
)
|
|
|
|
-- TODO: should we extract the Maybe conversion
|
|
-- and represent cannotSelect with Nothing ??
|
|
isSelected =
|
|
itemInSelection model.state.selection
|
|
in
|
|
{ title = "Loot-a-lot in ELM"
|
|
, body =
|
|
[ viewHeaderBar model
|
|
, viewPlayerBar model.player model.notification headerControls
|
|
, article [class "section container"]
|
|
[ p [class "heading"] [text header]
|
|
, viewSearchBar
|
|
, viewChest isSelected rowControls shownLoot
|
|
]
|
|
, hr [] []
|
|
, section [class "container"] [viewDebugSection model]
|
|
]
|
|
}
|
|
|
|
viewNotification : Maybe String -> Html Msg
|
|
viewNotification notification =
|
|
case notification of
|
|
Just t -> div [ class "notification is-success is-marginless"]
|
|
[ button [class "delete", onClick ClearNotification ] []
|
|
, text t ]
|
|
Nothing -> text ""
|
|
|
|
-- LOOT Views
|
|
|
|
itemInSelection : Maybe Selection -> Item -> Bool
|
|
itemInSelection selection item =
|
|
Maybe.map (Set.member item.id) selection
|
|
|> Maybe.withDefault False
|
|
|
|
itemInClaims : List Claim -> Item -> Bool
|
|
itemInClaims claims item =
|
|
List.any (\c -> c.loot_id == item.id) claims
|
|
|
|
renderIfClaimed : (Item -> Bool) -> Item -> Html Msg
|
|
renderIfClaimed isClaimed item =
|
|
case isClaimed item of
|
|
True -> renderIcon "fas fa-praying-hands" "1x"
|
|
False -> text ""
|
|
|
|
viewChest : (Item -> Bool) -> Maybe (Item -> Html Msg) -> Loot -> Html Msg
|
|
viewChest isSelected rowControls items =
|
|
table [ class "table is-fullwidth is-hoverable"]
|
|
[ thead [ class "table-header" ]
|
|
[ th [] [ text "Nom" ] ]
|
|
, tbody [] <| List.map (viewItemTableRow isSelected rowControls) items
|
|
]
|
|
|
|
-- Renders controls for a specific mode
|
|
rowControlsForMode : ViewMode -> (Item -> Bool) -> Item -> Html Msg
|
|
rowControlsForMode mode isSelected item =
|
|
let
|
|
itemInfo = case mode of
|
|
Buy -> p [class "level-item"] [ text (String.fromInt item.base_price ++ "po")]
|
|
Sell -> p [class "level-item"] [ text (String.fromFloat (toFloat item.base_price / 2) ++ "po")]
|
|
Grab -> p [class "level-item"] [ text "Grab" ]
|
|
Add -> p [class "level-item"] [ text "New !" ]
|
|
in
|
|
div [ class "level-right" ]
|
|
<| itemInfo
|
|
:: if canSelectIn mode then
|
|
[input [ class "checkbox level-item"
|
|
, type_ "checkbox"
|
|
, checked <| isSelected item
|
|
, onCheck (\v -> LootViewItemSwitched item.id)
|
|
] [] ]
|
|
else
|
|
[]
|
|
|
|
|
|
viewItemTableRow : (Item -> Bool) -> Maybe (Item -> Html Msg) -> Item -> Html Msg
|
|
viewItemTableRow isSelected rowControls item =
|
|
tr [ classList [ ("is-selected", isSelected item) ] ]
|
|
[ td []
|
|
[ label [ class "level checkbox" ]
|
|
<| div [ class "level-left" ]
|
|
[ p [class "level-item"] [ text item.name ]]
|
|
:: case rowControls of
|
|
Just render -> List.singleton (render item)
|
|
Nothing -> []
|
|
]
|
|
]
|
|
|
|
-- DEBUG SECTION
|
|
|
|
viewDebugSection : Model -> Html Msg
|
|
viewDebugSection model =
|
|
div [class "panel is-danger"]
|
|
[ p [class "panel-heading"] [text "Debug"]
|
|
, debugSwitchPlayers
|
|
, p [class "panel-block has-text-danger"] [text model.state.error]
|
|
, p [class "panel-block"] [text ("Route : " ++ Debug.toString model.state.route)]
|
|
, p [class "panel-block"] [text ("Active Mode : " ++ Debug.toString model.state.activeMode)]
|
|
, p [class "panel-block"] [text ("Selection : " ++ Debug.toString model.state.selection)]
|
|
, p [class "panel-block"] [text ("Claims : " ++ Debug.toString model.claims)]
|
|
, p [] debugSandbox
|
|
]
|
|
|
|
stackedIcon name =
|
|
span [class "icon is-medium"]
|
|
[ span [ class "fa-stack" ]
|
|
[ i [ class "fas fa-circle fa-stack-2x" ] []
|
|
, i [ class (name ++ " fa-inverse fa-stack-1x") ] []
|
|
, text ""
|
|
]
|
|
]
|
|
|
|
debugSandbox =
|
|
[ stackedIcon "fas fa-coins"
|
|
, stackedIcon "fab fa-d-and-d"
|
|
, stackedIcon "fas fa-praying-hands"
|
|
, stackedIcon "fas fa-gem"
|
|
, stackedIcon "fas fa-pen"
|
|
, stackedIcon "fas fa-percentage"
|
|
, stackedIcon "fas fa-store-alt"
|
|
, stackedIcon "fas fa-cart-plus"
|
|
, stackedIcon "fas fa-angry"
|
|
, stackedIcon "fas fa-plus"
|
|
, stackedIcon "fas fa-tools"
|
|
, stackedIcon "fas fa-search"
|
|
]
|
|
|
|
debugSwitchPlayers : Html Msg
|
|
debugSwitchPlayers =
|
|
div [ class "panel-tabs" ]
|
|
[ a [ onClick (PlayerChanged 0) ] [text "Groupe"]
|
|
, a [ onClick (PlayerChanged 1) ] [text "Lomion"]
|
|
, a [ onClick (PlayerChanged 2) ] [text "Fefi"]
|
|
]
|
|
|
|
|
|
renderIcon name size =
|
|
span [ class <| "icon is-medium"]
|
|
[ i [ class <| name ++ " fa-" ++ size] [] ]
|
|
|
|
|
|
-- HEADER SECTION
|
|
|
|
viewHeaderBar : Model -> Html Msg
|
|
viewHeaderBar model =
|
|
nav [ class "navbar container", class "is-info" ]
|
|
[ div [ class "navbar-brand" ]
|
|
[ a [ class "navbar-item", href "/"]
|
|
[ renderIcon "fab fa-d-and-d" "2x"
|
|
, span [] [ text model.player.name ]
|
|
]
|
|
, a [class "navbar-burger is-active"]
|
|
[ span [attribute "aria-hidden" "true"] []
|
|
, span [attribute "aria-hidden" "true"] []
|
|
, span [attribute "aria-hidden" "true"] []
|
|
]
|
|
]
|
|
, div [ class "navbar-menu is-active" ]
|
|
[ div [class "navbar-end"]
|
|
[ a [class "navbar-item", href "/marchand"]
|
|
[ renderIcon "fas fa-store-alt" "1x"
|
|
, span [] [text "Marchand"]
|
|
]
|
|
, a
|
|
[ class "navbar-item"
|
|
, href (if model.player.id == 0
|
|
then
|
|
"/nouveau-tresor"
|
|
else
|
|
"/coffre")
|
|
]
|
|
[ renderIcon "fas fa-gem" "1x"
|
|
, span [] [text (if model.player.id == 0 then "Nouveau loot" else "Coffre de groupe")]
|
|
]
|
|
]
|
|
]
|
|
|
|
]
|
|
|
|
-- PLAYER BAR
|
|
|
|
viewPlayerBar : Player -> Maybe String -> List (Html Msg)-> Html Msg
|
|
viewPlayerBar player notification actionControls =
|
|
section [ class "level container is-mobile box" ]
|
|
[ div [class "level-left"]
|
|
([div [ class "level-item" ]
|
|
[ span [ class "icon is-large" ]
|
|
[ i [ class "fas fa-2x fa-piggy-bank" ] [] ]]
|
|
]
|
|
++ (viewWealth player.wealth)
|
|
++ (if player.debt > 0 then
|
|
[div [class "level-item"]
|
|
[p [class "heading is-size-4 has-text-danger"]
|
|
[text ("Dette : " ++ (String.fromInt player.debt) ++ "po")]
|
|
]]
|
|
else
|
|
[]
|
|
)
|
|
)
|
|
, viewNotification notification
|
|
, div [class "level-right"] actionControls
|
|
]
|
|
|
|
|
|
viewWealth : Wealth -> List (Html Msg)
|
|
viewWealth wealth =
|
|
[ showWealthField "pp" <| String.fromInt wealth.pp
|
|
, showWealthField "gp" <| String.padLeft 2 '0' <| String.fromInt wealth.gp
|
|
, showWealthField "sp" <| String.fromInt wealth.sp
|
|
, showWealthField "cp" <| String.fromInt wealth.cp
|
|
]
|
|
|
|
showWealthField : String -> String -> Html Msg
|
|
showWealthField name value =
|
|
div [ class "level-item" ]
|
|
[ p [class "has-text-right"] [ strong [ class "heading is-marginless"] [text name]
|
|
, span [ class <| "is-size-4" ] [ text value ]
|
|
]
|
|
]
|
|
|
|
-- Search Bar
|
|
|
|
viewSearchBar : Html Msg
|
|
viewSearchBar =
|
|
input [class "input"] []
|
|
|
|
---
|
|
-- ROUTES
|
|
---
|
|
|
|
type Route
|
|
= PlayerChest
|
|
| Merchant
|
|
| GroupLoot
|
|
| NewLoot
|
|
|
|
routeParser : Parser (Route -> a) a
|
|
routeParser =
|
|
oneOf
|
|
[ P.map GroupLoot (P.s "coffre")
|
|
, P.map PlayerChest P.top
|
|
, P.map Merchant (P.s "marchand")
|
|
, P.map NewLoot (P.s "nouveau-tresor")
|
|
]
|
|
|