Composite pattern

Category:
Design patterns
Description: For more information about composite pattern, please go to http://en.wikipedia.org/wiki/Composite_pattern
Code:
type CompositeNode<'T> = 
| Node of 'T
| Tree of 'T * CompositeNode<'T> * CompositeNode<'T>
with
member this.InOrder f =
match this with
| Tree(n, left, right) ->
left.InOrder(f)
f(n)
right.InOrder(f)
| Node(n) -> f(n)
member this.PreOrder f =
match this with
| Tree(n, left, right) ->
f(n)
left.PreOrder(f)
right.PreOrder(f)
| Node(n) -> f(n)
member this.PostOrder f =
match this with
| Tree(n, left, right) ->
left.PostOrder(f)
right.PostOrder(f)
f(n)
| Node(n) -> f(n)

let OtherCompositePatternSample() =
let tree = Tree(1, Tree(11, Node(12), Node(13)), Node(2))
let nodeAccessFunc = printf "%A,"

printf "in order process: "
tree.InOrder nodeAccessFunc
printfn ""

printf "pre order process: "
tree.PreOrder nodeAccessFunc
printfn ""

printf "post order process: "
tree.PostOrder nodeAccessFunc
printfn ""

Execution Result:
in order process: 12,11,13,1,2,
pre order process: 1,11,12,13,2,
post order process: 12,13,11,2,1,

Composite pattern with variable

Category:
Design patterns
Description: This implementation uses a global variable resultRef to hold the result. For more information, please go to http://en.wikipedia.org/wiki/Composite_pattern
Code:
type CompositeNode<'T> = 
| Node of 'T
| Tree of 'T * CompositeNode<'T> * CompositeNode<'T>
with
member this.InOrder f =
match this with
| Tree(n, left, right) ->
left.InOrder(f)
f(n)
right.InOrder(f)
| Node(n) -> f(n)
member this.PreOrder f =
match this with
| Tree(n, left, right) ->
f(n)
left.PreOrder(f)
right.PreOrder(f)
| Node(n) -> f(n)
member this.PostOrder f =
match this with
| Tree(n, left, right) ->
left.PostOrder(f)
right.PostOrder(f)
f(n)
| Node(n) -> f(n)

let OtherCompositePatternSample2() =
let tree = Tree(1, Tree(11, Node(12), Node(13)), Node(2))
let resultRef = ref 0
let nodeAccessFunc n = resultRef := !resultRef + n
tree.PreOrder nodeAccessFunc
printfn "result = %d" !resultRef

Assert.AreEqual(!resultRef, 39)

Execution Result:
result = 39
both elements are equal

Composite pattern with variable in a class

Category:
Design patterns
Description: After define a variable in the class-like structure, use a property to retrieve the result back when comptation is finished. For more information, please go to http://en.wikipedia.org/wiki/Composite_pattern
Code:
type IA<'T> =
abstract member Do : 'T -> unit
abstract member Result : unit -> 'T

let OtherCompositePatternSample3() =
let tree = Tree(1, Tree(11, Node(12), Node(13)), Node(2))
let wrapper =
let result = ref 0
{ new IA with
member this.Do(n) =
result := !result + n
member this.Result() = !result
}
tree.PreOrder (wrapper.Do)
printfn "result = %d" (wrapper.Result())

Execution Result:
result = 39

Composite pattern with variable in a class-like structure

Category:
Design patterns
Description: Composite pattern with variable in a class-like structure. The computation result will be brought back by the class-like structure. For more information, please go to http://en.wikipedia.org/wiki/Composite_pattern
Code:
type IA2<'T> =
abstract member Do : 'T -> unit

let OtherCompositePatternSample4() =
let tree = Tree(1, Tree(11, Node(12), Node(13)), Node(2))
let wrapper =
let result = ref 0
({ new IA2 with
member this.Do(n) =
result := !result + n
}, result)
tree.PreOrder (fst wrapper).Do
printfn "result = %d" !(snd wrapper)

Execution Result:
result = 39

Composite pattern & continuation

Category:
Design patterns
Description: Composite pattern with continuation implementation to get the sum of all tree nodes. For more information, please go to http://en.wikipedia.org/wiki/Composite_pattern
Code:
type TreeStructure<'a> = 
| Node of 'a * TreeStructure<'a> * TreeStructure<'a>
| Leaf

let OtherCompositePatternSample5() =
let tree = Node(4, Node(2, Node(1, Leaf, Leaf), Node(3, Leaf, Leaf)),
Node(6, Node(5, Leaf, Leaf), Node(7, Leaf, Leaf)))
let FoldTree nodeF leafV t =
let rec Loop t cont =
match t with
| Node(x,left,right) -> Loop left (fun lacc ->
Loop right (fun racc ->
cont (nodeF x lacc racc)))
| Leaf -> cont leafV
Loop t (fun x -> x)

