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") ]