Wednesday 16 December 2009

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)

Monday 14 December 2009

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);
    }
}

Friday 25 September 2009

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)

Thursday 10 September 2009

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"))))

Saturday 8 August 2009

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

Sunday 26 July 2009

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) }) }

Wednesday 22 July 2009

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)

Tuesday 28 April 2009

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

Tuesday 21 April 2009

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

Sunday 19 April 2009

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

Monday 2 March 2009

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)