module Here4.World exposing (Attributes, Multiverse, create)

import Color exposing (Color)
import Dynamic exposing (Dynamic)
import Here4.App.Types exposing (..)
import Here4.App.Internal as App exposing (..)
import Here4.Bag as Bag exposing (Bag)
import Here4.Body exposing (Body)
import Here4.Camera.Types exposing (Framing, Shot)
import Here4.Control exposing (..)
import Here4.Dispatch exposing (..)
import Here4.Ground exposing (Ground)
import Here4.Location exposing (..)
import Here4.Model as Model exposing (GlobalMsg, NavigatorMsg, WorldKey(..), AppKey(..), PartyKey(..))
import Here4.Navigator.Control exposing (NavMsg)
import Here4.Orientation as Orientation exposing (Orientation)
import Here4.Space as Space
import Html exposing (Html)
import Math.Vector3 as V3 exposing (vec3)
import Maybe.Extra exposing (isJust)
import Task
import Time exposing (Time)


type alias Attributes =
    { id : String
    , label : String
    , backgroundColor : Color
    , apps : List ( App, Cmd AppMsg )
    , defaultSelf : ( App, Cmd AppMsg )
    }


type alias Multiverse state =
    { state : state
    , worlds : Bag World
    }


type alias World =
    { id : String
    , label : String
    , backgroundColor : Color
    , maybeGround : Maybe Ground
    , apps : Bag App
    , parties : Bag Party
    , defaultSelf : ( App, Cmd AppMsg )
    }


type alias Party =
    { rideKey : Maybe AppKey
    , self : App -- App to be when not riding

    -- , focusKey : Bag.Key
    }


create :
    (flags -> ( model, Cmd (NavMsg msg) ))
    -> (NavMsg msg -> model -> ( model, Cmd (NavMsg msg) ))
    -> (Multiverse model -> Sub (NavMsg msg))
    -> List Attributes
    -> Program flags (Model.Model (Multiverse model) (WorldMsg (NavMsg msg))) (Model.Msg (WorldMsg (NavMsg msg)))
create hubInit hubUpdate navSubscriptions attributes =
    Space.programWithFlags navSubscriptions
        { init = worldInit hubInit attributes
        , view = worldView
        , update = worldUpdate hubUpdate
        , worldId = worldId
        , worldLabel = worldLabel
        , partyLabel = worldPartyLabel
        , overlay = worldOverlay
        , animate = worldAnimate
        , join = worldJoin
        , leave = worldLeave
        , changeRide = worldChangeRide
        , framing = worldFraming
        , focus = worldFocus
        , ground = worldGround
        }


worldApp : WorldKey AppKey -> Multiverse a -> Maybe App
worldApp (WorldKey worldKey (AppKey appKey)) model =
    Bag.get worldKey model.worlds
        |> Maybe.map .apps
        |> Maybe.andThen (Bag.get appKey)


worldParty : WorldKey PartyKey -> Multiverse a -> Maybe Party
worldParty (WorldKey worldKey (PartyKey partyKey)) model =
    Bag.get worldKey model.worlds
        |> Maybe.map .parties
        |> Maybe.andThen (Bag.get partyKey)


worldAddApps : WorldKey () -> List ( App, Cmd AppMsg ) -> Bag App -> ( Bag App, List (Cmd (WorldMsg msg)) )
worldAddApps (WorldKey worldKey ()) appsList apps0 =
    let
        response appKey x =
            case x of
                Effect e ->
                    HubEff (toWorldEffect (WorldKey worldKey ()) (Just appKey) e)

                m ->
                    let
                        key =
                            ToApp (WorldKey worldKey appKey)
                    in
                        toWorldMsg (WorldKey worldKey ()) (Just appKey) (Send key m)

        f ( newApp, newCmdMsg ) ( oldBag, oldCmdMsgs ) =
            let
                ( appKey, newBag ) =
                    Bag.insert newApp oldBag
            in
                ( newBag, Cmd.map (response (AppKey appKey)) newCmdMsg :: oldCmdMsgs )

        ( appsBag, worldCmds ) =
            List.foldl f ( apps0, [] ) appsList
    in
        ( appsBag, worldCmds )


