Using FSharp.Control.Reactive to recognize keyboard input

ReactiveExample.fs

#r "PresentationCore"
#r "PresentationFramework"
#r "WindowsBase"
#r "System.Xaml"
#I "../../packages/FSharp.Control.Reactive.2.3.1/lib/net40/"
#I "../../packages/Rx-Linq.2.2.5/lib/net45"
#I "../../packages/Rx-Core.2.2.5/lib/net45"
#I "../../packages/Rx-Interfaces.2.2.5/lib/net45"
#I "../../packages/Rx-PlatformServices.2.2.5/lib/net45"
#I "../../packages/Rx-Providers.2.2.5/lib/net45"
#r "System.Reactive.Core"
#r "System.Reactive.Interfaces"
#r "System.Reactive.Providers"
#r "System.Reactive.PlatformServices"
#r "System.Reactive.Linq"
#r "FSharp.Control.Reactive"
// #endregion


open System
open System.Windows
open System.Windows.Input
open System.Windows.Media
open FSharp.Control.Reactive.Observable
open System.Collections.Generic

module ReactiveInput =
    
    type Chord      = (Key list) * Key
    type ChordMulti = (Key list) * (Key list)
    type Combo      =  Key list


    type KeyInput =
        | Chord         of Chord
        | ChordMulti    of ChordMulti
        | Combo         of Combo


    /// Does the key from the event match the specified key?
    /// Used as a predicate for functions like 'filter'
    let matchKey (k:Key) (x:KeyEventArgs) : bool = 
        x.Key = k 


    /// Does the key from the event match any of the keys in the list?
    /// Used as a prediate for functions like 'filter'
    let matchKeys (ks:Key list) (x:KeyEventArgs) =
        let rec loop = function
            | hd::tl when hd = x.Key -> true
            | hd::tl                 -> loop tl
            | []                     -> false
        loop ks


    /// Returns an observable sequence if the last keyEvent
    /// orginated from the provided key
    /// Used with flatmap to build up combos 
    let nextKey ( k:Key ) ( keyEvent:IEvent<_,_> ) _ : IObservable<_> =
        keyEvent 
        |> take 1  
        |> filter ( matchKey k )


    /// Construct an observable that fires after a list of keys have been entered in order
    /// e.g   let listCombo = comboMaker ( window.KeyUp ) [ Key.NumPad4; Key.NumPad5; Key.NumPad6 ]
    let comboMaker  ( keys   : Combo                                ) 
                    ( keyUp  : IEvent<KeyEventHandler,KeyEventArgs> ) : IObservable<_> =
        let rec loop ( keys: Key list ) ( acc:IObservable<_> ) =
            match keys with
            | hd::tl    -> loop tl ( acc |> flatmap ( nextKey hd keyUp ))
            | []        -> acc
        keyUp
        |> filter (matchKeys keys )
        |> loop keys 


    /// Returns an observable sequence if the last keyDown event
    /// orginated from any of the provided keys
    /// Used with flatmap to build up combos 
    let nextKeyOr (ks:Key list) (keyEvent:IEvent<_,_>) _ =
        keyEvent 
        |> take 1 |> filter ( matchKeys ks )


    /// Constructs and observable that fires when the 'k' is pressed 
    /// while the 'hold' key is pressed down
    /// While all keys are pressed down the observable will iterate, 
    /// release the 'holds' keys before 'k' and it will stop
    let keyChord ((holds,k):Chord) (keyDown:IEvent<_,_>)(keyUp:IEvent<_,_>)  = 
        /// fire as long as k is held down and none of the hold keys are released
        let play _  = keyDown
                    |> takeWhile ( matchKey k )
                    |> takeUntilOther 
                      ( keyUp 
                        |> filter ( matchKeys holds )) 

        // loop ensures that the number of nextDownKey checks equals the number of keys in the hold list
        let rec chordLoop hs (acc:IObservable<KeyEventArgs>) =
            match hs with 
            | hd::tl    -> chordLoop tl ( acc |> flatmap ( nextKeyOr holds keyDown))
            | []        -> acc
        chordLoop holds keyDown
        |> flatmap  ( play )
        |> distinct


    /// Constructs and observable that fires when the sequence of keys in 'ks' are 
    /// pressed in order while the 'holds' keys are pressed down
    let keyChordMulti ((holds,ks):ChordMulti)(keyDown:IEvent<_,_>)(keyUp:IEvent<_,_>) =
        let chordBreak k = 
            takeUntilOther 
             (  keyDown 
                |> filter  ( fun x -> matchKeys (k::holds) x |> not ))
        let playKey k _   = keyDown
                            |> filter ( matchKey k)
                            |> take 1
                            |> takeUntilOther 
                                ( keyUp  |>  filter ( matchKeys holds ) ) 
                            |> chordBreak k
        let rec loop keys acc =
            match keys with
            | []      -> acc
            | hd::tl  -> loop tl ( acc |> flatmap (playKey hd ))
        loop ks keyDown
        |> filter (matchKeys (holds@ks))
        |> distinct


    /// Constructs and observable that fires when the sequence of keys in 'ks' are 
    /// pressed in order while the 'holds' keys are pressed down
    /// If the 'holds' and the last key in the sequence are pressed down the observable
    /// will continue to fire
    let keyChordMultiSustain ((holds,ks): ChordMulti    )
                             ( keyDown  : IEvent<_,_>   )
                             ( keyUp    : IEvent<_,_>   ) =
        let chordBreak k = 
            takeUntilOther 
             (  keyDown 
                |> filter  ( fun x -> matchKeys (k::holds) x |> not ))
        let playKey k _   = keyDown
                            |> filter ( matchKey k )
                            |> take 1
                            |> takeUntilOther 
                                ( keyUp  |>  filter ( matchKeys holds )) 
                            |> chordBreak k
        let sustain k _ = keyDown
                            |> filter ( matchKey k )
                            |> takeUntilOther 
                                ( keyUp  |> filter ( matchKeys holds )) 
        let rec loop keys acc =
            match keys with
            | []      -> acc
            | hd::[]  -> acc |> flatmap ( sustain hd )
            | hd::tl  -> loop tl ( acc |> flatmap ( playKey hd ))
        loop ks keyDown
        |> filter (matchKeys (holds@ks))
        |> distinct



    /// Takes a list of inputs for combos, chords and multichords and constructs and observable
    /// that fires when the keyinputs for each kind of hotkey signal occur in the order
    /// of the inputlist
    let complexCombo (inputs:KeyInput list)(keyDown:IEvent<_,_>)(keyUp:IEvent<_,_>) =
        /// Variation on comboMaker that allows combos to be strung together 
        /// as part of a complex combo
        let comboBuild ( keys: Key list )  (acc:IObservable<KeyEventArgs>) =
            let rec comboLoop( keys: Key list ) ( acc:IObservable<_> ) =
                match keys with
                | hd::tl    -> comboLoop tl ( acc |> flatmap ( nextKey hd keyDown ))
                | []        -> acc
            comboLoop keys acc
        /// Variation on keyChord that allows chords to be strung together as
        /// part of a complex combo
        let chordBuild ((holds,k):Chord) (acc:IObservable<KeyEventArgs>) = 
            /// checks to make sure the keyDown matches k
            let play _  = keyDown
                        |> take 1    
                        |> filter ( matchKey k )   
                        |> distinct
            /// ends the chord if the holdkeys are released before k is pressed
            let press _ = keyUp
                        |> takeWhile 
                          ( fun x -> not ( matchKeys holds x ))
                        |> take 1
                        |> distinct
            let sustain x   = play x
                            |> flatmap (press)
            // holdLoop ensures that the number of nextDownKey checks equals the number of keys in the hold list
            let rec holdLoop hs (acc:IObservable<KeyEventArgs>) =
                match hs with 
                | hd::tl    -> holdLoop tl ( acc |> flatmap ( nextKeyOr holds keyDown))
                | []        -> acc
            holdLoop holds acc
            |> flatmap  ( sustain )
            |> distinct

        /// Variation on keyChordMulti that allows multichords to be strung together as part of
        /// a complex combo
        let multichordBuild ((holds,ks):ChordMulti) (acc:IObservable<KeyEventArgs>) =
            /// ends the chord if the holdkeys are released before all the keys in ks are pressed
            let press _ = keyUp
                        |> takeWhile 
                          ( fun x -> not ( matchKeys holds x ))
                        |> take 1
                        |> distinct

            /// holdLoop ensures that the number of nextDownKey checks equals the number of keys in the hold list
            let rec holdLoop hs (acc:IObservable<KeyEventArgs>) =
                match hs with 
                | hd::tl    -> holdLoop tl ( acc |> flatmap ( nextKeyOr holds keyDown))
                | []        -> acc
            /// keyLoop ensures that after the holds are checked the keyDown stream matches
            /// the keys in ks in order
            let rec keyLoop keys acc =
                match keys with
                | []      -> acc
                | k::tl  -> keyLoop tl ( acc |> flatmap ( nextKey k keyDown ))

            holdLoop holds acc
            |> keyLoop ks 
            |> flatmap press

        /// Recursively build the complexCombo observable based on the KeyInput list
        let rec make (input:KeyInput list) (acc:IObservable<KeyEventArgs>)  =
            match input with
            | Combo         ks ::tl  -> make tl ( comboBuild ks acc )
            | Chord         ks ::tl  -> make tl ( chordBuild ks acc )
            | ChordMulti    ks ::tl  -> make tl ( multichordBuild ks acc) 
            | []                     -> acc
        make inputs keyDown
        |> distinct


    let konamiCode (keyUp:IEvent<_,_>) = comboMaker  [  Key.Up  ; Key.Up    ; 
                                                        Key.Down; Key.Down  ; 
                                                        Key.Left; Key.Right ; 
                                                        Key.Left; Key.Right ;
                                                        Key.B   ; Key.A     ] keyUp

