restores all functionnality after refactoring

ready to go on !
This commit is contained in:
2019-11-06 21:50:49 +01:00
parent 081ef1a89f
commit 8a604279db
6 changed files with 694 additions and 394 deletions

View File

@@ -1,17 +1,18 @@
module Api exposing (..)
import Http
import Json.Decode as D
import Json.Decode exposing (Decoder, int, string, field, succeed)
import Json.Decode as D exposing (Decoder, field, int, string, succeed)
import Json.Encode as E
import Modes exposing (ViewMode)
type alias HttpResult a = (Result Http.Error a)
type alias HttpResult a =
Result Http.Error a
type alias Response =
{ value: Maybe String
, notification: Maybe String
{ value : Maybe String
, notification : Maybe String
, updates : Maybe (List Update)
, errors : Maybe String
}
@@ -24,6 +25,7 @@ type Update
| ClaimAdded ()
| ClaimRemoved ()
type Msg
= GotPlayer (HttpResult Player)
| GotClaims Int (HttpResult Claims)
@@ -31,67 +33,84 @@ type Msg
| GotActionResult (HttpResult Response)
---
-- MODELS
---
-- Player
type alias Player =
{ id: Int
, name: String
, debt: Int
, wealth: Wealth
{ id : Int
, name : String
, debt : Int
, wealth : Wealth
}
blankPlayer =
Player 0 "Loot-a-lot" 0 (Wealth 0 0 0 0)
type alias Wealth =
{ cp: Int
, sp: Int
, gp: Int
, pp: Int
{ cp : Int
, sp : Int
, gp : Int
, pp : Int
}
-- Loot
type alias Loot = List Item
type alias Loot =
List Item
type alias Item =
{ id: Int
, name: String
, base_price: Int
{ id : Int
, name : String
, base_price : Int
}
-- Claims
type alias Claims = List Claim
type alias Claims =
List Claim
type alias Claim =
{ id: Int
, player_id: Int
, loot_id: Int
{ id : Int
, player_id : Int
, loot_id : Int
}
-- PLAYERS
--
fetchPlayer : Int -> Cmd Msg
fetchPlayer id =
Http.get
{ url = "http://localhost:8088/api/players/" ++ (String.fromInt id) ++ "/"
, expect = Http.expectJson GotPlayer (valueDecoder playerDecoder )
{ url = "http://localhost:8088/api/players/" ++ String.fromInt id ++ "/"
, expect = Http.expectJson GotPlayer (valueDecoder playerDecoder)
}
playerDecoder : Decoder Player
playerDecoder =
D.map4 Player
(D.field "id" int)
(D.field "name" string)
(D.field "debt" int)
wealthDecoder
(D.field "id" int)
(D.field "name" string)
(D.field "debt" int)
wealthDecoder
wealthDecoder : Decoder Wealth
wealthDecoder =
@@ -101,127 +120,172 @@ wealthDecoder =
(D.field "gp" int)
(D.field "pp" int)
-- LOOT
-- LOOT
-- Location of a loot
type ToChest
= OfPlayer Int
| OfGroup
| OfShop
itemDecoder =
D.map3 Item
(D.field "id" int)
(D.field "name" string)
(D.field "base_price" int)
lootDecoder : Decoder Loot
lootDecoder =
Json.Decode.list itemDecoder
D.list itemDecoder
fetchLoot : ToChest -> Cmd Msg
fetchLoot dest =
let
url = case dest of
OfPlayer id -> "http://localhost:8088/api/players/" ++ (String.fromInt id) ++ "/loot"
OfShop -> "http://localhost:8088/api/items"
OfGroup -> "http://localhost:8088/api/players/0/loot"
url =
case dest of
OfPlayer id ->
"http://localhost:8088/api/players/" ++ String.fromInt id ++ "/loot"
OfShop ->
"http://localhost:8088/api/items"
OfGroup ->
"http://localhost:8088/api/players/0/loot"
in
Http.get
{ url = url
, expect = Http.expectJson (GotLoot dest) (valueDecoder lootDecoder)}
, expect = Http.expectJson (GotLoot dest) (valueDecoder lootDecoder)
}
-- CLAIMS
claimDecoder =
D.map3 Claim
(D.field "id" int)
(D.field "player_id" int)
(D.field "loot_id" int)
fetchClaims : Int -> Cmd Msg
fetchClaims playerId =
Http.get
{ url = "http://localhost:8088/api/claims"
, expect = valueDecoder (D.list claimDecoder)
|> Http.expectJson (GotClaims playerId)
, expect =
valueDecoder (D.list claimDecoder)
|> Http.expectJson (GotClaims playerId)
}
-- API Response
--
valueDecoder : Decoder a -> Decoder a
valueDecoder thenDecoder =
D.field "value" thenDecoder
-- TODO: update server to produce better json
-- like an object with list of updates of the same type
-- { ItemRemoved : [..], Wealth : [ .. ], .. }
updatesDecoder : Decoder Update
updatesDecoder =
-- We expect one update but do not know it's kind
Json.Decode.oneOf
[ (field "ItemRemoved" (itemDecoder |> Json.Decode.andThen (\i -> succeed <| ItemRemoved i)))
, (field "ItemAdded" (itemDecoder |> Json.Decode.andThen (\i -> succeed <| ItemAdded i)))
, (field "Wealth" (wealthDecoder |> Json.Decode.andThen (\i -> succeed <| WealthUpdated i)))
, (field "ClaimRemoved" (succeed () |> Json.Decode.andThen (\i -> succeed <| ClaimRemoved i)))
, (field "ClaimAdded" (succeed () |> Json.Decode.andThen (\i -> succeed <| ClaimAdded i)))
]
D.oneOf
[ field "ItemRemoved" (itemDecoder |> D.andThen (\i -> succeed <| ItemRemoved i))
, field "ItemAdded" (itemDecoder |> D.andThen (\i -> succeed <| ItemAdded i))
, field "Wealth" (wealthDecoder |> D.andThen (\i -> succeed <| WealthUpdated i))
, field "ClaimRemoved" (succeed () |> D.andThen (\i -> succeed <| ClaimRemoved i))
, field "ClaimAdded" (succeed () |> D.andThen (\i -> succeed <| ClaimAdded i))
]
apiResponseDecoder : Decoder Response
apiResponseDecoder =
Json.Decode.map4 Response
D.map4 Response
(D.maybe (field "value" string))
(Json.Decode.maybe (field "notification" string))
(Json.Decode.maybe (field "updates" (Json.Decode.list updatesDecoder)))
(Json.Decode.maybe (field "errors" string))
(D.maybe (field "notification" string))
(D.maybe (field "updates" (D.list updatesDecoder)))
(D.maybe (field "errors" string))
undoLastAction id =
Http.request
{ url = "http://localhost:8088/api/players/" ++ String.fromInt id ++ "/events/last"
, method = "DELETE"
, headers = []
, body = Http.emptyBody
, expect = Http.expectJson GotActionResult apiResponseDecoder
, timeout = Nothing
, tracker = Nothing
}
undoLastAction id = Http.request
{ url = "http://localhost:8088/api/players/" ++ String.fromInt id ++"/events/last"
, method = "DELETE"
, headers = []
, body = Http.emptyBody
, expect = Http.expectJson GotActionResult apiResponseDecoder
, timeout = Nothing
, tracker = Nothing
}
buildPayload : ViewMode -> List Item -> E.Value
buildPayload mode items =
case mode of
Modes.Buy -> E.object
[ ( "items", items |> E.list (\i -> E.list identity [E.int i.id, E.null]))
, ("global_mod", E.null )
]
Modes.Sell -> E.object
[ ( "items", items |> E.list (\i -> E.list identity [E.int i.id, E.null]))
, ("global_mod", E.null )
]
Modes.Grab -> E.object
[ ( "items", items |> E.list (\i -> E.int i.id))
, ("global_mod", E.null )
]
Modes.Add -> E.object
[ ( "items", items |> E.list (\i -> E.int i.id))
, ("global_mod", E.null )
]
case mode of
Modes.Buy ->
E.object
[ ( "items", items |> E.list (\i -> E.list identity [ E.int i.id, E.null ]) )
, ( "global_mod", E.null )
]
Modes.Sell ->
E.object
[ ( "items", items |> E.list (\i -> E.list identity [ E.int i.id, E.null ]) )
, ( "global_mod", E.null )
]
Modes.Grab ->
E.object
[ ( "items", items |> E.list (\i -> E.int i.id) )
, ( "global_mod", E.null )
]
Modes.Add ->
E.object
[ ( "items", items |> E.list (\i -> E.int i.id) )
, ( "global_mod", E.null )
]
sendRequest : ViewMode -> String -> List Item -> Cmd Msg
sendRequest mode id items =
let
(endpoint, method) = case mode of
Modes.Add ->
( "http://localhost:8088/api/players/" ++ id ++ "/loot"
, "POST" )
Modes.Buy ->
( "http://localhost:8088/api/players/" ++ id ++ "/loot"
, "PUT" )
Modes.Sell ->
( "http://localhost:8088/api/players/" ++ id ++ "/loot"
, "DELETE" )
Modes.Grab ->
( "http://localhost:8088/api/players/" ++ id ++ "/claims"
, "POST" )
( endpoint, method ) =
case mode of
Modes.Add ->
( "http://localhost:8088/api/players/" ++ id ++ "/loot"
, "POST"
)
Modes.Buy ->
( "http://localhost:8088/api/players/" ++ id ++ "/loot"
, "PUT"
)
Modes.Sell ->
( "http://localhost:8088/api/players/" ++ id ++ "/loot"
, "DELETE"
)
Modes.Grab ->
( "http://localhost:8088/api/players/" ++ id ++ "/claims"
, "POST"
)
in
Http.request
{ method = method
@@ -234,9 +298,11 @@ sendRequest mode id items =
}
printError : Http.Error -> String
printError error =
case error of
Http.NetworkError -> "Le serveur ne répond pas"
_ -> "Erreur inconnue"
Http.NetworkError ->
"Le serveur ne répond pas"
_ ->
"Erreur inconnue"

View File

@@ -1,33 +1,46 @@
module Chest exposing (..)
import Api exposing (Claims, Item, Loot)
import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (onCheck)
import Set exposing (Set)
import Route
import Modes exposing (ViewMode)
import Api exposing (Item)
import Route exposing (..)
import Set exposing (Set)
import Utils exposing (..)
type alias Model =
{ items: List Item
{ loot : Loot
, groupLoot : Loot
, merchantItems : Loot
, newLoot : Loot
, selection : Maybe Selection
, claims : Claims
}
type alias Selection = Set Int
type alias Selection =
Set Int
type Msg
= SetSelection (Maybe Selection)
| SwitchSelectionState Int
init : Model
init =
{ items = []
{ loot = []
, groupLoot = []
, merchantItems = []
, newLoot = []
, selection = Nothing
, claims = []
}
update : Msg -> Model -> (Model, Cmd Msg)
update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
case msg of
SwitchSelectionState id ->
@@ -36,66 +49,121 @@ update msg model =
SetSelection new ->
( { model | selection = new }, Cmd.none )
view : Maybe ViewMode -> Route.Route -> Model -> Html Msg
view mode route model =
let
isSelected = itemInSelection model.selection
rowControls = case mode of
Just m ->
Just (rowControlsForMode isSelected m)
Nothing -> -- Claim controls for Group chest
case route of
Route.GroupLoot -> Just (claimedItemRenderer isSelected)
_ -> Nothing
( header, shownItems ) =
case route of
Route.PlayerChest ->
( "Mon coffre", model.loot )
Route.GroupLoot ->
( "Coffre de groupe", model.groupLoot )
Route.Merchant ->
( "Marchand", model.merchantItems )
Route.NewLoot ->
( "Nouveau trésor :)", [] )
isSelected =
itemInSelection model.selection
rowControls =
case mode of
Just m ->
Just (rowControlsForMode isSelected m)
Nothing ->
case route of
Route.GroupLoot ->
-- Claim controls for Group chest
Just <|
claimedItemRenderer <|
itemInClaims model.claims
_ ->
Nothing
in
table [ class "table is-fullwidth is-hoverable"]
[ thead [ class "table-header" ]
[ th [] [ text "Nom" ] ]
, tbody [] <| List.map (viewItemTableRow isSelected rowControls) model.items
article
[ class "section" ]
[ p [ class "heading" ] [ text header ]
, viewSearchBar
, table [ class "table is-fullwidth is-hoverable" ]
[ thead [ class "table-header" ]
[ th [] [ text "Nom" ] ]
, tbody [] <| List.map (viewItemTableRow isSelected rowControls) shownItems
]
]
claimedItemRenderer isSelected item =
case isSelected item of
True -> renderIcon "fas fa-praying-hands" "1x"
False -> text ""
claimedItemRenderer : (Item -> Bool) -> Item -> Html Msg
claimedItemRenderer isClaimed item =
case isClaimed item of
True ->
renderIcon "fas fa-praying-hands" "1x"
False ->
text ""
-- Renders controls for a specific mode
rowControlsForMode : (Item -> Bool) -> ViewMode -> Item -> Html Msg
rowControlsForMode isSelected mode item =
let
itemInfo = case mode of
Modes.Buy -> p [class "level-item"] [ text (String.fromInt item.base_price ++ "po")]
Modes.Sell -> p [class "level-item"] [ text (String.fromFloat (toFloat item.base_price / 2) ++ "po")]
Modes.Grab -> p [class "level-item"] [ text "Grab" ]
Modes.Add -> p [class "level-item"] [ text "New !" ]
itemInfo =
case mode of
Modes.Buy ->
p [ class "level-item" ] [ text (String.fromInt item.base_price ++ "po") ]
Modes.Sell ->
p [ class "level-item" ] [ text (String.fromFloat (toFloat item.base_price / 2) ++ "po") ]
Modes.Grab ->
p [ class "level-item" ] [ text "Grab" ]
Modes.Add ->
p [ class "level-item" ] [ text "New !" ]
in
div [ class "level-right" ]
<| itemInfo
:: if Modes.canSelectIn mode then
[input [ class "checkbox level-item"
, type_ "checkbox"
, checked <| isSelected item
, onCheck (\v -> SwitchSelectionState item.id)
] [] ]
else
[]
div [ class "level-right" ] <|
itemInfo
:: (if Modes.canSelectIn mode then
[ input
[ class "checkbox level-item"
, type_ "checkbox"
, checked <| isSelected item
, onCheck (\v -> SwitchSelectionState item.id)
]
[]
]
else
[]
)
viewItemTableRow : (Item -> Bool) -> Maybe (Item -> Html Msg) -> Item -> Html Msg
viewItemTableRow isSelected rowControls item =
tr [ classList [ ("is-selected", isSelected 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 -> []
[ 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 ->
[]
)
]
]
itemInSelection : Maybe Selection -> Item -> Bool
itemInSelection selection item =
Maybe.map (Set.member item.id) selection
@@ -106,7 +174,54 @@ 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
Just <|
case Set.member id s of
True ->
Set.remove id s
False ->
Set.insert id s
Nothing ->
Debug.log "ignore switchSelectionState" Nothing
--
-- Search Bar
viewSearchBar : Html Msg
viewSearchBar =
input [ class "input" ] []
targetItemsFor : Route -> Model -> List Item
targetItemsFor route model =
case route of
Route.NewLoot ->
model.newLoot
Route.Merchant ->
model.merchantItems
Route.PlayerChest ->
model.loot
Route.GroupLoot ->
model.groupLoot
getSelected : Route -> Model -> Loot
getSelected route model =
targetItemsFor route model
|> List.filter (itemInSelection model.selection)
-- LOOT Views
itemInClaims : Claims -> Item -> Bool
itemInClaims claims item =
List.any (\c -> c.loot_id == item.id) claims

View File

@@ -1,23 +1,25 @@
module Main exposing (..)
import Api exposing (Claim, Claims, Item, Loot, Player, Wealth)
import Browser
import Browser.Navigation as Nav
import Url
import Chest exposing (Msg)
import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (..)
import Svg.Attributes
import Set exposing (Set)
import Json.Encode as E
import Api exposing (Player, Loot, Wealth, Item, Claim, Claims)
import Modes exposing (ViewMode)
import Route exposing (..)
import Chest
import Chest exposing (Msg)
import Set exposing (Set)
import Svg.Attributes
import Url
import Utils exposing (..)
-- Main
main : Program () Model Msg
main =
Browser.application
@@ -29,45 +31,48 @@ main =
, onUrlRequest = LinkClicked
}
-- Model
type alias State =
{ navKey : Nav.Key
, route : Route
, error : String
, menuOpen : Bool
, activeMode : Maybe ViewMode
{ menuOpen : Bool
, error : Maybe String
, notification : Maybe String
}
type alias Model =
{ state : State
, player: Player
, navKey : Nav.Key
, route : Route
, mode : Maybe ViewMode
, player : Player
, chest : Chest.Model
, 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 routeParser url of
Just r -> r
Nothing -> PlayerChest
route =
case routeParser url of
Just r ->
r
Nothing ->
PlayerChest
in
( Model
(State key route "" False Nothing)
Api.blankPlayer
Chest.init
[]
Nothing
Nothing
Nothing
Nothing
, fetchInitialData 0)
( Model
(State False Nothing Nothing)
key
route
Nothing
Api.blankPlayer
Chest.init
, fetchInitialData 0
)
fetchInitialData : Int -> Cmd Msg
@@ -78,6 +83,7 @@ fetchInitialData playerId =
, Cmd.map ApiMsg <| Api.fetchLoot Api.OfGroup
]
initPlayer id =
Cmd.batch
[ Cmd.map ApiMsg <| Api.fetchPlayer id
@@ -85,8 +91,11 @@ initPlayer id =
, Cmd.map ApiMsg <| Api.fetchClaims id
]
-- UPDATE
type Msg
= LinkClicked Browser.UrlRequest
| UrlChanged Url.Url
@@ -98,303 +107,391 @@ type Msg
| 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) )
( model, Nav.pushUrl model.navKey (Url.toString url) )
Browser.External href ->
( setError ("External request '" ++ href ++ "'") model
, Cmd.none )
, Cmd.none
)
UrlChanged url ->
let
route = routeParser url
state = model.state
route =
routeParser url
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 Modes.Add)
other -> ModeSwitched Nothing
)
case route of
Just page ->
{ model | route = page }
|> update
(case page of
-- Directly enter add mode on NewLoot view
NewLoot ->
ModeSwitched (Just Modes.Add)
Nothing ->
( setError "Invalid route" model, Cmd.none )
other ->
ModeSwitched Nothing
)
Nothing ->
( setError "Invalid route" model, Cmd.none )
PlayerChanged newId ->
( { model | player = Api.blankPlayer }, initPlayer newId )
ChestMsg chestMsg ->
let
(chest, _) = Chest.update chestMsg model.chest
( chest, _ ) =
Chest.update chestMsg model.chest
in
( { model | chest = chest }, Cmd.none )
( { model | chest = chest }, Cmd.none )
ApiMsg apiMsg -> case apiMsg of
Api.GotActionResult response ->
case response of
Ok result ->
let
updates = Maybe.withDefault [] result.updates
notification = result.notification
errors = Maybe.withDefault "" result.errors
in
ApiMsg apiMsg ->
case apiMsg of
Api.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)
Api.GotPlayer result ->
case result of
Ok player ->
( { model | player = player }
, Cmd.none
)
Err error ->
( setError ("Fetching player... " ++ Debug.toString error) model
, Cmd.none
)
Err r ->
( setError (Debug.toString r) model, Cmd.none )
Api.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)
Api.GotPlayer result ->
case result of
Ok player ->
( { model | player = player }
, Cmd.none
)
Api.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... " ++ Debug.toString error) model
, Cmd.none
)
Err error ->
( setError ("Fetching player... " ++ Debug.toString error) model
, Cmd.none
)
Api.GotClaims id result ->
case result of
Ok claims ->
( let
chest =
model.chest
in
{ model
| chest =
{ chest
| claims =
List.filter
(\c -> c.player_id == id)
claims
}
}
, Cmd.none
)
Err error ->
( setError ("Fetching claims..." ++ Debug.toString error) model, Cmd.none )
Api.GotLoot dest result ->
case result of
Ok loot ->
let
chest =
model.chest
in
( case dest of
Api.OfPlayer _ ->
{ model | chest = { chest | loot = loot } }
Api.OfGroup ->
{ model | chest = { chest | groupLoot = loot } }
Api.OfShop ->
{ model | chest = { chest | merchantItems = loot } }
, Cmd.none
)
Err error ->
( setError ("Fetching loot... " ++ Debug.toString error) model
, Cmd.none
)
ModeSwitched newMode ->
let
state = model.state
in
( { model | state =
{ state | activeMode = newMode }
, chest =
let
(newChest, _) = Chest.update (Chest.SetSelection
( { model
| mode = newMode
, chest =
let
( newChest, _ ) =
Chest.update
(Chest.SetSelection
(case newMode of
Nothing ->
Nothing
Just Modes.Grab -> -- Currently claimed object are initially selected
Just ( Set.fromList <| List.map (\c -> c.loot_id) model.claims)
Just Modes.Grab ->
-- Currently claimed object are initially selected
Just (Set.fromList <| List.map (\c -> c.loot_id) model.chest.claims)
Just others ->
Just Set.empty
))
model.chest
in newChest
}
, Cmd.none )
)
)
model.chest
in
newChest
}
, Cmd.none
)
ConfirmAction ->
case model.state.activeMode of
case model.mode of
Nothing ->
update (ModeSwitched Nothing) model
Just mode ->
let items = targetItemsFor mode model
|> List.filter (Chest.itemInSelection model.chest.selection)
let
items =
Chest.getSelected model.route model.chest
in
( model
, Cmd.map ApiMsg
<| Api.sendRequest
, Cmd.map ApiMsg <|
Api.sendRequest
mode
(String.fromInt model.player.id)
items
)
UndoLastAction ->
(model, Cmd.map ApiMsg <| Api.undoLastAction model.player.id)
( model, Cmd.map ApiMsg <| Api.undoLastAction model.player.id )
ClearNotification ->
( { model | notification = Nothing }, Cmd.none )
( setNotification Nothing model, Cmd.none )
setNotification : Maybe String -> Model -> Model
setNotification notification model =
{ model | notification = notification }
let
state =
model.state
in
{ model
| state =
{ state | notification = notification }
}
setLoot : Loot -> Model -> Model
setLoot items model =
let
chest =
model.chest
in
{ model | chest = { chest | loot = items } }
targetItemsFor : ViewMode -> Model -> List Item
targetItemsFor mode model =
case mode of
Modes.Add -> []
Modes.Buy -> Maybe.withDefault [] model.merchantItems
Modes.Sell ->Maybe.withDefault [] model.loot
Modes.Grab -> Maybe.withDefault [] model.groupLoot
-- DbUpdates always refer to the active player's loot
applyUpdate : Api.Update -> Model -> Model
applyUpdate u model =
case u of
Api.ItemRemoved item -> { model | loot = Just
<| List.filter (\i -> i.id /= item.id)
<| Maybe.withDefault [] model.loot }
Api.ItemAdded item -> { model | loot = Just
<| item :: Maybe.withDefault [] model.loot }
Api.ItemRemoved item ->
model
|> setLoot (List.filter (\i -> i.id /= item.id) model.chest.loot)
Api.ItemAdded item ->
model |> setLoot (item :: model.chest.loot)
Api.WealthUpdated diff ->
let
player = model.player
wealth = player.wealth
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)
)}}
Api.ClaimAdded _ -> model
Api.ClaimRemoved _ -> model
{ model
| player =
{ player
| wealth =
Wealth
(wealth.cp + diff.cp)
(wealth.sp + diff.sp)
(wealth.gp + diff.gp)
(wealth.pp + diff.pp)
}
}
Api.ClaimAdded _ ->
model
Api.ClaimRemoved _ ->
model
-- ERRORS
setError : String -> Model -> Model
setError error model =
let
state = model.state
state =
model.state
in
{ model | state =
{ state | error = error }}
{ model
| state =
{ state | error = Just error }
}
-- STATE Utils
-- SUBSCRIPTIONS
--
subscriptions : Model -> Sub Msg
subscriptions _ =
Sub.none
---
-- VIEWS
---
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]
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"
]
[ 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 Modes.Sell)) "Vendre" "coins" "danger"]
GroupLoot -> [actionButton (ModeSwitched (Just Modes.Grab)) "Demander" "praying-hands" "primary"]
Merchant -> [actionButton (ModeSwitched (Just Modes.Buy)) "Acheter" "coins" "success"]
NewLoot -> [actionButton (ModeSwitched (Just Modes.Add)) "Nouveau loot" "plus" "primary"]
PlayerChest ->
[ actionButton (ModeSwitched (Just Modes.Sell)) "Vendre" "coins" "danger" ]
GroupLoot ->
[ actionButton (ModeSwitched (Just Modes.Grab)) "Demander" "praying-hands" "primary" ]
Merchant ->
[ actionButton (ModeSwitched (Just Modes.Buy)) "Acheter" "coins" "success" ]
NewLoot ->
[ actionButton (ModeSwitched (Just Modes.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
Header controls are inserted in the PlayerBar
and rowControls to the right side of every item rows
-}
headerControls =
case model.state.activeMode of
Just mode -> controlsWhenModeActive mode
Nothing -> -- Buttons to enter mode
case model.mode of
Just mode ->
controlsWhenModeActive mode
Nothing ->
-- Buttons to enter mode
actionButton UndoLastAction "Annuler action" "backspace" "danger"
:: controlsWhenRoute model.state.route
:: controlsWhenRoute model.route
in
{ title = "Loot-a-lot in ELM"
, body =
[ viewHeaderBar model
, viewPlayerBar model.player model.notification headerControls
, article
[ class "section container" ]
[ viewNotification model.notification
, p [class "heading"] [text header]
, viewSearchBar
, viewPlayerBar model.player headerControls
, main_
[ class "container" ]
[ viewNotification model.state.notification
, Chest.view
model.state.activeMode
model.state.route
model.mode
model.route
model.chest
|> Html.map ChestMsg
|> Html.map ChestMsg
]
, hr [] []
, section [class "container"] [viewDebugSection model]
, 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 ""
Just t ->
div [ class "notification is-success is-marginless" ]
[ button [ class "delete", onClick ClearNotification ] []
, text t
]
Nothing ->
text ""
-- LOOT Views
itemInClaims : List Claim -> Item -> Bool
itemInClaims claims item =
List.any (\c -> c.loot_id == item.id) claims
-- DEBUG SECTION
viewDebugSection : Model -> Html Msg
viewDebugSection model =
div [class "panel is-danger"]
[ p [class "panel-heading"] [text "Debug"]
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.chest.selection)]
, p [class "panel-block"] [text ("Claims : " ++ Debug.toString model.claims)]
, p [] debugSandbox
, p [ class "panel-block has-text-danger" ] [ text <| Maybe.withDefault "" model.state.error ]
, p [ class "panel-block" ] [ text ("Route : " ++ Debug.toString model.route) ]
, p [ class "panel-block" ] [ text ("Active Mode : " ++ Debug.toString model.mode) ]
, p [ class "panel-block" ] [ text ("Selection : " ++ Debug.toString model.chest.selection) ]
, p [ class "panel-block" ] [ text ("Claims : " ++ Debug.toString model.chest.claims) ]
, p [] debugSandbox
]
stackedIcon name =
span [class "icon is-medium"]
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 ""
]
[ 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"
@@ -410,76 +507,92 @@ debugSandbox =
, 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"]
[ a [ onClick (PlayerChanged 0) ] [ text "Groupe" ]
, a [ onClick (PlayerChanged 1) ] [ text "Lomion" ]
, a [ onClick (PlayerChanged 2) ] [ text "Fefi" ]
]
-- 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"] []
]
]
[ 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")]
]
[ 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 =
viewPlayerBar : Player -> List (Html Msg) -> Html Msg
viewPlayerBar player 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" ] [] ]]
[ div [ class "level-left" ]
([ div [ class "level-item" ]
[ span [ class "icon is-large" ]
[ i [ class "fas fa-2x fa-piggy-bank" ] [] ]
]
++ (viewWealth player.wealth)
]
++ 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")]
]]
[ 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
)
, div [ class "level-right" ] actionControls
]
@@ -491,16 +604,12 @@ viewWealth wealth =
, 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 ]
]
[ 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"] []

View File

@@ -1,5 +1,6 @@
module Modes exposing (..)
type ViewMode
= Sell
| Buy
@@ -10,7 +11,14 @@ type ViewMode
canSelectIn : ViewMode -> Bool
canSelectIn mode =
case mode of
Sell -> True
Buy -> True
Grab -> True
Add -> False
Sell ->
True
Buy ->
True
Grab ->
True
Add ->
False

View File

@@ -3,6 +3,7 @@ module Utils exposing (renderIcon)
import Html exposing (..)
import Html.Attributes exposing (..)
renderIcon name size =
span [ class <| "icon is-medium"]
[ i [ class <| name ++ " fa-" ++ size] [] ]
span [ class <| "icon is-medium" ]
[ i [ class <| name ++ " fa-" ++ size ] [] ]