C# Continuation Monad

using System;

public static class ContinuationMonad

{

    public static Func<Func<V, R>, R> SelectMany<T, U, V, R>(

             this Func<Func<T, R>, R> m,

                  Func<T, Func<Func<U, R>, R>> f,

                  Func<T, U, V> p)

    {

        return c => m(a => f(a)(x => c(p(a, x))));

    }

    public static Func<Func<T, R>, R> Return<T, R>(this T x)

    {

        return k => k(x);

    }

}

public class Program

{

    public static void Main()

    {

        Func<int, Func<Func<int, int>, int>> facCont = null;

        facCont = n => n == 0 ? 1.Return<int, int>()

                          : from x in n.Return<int, int>()

                            from y in facCont(x - 1)

                            select x * y;

        Func<int, int> fac = n => facCont(n)(x => x);

        Console.WriteLine(fac(5));

    }

}

F# Continuation Monad (Tail Recursive Factorial)

// Continuation Monad in F#

type ContinuationMonad() =

    // ma -> (a -> mb) -> mb

    member this.Bind (m, f) = fun c -> m (fun a -> f a c)

    // a -> ma

    member this.Return x = fun k -> k x

    // ma -> ma

    member this.ReturnFrom m = m

let cont = ContinuationMonad()

let fac n =

    let rec loop n =

      cont {

              match n with

              | n when n = 0I -> return 1I

              | _ -> let! x = fun f -> f n

                     let! y = loop (n - 1I)

                     return x * y

           }

    loop n (fun x -> x)

printf "%A" (fac 100000I)

C# QuickSort using Continuation Passing Style (As requested by a comment)

using System;

using System.Linq;

using System.Collections.Generic;

public static class ListExtensions

{

    public static Tuple<IEnumerable<T>, IEnumerable<T>> Partition<T>(

         this IEnumerable<T> items, Func<T, bool> p)

    {

        var xs = items.Where(p);

        var ys = items.Except(xs);

        return Tuple.Create(xs, ys);

    }

    public static IEnumerable<T> Loop<T>(

        IEnumerable<T> xs,

        Func<IEnumerable<T>, IEnumerable<T>> cont) where T : IComparable

    {

        if (!xs.GetEnumerator().MoveNext())

            return cont(new T[0]);

        else

        {

            var x = xs.First();

            var xsp = xs.Skip(1);

            var parts = xsp.Partition(y => y.CompareTo(x) > 0);

            return Loop<T>(parts.Item1, lacc =>

                   Loop<T>(parts.Item2, racc =>

                       cont(lacc.Concat(new[] { x }).Concat(racc))));

        }

    }

    public static IEnumerable<T> QuickSort<T>(this IEnumerable<T> xs)

                                 where T : IComparable

    {

        return Loop<T>(xs, x => x);

    }

}

Tail Recursive QuickSort using Continuation Passing Style

//val qsort: 'a list -> 'a list
let rec qsort = function
                | [] -> []
                | x::xs' -> let (l, r) = List.partition ((>) x) xs'
                            List.concat [(qsort l);[x];(qsort r)]

//val qsortCPS: 'a list -> 'a list
let qsortCPS xs =   
    let rec loop xs cont =
            match xs with
            | [] -> cont []
            | x::xs' -> let (l, r) = List.partition ((>) x) xs'                          
                        loop l (fun lacc ->
                        loop r (fun racc -> cont (lacc @ x :: racc)))
    loop xs (fun x -> x)

Catamorphism (generalised fold on type)

// Catamorphism
// Generalised Fold on a datatype

type exp = | Var of string
           | Lambda of string * exp
           | Apply of exp * exp

// This fold was made Tail Recursive using continuations.
let foldExpr varF lamF appF exp =
  let rec Loop e cont =
      match e with
      | Var x -> cont (varF x)
      | Lambda (x, body) -> Loop body (fun bodyAcc -> cont (lamF x bodyAcc))
      | Apply (l, r) -> Loop l (fun lAcc ->
                        Loop r (fun rAcc ->
                              cont (appF lAcc rAcc)))
  Loop exp (fun x -> x)


let toString =
  foldExpr
      (fun x -> sprintf "%s" x)
      (fun x y -> sprintf "(λ%s.%s)" x y)
      (fun x y -> sprintf "(%s %s)" x y)

