Nelmish

[<AutoOpen>]
module GelmDispatcherModule =

    type [<NoEquality; NoComparison>] Binding<'m, 's when 's :> Simulant> =
        { Address : Address<obj>
          AddressType : Type
          MakeMessage : Event<obj, 's> -> 'm option }

    type [<NoEquality; NoComparison>] Binding<'m, 'e, 's when 's :> Simulant> =
        | Binding of Binding<'m, 's>
        | BindingEffect of Binding<'e, 's>

    module Binding =

        let make<'a, 'm> (address : Address<'a>) (message : 'm) =
            { Address = atooa address
              AddressType = typeof<'a>
              MakeMessage = fun _ -> Some message }

        let makeFun<'a, 's, 'm when 's :> Simulant> (address : Address<'a>) (makeMessage : Event<obj, 's> -> 'm option) =
            { Address = atooa address
              AddressType = typeof<'a>
              MakeMessage = makeMessage }

    let (==>) address message =
        Binding (Binding.make address message)

    let (=>>) address message =
        Binding (Binding.makeFun address message)

    let (=!>) address message =
        BindingEffect (Binding.make address message)

    let (=!>>) address message =
        BindingEffect (Binding.makeFun address message)

    type ViewPhase =
        | Initialize
        | Actualize
        | Finalize

    type [<AbstractClass>]
        GelmDispatcher<'model, 'message, 'messageEffect> () =
        inherit GameDispatcher ()

        override this.Register (game, world) =
            let bindings = this.BindModel (game, world)
            let world =
                List.fold (fun world binding ->
                    match binding with
                    | Binding binding ->
                        World.monitor (fun evt world ->
                            let model = this.GetModel (game, world)
                            let messageOpt = binding.MakeMessage evt
                            match messageOpt with
                            | Some message ->
                                let model = this.UpdateModel (message, model, game, world)
                                this.SetModel (model, game, world)
                            | None -> world)
                            binding.Address game world
                    | BindingEffect binding ->
                        World.monitor (fun evt world ->
                            let model = this.GetModel (game, world)
                            let messageOpt = binding.MakeMessage evt
                            match messageOpt with
                            | Some message -> this.EffectModel (message, model, game, world)
                            | None -> world)
                            binding.Address game world)
                    world bindings
            let model = this.GetModel (game, world)
            let world = this.ViewModel (Initialize, model, game, world)
            world
            
        override this.Unregister (game, world) =
            let model = this.GetModel (game, world)
            let world = this.ViewModel (Finalize, model, game, world)
            world

        override this.Actualize (game, world) =
            let model = this.GetModel (game, world)
            this.ViewModel (Actualize, model, game, world)

        abstract member GetModel : Game * World -> 'model
        abstract member SetModel : 'model * Game * World -> World
        abstract member BindModel : Game * World -> Binding<'message, 'messageEffect, Game> list
        abstract member UpdateModel : 'message * 'model * Game * World -> 'model
        abstract member EffectModel : 'messageEffect * 'model * Game * World -> World
        abstract member ViewModel : ViewPhase * 'model * Game * World -> World

    type [<NoEquality; NoComparison>] Model =
        { Count : int
          Screen : Screen }

    type Message =
        | Message1
        | Message2

    type MessageEffect =
        | Exit

    type Game with
            
        member this.GetSampleModel world : Model = this.Get Property? SampleModel world
        member this.SetSampleModel (value : Model) world = this.Set Property? SampleModel value world
        member this.SampleModel = PropertyTag.make this Property? SampleModel this.GetSampleModel this.SetSampleModel

    type SampleDisaptcher () =
        inherit GelmDispatcher<Model, Message, MessageEffect> ()

        static member PropertyDefinitions = [Define? SampleModel { Count = 0; Screen = !> "Screen" }]
        override this.GetModel (game, world) = game.GetSampleModel world
        override this.SetModel (model, game, world) = game.SetSampleModel model world

        override this.BindModel (game, world) =
            [game.GetChangeEvent Property? EyeCenter ==> Message1
             game.GetChangeEvent Property? EyeSize ==> Message2
             game.GetChangeEvent Property? Script =!> Exit]

        override this.UpdateModel (message, model, game, world) =
            match message with
            | Message1 -> { model with Count = inc model.Count }
            | Message2 -> { model with Count = dec model.Count }

        override this.EffectModel (message, model, game, world) =
            match message with
            | Exit -> World.exit world

        override this.ViewModel (phase, model, game, world) =
            match phase with
            | Initialize -> World.createScreen (Some model.Screen.ScreenName) world |> snd
            | Actualize -> world
            | Finalize -> world

        override this.Update (game, world) =
            game.EyeCenter.Update ((+) Vector2.One) world