| summaryrefslogtreecommitdiff |
diff options
Diffstat (limited to 'src')
20 files changed, 326 insertions, 417 deletions
diff --git a/src/battle/src/Comm/Send.elm b/src/battle/src/Comm/Send.elm index 98e3ba4..f501b19 100644 --- a/src/battle/src/Comm/Send.elm +++ b/src/battle/src/Comm/Send.elm @@ -6,7 +6,7 @@ import Http import Json.Decode import Json.Encode --- Map ------------------------------------------------------------------- +-- Battle ---------------------------------------------------------------------- import Comm.AddArmor import Comm.AddChar import Comm.AddTile @@ -36,6 +36,9 @@ internal_decoder reply_type = "set_map" -> (Comm.SetMap.decode) "turn_results" -> (Comm.TurnResults.decode) "set_timeline" -> (Comm.SetTimeline.decode) + "disconnected" -> (Json.Decode.succeed Struct.ServerReply.Disconnected) + "okay" -> (Json.Decode.succeed Struct.ServerReply.Okay) + other -> (Json.Decode.fail ( diff --git a/src/battle/src/Struct/Flags.elm b/src/battle/src/Struct/Flags.elm deleted file mode 100644 index 228d258..0000000 --- a/src/battle/src/Struct/Flags.elm +++ /dev/null @@ -1,42 +0,0 @@ -module Struct.Flags exposing - ( - Type, - maybe_get_param - ) - --- Elm ------------------------------------------------------------------------- -import List - --- Map ------------------------------------------------------------------- -import Util.List - --------------------------------------------------------------------------------- --- TYPES ----------------------------------------------------------------------- --------------------------------------------------------------------------------- -type alias Type = - { - user_id : String, - token : String, - url_params : (List (List String)) - } - --------------------------------------------------------------------------------- --- LOCAL ----------------------------------------------------------------------- --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- EXPORTED -------------------------------------------------------------------- --------------------------------------------------------------------------------- -maybe_get_param : String -> Type -> (Maybe String) -maybe_get_param param flags = - case - (Util.List.get_first - (\e -> ((List.head e) == (Just param))) - flags.url_params - ) - of - Nothing -> Nothing - (Just a) -> - case (List.tail a) of - Nothing -> Nothing - (Just b) -> (List.head b) diff --git a/src/battle/src/Struct/Model.elm b/src/battle/src/Struct/Model.elm index c32db67..8722066 100644 --- a/src/battle/src/Struct/Model.elm +++ b/src/battle/src/Struct/Model.elm @@ -23,12 +23,14 @@ import Array import Dict +-- Shared ---------------------------------------------------------------------- +import Struct.Flags + -- Battle ---------------------------------------------------------------------- import Struct.Armor import Struct.Character import Struct.CharacterTurn import Struct.Error -import Struct.Flags import Struct.HelpRequest import Struct.Location import Struct.Map @@ -46,6 +48,7 @@ import Util.Array -------------------------------------------------------------------------------- type alias Type = { + flags: Struct.Flags.Type, help_request: Struct.HelpRequest.Type, animator: (Maybe Struct.TurnResultAnimator.Type), map: Struct.Map.Type, @@ -80,6 +83,7 @@ new flags = maybe_battle_id = (Struct.Flags.maybe_get_param "id" flags) model = { + flags = flags, help_request = Struct.HelpRequest.None, animator = Nothing, map = (Struct.Map.empty), diff --git a/src/battle/src/Struct/ServerReply.elm b/src/battle/src/Struct/ServerReply.elm index 87325a5..28dde0d 100644 --- a/src/battle/src/Struct/ServerReply.elm +++ b/src/battle/src/Struct/ServerReply.elm @@ -2,7 +2,7 @@ module Struct.ServerReply exposing (Type(..)) -- Elm ------------------------------------------------------------------------- --- Map ------------------------------------------------------------------- +-- Battle ---------------------------------------------------------------------- import Struct.Armor import Struct.Map import Struct.Character @@ -16,6 +16,7 @@ import Struct.Weapon type Type = Okay + | Disconnected | AddArmor Struct.Armor.Type | AddWeapon Struct.Weapon.Type | AddCharacter (Struct.Character.Type, Int, Int, Int) diff --git a/src/battle/src/Update/HandleServerReply.elm b/src/battle/src/Update/HandleServerReply.elm index 85e7a39..b1506ba 100644 --- a/src/battle/src/Update/HandleServerReply.elm +++ b/src/battle/src/Update/HandleServerReply.elm @@ -11,7 +11,14 @@ import Http import Time --- Map ------------------------------------------------------------------- +-- Shared ---------------------------------------------------------------------- +import Action.Ports + +import Struct.Flags + +-- Battle ---------------------------------------------------------------------- +import Constants.IO + import Struct.Armor import Struct.Map import Struct.Character @@ -46,135 +53,151 @@ armor_getter model ref = ----------- +disconnected : ( + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) + ) +disconnected current_state = + let (model, cmds) = current_state in + ( + model, + [ + (Action.Ports.go_to + ( + Constants.IO.base_url + ++ "/login/?action=disconnect&goto=" + ++ + (Http.encodeUri + ( + "/battle/?" + ++ (Struct.Flags.get_params_as_url model.flags) + ) + ) + ) + ) + ] + ) + add_armor : ( Struct.Armor.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) add_armor ar current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> ((Struct.Model.add_armor ar model), Nothing) + let (model, cmds) = current_state in + ((Struct.Model.add_armor ar model), cmds) add_tile : ( Struct.Tile.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) add_tile tl current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> ((Struct.Model.add_tile tl model), Nothing) + let (model, cmds) = current_state in + ((Struct.Model.add_tile tl model), cmds) add_weapon : ( Struct.Weapon.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) add_weapon wp current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> ((Struct.Model.add_weapon wp model), Nothing) + let (model, cmds) = current_state in + ((Struct.Model.add_weapon wp model), cmds) add_character : ( (Struct.Character.Type, Int, Int, Int) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) add_character char_and_refs current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> - let - (char, awp_ref, swp_ref, ar_ref) = char_and_refs - awp = (weapon_getter model awp_ref) - swp = (weapon_getter model swp_ref) - ar = (armor_getter model ar_ref) - in - ( - (Struct.Model.add_character - (Struct.Character.fill_missing_equipment_and_omnimods - (Struct.Model.tile_omnimods_fun model) - awp - swp - ar - char - ) - model - ), - Nothing + let + (model, cmds) = current_state + (char, awp_ref, swp_ref, ar_ref) = char_and_refs + awp = (weapon_getter model awp_ref) + swp = (weapon_getter model swp_ref) + ar = (armor_getter model ar_ref) + in + ( + (Struct.Model.add_character + (Struct.Character.fill_missing_equipment_and_omnimods + (Struct.Model.tile_omnimods_fun model) + awp + swp + ar + char ) + model + ), + cmds + ) set_map : ( Struct.Map.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) set_map map current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> - ( - {model | - map = - (Struct.Map.solve_tiles model.tiles map) - }, - Nothing - ) + let (model, cmds) = current_state in + ( + {model | + map = (Struct.Map.solve_tiles model.tiles map) + }, + cmds + ) add_to_timeline : ( (List Struct.TurnResult.Type) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) add_to_timeline turn_results current_state = - case current_state of - (_, (Just _)) -> current_state - - (model, _) -> + let (model, cmds) = current_state in + ( + {model | + animator = + (Struct.TurnResultAnimator.maybe_new + (List.reverse turn_results) + False + ), + timeline = + (Array.append + (Array.fromList turn_results) + model.timeline + ), + ui = + (Struct.UI.set_displayed_tab + Struct.UI.TimelineTab + model.ui + ) + }, ( - {model | - animator = - (Struct.TurnResultAnimator.maybe_new - (List.reverse turn_results) - False - ), - timeline = - (Array.append - (Array.fromList turn_results) - model.timeline - ), - ui = - (Struct.UI.set_displayed_tab - Struct.UI.TimelineTab - model.ui - ) - }, - Nothing + (Delay.after 1 Time.millisecond Struct.Event.AnimationEnded) + :: cmds ) + ) set_timeline : ( (List Struct.TurnResult.Type) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) set_timeline turn_results current_state = - case current_state of - (_, (Just _)) -> current_state - - (model, _) -> - ( - {model | timeline = (Array.fromList turn_results)}, - Nothing - ) + let (model, cmds) = current_state in + ( + {model | timeline = (Array.fromList turn_results)}, + cmds + ) apply_command : ( Struct.ServerReply.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) apply_command command current_state = case command of + Struct.ServerReply.Disconnected -> (disconnected current_state) + (Struct.ServerReply.AddWeapon wp) -> (add_weapon wp current_state) @@ -219,18 +242,15 @@ apply_to model query_result = (Result.Ok commands) -> let - new_model = - ( - case (List.foldl (apply_command) (model, Nothing) commands) of - (updated_model, Nothing) -> updated_model - (_, (Just error)) -> (Struct.Model.invalidate error model) - ) + (new_model, elm_commands) = + (List.foldl (apply_command) (model, [Cmd.none]) commands) in ( new_model, - if (new_model.animator == Nothing) - then - Cmd.none - else - (Delay.after 1 Time.millisecond Struct.Event.AnimationEnded) + ( + case elm_commands of + [] -> Cmd.none + [cmd] -> cmd + _ -> (Cmd.batch elm_commands) + ) ) diff --git a/src/character/src/Struct/Flags.elm b/src/character/src/Struct/Flags.elm deleted file mode 100644 index 228d258..0000000 --- a/src/character/src/Struct/Flags.elm +++ /dev/null @@ -1,42 +0,0 @@ -module Struct.Flags exposing - ( - Type, - maybe_get_param - ) - --- Elm ------------------------------------------------------------------------- -import List - --- Map ------------------------------------------------------------------- -import Util.List - --------------------------------------------------------------------------------- --- TYPES ----------------------------------------------------------------------- --------------------------------------------------------------------------------- -type alias Type = - { - user_id : String, - token : String, - url_params : (List (List String)) - } - --------------------------------------------------------------------------------- --- LOCAL ----------------------------------------------------------------------- --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- EXPORTED -------------------------------------------------------------------- --------------------------------------------------------------------------------- -maybe_get_param : String -> Type -> (Maybe String) -maybe_get_param param flags = - case - (Util.List.get_first - (\e -> ((List.head e) == (Just param))) - flags.url_params - ) - of - Nothing -> Nothing - (Just a) -> - case (List.tail a) of - Nothing -> Nothing - (Just b) -> (List.head b) diff --git a/src/login/src/Struct/Flags.elm b/src/login/src/Struct/Flags.elm deleted file mode 100644 index 228d258..0000000 --- a/src/login/src/Struct/Flags.elm +++ /dev/null @@ -1,42 +0,0 @@ -module Struct.Flags exposing - ( - Type, - maybe_get_param - ) - --- Elm ------------------------------------------------------------------------- -import List - --- Map ------------------------------------------------------------------- -import Util.List - --------------------------------------------------------------------------------- --- TYPES ----------------------------------------------------------------------- --------------------------------------------------------------------------------- -type alias Type = - { - user_id : String, - token : String, - url_params : (List (List String)) - } - --------------------------------------------------------------------------------- --- LOCAL ----------------------------------------------------------------------- --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- EXPORTED -------------------------------------------------------------------- --------------------------------------------------------------------------------- -maybe_get_param : String -> Type -> (Maybe String) -maybe_get_param param flags = - case - (Util.List.get_first - (\e -> ((List.head e) == (Just param))) - flags.url_params - ) - of - Nothing -> Nothing - (Just a) -> - case (List.tail a) of - Nothing -> Nothing - (Just b) -> (List.head b) diff --git a/src/login/src/Struct/Model.elm b/src/login/src/Struct/Model.elm index 859c054..7d14239 100644 --- a/src/login/src/Struct/Model.elm +++ b/src/login/src/Struct/Model.elm @@ -9,9 +9,11 @@ module Struct.Model exposing -- Elm ------------------------------------------------------------------------- +-- Shared ---------------------------------------------------------------------- +import Struct.Flags + -- Login ----------------------------------------------------------------------- import Struct.Error -import Struct.Flags import Struct.HelpRequest import Struct.UI @@ -22,6 +24,7 @@ type alias Type = { help_request: Struct.HelpRequest.Type, error: (Maybe Struct.Error.Type), + flags: Struct.Flags.Type, username: String, password1: String, password2: String, @@ -46,6 +49,7 @@ new flags = model = { help_request = Struct.HelpRequest.None, + flags = flags, error = Nothing, username = "", password1 = "", diff --git a/src/login/src/Update/HandleConnected.elm b/src/login/src/Update/HandleConnected.elm index 2888153..8f6348b 100644 --- a/src/login/src/Update/HandleConnected.elm +++ b/src/login/src/Update/HandleConnected.elm @@ -1,13 +1,16 @@ module Update.HandleConnected exposing (apply_to) + -- Elm ------------------------------------------------------------------------- +import Http -- Login ----------------------------------------------------------------------- import Action.Ports import Constants.IO -import Struct.Model import Struct.Event +import Struct.Flags +import Struct.Model -------------------------------------------------------------------------------- -- LOCAL ----------------------------------------------------------------------- @@ -20,5 +23,17 @@ apply_to : Struct.Model.Type -> (Struct.Model.Type, (Cmd Struct.Event.Type)) apply_to model = ( model, - (Action.Ports.go_to (Constants.IO.base_url ++"/main-menu/")) + (Action.Ports.go_to + (Constants.IO.base_url ++ + ( + case (Struct.Flags.maybe_get_param "goto" model.flags) of + Nothing -> "/main-menu/" + (Just string) -> + case (Http.decodeUri string) of + Nothing -> "/main-menu/" + (Just "") -> "/main-menu/" + (Just url) -> url + ) + ) + ) ) diff --git a/src/login/src/Update/HandleServerReply.elm b/src/login/src/Update/HandleServerReply.elm index b0f4e6b..2cbcf08 100644 --- a/src/login/src/Update/HandleServerReply.elm +++ b/src/login/src/Update/HandleServerReply.elm @@ -3,9 +3,10 @@ module Update.HandleServerReply exposing (apply_to) -- Elm ------------------------------------------------------------------------- import Http --- Map ------------------------------------------------------------------- +-- Shared ---------------------------------------------------------------------- import Action.Ports +-- Login ----------------------------------------------------------------------- import Struct.Error import Struct.Event import Struct.Model @@ -21,46 +22,26 @@ import Struct.ServerReply set_session : ( String -> String -> - ( - Struct.Model.Type, - (Maybe Struct.Error.Type), - (List (Cmd Struct.Event.Type)) - ) -> - ( - Struct.Model.Type, - (Maybe Struct.Error.Type), - (List (Cmd Struct.Event.Type)) - ) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) set_session pid stk current_state = - case current_state of - (_, (Just _), _) -> current_state - - (model, _, cmd_list) -> + let (model, cmds) = current_state in + ( + {model | + player_id = pid, + session_token = stk + }, ( - {model | - player_id = pid, - session_token = stk - }, - Nothing, - ( - (Action.Ports.store_new_session (pid, stk)) - :: cmd_list - ) + (Action.Ports.store_new_session (pid, stk)) + :: cmds ) + ) apply_command : ( Struct.ServerReply.Type -> - ( - Struct.Model.Type, - (Maybe Struct.Error.Type), - (List (Cmd Struct.Event.Type)) - ) -> - ( - Struct.Model.Type, - (Maybe Struct.Error.Type), - (List (Cmd Struct.Event.Type)) - ) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) apply_command command current_state = case command of @@ -89,23 +70,16 @@ apply_to model query_result = ) (Result.Ok commands) -> - ( - case - (List.foldl - (apply_command) - (model, Nothing, []) - commands + let + (new_model, elm_commands) = + (List.foldl (apply_command) (model, [Cmd.none]) commands) + in + ( + new_model, + ( + case elm_commands of + [] -> Cmd.none + [cmd] -> cmd + _ -> (Cmd.batch elm_commands) ) - of - (updated_model, Nothing, cmds) -> - ( - updated_model, - (Cmd.batch cmds) - ) - - (_, (Just error), _) -> - ( - (Struct.Model.invalidate error model), - Cmd.none - ) - ) + ) diff --git a/src/main-menu/src/Comm/Send.elm b/src/main-menu/src/Comm/Send.elm index 925b956..3641e46 100644 --- a/src/main-menu/src/Comm/Send.elm +++ b/src/main-menu/src/Comm/Send.elm @@ -26,6 +26,7 @@ internal_decoder reply_type = case reply_type of "okay" -> (Comm.Okay.decode) "set_plr" -> (Comm.SetPlayer.decode) + "disconnected" -> (Json.Decode.succeed Struct.ServerReply.Disconnected) other -> (Json.Decode.fail ( diff --git a/src/main-menu/src/Struct/Flags.elm b/src/main-menu/src/Struct/Flags.elm deleted file mode 100644 index 99c7458..0000000 --- a/src/main-menu/src/Struct/Flags.elm +++ /dev/null @@ -1,42 +0,0 @@ -module Struct.Flags exposing - ( - Type, - maybe_get_param - ) - --- Elm ------------------------------------------------------------------------- -import List - --- Main Menu ------------------------------------------------------------------- -import Util.List - --------------------------------------------------------------------------------- --- TYPES ----------------------------------------------------------------------- --------------------------------------------------------------------------------- -type alias Type = - { - user_id : String, - token : String, - url_params : (List (List String)) - } - --------------------------------------------------------------------------------- --- LOCAL ----------------------------------------------------------------------- --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- EXPORTED -------------------------------------------------------------------- --------------------------------------------------------------------------------- -maybe_get_param : String -> Type -> (Maybe String) -maybe_get_param param flags = - case - (Util.List.get_first - (\e -> ((List.head e) == (Just param))) - flags.url_params - ) - of - Nothing -> Nothing - (Just a) -> - case (List.tail a) of - Nothing -> Nothing - (Just b) -> (List.head b) diff --git a/src/main-menu/src/Struct/Model.elm b/src/main-menu/src/Struct/Model.elm index d748cfa..747a39e 100644 --- a/src/main-menu/src/Struct/Model.elm +++ b/src/main-menu/src/Struct/Model.elm @@ -9,9 +9,11 @@ module Struct.Model exposing -- Elm ------------------------------------------------------------------------- +-- Shared ---------------------------------------------------------------------- +import Struct.Flags + -- Main Menu ------------------------------------------------------------------- import Struct.Error -import Struct.Flags import Struct.Player import Struct.UI @@ -20,6 +22,7 @@ import Struct.UI -------------------------------------------------------------------------------- type alias Type = { + flags: Struct.Flags.Type, error: (Maybe Struct.Error.Type), player_id: String, session_token: String, @@ -37,6 +40,7 @@ type alias Type = new : Struct.Flags.Type -> Type new flags = { + flags = flags, error = Nothing, player_id = flags.user_id, session_token = flags.token, diff --git a/src/main-menu/src/Struct/ServerReply.elm b/src/main-menu/src/Struct/ServerReply.elm index a0663a8..fb4967b 100644 --- a/src/main-menu/src/Struct/ServerReply.elm +++ b/src/main-menu/src/Struct/ServerReply.elm @@ -11,6 +11,7 @@ import Struct.Player type Type = Okay + | Disconnected | SetPlayer Struct.Player.Type -------------------------------------------------------------------------------- diff --git a/src/main-menu/src/Update/HandleServerReply.elm b/src/main-menu/src/Update/HandleServerReply.elm index 96cb0f1..d68496c 100644 --- a/src/main-menu/src/Update/HandleServerReply.elm +++ b/src/main-menu/src/Update/HandleServerReply.elm @@ -3,7 +3,14 @@ module Update.HandleServerReply exposing (apply_to) -- Elm ------------------------------------------------------------------------- import Http +-- Shared ---------------------------------------------------------------------- +import Action.Ports + +import Struct.Flags + -- Main Menu ------------------------------------------------------------------- +import Constants.IO + import Struct.Error import Struct.Event import Struct.Model @@ -17,46 +24,48 @@ import Struct.ServerReply -------------------------------------------------------------------------------- -- LOCAL ----------------------------------------------------------------------- -------------------------------------------------------------------------------- -set_player : ( - Struct.Player.Type -> - ( - Struct.Model.Type, - (Maybe Struct.Error.Type), - (List (Cmd Struct.Event.Type)) - ) -> +disconnected : ( + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) + ) +disconnected current_state = + let (model, cmds) = current_state in ( - Struct.Model.Type, - (Maybe Struct.Error.Type), - (List (Cmd Struct.Event.Type)) + model, + [ + (Action.Ports.go_to + ( + Constants.IO.base_url + ++ "/login/?action=disconnect&goto=" + ++ + (Http.encodeUri + ( + "/main-menu/?" + ++ (Struct.Flags.get_params_as_url model.flags) + ) + ) + ) + ) + ] ) + +set_player : ( + Struct.Player.Type -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) set_player player current_state = - let - (model, error, event_list) = current_state - in - ( - {model | - player = player - }, - error, - event_list - ) + let (model, cmds) = current_state in + ({model | player = player}, cmds) apply_command : ( Struct.ServerReply.Type -> - ( - Struct.Model.Type, - (Maybe Struct.Error.Type), - (List (Cmd Struct.Event.Type)) - ) -> - ( - Struct.Model.Type, - (Maybe Struct.Error.Type), - (List (Cmd Struct.Event.Type)) - ) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) apply_command command current_state = case command of + Struct.ServerReply.Disconnected -> (disconnected current_state) (Struct.ServerReply.SetPlayer player) -> (set_player player current_state) Struct.ServerReply.Okay -> current_state @@ -80,23 +89,16 @@ apply_to model query_result = ) (Result.Ok commands) -> - ( - case - (List.foldl - (apply_command) - (model, Nothing, []) - commands + let + (new_model, elm_commands) = + (List.foldl (apply_command) (model, [Cmd.none]) commands) + in + ( + new_model, + ( + case elm_commands of + [] -> Cmd.none + [cmd] -> cmd + _ -> (Cmd.batch elm_commands) ) - of - (updated_model, Nothing, cmds) -> - ( - updated_model, - (Cmd.batch cmds) - ) - - (_, (Just error), _) -> - ( - (Struct.Model.invalidate error model), - Cmd.none - ) - ) + ) diff --git a/src/map-editor/src/Comm/Send.elm b/src/map-editor/src/Comm/Send.elm index d70fc13..c61be07 100644 --- a/src/map-editor/src/Comm/Send.elm +++ b/src/map-editor/src/Comm/Send.elm @@ -30,6 +30,7 @@ internal_decoder reply_type = "add_tile_pattern" -> (Comm.AddTilePattern.decode) "set_map" -> (Comm.SetMap.decode) "okay" -> (Comm.Okay.decode) + "disconnected" -> (Json.Decode.succeed Struct.ServerReply.Disconnected) other -> (Json.Decode.fail ( diff --git a/src/map-editor/src/Struct/Model.elm b/src/map-editor/src/Struct/Model.elm index 70b840f..a7ec964 100644 --- a/src/map-editor/src/Struct/Model.elm +++ b/src/map-editor/src/Struct/Model.elm @@ -12,9 +12,11 @@ module Struct.Model exposing -- Elm ------------------------------------------------------------------------- import Dict --- Map ------------------------------------------------------------------- -import Struct.Error +-- Shared ---------------------------------------------------------------------- import Struct.Flags + +-- Map Editor ------------------------------------------------------------------ +import Struct.Error import Struct.HelpRequest import Struct.Map import Struct.Tile @@ -27,6 +29,7 @@ import Struct.UI -------------------------------------------------------------------------------- type alias Type = { + flags: Struct.Flags.Type, toolbox: Struct.Toolbox.Type, help_request: Struct.HelpRequest.Type, map: Struct.Map.Type, @@ -53,6 +56,7 @@ new flags = maybe_map_id = (Struct.Flags.maybe_get_param "id" flags) model = { + flags = flags, toolbox = (Struct.Toolbox.default), help_request = Struct.HelpRequest.None, map = (Struct.Map.empty), diff --git a/src/map-editor/src/Struct/ServerReply.elm b/src/map-editor/src/Struct/ServerReply.elm index 177950b..e3116fe 100644 --- a/src/map-editor/src/Struct/ServerReply.elm +++ b/src/map-editor/src/Struct/ServerReply.elm @@ -2,7 +2,7 @@ module Struct.ServerReply exposing (Type(..)) -- Elm ------------------------------------------------------------------------- --- Battlemap ------------------------------------------------------------------- +-- Map Editor ------------------------------------------------------------------ import Struct.Map import Struct.Tile import Struct.TilePattern @@ -13,6 +13,7 @@ import Struct.TilePattern type Type = Okay + | Disconnected | AddTile Struct.Tile.Type | AddTilePattern Struct.TilePattern.Type | SetMap Struct.Map.Type diff --git a/src/map-editor/src/Update/HandleServerReply.elm b/src/map-editor/src/Update/HandleServerReply.elm index 0e69c51..e982ef7 100644 --- a/src/map-editor/src/Update/HandleServerReply.elm +++ b/src/map-editor/src/Update/HandleServerReply.elm @@ -3,7 +3,13 @@ module Update.HandleServerReply exposing (apply_to) -- Elm ------------------------------------------------------------------------- import Http --- Map ------------------------------------------------------------------- +-- Shared ---------------------------------------------------------------------- +import Action.Ports + +import Struct.Flags + +-- Map Editor ------------------------------------------------------------------ +import Constants.IO import Struct.Map import Struct.Error import Struct.Event @@ -19,61 +25,75 @@ import Struct.TilePattern -------------------------------------------------------------------------------- -- LOCAL ----------------------------------------------------------------------- -------------------------------------------------------------------------------- +disconnected : ( + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) + ) +disconnected current_state = + let (model, cmds) = current_state in + ( + model, + [ + (Action.Ports.go_to + ( + Constants.IO.base_url + ++ "/login/?action=disconnect&goto=" + ++ + (Http.encodeUri + ( + "/map-editor/?" + ++ (Struct.Flags.get_params_as_url model.flags) + ) + ) + ) + ) + ] + ) + add_tile : ( Struct.Tile.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) add_tile tl current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> ((Struct.Model.add_tile tl model), Nothing) + let (model, cmds) = current_state in + ((Struct.Model.add_tile tl model), cmds) add_tile_pattern : ( Struct.TilePattern.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) add_tile_pattern tp current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> - ( - (Struct.Model.add_tile_pattern tp model), - Nothing - ) + let (model, cmds) = current_state in + ((Struct.Model.add_tile_pattern tp model), cmds) set_map : ( Struct.Map.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) set_map map current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> - ( {model | map = (Struct.Map.solve_tiles model.tiles map)}, Nothing) + let (model, cmds) = current_state in + ({model | map = (Struct.Map.solve_tiles model.tiles map)}, cmds) refresh_map : ( - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) refresh_map current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> - ( - {model | map = (Struct.Map.solve_tiles model.tiles model.map)}, - Nothing - ) + let (model, cmds) = current_state in + ({model | map = (Struct.Map.solve_tiles model.tiles model.map)}, cmds) apply_command : ( Struct.ServerReply.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) apply_command command current_state = case command of + Struct.ServerReply.Disconnected -> (disconnected current_state) + (Struct.ServerReply.AddTile tl) -> (add_tile tl current_state) @@ -106,10 +126,16 @@ apply_to model query_result = ) (Result.Ok commands) -> - case (List.foldl (apply_command) (model, Nothing) commands) of - (updated_model, Nothing) -> (updated_model, Cmd.none) - (_, (Just error)) -> + let + (new_model, elm_commands) = + (List.foldl (apply_command) (model, [Cmd.none]) commands) + in + ( + new_model, ( - (Struct.Model.invalidate error model), - Cmd.none + case elm_commands of + [] -> Cmd.none + [cmd] -> cmd + _ -> (Cmd.batch elm_commands) ) + ) diff --git a/src/map-editor/src/Struct/Flags.elm b/src/shared/elm/Struct/Flags.elm index c0316f0..8cb8aea 100644 --- a/src/map-editor/src/Struct/Flags.elm +++ b/src/shared/elm/Struct/Flags.elm @@ -1,13 +1,14 @@ module Struct.Flags exposing ( Type, - maybe_get_param + maybe_get_param, + get_params_as_url ) -- Elm ------------------------------------------------------------------------- import List --- Battlemap ------------------------------------------------------------------- +-- Shared ---------------------------------------------------------------------- import Util.List -------------------------------------------------------------------------------- @@ -23,6 +24,11 @@ type alias Type = -------------------------------------------------------------------------------- -- LOCAL ----------------------------------------------------------------------- -------------------------------------------------------------------------------- +param_as_url : (List String) -> String +param_as_url param = + case param of + [name, value] -> (name ++ "=" ++ value) + _ -> "" -------------------------------------------------------------------------------- -- EXPORTED -------------------------------------------------------------------- @@ -40,3 +46,13 @@ maybe_get_param param flags = case (List.tail a) of Nothing -> Nothing (Just b) -> (List.head b) + +get_params_as_url : Type -> String +get_params_as_url flags = + (List.foldl + (\param -> \current_params -> + (current_params ++ "&" ++ (param_as_url param)) + ) + "" + flags.url_params + ) |