let SumTree = FoldTree (fun x l r -> x + l + r) 0
let InOrder = FoldTree (fun x l r -> l @ [x] @ r) []
let Height = FoldTree (fun _ l r -> 1 + max l r) 0
printfn "sum = %d" (SumTree(tree))
printfn "inorder = %A" (InOrder(tree))
printfn "height = %d" (Height(tree))

Execution Result:
sum = 28
inorder = [1; 2; 3; 4; 5; 6; 7]
height = 3

Command pattern

Category:
Design patterns
Description: Command pattern to demostrate a redo-undo framework. Each command contains both Do and Undo section. For more information, please go to http://en.wikipedia.org/wiki/Command_pattern
Code:
type Command = { Redo: unit->unit
Undo: unit->unit }

let CommandPatternSample() =
let result = ref 7
let add n = { Redo = (fun _ -> result:= !result + n); Undo = (fun _ -> result := !result - n) }
let minus n = { Redo = (fun _ -> result:= !result - n); Undo = (fun _ -> result := !result + n) }
let cmd = (add 3)
printfn "current state = %d" !result
cmd.Redo()
printfn "after redo: %d" !result
cmd.Undo()
printfn "after undo: %d" !result

Execution Result:
current state = 7
after redo: 10
after undo: 7

Command pattern

Category:
Design patterns
Description: Command pattern to demostrate a redo-undo framework. This implementation group the commands under Do/Undo category. For more information, please go to http://en.wikipedia.org/wiki/Command_pattern
Code:
type CommandType = 
| Deposit
| Withdraw
type TCommand =
| Command of CommandType * int

let CommandPatternSample2() =
let result = ref 7
let deposit x = result := !result + x
let withdraw x = result := !result - x
let Do = fun (cmd:TCommand) ->
match cmd with
| Command(CommandType.Deposit, n) -> deposit n
| Command(CommandType.Withdraw,n) -> withdraw n
let Undo = fun (cmd:TCommand) ->
match cmd with
| Command(CommandType.Deposit, n) -> withdraw n
| Command(CommandType.Withdraw,n) -> deposit n
printfn "current balance %d" !result
let depositCmd = Command(Deposit, 3)
Do depositCmd
printfn "after deposit: %d" !result
Undo depositCmd
printfn "after undo: %d" !result

Execution Result:
current balance 7
after deposit: 10
after undo: 7

Singleton pattern

Category:
Design patterns
Description: The key point is the private constructor which makes sure only one instance is created. For more information, please go to http://en.wikipedia.org/wiki/Singleton_pattern
Code:
type A private () =
static let instance = A()
static member Instance = instance
member this.Action() = printfn "action"

let DesignPatter1() =
let a = A.Instance;
a.Action()

Execution Result:
action

Factory pattern

Category:
Design patterns
Description: Factory pattern implementation: it returns different types based on inputs. For more information, please go to http://en.wikipedia.org/wiki/Factory_method_pattern
Code:
let factorySample() = 
let factory = function
| TypeA -> { new IA with
member this.Action() = printfn "type A" }
| TypeB -> { new IA with
member this.Action() = printfn "type B" }
let output = factory Type.TypeA
output.Action()

Execution Result:
type A

State pattern

Category:
Design patterns
Description: State pattern implementation shows how a class's internal state can change its behavior. For more information, please go to http://en.wikipedia.org/wiki/Factory_method_pattern
Code:
type AccountState = 
| Overdrawn
| Silver
| Gold
[] type USD
type Account<[] 'u>() =
let mutable balance = 0.0<_>
member this.State
with get() =
match balance with
| _ when balance <= 0.0<_> -> Overdrawn
| _ when balance > 0.0<_> && balance < 10000.0<_> -> Silver
| _ -> Gold
member this.PayInterest() =
let interest =
match this.State with
| Overdrawn -> 0.
| Silver -> 0.01
| Gold -> 0.02
interest * balance
member this.Deposit(x:float<_>) =
let (a:float<_>) = x
balance <- balance + a
member this.Withdraw(x:float<_>) = balance <- balance - x

let state() =
let account = Account()
account.Deposit(10000.)
printfn "interest = %A" (account.PayInterest())
account.Withdraw(20000.)
printfn "interest = %A" (account.PayInterest())

Execution Result:
interest = 200.0
interest = 0.0

Strategy pattern

Category:
Design patterns
Description: Strategy pattern shows the underlying algorithm can be changed dynamically by setting the function from outside. For more information, please go to http://en.wikipedia.org/wiki/Strategy_pattern
Code:
let quicksort l = 
printfn "quick sort"
let shellsort l =
printfn "shell short"
let bubblesort l =
printfn "bubble sort"
type Strategy() =
let mutable sortFunction = fun _ -> ()
member this.SetStrategy(f) = sortFunction <- f
member this.Execute(n) = sortFunction(n)

let stragegy() =
let s = Strategy()
s.SetStrategy(quicksort)
s.Execute([1..6])

Execution Result:
quick sort

Proxy pattern