oneWorldInit :
    Attributes
    -> ( Bag World, List (Cmd (WorldMsg msg)) )
    -> ( Bag World, List (Cmd (WorldMsg msg)) )
oneWorldInit attributes ( oldWorlds, oldCmds ) =
    let
        emptyWorld =
            { id = attributes.id
            , label = attributes.label
            , backgroundColor = attributes.backgroundColor
            , maybeGround = Nothing
            , apps = Bag.empty
            , parties = Bag.empty
            , defaultSelf = attributes.defaultSelf
            }

        ( worldKey, oneWorlds ) =
            Bag.insert emptyWorld oldWorlds

        ( appsBag, appCmds ) =
            worldAddApps (WorldKey worldKey ()) attributes.apps Bag.empty

        updateApps world =
            { world | apps = appsBag }

        newWorlds =
            Bag.update worldKey (Maybe.map updateApps) oneWorlds
    in
        ( newWorlds, oldCmds ++ appCmds )


worldInit :
    (flags -> ( model, Cmd msg ))
    -> List Attributes
    -> flags
    -> ( Multiverse model, Cmd (WorldMsg msg) )
worldInit hubInit attributes flags =
    let
        ( hubModel, hubCmd ) =
            hubInit flags

        ( worldsBag, worldsCmds ) =
            List.foldl oneWorldInit ( Bag.empty, [] ) attributes
    in
        ( { state = hubModel
          , worlds = worldsBag
          }
        , Cmd.batch (Cmd.map Hub hubCmd :: worldsCmds)
        )


worldView : WorldKey () -> Multiverse model -> Maybe Model.World
worldView (WorldKey worldKey ()) model =
    let
        mWorld =
            Bag.get worldKey model.worlds
    in
        case Maybe.andThen .maybeGround mWorld of
            Nothing ->
                Nothing

            Just ground ->
                Maybe.map (makeWorld ground) mWorld


makeWorld : Ground -> World -> Model.World
makeWorld ground world =
    let
        partyBodies party =
            case party.rideKey of
                Just _ ->
                    always []

                Nothing ->
                    bodies party.self

        worldBodies pos =
            List.concatMap (\app -> (bodies app) pos) (Bag.items world.apps)
                ++ List.concatMap (\app -> (partyBodies app) pos) (Bag.items world.parties)
    in
        { backgroundColor = world.backgroundColor
        , bodies = worldBodies
        , ground = ground
        }


toWorldEffect : WorldKey () -> Maybe AppKey -> EffectMsg () () -> EffectMsg (WorldKey ()) (Maybe AppKey)
toWorldEffect worldKey appKey e =
    case e of
        UpdateGround () ground ->
            UpdateGround worldKey ground

        RelocateParty () partyKey location ->
            RelocateParty worldKey partyKey location

        AddApp () app ->
            AddApp worldKey app

        RemoveApp () () ->
            RemoveApp worldKey appKey


toWorldMsg :
    WorldKey ()
    -> Maybe AppKey
    -> DispatchHub Route (EffectMsg () ()) Msg Dynamic GlobalMsg NavigatorMsg a
    -> DispatchHub Route (EffectMsg (WorldKey ()) (Maybe AppKey)) Msg Dynamic GlobalMsg NavigatorMsg a
toWorldMsg worldKey appKey msg =
    let
        toWorldDispatch d =
            case d of
                Self nodeMsg ->
                    Self nodeMsg

                Ctrl ctrlMsg ->
                    Ctrl ctrlMsg

                Effect e ->
                    Effect (toWorldEffect worldKey appKey e)
    in
        case msg of
            Hub hubMsg ->
                Hub hubMsg

            Send key dispatch ->
                Send key (toWorldDispatch dispatch)

            Forward key ctrlMsg ->
                Forward key ctrlMsg

            HubEff e ->
                HubEff (toWorldEffect worldKey appKey e)

            GlobalEffect globalMsg ->
                GlobalEffect globalMsg

            NavEffect navMsg ->
                NavEffect navMsg