open ReactiveInput



let rarr() =  let rnd = new System.Random()
              [| for x in 0..1000 -> (rnd.Next(1,300)) |]



type KeyPadder() as self =
    let canvas = Controls.Canvas()


    let keylabel = Controls.Label()
    let grid     = Controls.Grid()
    let window   = Window()
    let rect     = Shapes.Rectangle()
    let initrect =
        rect.Width      <- 200.0
        rect.Height     <- 40.0
        rect.Fill       <- Brushes.DarkRed
        window.Width    <- 500.0
        window.Height   <- 500.0

    let mutable count = 0

    let setup =

        keylabel.Content    <- "show this"
        keylabel.Background <- Brushes.White
        keylabel.Width      <- 200.0
        keylabel.Height     <- 200.0
        canvas.Background   <- Brushes.Black
        grid.Children.Add(canvas)   |> ignore
        grid.Children.Add(keylabel) |> ignore
        canvas.Children.Add(rect)   |> ignore
        
        grid.UpdateLayout()
        window.Content      <-  grid
        window.Show()
        
    /// Shape Dragging

    let overRect  _ = rect.IsMouseOver

    let moveUntil _ = canvas.MouseMove 
                    |> takeUntilOther canvas.MouseLeftButtonUp

    let dragMove =  canvas.MouseLeftButtonDown
                    |> filter       overRect
                    |> map          moveUntil
                    |> concatInner


    let moveRect (args:Input.MouseEventArgs) =
        let pos  = args.GetPosition(canvas)
        let x, y = pos.X, pos.Y
        rect.RenderTransform <- TranslateTransform(x,y) 


    /// When you hold down the block, shots fired!

    let spaceKey   = window.KeyUp
                   |> filter ( matchKey Key.Space )

    let shootUntil _    = spaceKey
                        |> takeUntilOther canvas.MouseLeftButtonUp

    let dragShot    =  canvas.MouseLeftButtonDown
                    |> filter overRect
                    |> map shootUntil
                    |> concatInner            

    let shotsFired _ =  count <- count + 1
                        keylabel.Content <- "Shots Fired :: " + string count



        
    let listCombo = comboMaker [Key.NumPad1;Key.NumPad2;Key.NumPad3]  window.KeyUp
    let repeatCombo = comboMaker [Key.NumPad1;Key.NumPad2;Key.NumPad1]  window.KeyUp

    let konami = konamiCode  window.KeyUp

    let tkey = keyChord ( [Key.LeftShift], Key.W ) window.KeyDown window.KeyUp

    let tchord = keyChord ([ Key.RightShift; Key.RightCtrl; Key.LeftCtrl ], Key.G) window.KeyDown window.KeyUp


    let multiChord = keyChordMulti (    [ Key.RightCtrl; Key.RightShift ]  ,
                                        [ Key.A; Key.S; Key.D; Key.F    ]  ) 
                                    window.KeyDown          
                                    window.KeyUp

    let com1:Combo = [Key.NumPad7;Key.NumPad8;Key.NumPad9]
    let com2:Combo = [Key.NumPad4;Key.NumPad5;Key.NumPad6]

    let c2:Chord = [Key.RightShift],Key.Z
    let cm1:ChordMulti = [Key.RightCtrl],[Key.X;Key.C]
    let cm2:ChordMulti = [Key.RightCtrl],[Key.V;Key.B]

    let intch = keyChordMulti (     [Key.RightAlt;Key.RightShift] ,
                                        [ Key.Z   ]  ) 
                                    window.KeyDown          
                                    window.KeyUp


    let cCombo = complexCombo   [ 
                                    Combo com1      ;
                                    Chord c2        ;
                                    Combo com1      ;
                                ]
                                window.KeyDown          
                                window.KeyUp
    

    /// Subscriptions that trigger at the end of the observables defined above                     
    let subs =  
                let num  = Array.init 20 (fun x -> ref 0)

                let sub str obs     =  subscribe ( fun x -> printfn  "%s !!!!" str ) obs |> ignore
                let sub' n str obs = subscribe ( fun x ->   n := !n + 1
                                                            printfn  "%s played %d" str !n ) obs |> ignore

                subscribe  moveRect     dragMove    |> ignore
                subscribe  shotsFired   listCombo   |> ignore
                subscribe  shotsFired   dragShot    |> ignore

                sub "KONAMI" konami

                sub' num.[0] "Hold Key List chord"        tchord
                sub' num.[1] "chord"                      tkey
                sub' num.[2] "multi-chord"                multiChord
                sub' num.[3] "Complex Combo"              cCombo
                sub' num.[4] "list Combo"                 listCombo  
                sub' num.[5] "repeat Combo"               repeatCombo

    member this.Dispose() =
        window.Close()

    interface IDisposable with
        member x.Dispose() = self.Dispose()


let kp = new KeyPadder()