Category:
Design patterns
Description: Proxy pattern provides a placeholder to expose different methods. For more information, please go to http://en.wikipedia.org/wiki/Proxy_pattern
Code:
type CoreComputation() = 
member this.Add(x) = x + 1
member this.Sub(x) = x - 1
member this.GetProxy(name) =
match name with
| "Add" -> (this.Add, "add")
| "Sub" -> (this.Sub, "sub")
| _ -> failwith "not supported"

let proxy() =
let core = CoreComputation()
let proxy = core.GetProxy("Add")
printfn "result = %d" ((fst proxy) 1)

Execution Result:
result = 2

Adapter pattern

Category:
Design patterns
Description: Adapter pattern make incompatible types work (walk) together without changing existing code. In the sample the dog and cat are imcompatible types. For more information, please go to http://en.wikipedia.org/wiki/Adapter_pattern
Code:
type Cat() = 
member this.Walk() = printfn "cat walk"
type Dog() =
member this.Walk() = printfn "dog walk"

let adapter() =
let cat = Cat()
let dog = Dog()
let inline walk (x : ^T) = (^T : (member Walk : unit->unit) (x))
walk(cat)
walk(dog)

Execution Result:
cat walk
dog walk

Chain of responsibility pattern

Category:
Design patterns
Description: Chain of responsibility pattern shows how a request can go through different function (responsibility) by using function composition. For more information, please go to http://en.wikipedia.org/wiki/Chain-of-responsibility_pattern
Code:
type Record = {
Name : string;
Age : int;
Weight: float;
Height: float;
}
let ChainOfResponsibility() =
let validAge (record:Record) =
record.Age < 65 && record.Age > 18
let validWeight (record:Record) =
record.Weight < 200.
let validHeight (record:Record) =
record.Height > 120.

let check (f:Record->bool) (record:Record, result:bool) =
if result=false then (record, false)
else (record, f(record))

let chainOfResponsibility = check(validAge) >> check(validWeight) >> check(validHeight)

let john = { Name = "John"; Age = 80; Weight = 180.; Height=180. }
let dan = { Name = "Dan"; Age = 20; Weight = 160.; Height=190. }

printfn "john result = %b" ((chainOfResponsibility (john, true)) |> snd)
printfn "dan result = %b" ((chainOfResponsibility (dan, true)) |> snd)

Execution Result:
john result = false
dan result = true

Chain of responsibility pattern

Category:
Design patterns
Description: Chain of responsibility pattern implementation shows how a request can go through different function (responsibility) by using pipeline. For more information, please go to http://en.wikipedia.org/wiki/Chain-of-responsibility_pattern
Code:
let ChainOfResponsibility2() = 
let chainTemplate processFunction canContinue s =
if canContinue s then processFunction s
else s

let canContinueF _ = true
let processF x = x + 1

let chainFunction = chainTemplate processF canContinueF //combine two functions to get a chainFunction
let s = 1 |> chainFunction |> chainFunction
printfn "%A" s

Execution Result:
3

Decorate pattern

Category:
Design patterns
Description: Decorate pattern implementation shows how we can add new functionality (check zero) dynamically. For more information, please go to http://en.wikipedia.org/wiki/Decorator_pattern
Code:
type Divide() = 
let mutable divide = fun (a,b) -> a / b
member this.Function
with get() = divide
and set(v) = divide <- v
member this.Invoke(a,b) = divide (a,b)

let decorate() =
let d = Divide()
let checkZero (a,b) = if b = 0 then failwith "a/b and b is 0" else (a,b)
try
d.Invoke(1, 0) |> ignore
with e -> printfn "without check, the error is = %s" e.Message
d.Function <- checkZero >> d.Function
try
d.Invoke(1,0) |> ignore
with e -> printfn "after add check, error is = %s" e.Message

Execution Result:
without check, the error is = Attempted to divide by zero.
after add check, error is = a/b and b is 0

Observer pattern

Category:
Design patterns
Description: This sample show how a change can notify different subscribers. For more information, please go to http://en.wikipedia.org/wiki/Observer_pattern
Code:
type Subject() = 
let mutable notify = fun _ -> ()
member this.Subscribe (notifyFunction) =
let wrap f i = f(i); i
notify <- (wrap notifyFunction) >> notify
member this.Reset() = notify <- fun _ -> ()
member this.SomethingHappen(k) =
notify k

type ObserverA() =
member this.NotifyMe(i) = printfn "notified A %A" i
type ObserverB() =
member this.NotifyMeB(i) = printfn "notified B %A" i
let observer() =
let a = ObserverA()
let b = ObserverB()
let subject = Subject()
subject.Subscribe(a.NotifyMe)
subject.Subscribe(b.NotifyMeB)
subject.SomethingHappen("good")

Execution Result:
notified B "good"
notified A "good"

Last edited Sep 13, 2011 at 12:17 AM by ttliu2000, version 1

Comments

No comments yet.