toAppMsg : Dispatch (EffectMsg (WorldKey ()) appKey) Msg Dynamic -> AppMsg
toAppMsg dispatch =
    let
        toAppEffect e =
            case e of
                UpdateGround _ ground ->
                    UpdateGround () ground

                RelocateParty _ partyKey location ->
                    RelocateParty () partyKey location

                AddApp _ app ->
                    AddApp () app

                RemoveApp _ _ ->
                    RemoveApp () ()
    in
        case dispatch of
            Self nodeMsg ->
                Self nodeMsg

            Ctrl ctrlMsg ->
                Ctrl ctrlMsg

            Effect e ->
                Effect (toAppEffect e)


relativeAppPosition : WorldKey PartyKey -> Relative -> Multiverse model -> ( Maybe AppKey, Maybe AppPosition )
relativeAppPosition (WorldKey worldKey (PartyKey partyKey)) relative model =
    let
        -- lookup : AppId -> (AppKey, App)
        lookup appId =
            Bag.get worldKey model.worlds
                |> Maybe.map .apps
                |> Maybe.andThen (Bag.find (\app -> App.id app == appId))

        mTarget appId =
            lookup appId
                |> Maybe.map Tuple.second
                |> Maybe.andThen (App.framing (PartyKey partyKey))
                |> Maybe.map .target

        mAppKey appId =
            lookup appId
                |> Maybe.map (Tuple.first >> AppKey)

        near d target =
            let
                position =
                    V3.add target.position (V3.scale d (Model.direction target))

                displacement =
                    V3.sub target.position position

                orientation =
                    Orientation.fromTo V3.k displacement
            in
                { position = position
                , orientation = orientation
                }
    in
        case relative of
            At position o ->
                case o of
                    FacingNorth ->
                        ( Nothing
                        , Just
                            { position = position
                            , orientation = Orientation.initial
                            }
                        )

                    WithOrientation orientation ->
                        ( Nothing
                        , Just
                            { position = position
                            , orientation = orientation
                            }
                        )

            Facing appId ->
                ( Nothing, Maybe.map (near 7) (mTarget appId) )

            Behind appId ->
                ( Nothing, Maybe.map (near -7) (mTarget appId) )

            Become appId ->
                ( mAppKey appId, Nothing )


relativeRelocate : WorldKey PartyKey -> Relative -> Multiverse model -> ( Multiverse model, Cmd (WorldMsg msg) )
relativeRelocate worldPartyKey relative model =
    let
        (WorldKey worldKey (PartyKey partyKey)) =
            worldPartyKey

        updateRide party =
            case relativeAppPosition worldPartyKey relative model of
                ( Just rideKey, _ ) ->
                    ( { party | rideKey = Just rideKey }
                    , Cmd.map (Send (ToApp (WorldKey worldKey rideKey)))
                        (Task.succeed (PartyKey partyKey) |> Task.perform (Ctrl << Enter))
                    )

                ( _, Just appPosition ) ->
                    ( { party
                        | rideKey = Nothing
                        , self = App.reposition (Just appPosition) party.self
                      }
                    , Cmd.none
                    )

                _ ->
                    ( party, Cmd.none )

        mNewPartyCmds =
            Maybe.map updateRide <| worldParty (WorldKey worldKey (PartyKey partyKey)) model

        mNewParty =
            Maybe.map Tuple.first mNewPartyCmds

        newCmds =
            Maybe.map Tuple.second mNewPartyCmds
                |> Maybe.withDefault Cmd.none

        updateParties world =
            { world | parties = Bag.update partyKey (always mNewParty) world.parties }
    in
        ( { model | worlds = Bag.update worldKey (Maybe.map updateParties) model.worlds }
        , newCmds
        )