printf "%s" (toString (Apply(Lambda("x", Var "x"), Lambda("y", Var "y"))))

Lambda Calculus Normal Order Reducer

// This implementation support evaluation of anonymous recursion through Y Combinator (ex. Y Factorial)

type exp = | Var of string
           | Lambda of string * exp
           | Apply of exp * exp

let rec subst x v a =
  match a with 
  | Var y -> 
        if x = y then v else a
  | Lambda(y, a') ->
        if x = y then a else Lambda(y, subst x v a')
  | Apply(a', a'') ->
        Apply(subst x v a', subst x v a'')

let rec reduce e =
    let rec reduce' e = 
        match e with
        | Var _ -> e
        | Lambda (s, e') -> Lambda(s, reduce' e')
        | Apply(e1, e2) ->
           match e1 with
           | Lambda(s, e3) -> subst s e2 e3
           | _ -> Apply(reduce' e1, reduce' e2)
    reduce' e
    
let rec loop f x =
    let x' = f x
    if x = x' then x' else loop f x'

let normalOrderReducer = loop reduce 

GroupBy Rx Combinator

type IObservableGrouping<'a,'b> =
    inherit IObservable<'b>
    abstract member Key: 'a with get        
                
        
[<Extension>]
let GroupBy(source : IObservable<'a>, keySelector : Func<'a, 'b>) =
    let dict = new System.Collections.Generic.Dictionary<'b, bool * IObservableGrouping<'b, 'a> * ('a -> unit)>()

    { new IObservable<IObservableGrouping<'b, 'a>>
        with member o.Subscribe(observer) = 
                 source.Subscribe({ new IObserver<'a> with 
                                        member o.OnNext x =
                                               let y = keySelector.Invoke x
                                               let getValue key value =
                                                    if (not (dict.ContainsKey key)) then
                                                         dict.Add (key, (false, { new IObservableGrouping<'b, 'a> with 
                                                                                member o.Key = y                                                        
                                                                                member o.Subscribe(observer') = 
                                                                                        observer'.OnNext value
                                                                                        let (_, obv, _) = dict.[y]
                                                                                        dict.[y] <- (true, obv, fun x' -> observer'.OnNext x')
                                                                                        null }, fun x' -> ()))
                                                    dict.[key]
                                               let (subs, obv, f) = getValue y x
                                               if (not subs) then observer.OnNext(obv)
                                               f(x) }) }        

Reactive Linq in F#

namespace FSReactiveLinq
[<System.Runtime.CompilerServices.Extension>]
module LinqEnabler

open System
open System.Runtime.CompilerServices

// IObservable interfaces

type IObserver<'a> = 
    abstract member OnNext : 'a -> unit

type IObservable<'a> = 
    abstract member Subscribe : IObserver<'a> -> IDisposable
    
let CreateObserver f (next: IObserver<'b>) = { new IObserver<'a> with 
                                                               member o.OnNext(x) = 
                                                                   next.OnNext(f x) }                                                                   
let Map(observable: IObservable<'a>, f) 
                    = { new IObservable<'b> with 
                            member o.Subscribe(observer) =
                                observable.Subscribe(CreateObserver f observer) }
                                                                     
let Bind(observable: IObservable<'a>, selector : 'a -> IObservable<'b>, projection) =
                    
                    let project (observer:IObserver<'c>) x = CreateObserver (projection x) observer
                                                                 
                    let Subscribe observer = { new IObserver<'a> with 
                                                   member o.OnNext x = 
                                                         //TODO: Add support for IDisposable
                                                         ignore ((selector x).Subscribe(project observer x)) } 
                    
                    {  new IObservable<'c> with 
                          member o.Subscribe(observer) =
                              observable.Subscribe(Subscribe observer) }
                                     

[<Extension>]
let Select(observable : IObservable<'a>, selector : Func<'a,'b>) = 
    Map(observable, fun x -> selector.Invoke(x))
     
[<Extension>]
let SelectMany(observable : IObservable<'a>, selector : Func<'a, IObservable<'b>>, projection : Func<'a, 'b, 'c>) = 
    Bind(observable, (fun x -> selector.Invoke(x)), (fun x -> fun y -> projection.Invoke(x, y)))
    
                                    
[<Extension>]
let Subscribe<'a> (observable : IObservable<'a>)  (action:Action<'a>) =
        let observer = { new IObserver<'a>
                            with member o.OnNext x = action.Invoke x }
        observable.Subscribe(observer)

Monadic LOGO Large Step Interpreter

open System

//F# State Monad

type State<'state, 'a> = State of ('state ->'a * 'state)

type StateMonad() = 
        member b.Bind(m, f) = State (fun s -> let r = match m with
                                                      | State f -> f s
                                              match r with
                                              | (v,s) -> match f v with
                                                         | State f -> f s)    
        member b.Return(x) = State (fun s -> x, s)

let state = StateMonad()

let GetState = State (fun s -> s, s)
let SetState s = State (fun s' -> (), s)  

let Execute m s = match m with
                  | State f -> let (x,s') = f s
                               s'
                               
let rec ForEach f xs =  
                state {
                        match xs with
                        | x :: xs' -> do! f x                                      
                                      return! ForEach f xs'
                        | [] -> return ()
                      }

let sin = Math.Sin
let cos = Math.Cos
let atan = Math.Atan

let float_of_int x = (float x)
let int_of_float x = (int x)

type logo = | Home
            | Forward of int
            | Turn of int
            | For of int * logo list

let pi = 4.0 * atan 1.0
let dsin t = sin(pi * (float_of_int t) / 180.0) 
and dcos t = cos(pi * (float_of_int t) / 180.0)

let AddToState x = state { let! xs = GetState  
                           do! SetState (x::xs) }

let GoHome = state { do! AddToState (0,0,0) }

let GoForward n = state { let! (x,y,d)::xs = GetState
                          do! AddToState (x + (int_of_float ((float n) * dsin d)), y + (int_of_float ((float n) * dcos d)), d) }                            
let GoTurn n = state { let! (x,y,d)::xs = GetState 
                       do! AddToState (x,y,d+n) }


let rec interpret e = state { 
                             do! match e with
                                 | Home -> GoHome
                                 | Forward n -> GoForward n
                                 | Turn(n) -> GoTurn n
                                 | For(i, es) -> if i > 0 then
                                                    state {
                                                            do! interpret_prog es
                                                            do! interpret (For(i - 1, es))
                                                          }
                                                 else
                                                    state { return () } }
and interpret_prog xs = ForEach interpret xs  

let sample = [Home; For(20, [Turn 18; For(36, [Forward 10; Turn 10])])]

let Run = Execute(interpret_prog sample) [(0,0,0)] |> List.to_array

LOGO Translator

open System;
let sin = Math.Sin
let cos = Math.Cos 
let atan = Math.Atan
let float_of_int x = (float x)
let int_of_float x = (int x)
  

type logo = | Home
            | Forward of int
            | Turn of int
            | For of int * logo list
  

let pi = 4.0 * atan 1.0
let dsin t = sin(pi * (float_of_int t) / 180.0)
and dcos t = cos(pi * (float_of_int t) / 180.0)
  

let forward (x,y,d) steps =  (x + (int_of_float ((float steps) * dsin d)),
                              y + (int_of_float ((float steps) * dcos d)), d)
  

let compose f g = fun x -> f(g(x))
  

let rec translate h x = match x with
                        | Home -> fun pos -> pos
                        | Forward(n) -> fun pos ->
                                                    let pos' = forward pos n
                                                    h pos'
                        | Turn(n) -> fun (x,y,d) -> (x,y,d + n)
                        | For(i, xs) -> let f = translate_prog h xs in
                                        if i > 1 then
                                           compose f (translate h (For(i - 1, xs)))
                                        else
                                           f
and translate_prog h xs = List.fold_left (fun f x -> compose (translate h x) f) (fun pos -> pos) xs             
let current = (0, 0, 0)
let sample = [Home; For(20, [Turn 18; For(36, [Forward 10; Turn 10])])]
  

let f = translate_prog (fun x -> (printf "%A" x) ; x) sample
  

let result = f current

LOGO Large Step Interpreter

open System;
  

let sin = Math.Sin
let cos = Math.Cos
let atan = Math.Atan
  

let float_of_int x = (float x)
let int_of_float x = (int x)
  

type logo = | Home
            | Forward of int
            | Turn of int
            | For of int * logo list
  

let pi = 4.0 * atan 1.0
let dsin t = sin(pi * (float_of_int t) / 180.0)
and dcos t = cos(pi * (float_of_int t) / 180.0)
  

let rec interpret f (x,y,d) e =
   let interpret' (x,y,d) e = match e with
                              | Home -> (0,0,0)
                              | Forward(n) -> (x + (int_of_float ((float n) * dsin d)), y + (int_of_float ((float n) * dcos d)), d)
                              | Turn(n) ->  (x, y, d + n)
                              | For(i, xs) -> if i > 0 then
                                                interpret f (interpret_prog f (x,y,d) xs) (For(i - 1, xs))
                                              else
                                                (x,y,d)
   f (x,y,d)
   interpret' (x,y,d) e
and interpret_prog f pos xs =  match xs with
                               | x::xs' ->  interpret_prog f (interpret f pos x) xs'              
                               | [] -> pos
  

let current = (0, 0, 0)
let sample = [Home; For(20, [Turn 18; For(36, [Forward 10; Turn 10])])]
  

let result = interpret_prog (printf "%A") current sample

Bowling Game Kata Implementation

//Bowling Game Kata Implementation

open StateMonad

let AllPins = 10
let ZeroPins = 0

let IsStrike(roll, _) = roll = AllPins
let IsSpare(roll, nextRoll) = (roll + nextRoll) = AllPins
let SpareBonus rolls = match rolls with
                       | (rollA, rollB)::rolls' -> rollA
                       | [] -> 0
let StrikeBonus rolls =  match rolls with
                         | (rollA,rollB)::rolls' -> rollA + if rollA = AllPins then rollA else rollB
                         | [] -> 0

let frames rolls =
       let rec frames' rolls =
           match rolls with
           | rollA::rollB::[] -> [(rollA,rollB)]
           | rollA::rollB::rolls' ->  if (IsStrike(rollA, rollB)) then
                                           (rollA, ZeroPins)    :: frames' (rollB::rolls')
                                      else
                                           (rollA, rollB)       :: frames' rolls'
           | rollA::[] -> [(rollA, ZeroPins)]
       frames' rolls
      
                   
let NextScoreNoBonus prevScore rollA rollB = prevScore + rollA + rollB
      
let rec totals xs score =
 match xs with
 | (x,y)::[] when x < AllPins -> (NextScoreNoBonus score x y)
 | (_,_)::[] -> score
 | (x,y)::xs ->
   if (IsStrike(x,y)) then
      totals xs (score + x + StrikeBonus xs)
   else
       if (IsSpare(x,y)) then
           totals xs ((NextScoreNoBonus score x y) + SpareBonus xs)
       else
           totals xs (NextScoreNoBonus score x y)
 | [] -> score


let Score m = Execute (state { do! m
                               let! score = GetState
                               return score }) []
let Total xs = (totals (frames xs) 0)

let Roll(pins) = state { let! s = GetState
                        do! SetState(s @ [pins]) }

let RollList xs = state { let! xs' = MMap (fun s -> state { do! Roll s }) xs
                         return () }

let RollMany t s = state { do! RollList (List.map (fun _ -> s) [1..t]) }
                         
let RollSpare = state { do! Roll 5
                        do! Roll 5 }
                      
let RollStrike = state { do! Roll 10 }

Bowling Game Kata Tests

// Bowling Game Kata Tests

open NUnit.Framework
open Bowling
open StateMonad
                                         
[<TestFixture>]
type BowlingTests =
   new() = {}
      
   [<Test>]
   member x.gutterGame() =
       Assert.AreEqual(0, Score(RollMany 20 0) |> Total)
      
   [<Test>]
   member x.allOnes() =
       Assert.AreEqual(20, Score(RollMany 20 1) |> Total)
      
   [<Test>]
   member x.oneSpare() = 
       Assert.AreEqual(16, Score(state {  do! RollSpare
                                          do! Roll 3
                                          do! RollMany 17 0 }) |> Total)                                    
   [<Test>]
   member x.oneStrike() =
       Assert.AreEqual(24, Score(state { do! RollStrike
                                         do! Roll 3
                                         do! Roll 4
                                         do! RollMany 16 0 }) |> Total)                                     
   [<Test>]
   member x.perfectGame() =
       Assert.AreEqual(300, Score(state { do! RollMany 12 10 }) |> Total)