F# Code

Zipper Forests ( from Haskell )

2013-05-22T22:54:00.001+01:00

type 'a Tree = { rootLabel:'a

subForest:'a Forest }

and 'a Forest = 'a Tree list

type 'a TreeLoc = { tree : 'a Tree

lefts : 'a Forest

rights : 'a Forest

parents : ('a Forest * 'a * 'a Forest) list }

// create_node : 'a -> 'a Tree

let create_node x = { rootLabel = x

subForest = [] }

// maybe : 'a -> ('b -> 'a) -> 'b option -> 'a

let maybe n f m = match m with

| None -> n

| Some x -> f x

// combChildren : 'a list -> 'a -> 'a list -> 'a list

let private combChildren ls t rs = List.fold (fun xs x -> x::xs) (t::rs) ls

// downParents : 'a TreeLoc -> ('a Forest * 'a * 'a Forest) list

let private downParents loc = (loc.lefts, (loc.tree).rootLabel, loc.rights) :: loc.parents

// splitChildren : 'a list -> 'a list -> int -> ('a list * 'a list) option

let rec splitChildren acc xs n =

match (acc, xs, n) with

| (acc, xs, 0) -> Some (acc, xs)

| (acc, x::xs, n) -> splitChildren (x::acc) xs (n - 1)

| _ -> None

// parent : 'a TreeLoc -> 'a TreeLoc option

let parent loc = match loc.parents with

| (pls, v, prs) :: ps ->

Some { tree = { rootLabel = v

subForest = (combChildren (loc.lefts) (loc.tree) (loc.rights)) }

lefts = pls

rights = prs

parents = ps }

| [] -> None

// root : 'a TreeLoc -> 'a TreeLoc

let rec root loc = maybe loc root (parent loc)

// left : 'a TreeLoc -> 'a TreeLoc option

let left loc = match loc.lefts with

| t::ts -> Some { loc with

tree = t

lefts = ts

rights = loc.tree :: loc.rights }

| [] -> None

// right : 'a TreeLoc -> 'a TreeLoc option

let right loc = match loc.rights with

| t::ts -> Some { loc with

tree = t

lefts = loc.tree :: loc.lefts

rights = ts }

| [] -> None

// firstChild : 'a TreeLoc -> 'a TreeLoc option

let firstChild loc = match (loc.tree).subForest with

| t::ts -> Some { tree = t

lefts = []

rights = ts

parents = downParents loc }

| [] -> None

// lastChild : 'a TreeLoc -> 'a TreeLoc option

let lastChild loc = match (List.rev ((loc.tree).subForest)) with

| t::ts -> Some { tree = t

lefts = ts

rights = []

parents = downParents loc }

| [] -> None

// getChild : int -> 'a TreeLoc -> 'a TreeLoc option

let getChild n loc =

splitChildren [] ((loc.tree).subForest) n

|> Option.map (fun (t::ls, rs) -> { tree = t

lefts = ls

rights = rs

parents = downParents loc })

// findChild : ('a Tree -> bool) -> 'a TreeLoc -> 'a TreeLoc option

let findChild p loc =

let rec split acc xs =

match xs with

| x::xs when p x -> Some(acc, x, xs)

| x::xs -> split (x::acc) xs

| []-> None

split [] ((loc.tree).subForest)

|> Option.map (fun (ls, t, rs) -> { tree = t

lefts = ls

rights = rs

parents = downParents loc })

// fromTree : 'a Tree -> 'a TreeLoc

let fromTree t = { tree = t

lefts = []

rights = []

parents = [] }

// fromForest : 'a Forest -> 'a TreeLoc option

let fromForest (ts : 'a Forest) =

match ts with

| t::ts -> Some { tree = t

lefts = []

rights = ts

parents = [] }

| [] -> None

// toTree : 'a TreeLoc -> 'a Tree

let toTree loc = (root loc).tree

// toForest : 'a TreeLoc -> 'a Forest

let toForest loc : 'a Forest =

let r = root loc in combChildren (r.lefts) (r.tree) (r.rights)

// isRoot : 'a TreeLoc -> bool

let isRoot loc = List.isEmpty (loc.parents)

// isFirst : 'a TreeLoc -> bool

let isFirst loc = List.isEmpty (loc.lefts)

// isLast : 'a TreeLoc -> bool

let isLast loc = List.isEmpty (loc.rights)

// isLeaf : 'a TreeLoc -> bool

let isLeaf loc = List.isEmpty ((loc.tree).subForest)

// isChild : 'a TreeLoc -> bool

let isChild loc = not (isRoot loc)

// hasChildren : 'a TreeLoc -> bool

let hasChildren loc = not (isLeaf loc)

// setTree : 'a Tree -> 'a TreeLoc -> 'a TreeLoc

let setTree t loc = { loc with tree = t }

// modifyTree : ('a Tree -> 'a Tree) -> 'a TreeLoc -> 'a TreeLoc

let modifyTree f loc = setTree (f (loc.tree)) loc

// setLabel : 'a -> 'a TreeLoc -> 'a TreeLoc

let setLabel v loc = modifyTree (fun t -> { t with rootLabel = v }) loc

// getLabel : 'a TreeLoc -> 'a

let getLabel loc = (loc.tree).rootLabel

// modifyLabel : ('a -> 'a) -> 'a TreeLoc -> 'a TreeLoc

let modifyLabel f loc = setLabel (f (getLabel loc)) loc

// insertLeft : 'a Tree -> 'a TreeLoc -> 'a TreeLoc

let insertLeft t loc = { loc with tree = t

rights = loc.tree :: loc.rights }

// insertRight : 'a Tree -> 'a TreeLoc -> 'a TreeLoc

let insertRight t loc = { loc with tree = t

lefts = loc.tree :: loc.lefts }

// insertDownFirst : 'a Tree -> 'a TreeLoc -> 'a TreeLoc

let insertDownFirst t loc = { loc with tree = t

lefts = []

rights = (loc.tree).subForest

parents = downParents loc }

// insertDownLast : 'a Tree -> 'a TreeLoc -> 'a TreeLoc

let insertDownLast t loc = { loc with tree = t

lefts = List.rev ((loc.tree).subForest)

rights = []

parents = downParents loc }

// insertDownAt : int -> 'a Tree -> 'a TreeLoc -> 'a TreeLoc option

let insertDownAt n t loc =

splitChildren [] ((loc.tree).subForest) n

|> Option.map (fun (ls, rs) -> { loc with tree = t

lefts = ls

rights = rs

parents = downParents loc })

Rx Live Morse Code Translation

2013-01-24T23:30:00.001Z

open System

open System.Threading

open System.Threading.Tasks

open System.Reactive.Linq

open System.Reactive.Threading

open System.Reactive.Concurrency

open System.Reactive.Subjects

module Observable =

let observeOn (scheduler:IScheduler) (xs:IObservable<'a>) =

Observable.ObserveOn(xs, scheduler)

let subscribeOn (scheduler:IScheduler) (xs:IObservable<'a>) =

Observable.SubscribeOn(xs, scheduler)

let window (f: Unit -> IObservable<'b>) (xs:IObservable<'a>) =

Observable.Window(xs, new Func<IObservable<'b>>(f))

let subscribe' f g (xs:IObservable<'a>) =

ObservableExtensions.Subscribe(xs, new Action<'a>(f), new Action(g))

let splitBy separator (xs:IObservable<'a>) =

xs |> Observable.window (fun () -> xs |> Observable.filter (fun x -> x = separator))

|> Observable.map (Observable.filter (fun y -> y <> separator))

type MorseCode = Node of string * MorseCode * MorseCode

| Leaf of string

| Empty

let morseCodeTree =

let zeroNode = Leaf("0")

let nineNode = Leaf("9")

let dashNode = Node("", zeroNode, nineNode)

let nullLeaf = Empty

let eightNode = Leaf("8")

let dotNode = Node("", nullLeaf, eightNode)

let oNode = Node("O", dashNode, dotNode)

let qNode = Node("Q", nullLeaf, nullLeaf)

let sevenNode = Leaf("7")

let zNode = Node("Z", nullLeaf, sevenNode)

let gNode = Node("G", qNode, zNode)

let mNode = Node("M", oNode, gNode)

let yNode = Leaf("Y")

let cNode = Leaf("C")

let kNode = Node("K", yNode, cNode)

let xNode = Leaf("X")

let sixNode = Leaf("6")

let bNode = Node("B", nullLeaf, sixNode)

let dNode = Node("D", xNode, bNode)

let nNode = Node("N", kNode, dNode)

let tNode = Node("T", mNode, nNode)

let oneNode = Leaf("1")

let jNode = Node("J", oneNode, nullLeaf)

let pNode = Leaf("P")

let wNode = Node("W", jNode, pNode)

let lNode = Leaf("L")

let rNode = Node("R", nullLeaf, lNode)

let aNode = Node("A", wNode, rNode)

let twoNode = Leaf("2")

let udNode = Node("", twoNode, nullLeaf)

let fNode = Leaf("F")

let uNode = Node("U", udNode, fNode)

let threeNode = Leaf("3")

let vNode = Node("V", threeNode, nullLeaf)

let fourNode = Leaf("4")

let fiveNode = Leaf("5")

let hNode = Node("H", fourNode, fiveNode)

let sNode = Node("S", vNode, hNode)

let iNode = Node("I", uNode, sNode)

let eNode = Node("E", aNode, iNode)

Node("", tNode, eNode)

let extractChar n = match n with

| Node (ch, _, _) -> ch

| Leaf ch -> ch

| Empty -> ""

let processChar acc ch = match (ch, acc) with

| '-', Node (_, dash, _) -> dash

| '.', Node (_, _, dot) -> dot

| _ -> Empty

let translateMorseCode xs =

xs |> splitBy ' '

|> Observable.map(Observable.scan processChar morseCodeTree >> Observable.map extractChar)

let processKeyPress(subject:ISubject<char>) =

let mutable info:ConsoleKeyInfo option = None

while (info.IsNone || info.Value.Key <> ConsoleKey.Enter) do

info <- Some (Console.ReadKey())

subject.OnNext info.Value.KeyChar

Environment.Exit(0)

let getKeyPresses =

let subject = new Subject<char>()

Task.Run(fun () -> processKeyPress(subject)) |> ignore

subject |> Observable.observeOn(CurrentThreadScheduler.Instance)

let mutable index = 0

let writeCode (x:string) =

let oldpos = Console.CursorLeft

Console.SetCursorPosition (index, 1)

Console.Write x

Console.SetCursorPosition (oldpos, 0)

getKeyPresses |> translateMorseCode

|> Observable.subscribe(Observable.subscribe' writeCode (fun () -> index <- index + 1) >> ignore)

|> ignore

Thread.Sleep -1

Functional IoC Container Example

2011-08-28T21:34:00.001+01:00

open System

type StateMonad() =

member this.ReturnFrom x = x

member this.Return x s = (x, s)

member this.Bind (m, f) s = let (x, s1) = m s

in (f x) s1

let state = new StateMonad()

type IEnvironment =

abstract member UserName : string with get

type ILogger =

abstract member Log : string -> unit

type Container = { Environment : IEnvironment

Logger : ILogger }

let getContainer = fun f -> (f(), f)

let run ctx m = m (fun () -> ctx) |> fst

let rec fac n acc = state { let! container = getContainer

container.Logger.Log (sprintf "%d" acc)

if (n = 0) then return acc

else return! fac (n - 1) (n * acc) }

let compute n = state { let! container = getContainer

container.Logger.Log (sprintf "Begin fac %d" n)

let! result = fac n 1

container.Logger.Log (sprintf "End fac %d" n)

let userName = container.Environment.UserName

container.Logger.Log (sprintf "Computed by %s" userName)

return result }

let prodContainer =

{ Environment = { new IEnvironment with

member this.UserName

with get () =

Environment.UserName }

Logger = { new ILogger with

member this.Log s =

Console.WriteLine ("{0} : {1}", (DateTime.Now), s) } }

let testContainer =

{ Environment = { new IEnvironment with

member this.UserName

with get () =

"John Doe" }

Logger = { new ILogger with

member this.Log s = Console.WriteLine (" {0} ", s) } }

printfn "Result %A" (run prodContainer (compute 10))

printfn "Result %A" (run testContainer (compute 10))

Functional WPF Part Five (Simple example of how to use it)

2011-07-17T17:28:00.002+01:00

// Example using the Functional WPF DSL

// View Model

type Person (firstName, lastName, age) =

static member New (firstName, lastName, age) =

new Person(firstName, lastName, age)

member this.LastName

with get () = lastName

and set (value : string) = ()

member this.FirstName

with get () = firstName

and set (value : string) = ()

member this.Age

with get () = age

and set (value : int) = ()

let dataContext = [("Homer", "Simpson", 46)

("Marge", "Simpson", 42)

("Lisa", "Simpson", 9)

("Bart", "Simpson", 12) ] |> List.map (Person.New)

// Header

let header = [ label [width 100] "First Name"

label [width 100] "Last Name"

label [width 50] "Age" ] |> stackpanel [] Horizontal

// Row

let row = [ textbox [width 100] <@@ fun (x:Person) -> x.FirstName @@>

textbox [width 100] <@@ fun (x:Person) -> x.LastName @@>

textbox [width 50] <@@ fun (x:Person) -> x.Age @@> ]

|> stackpanel [] Horizontal

// Data Template

let sampleTemplate = datatemplate row

// Final composition

let sampleGrid = [ header

itemscontrol sampleTemplate

button "submit" ] |> stackpanel [width 250] Vertical

|> border Blue

// Main Window

let mainWindow = window [width 400; height 200] sampleGrid

// Application

let sampleApplication = application mainWindow

// Run the app with the given dataContext

[<STAThread()>]

do run sampleApplication dataContext

Functional WPF Part Four

2011-07-17T17:22:00.001+01:00

// Functional WPF Part Four
// Running the WPF Application

#if INTERACTIVE

#r @"WindowsBase.dll"

#r @"PresentationCore.dll"

#r @"PresentationFramework.dll"

#endif

open System.Windows

open System.Windows.Controls

open System.Windows.Markup

let run app data = app |> parseApplication

|> XamlReader.Parse

|> fun x -> (x :?> System.Windows.Application)

|> fun x -> x.MainWindow.DataContext <- data

x.MainWindow.Show()

x.Run()

|> ignore

Functional WPF Part Three

2011-07-17T17:15:00.002+01:00

// Functional WPF Part Three

// Parsing to Xaml

let parseColor o =

match o with

| Red -> "Red"

| Green -> "Green"

| Blue -> "Blue"

let parseOrientation o =

match o with

| Horizontal -> "Horizontal"

| Vertical -> "Vertical"

let parseAttribute attr =

match attr with

| Width x -> sprintf @"Width = ""%i""" x

| Height x -> sprintf @"Height = ""%i""" x

let parseAttributes =

List.fold (fun acc x -> sprintf "%s %s" acc (parseAttribute x)) ""

let rec parseBinding (b:Expr) =

match b with

| Lambda (_, e) -> parseBinding e

| PropertyGet (_, info, _) -> sprintf @"{Binding Path=%s}" (info.Name)

let rec parseDataTemplate (DataTemplate x) =

sprintf @"<DataTemplate>%s</DataTemplate>"
(parseFrameworkElement x)

and parseFrameworkElement x =

match x with

| Label (s, attrs) -> sprintf @"<Label Content=""%s"" %s/>" s

(parseAttributes attrs)

| Button s -> sprintf @"<Button Content=""%s""/>" s

| TextBox (attrs, b) -> sprintf @"<TextBox %s Text=""%s""/>"

(parseAttributes attrs)

(parseBinding b)

| StackPanel (xs, attrs, orient) ->

let (+) x y = sprintf "%s\n%s" x y

sprintf @"<StackPanel Orientation = ""%s"" %s>%s
</StackPanel>"

(parseOrientation orient)

(parseAttributes attrs)

(List.fold (fun acc x -> acc + (parseFrameworkElement x)) "" xs)

| Border (c, x) -> sprintf @"<Border BorderBrush=""%s""

BorderThickness=""2"">%s</Border>"

(parseColor c)

(parseFrameworkElement x)

| ItemsControl t ->

sprintf @"<ItemsControl ItemsSource=""{Binding .}"">

<ItemsControl.ItemTemplate>%s</ItemsControl.ItemTemplate>

</ItemsControl>" (parseDataTemplate t)

let parseWindow (Window (c, attrs)) =

sprintf @"<Window %s>%s</Window>"

(parseAttributes attrs)

(parseFrameworkElement c)

let parseApplication (Application c) =

sprintf @"<Application

xmlns=""http://schemas.microsoft.com/winfx/2006/xaml/presentation""

xmlns:x=""http://schemas.microsoft.com/winfx/2006/xaml"">

<Application.MainWindow>%s</Application.MainWindow></Application>"

(parseWindow c)

Functional WPF Part Two

2011-07-17T17:11:00.000+01:00

// Functional WPF Part Two

// Helper functions

let width = Width

let height = Height

let stackpanel attrs orient xs = StackPanel (xs, attrs, orient)

let border c x = Border(c, x)

let label attrs s = Label(s, attrs)

let button = Button

let textbox attrs b = TextBox(attrs, b)

let itemscontrol = ItemsControl

let datatemplate = DataTemplate

let application = Application

let window attrs c = Window (c, attrs)

Functional WPF Part One

2011-07-17T17:08:00.000+01:00

// Functional WPF (An Experiment in F# DSL to Xaml)

open System

open Microsoft.FSharp.Quotations

open Microsoft.FSharp.Quotations.Patterns

// Type Definitions

type Color = Red | Green | Blue

type Orientation = Horizontal | Vertical

type Attribute = Width of int

| Height of int

type DataTemplate = DataTemplate of FrameworkElement

and FrameworkElement

= Label of string * Attribute list

| Button of string

| TextBox of Attribute list * Expr

| StackPanel of FrameworkElement list * Attribute list * Orientation

| Border of Color * FrameworkElement

| ItemsControl of DataTemplate

type Window = Window of FrameworkElement * Attribute list

type Application = Application of Window

Reactive Extensions v1.0.10425 Computation Expression Builder

2011-05-28T02:41:00.001+01:00

// Reactive Extensions v1.0.10425 Computation Expression Builder
// http://msdn.microsoft.com/en-us/data/gg577609

open System

open System.Linq

open System.Reactive.Linq

type rxBuilder() =

member this.Bind ((xs:'a IObservable), (f:'a -> 'b IObservable)) =

Observable.SelectMany (xs, f)

member this.Delay f = Observable.Defer f

member this.Return x = Observable.Return x

member this.ReturnFrom xs = xs

member this.Combine (xs:'a IObservable, ys: 'a IObservable) =

Observable.Concat (xs, ys)

member this.For (xs : 'a seq, f: 'a -> 'b IObservable) =

Observable.For(xs, new Func<_, IObservable<_>>(f))

member this.TryFinally (xs: 'a IObservable, f : unit -> unit) =

Observable.Finally(xs, new Action(f))

member this.TryWith (xs: 'a IObservable, f: exn -> 'a IObservable) =

Observable.Catch (xs, new Func<exn, 'a IObservable>(f))

member this.While (f, xs: 'a IObservable) =

Observable.While (new Func<bool>(f), xs)

member this.Yield x = Observable.Return x

member this.YieldFrom xs = xs

member this.Zero () = Observable.Empty()

let rx = rxBuilder()

// Rx combinators

let repeat (xs:IObservable<_>) = xs.Repeat()

// Sample usages

let xs = rx { yield 42

yield 43 }

let ys = rx { yield 42

yield! xs }

let zs = rx { for i = 0 to 10 do yield i }

let redTime = rx { while (DateTime.Now.Second > 30) do

yield ConsoleColor.Red }

let blueTime = rx { while (DateTime.Now.Second < 30) do

yield ConsoleColor.Green }

let coloredTime = rx { yield! redTime

yield! blueTime } |> repeat

Kleisli List Arrow Combinators

2011-04-29T19:36:00.005+01:00

// Kleisli List Arrow

// ( >>= ) : 'a list -> ('a -> 'b list) -> 'b list

let (>>=) m f = m |> List.map f |> List.concat

// unit : 'a -> 'a list

let unit x = [x]

type Arrow<'i,'o> = Arrow of('i -> 'o list)

// arr : ('a -> 'b list) -> Arrow<'a,'b>

let arr f = Arrow f

// pure' : ('a -> 'b) -> Arrow<'a,'b>

let pure' f = arr (unit << f)

// ( >>>> ) : Arrow<'a,'b> -> Arrow<'b,'c> -> Arrow<'a,'c>
let (>>>>) (Arrow f) (Arrow g) = arr ((fun m -> m >>= g) << f)

// first : Arrow<'a,'b> -> Arrow<('a * 'c),('b * 'c)>
let first (Arrow f) = arr (fun(x,y) -> (f x) >>= (fun x' -> unit (x', y)))

// second : Arrow<'a,'b> -> Arrow<('c * 'a),('c * 'b)>

let second (Arrow f) = arr (fun(x,y) -> (f y) >>= (fun y' -> unit (x, y')))

// mapA : Arrow<'a,'b> -> ('b -> 'c) -> Arrow<'a,'c>
// Not sure about this one. Is it right ?
let mapA m f = m >>>> pure' f

// toMonad : Arrow<unit,'a> -> 'a list

let toMonad (Arrow f) = f()

// map : 'a list -> ('a -> 'b) -> 'b list
let map m f = mapA (arr (fun _ -> m)) f |> toMonad

// bind : 'a list -> ('a -> 'b list) -> 'b list

let bind m f = (arr (fun _ -> m) >>>> arr f) |> toMonad

// fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b

let rec fix f x = f (fix f) x

// mfix : ('a -> 'a list) -> 'a list
// This one is wrong. Help!

let rec mfix f = match fix (fun x -> fun () -> f(List.head (x()))) () with

| [] -> []

| x::_ -> x :: mfix (List.tail<< f)

// liftM : ('a -> 'b) -> 'a list -> 'b list

let liftM f m = m >>= (fun a -> unit (f a))

// loop : Arrow<('a * 'b),('c * 'b)> -> Arrow<'a,'c>

let loop (Arrow f) = let f' x y = f (x, snd y)

arr (liftM fst << mfix << f')

Hindley Milner Type Inference Sample Implementation

2010-08-15T23:50:00.000+01:00

// Learn more about F# at http://fsharp.net

// Hindley Milner Type Inference Sample Implementation

// ************************************************

// AST

// ************************************************

type Literal

= Char of char // character literal

| String of string // string literal

| Integer of int // integer literal

| Float of float // floating point literal

type Exp

= Var of string // variable

| Lam of string * Exp // lambda abstraction

| App of Exp * Exp // application

| InfixApp of Exp * string * Exp // infix application

| Let of string * Exp * Exp // local definition

| Lit of Literal // literal

// ************************************************

// Type Tree

// ************************************************

type Type

= TyLam of Type * Type

| TyVar of string

| TyCon of string * Type list

with override this.ToString() =

match this with

| TyLam (t1, t2) -> sprintf "(%s -> %s)" (t1.ToString()) (t2.ToString())

| TyVar a -> a

| TyCon (s, ts) -> s

// ************************************************

// Subtitutions

// ************************************************

type Subst = Subst of Map<string, Type>

// extend: string -> Type -> Subst -> Subst

let extend v t (Subst s) = Subst (Map.add v t s)

// lookup: string -> Subst -> Type

let lookup v (Subst s) =

if (Map.containsKey v s) then

Map.find v s

else

TyVar v

// Apply a type substitution to a type

// subs: Type -> Subst -> Type

let rec subs t s =

match t with

| TyVar n ->

let t' = lookup n s

if t = t' then t'

else subs t' s

| TyLam(a, r) ->

TyLam(subs a s, subs r s)

| TyCon(name, tyArgs) ->

TyCon(name, tyArgs

|> List.map (fun x -> subs x s))

// ************************************************

// Environments

// ************************************************

type TyScheme = TyScheme of Type * Set<string>

type Env = Env of Map<string, TyScheme>

// Calculate the list of type variables occurring in a type,

// without repeats

// getTVarsOfType: Type -> Set<string>

let rec getTVarsOfType t =

match t with

| TyVar n -> Set.singleton n

| TyLam(t1, t2) -> getTVarsOfType(t1) + getTVarsOfType(t2)

| TyCon(_, args) ->

List.fold (fun acc t -> acc + getTVarsOfType t) Set.empty args

// getTVarsOfScheme: TyScheme -> Set<string>

let getTVarsOfScheme (TyScheme (t, tvars)) =

(getTVarsOfType t) - tvars

// getTVarsOfEnv: Env -> Set<string>

let getTVarsOfEnv (Env e) =

let schemes = e |> Map.toSeq |> Seq.map snd

Seq.fold (fun acc s -> acc + (getTVarsOfScheme s)) Set.empty schemes

// ************************************************************

// Unification

// ************************************************************

exception UnificationError of Type * Type

// Calculate the most general unifier of two types,

// raising a UnificationError if there isn't one

// mgu: Type -> Type -> Subst -> Subst

let rec mgu a b s =

match (subs a s, subs b s) with

| TyVar ta, TyVar tb when ta = tb -> s

| TyVar ta, _ when not <| Set.contains ta (getTVarsOfType b) -> extend ta b s

| _, TyVar _ -> mgu b a s

| TyLam (a1, b1), TyLam (a2, b2) -> mgu a1 a2 (mgu b1 b2 s)

| TyCon(name1, args1), TyCon(name2, args2) when name1 = name2 ->

(s, args1, args2) |||> List.fold2 (fun subst t1 t2 -> mgu t1 t2 subst)

| x,y -> raise <| UnificationError (x,y)

// ************************************************************

// State Monad

// ************************************************************

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

let run (State f) s = f s

type StateMonad() =

member b.Bind(State m, f) =

State (fun s ->

let (v,s') = m s in

let (State n) = f v in n s')

member b.Return x = State (fun s -> x, s)

member b.ReturnFrom x = x

member b.Zero () = State (fun s -> (), s)

member b.Combine(r1, r2) = b.Bind(r1, fun () -> r2)

member b.Delay f = State (fun s -> run (f()) s)

let state = StateMonad()

let getState = State (fun s -> s, s)

let setState s = State (fun _ -> (), s)

let execute m s = match m with

| State f -> let r = f s

match r with

|(x,_) -> x

let mmap f xs =

let rec MMap' (f, xs', out) =

state { match xs' with

| h :: t ->

let! h' = f(h)

return! MMap'(f, t, List.append out [h'])

| [] -> return out }

MMap' (f, xs, [])

// ************************************************************

// Alpha converter (Converts T4, T5, T6 to 'a, 'b, 'c)

// ************************************************************

let getName k =

let containsKey k = state { let! (map, id) = getState

return Map.containsKey k map }

let addName k = state { let! (map, id) = getState

let newid = char (int id + 1)

do! setState(Map.add k id map, newid)

return () }

state { let! success = containsKey k

if (not success) then

do! addName k

let! (map, id) = getState

return Map.find k map }

// renameTVarsToLetters: Type -> Type

let renameTVarsToLetters t =

let rec run x =

state {

match x with

| TyVar(name) ->

let! newName = getName name

return TyVar(sprintf "'%c" newName)

| TyLam(arg, res) ->

let! t1 = run arg

let! t2 = run res

return TyLam(t1, t2)

| TyCon(name, typeArgs) ->

let! list = mmap (fun x -> run x) typeArgs

return TyCon(name, list) }

execute (run t) (Map.empty, 'a')

// ****************************************************************

// Calculate principal Type

// ****************************************************************

let newTyVar =

state { let! x = getState

do! setState(x + 1)

return TyVar(sprintf "T%d" x) }

let integerCon = TyCon("int", [])

let floatCon = TyCon("float", [])

let charCon = TyCon("char", [])

let stringCon = TyCon("string", [])

let litToTy lit =

match lit with

| Integer _ -> integerCon

| Float _ -> floatCon

| Char _ -> charCon

| String _ -> stringCon

// Calculate the principal type scheme for an expression in a given

// typing environment

// tp: Env -> Exp -> Type -> Subst -> State<int, Subst>

let rec tp env exp bt s =

let findSc n (Env e) = Map.find n e

let containsSc n (Env e) = Map.containsKey n e

let addSc n sc (Env e) = Env (Map.add n sc e)

state {

match exp with

| Lit v ->

return mgu (litToTy v) bt s

| Var n ->

if not (containsSc n env)

then failwith "Name %s no found" n

let (TyScheme (t, _)) = findSc n env

return mgu (subs t s) bt s

| Lam (x, e) ->

let! a = newTyVar

let! b = newTyVar

let s1 = mgu bt (TyLam (a, b)) s

let newEnv = addSc x (TyScheme (a, Set.empty)) env

return! tp newEnv e b s1

| App(e1, e2) ->

let! a = newTyVar

let! s1 = tp env e1 (TyLam(a, bt)) s

return! tp env e2 a s1

| InfixApp(e1, op, e2) ->

let exp1 = App(App(Var op, e1), e2)

return! tp env exp1 bt s

| Let(name, inV, body) ->

let! a = newTyVar

let! s1 = tp env inV a s

let t = subs a s1

let newScheme = TyScheme (t, ((getTVarsOfType t) - (getTVarsOfEnv env)))

return! tp (addSc name newScheme env) body bt s1 }

let predefinedEnv =

Env(["+", TyScheme (TyLam(integerCon, TyLam(integerCon, integerCon)), Set.empty)

"*", TyScheme (TyLam(integerCon, TyLam(integerCon, integerCon)), Set.empty)

"-", TyScheme (TyLam(integerCon, TyLam(integerCon, integerCon)), Set.empty)

] |> Map.ofList)

// typeOf: Exp -> Type

let typeOf exp =

let typeOf' exp =

state { let! (a:Type) = newTyVar

let emptySubst = Subst (Map.empty)

let! s1 = tp predefinedEnv exp a emptySubst

return subs a s1 }

in execute (typeOf' exp) 0 |> renameTVarsToLetters

// ***********************************************************

// Example

// ***********************************************************

let composeAst = Let("compose",

Lam("f",

Lam("g",

Lam ("x",

App(Var "g", App(Var "f", Var "x"))))),

Var "compose")

let t = typeOf composeAst

printfn "%s" (t.ToString())

Subsequences of a seq<'a>

2010-06-20T19:36:00.000+01:00

let cons x xs = seq { yield x

yield! xs }

let (|Empty|Cons|) xs : Choice<Unit, 'a * seq<'a>> =

if (Seq.isEmpty xs) then

Empty

else

Cons(Seq.head xs, Seq.skip 1 xs)

let rec subseq xs =

match xs with

| Empty -> seq[seq[]]

| Cons(x,xs) -> let subseq = subseq xs

Seq.append (Seq.map (cons x) subseq) subseq

open System

open FsCheck

type MyGenerators =

static member Seq() =

let fsList = Arb.Default.FsList()

{new Arbitrary<seq<'a>>() with

override x.Generator =

Gen.resize 10 (Gen.map (List.toSeq) (fsList.Generator))

override x.Shrinker t =

Seq.map (List.toSeq) (fsList.Shrinker(Seq.toList t)) }

ignore (Arb.register<MyGenerators>())

Check.Quick (fun xs -> (Seq.length (subseq xs) =

int (Math.Pow(2.0, (float (Seq.length xs))))))

Factorial using only Algebraic Data Types and Pattern Matching

2010-06-19T20:07:00.001+01:00

type Nat = Zero | Succ of Nat

let one = Succ Zero

let two = Succ (Succ Zero)

let three = Succ (Succ (Succ Zero))

let rec add x y = match x with

| Zero -> y

| Succ x -> Succ (add x y)

let rec mul x y = match y with

| Zero -> Zero

| Succ Zero -> x

| Succ y -> add x (mul x y)

let rec fac n = match n with

| Zero -> Succ Zero

| Succ x -> mul n (fac x)

open FsCheck

// Addition properties

Check.Quick (fun x y -> (add x y) = (add y x))

Check.Quick (fun x y z -> (add x (add y z)) = (add (add x y) z))

Check.Quick (fun x -> (add x Zero) = x)

// Multiplication properties

Check.Quick (fun x y -> (mul x y) = (mul y x))

Check.Quick (fun x y z -> (mul x (mul y z)) = (mul (mul x y) z))

Check.Quick (fun x -> (mul x one) = x)

Composing Contracts Part 4: Sample Usage

2010-05-08T19:56:00.005+01:00

Composing contracts: an adventure in financial engineering
http://research.microsoft.com/en-us/um/people/simonpj/papers/financial-contracts/contracts-icfp.htm

open System

open ContractDataTypes

open Contracts

let t1 = Date(DateTime.Today.AddSeconds(10.0))

// zero-coupon bond

let c1 = zcb t1 10.0 USD

let ret = eval c1

ret.Subscribe(printf "%A")

Console.ReadLine ()

Composing Contracts Part 3: Sample Implementation

2010-05-08T19:07:00.001+01:00

module Contracts

open System

open System.Linq

open ContractDataTypes

let date s = Date (DateTime.Parse s)

let one c = One c

let scale k c = Scale(k, c)

let konst x = rx { return x }

let (==*) l r = rx { let! x = l

let! y = r

return x = y }

let obsTime = rx { let! x = Observable.Interval(TimeSpan.FromSeconds(1.0))

return Date(DateTime.Today.AddSeconds (float x)) }

let at t = obsTime ==* (konst t)

let cWhen t c = When (t, c)

// zero-coupon bond

let zcb t x k = cWhen (at t) (scale (konst x) (one k))

let rec eval c = match c with

| When (t, c) -> rx { let! x = t

if x then

return! (eval c) }

| Scale (k, c) -> rx { let! x = k

let! y = eval c

return x * y }

| One c -> match c with

| GBP -> rx { return Money (1.0, GBP) }

| USD -> rx { return Money (0.675310643, GBP) }

Composing Contracts Part 2: Signatures

2010-05-08T19:00:00.005+01:00

module Contracts

open System

open ContractDataTypes

val date: String -> Date

val one : Currency -> Contract

val scale : IObservable<double> -> Contract -> Contract

val konst : 'a -> IObservable<'a>

val (==*) : IObservable<'a> -> IObservable<'a> -> IObservable<bool> when 'a : equality

val obsTime : IObservable<Date>

val at: Date -> IObservable<bool>

val cWhen: IObservable<bool> -> Contract -> Contract

// zero-coupon bond

val zcb : Date -> Double -> Currency -> Contract

val eval: Contract -> IObservable<Money>

Composing Contracts Part 1: Data Types

2010-05-08T18:57:00.002+01:00

module ContractDataTypes

open System

open System.Linq

type Date = Date of DateTime

type Days = Days of TimeSpan

type Currency = GBP | USD

type Money = Money of float * Currency

with static member (*) (k, Money (v, c)) = Money (k * v, c)

type Contract = | One of Currency

| Scale of (IObservable<double> * Contract)

| When of (IObservable<bool> * Contract)

type RxBuilder() =

member this.Bind(m:IObservable<'a>, f:'a -> IObservable<'b>) =

Observable.SelectMany(m, new Func<'a, IObservable<'b>> (f))

member this.Return x = Observable.Return x

member this.ReturnFrom x = x

member this.Zero() = Observable.Empty()

let rx = RxBuilder()

Monad State Transformer

2010-05-04T01:46:00.008+01:00

This is an attempt to write a State Monad Transformer.
I haven't been able to make it generic and according to
Brian McNamara "this will never be possible in any .NET language"

http://cs.hubfs.net/forums/thread/13974.aspx

type StateT<'a, 'b, 'state> = StateT of ('state -> Parser<'a * 'state, 'b>)

type StateTBuilder (p:ParserMonad) =

// a -> m a

member this.Return a = StateT (fun s -> p.Return(a, s))

// m a -> (a -> m b) -> m b

member this.Bind (m, f) = StateT (fun s -> p { let! (v, s') = let (StateT f) = m in f s

let (StateT f') = f v

return! f' s' })

let statefulParser = StateTBuilder(parser)

let getState = StateT (fun s -> parser.Return(s, s))

let setState s = StateT (fun _ -> parser.Return((), s))

let lift c = StateT (fun s -> parser.Bind (c, (fun x -> parser.Return (x, s))))

let Execute m s = let (StateT f) = m in

parser { let! (x,_) = f s

return x }

SplitAt (Alternate definition)

2010-04-25T03:01:00.001+01:00

let rec splitAt n xs = match (n, xs) with

| 0, xs -> ([], xs)

| _, [] -> ([], [])

| n, x::xs -> let (xs', xs'') = splitAt (n - 1) xs in

(x::xs', xs'')

C# SplitEvery

2010-04-23T01:05:00.001+01:00

private static IEnumerable<IEnumerable<T>> SplitEvery<T>(this IEnumerable<T> xs, int n)

{

return xs.Unfold(ys => ys.Take(n), ys => ys.Any(), ys => ys.Skip(n));

}

private static IEnumerable<T> Unfold<T>(this T x, Func<T, T> h, Func<T, bool> p, Func<T, T> t)

{

for (var i = x; p(i); i = t(i))

yield return h(i);

}

SplitEvery (New version, no explicit recursion)

2010-04-23T00:51:00.001+01:00

open System.Linq

let repeat x = Seq.initInfinite (fun _ -> x)

let scan = Seq.scan

let iterate f x = scan (fun l _ -> f l) x (repeat x)

let any = Enumerable.Any

let take n = fun xs -> Enumerable.Take (xs, n)

let skip n = fun xs -> Enumerable.Skip (xs, n)

let unfold h p t = iterate t >> Seq.takeWhile p >> Seq.map h

let splitAt n = unfold (take n) any (skip n)

C# Permutations (using Rx System.Interactive)

2010-04-13T20:39:00.006+01:00

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

{

if (!xs.Any())

return EnumerableEx.Return(Enumerable.Empty<T>());

else

return from zs in Permutations(xs.Skip(1))

from i in Enumerable.Range(0, zs.Count() + 1)

select zs.Take(i).Concat(EnumerableEx.Return(xs.First())).Concat(zs.Skip(i));

}

Permutations

2010-04-11T20:49:00.001+01:00

let length = Seq.length

let take = Seq.take

let skip = Seq.skip

let (++) = Seq.append

let concat = Seq.concat

let map = Seq.map

let (|Empty|Cons|) (xs:seq<'a>) : Choice<Unit, 'a * seq<'a>> =

if (Seq.isEmpty xs) then Empty else Cons(Seq.head xs, Seq.skip 1 xs)

let interleave x ys =

seq { for i in [0..length ys] ->

(take i ys) ++ seq [x] ++ (skip i ys) }

let rec permutations xs =

match xs with

| Empty -> seq [seq []]

| Cons(x,xs) -> concat(map (interleave x) (permutations xs))

Generic Monadic Map and Join using statically resolved type variables

2010-03-30T01:09:00.003+01:00

let inline mapM b f m =

let unit x = (^x: (member Return: ^b -> ^n) b, x)

let (>>=) m f = (^x: (member Bind: ^m -> (^a -> ^n) -> ^n) b, m, f)

m >>= (fun x -> unit (f x))

let inline joinM b m =

let (>>=) m f = (^x: (member Bind: ^m -> (^n -> ^n) -> ^n) b, m, f)

m >>= id

SplitEvery (chunk)

2010-03-12T17:43:00.003Z

open System

open System.Collections.Generic

open System.Linq

//splitEvery :: Int -> [a] -> [[a]]

let splitAt n (xs:IEnumerable<'a>) = (xs.Take n, xs.Skip n)

let rec splitEvery n xs =

let (ks, vs) = splitAt n xs in

seq { yield ks

yield! splitEvery n vs }