remoteRelocate : WorldKey PartyKey -> WorldId -> Relative -> Multiverse model -> ( Multiverse model, Cmd (WorldMsg msg) )
remoteRelocate oldWorldPartyKey remoteWorldId relative model =
    let
        -- WorldKey worldKey (PartyKey partyKey) = oldWorldPartyKey
        mRemote =
            Bag.find (\world -> world.id == remoteWorldId) model.worlds
    in
        case mRemote of
            Just ( remoteWorldKey, remoteWorld ) ->
                let
                    -- leave this world
                    leftThisWorld =
                        worldLeave oldWorldPartyKey model

                    -- enter next world
                    ( mNewWorldPartyKey, joinedNewWorld, joinCmd ) =
                        worldJoin (WorldKey remoteWorldKey ()) leftThisWorld
                in
                    case mNewWorldPartyKey of
                        Just newWorldPartyKey ->
                            let
                                -- relocate relative
                                ( newModel, relativeCmd ) =
                                    relativeRelocate newWorldPartyKey relative joinedNewWorld

                                playerUpdateMsg =
                                    Model.PlayerUpdate oldWorldPartyKey newWorldPartyKey

                                playerUpdateCmd =
                                    Task.succeed playerUpdateMsg |> Task.perform GlobalEffect
                            in
                                ( newModel
                                , Cmd.batch
                                    [ playerUpdateCmd
                                    , relativeCmd
                                    , joinCmd
                                    ]
                                )

                        Nothing ->
                            ( model, Cmd.none )

            Nothing ->
                ( model, Cmd.none )


relocate : WorldKey PartyKey -> Location -> Multiverse model -> ( Multiverse model, Cmd (WorldMsg msg) )
relocate worldPartyKey location model =
    case location of
        Local relative ->
            relativeRelocate worldPartyKey relative model

        Remote remote relative ->
            remoteRelocate worldPartyKey remote relative model


worldUpdate :
    (NavMsg msg -> model -> ( model, Cmd (NavMsg msg) ))
    -> WorldMsg (NavMsg msg)
    -> Multiverse model
    -> ( Multiverse model, Cmd (WorldMsg (NavMsg msg)) )
worldUpdate hubUpdate msg model =
    case msg of
        Hub hubMsg ->
            let
                ( hubModel, hubCmd ) =
                    hubUpdate hubMsg model.state

                response m =
                    case m of
                        Effect e ->
                            NavEffect e

                        _ ->
                            Hub m
            in
                ( { model | state = hubModel }, Cmd.map response hubCmd )

        HubEff (UpdateGround (WorldKey worldKey ()) ground) ->
            let
                updateGround world =
                    { world | maybeGround = Just ground }
            in
                ( { model | worlds = Bag.update worldKey (Maybe.map updateGround) model.worlds }
                , Cmd.none
                )

        HubEff (RelocateParty (WorldKey worldKey ()) (PartyKey partyKey) location) ->
            relocate (WorldKey worldKey (PartyKey partyKey)) location model


        HubEff (AddApp (WorldKey worldKey ()) app) ->
            let
                addApp world =
                    let
                        ( newApps, newCmdMsgs ) =
                            worldAddApps (WorldKey worldKey ()) [app] world.apps
                    in
                        ( { world | apps = newApps }
                        , Cmd.batch newCmdMsgs
                        )

                replaceWorld w =
                    Bag.replace worldKey w model.worlds

                updateModel ws =
                    { model | worlds = ws }

            in
                Bag.get worldKey model.worlds
                |> Maybe.map
                    ( addApp >> Tuple.mapFirst (replaceWorld >> updateModel))
                |> Maybe.withDefault (model, Cmd.none)


        HubEff (RemoveApp (WorldKey worldKey ()) (Just (AppKey appKey))) ->
            let
                updateApps f world =
                    { world | apps = f world.apps }
                newModel =
                    { model | worlds = Bag.update worldKey (Maybe.map (updateApps (Bag.remove appKey))) model.worlds }
            in
                ( newModel, Cmd.none )


        Send key appMsg ->
            let
                ( mApp, worldKey, updateModel ) =
                    case key of
                        ToApp (WorldKey worldKey (AppKey appKey)) ->
                            ( worldApp (WorldKey worldKey (AppKey appKey)) model
                            , worldKey
                            , \newApp ->
                                let
                                    updateApps world =
                                        { world | apps = Bag.replace appKey newApp world.apps }
                                in
                                    { model | worlds = Bag.update worldKey (Maybe.map updateApps) model.worlds }
                            )

                        ToParty (WorldKey worldKey (PartyKey partyKey)) ->
                            let
                                u newSelf party =
                                    { party | self = newSelf }
                            in
                                ( Maybe.map .self <| worldParty (WorldKey worldKey (PartyKey partyKey)) model
                                , worldKey
                                , \newSelf ->
                                    let
                                        updateParties world =
                                            { world | parties = Bag.update partyKey (Maybe.map (u newSelf)) world.parties }
                                    in
                                        { model | worlds = Bag.update worldKey (Maybe.map updateParties) model.worlds }
                                )

                response x =
                    case x of
                        Effect e ->
                            HubEff (toWorldEffect (WorldKey worldKey ()) Nothing e)

                        m ->
                            toWorldMsg (WorldKey worldKey ()) Nothing (Send key m)
            in
                case mApp of
                    Nothing ->
                        ( model, Cmd.none )

                    Just app ->
                        let
                            ( appModel, appCmdMsg ) =
                                App.update (toAppMsg appMsg) app
                        in
                            ( updateModel appModel
                            , Cmd.map response appCmdMsg
                            )

        Forward (ToParty (WorldKey worldKey (PartyKey partyKey))) fwdMsg ->
            case worldParty (WorldKey worldKey (PartyKey partyKey)) model of
                Just party ->
                    case party.rideKey of
                        Just (AppKey rideKey) ->
                            case worldApp (WorldKey worldKey (AppKey rideKey)) model of
                                Just t ->
                                    let
                                        ( appModel, appCmdMsg ) =
                                            App.update (Ctrl fwdMsg) t

                                        updateApps world =
                                            { world | apps = Bag.replace rideKey appModel world.apps }

                                        newModel =
                                            { model | worlds = Bag.update worldKey (Maybe.map updateApps) model.worlds }
                                    in
                                        ( newModel
                                        , Cmd.map (Send (ToApp (WorldKey worldKey (AppKey rideKey))) >> toWorldMsg (WorldKey worldKey ()) Nothing) appCmdMsg
                                        )

                                Nothing ->
                                    ( model, Cmd.none )

                        Nothing ->
                            let
                                ( appModel, appCmdMsg ) =
                                    App.update (Ctrl fwdMsg) party.self

                                u newSelf party =
                                    { party | self = newSelf }

                                updateParties world =
                                    { world | parties = Bag.update partyKey (Maybe.map (u appModel)) world.parties }

                                newModel =
                                    { model | worlds = Bag.update worldKey (Maybe.map updateParties) model.worlds }
                            in
                                ( newModel
                                , Cmd.map (Send (ToParty (WorldKey worldKey (PartyKey partyKey))) >> toWorldMsg (WorldKey worldKey ()) Nothing) appCmdMsg
                                )

                Nothing ->
                    ( model, Cmd.none )

        _ ->
            ( model, Cmd.none )


worldAnimate : WorldKey () -> Ground -> Time -> Multiverse model
    -> ( Multiverse model, Cmd (WorldMsg (NavMsg msg)) )
worldAnimate (WorldKey worldKey ()) ground dt model =
    let
        response appKey x =
            case x of
                Effect e ->
                    HubEff (toWorldEffect (WorldKey worldKey ()) (Just appKey) e)

                m ->
                    let
                        key =
                            ToApp (WorldKey worldKey appKey)
                    in
                        toWorldMsg (WorldKey worldKey ()) (Just appKey) (Send key m)

        animate app ( apps, appCmds ) =
            let
                ( newApp, appCmd ) =
                    App.animate ground dt app

                ( appKey, newBag ) =
                    Bag.insert newApp apps
            in
                ( newBag, Cmd.map (response (AppKey appKey)) appCmd :: appCmds )
       
        updateApps world =
            let
                ( newApps, newAppCmds ) =
                    Bag.foldl animate ( Bag.empty, [] ) world.apps
            in
                ( { world | apps = newApps }, Cmd.batch newAppCmds )

        replaceWorld w =
            Bag.replace worldKey w model.worlds

        updateModel ws =
            { model | worlds = ws }
    in
        Bag.get worldKey model.worlds
        |> Maybe.map
            ( updateApps >> Tuple.mapFirst (replaceWorld >> updateModel))
        |> Maybe.withDefault (model, Cmd.none)


worldJoin : WorldKey () -> Multiverse model -> ( Maybe (WorldKey PartyKey), Multiverse model, Cmd (WorldMsg msg) )
worldJoin (WorldKey worldKey ()) model =
    let
        -- freshParty : World -> (Party, Cmd msg)
        freshParty world =
            let
                ( defaultSelfApp, defaultSelfCmd ) =
                    world.defaultSelf
            in
                ( { rideKey = Nothing
                  , self = defaultSelfApp
                  }
                , defaultSelfCmd
                )

        -- thisFreshParty : Maybe (Party, Cmd msg)
        thisFreshParty =
            Bag.get worldKey model.worlds
                |> Maybe.map freshParty

        -- insertParty : Party -> Bag Party -> ( WorldKey PartyKey, Bag Party )
        insertParty newParty parties =
            let
                ( partyKey, newParties ) =
                    Bag.insert newParty parties

                worldPartyKey =
                    WorldKey worldKey (PartyKey partyKey)
            in
                ( worldPartyKey, newParties )

        -- updateParties :
        --     (Bag Party -> (WorldKey PartyKey, Bag Party, Cmd msg))
        --     -> World -> (WorldKey PartyKey, World, Cmd msg)
        updateParties f world =
            let
                ( worldPartyKey, newParties ) =
                    f world.parties
            in
                ( worldPartyKey, { world | parties = newParties } )
    in
        case Bag.get worldKey model.worlds of
            Just world ->
                let
                    ( newParty, selfCmd ) =
                        freshParty world

                    ( worldPartyKey, newWorld ) =
                        updateParties (insertParty newParty) world

                    newModel =
                        { model | worlds = Bag.replace worldKey newWorld model.worlds }
                in
                    ( Just worldPartyKey
                    , newModel
                    , Cmd.map (Send (ToParty worldPartyKey) >> toWorldMsg (WorldKey worldKey ()) Nothing) selfCmd
                    )

            Nothing ->
                ( Nothing, model, Cmd.none )


worldLeave : WorldKey PartyKey -> Multiverse a -> Multiverse a
worldLeave (WorldKey worldKey (PartyKey partyKey)) model =
    let
        updateParties f world =
            { world | parties = f world.parties }
    in
        { model | worlds = Bag.update worldKey (Maybe.map (updateParties (Bag.remove partyKey))) model.worlds }


worldChangeRide : WorldKey PartyKey -> Multiverse model -> ( Multiverse model, Cmd (WorldMsg msg) )
worldChangeRide (WorldKey worldKey (PartyKey partyKey)) model =
    let
        updateRide party =
            case ( party.rideKey, App.framing (PartyKey partyKey) party.self ) of
                ( Just (AppKey rideKey), _ ) ->
                    let
                        positioning x =
                            { position = x.position, orientation = x.orientation }

                        ridePos =
                            Maybe.andThen (App.framing (PartyKey partyKey)) (worldApp (WorldKey worldKey (AppKey rideKey)) model)
                                |> Maybe.map (.pov >> positioning)

                        cmd =
                            Cmd.map (Send (ToApp ((WorldKey worldKey (AppKey rideKey)))))
                                (Task.succeed (PartyKey partyKey) |> Task.perform (Ctrl << Leave))
                    in
                        ( { party
                            | rideKey = Nothing
                            , self = App.reposition ridePos party.self
                          }
                        , cmd
                        )

                ( Nothing, Just myFraming ) ->
                    let
                        myPos =
                            myFraming.pov.position

                        myDir =
                            Model.direction myFraming.pov

                        secondPosition ( k, app ) =
                            case App.framing (PartyKey partyKey) app of
                                Just framing ->
                                    Just ( k, framing.target.position )

                                Nothing ->
                                    Nothing

                        relativePosition appPos =
                            V3.sub appPos myPos

                        inFrontOf relPos =
                            V3.dot relPos myDir > 0

                        mClosestKey =
                            Bag.get worldKey model.worlds
                                |> Maybe.map .apps
                                |> Maybe.withDefault Bag.empty
                                |> Bag.toList
                                |> List.filterMap secondPosition
                                |> List.map (Tuple.mapSecond relativePosition)
                                |> List.filter (Tuple.second >> inFrontOf)
                                |> List.map (Tuple.mapSecond V3.lengthSquared)
                                |> List.filter (Tuple.second >> (\d -> d < 10 * 10))
                                |> List.sortBy Tuple.second
                                |> List.head
                                |> Maybe.map Tuple.first
                                |> Maybe.map AppKey

                        cmd =
                            case mClosestKey of
                                Just (AppKey rideKey) ->
                                    Cmd.map (Send (ToApp (WorldKey worldKey (AppKey rideKey))))
                                        (Task.succeed (PartyKey partyKey) |> Task.perform (Ctrl << Enter))

                                Nothing ->
                                    Cmd.none
                    in
                        ( { party | rideKey = mClosestKey }
                        , cmd
                        )

                _ ->
                    ( party, Cmd.none )
    in
        let
            mNewPartyCmds =
                Maybe.map updateRide <| worldParty (WorldKey worldKey (PartyKey partyKey)) model

            mNewParty =
                Maybe.map Tuple.first mNewPartyCmds

            newCmds =
                Maybe.map Tuple.second mNewPartyCmds
                    |> Maybe.withDefault Cmd.none

            updateParties world =
                { world | parties = Bag.update partyKey (always mNewParty) world.parties }
        in
            ( { model | worlds = Bag.update worldKey (Maybe.map updateParties) model.worlds }
            , newCmds
            )


worldId : WorldKey () -> Multiverse a -> Maybe String
worldId (WorldKey worldKey ()) model =
    Bag.get worldKey model.worlds
        |> Maybe.map .id


worldLabel : WorldKey () -> Multiverse a -> Maybe String
worldLabel (WorldKey worldKey ()) model =
    Bag.get worldKey model.worlds
        |> Maybe.map .label


worldPartyLabel : WorldKey PartyKey -> Multiverse a -> String
worldPartyLabel worldPartyKey model =
    let
        (WorldKey worldKey (PartyKey _)) =
            worldPartyKey

        none =
            "<>"
    in
        case worldParty worldPartyKey model of
            Just party ->
                case party.rideKey of
                    Just (AppKey appKey) ->
                        case worldApp (WorldKey worldKey (AppKey appKey)) model of
                            Just app ->
                                App.label app

                            Nothing ->
                                "Ride not found"

                    Nothing ->
                        App.label party.self

            Nothing ->
                "Party not found"


worldOverlay : WorldKey PartyKey -> Multiverse a -> Html (WorldMsg msg)
worldOverlay worldPartyKey model =
    let
        (WorldKey worldKey (PartyKey _)) =
            worldPartyKey

        none =
            Html.text "Welcome to DreamBuggy"
    in
        case worldParty worldPartyKey model of
            Just party ->
                case party.rideKey of
                    Just (AppKey appKey) ->
                        let
                            worldAppKey =
                                WorldKey worldKey (AppKey appKey)
                        in
                            case worldApp worldAppKey model of
                                Just app ->
                                    Html.map (Send (ToApp worldAppKey) >> toWorldMsg (WorldKey worldKey ()) Nothing) (App.overlay app)

                                Nothing ->
                                    Html.text "App not found"

                    Nothing ->
                        Html.map (Send (ToParty worldPartyKey) >> toWorldMsg (WorldKey worldKey ()) Nothing) (App.overlay party.self)

            Nothing ->
                Html.text "Party not found"


worldFraming : WorldKey PartyKey -> Multiverse a -> Maybe Framing
worldFraming worldPartyKey model =
    let
        (WorldKey worldKey partyKey) =
            worldPartyKey
    in
        case worldParty worldPartyKey model of
            Just party ->
                case party.rideKey of
                    Just (AppKey appKey) ->
                        case worldApp (WorldKey worldKey (AppKey appKey)) model of
                            Just app ->
                                App.framing partyKey app

                            Nothing ->
                                Nothing

                    Nothing ->
                        App.framing partyKey party.self

            Nothing ->
                Nothing


worldFocus : WorldKey AppKey -> Multiverse a -> Maybe Focus
worldFocus appKey model =
    case worldApp appKey model of
        Just app ->
            App.focus app

        _ ->
            Nothing


worldGround : WorldKey () -> Multiverse model -> Maybe Ground
worldGround (WorldKey worldKey ()) model =
    Bag.get worldKey model.worlds
        |> Maybe.andThen .maybeGround