Fork me on GitHub

Code Snippet:

  1 module BottomUpMergeSort =
  2   type 'a Sortable =
  3     { less : 'a * 'a -> bool; size : int; segments : 'a list list Lazy}
  4   
  5   // Don't use as it gives stack-overflow
  6   let merge less xs ys =
  7     let rec mrg = function
  8       | [ ], zs | zs, [ ] -> zs
  9       | x :: xs, y :: ys ->
 10         if less (x,y) then
 11           x :: mrg (xs, y :: ys)
 12         else
 13           y :: mrg (x :: xs, ys)
 14     mrg (xs,ys)
 15   
 16   // Use this instead as it is tail-recursive
 17   let merge' less xs ys =
 18     let rec append = function
 19       | xs, [ ]     -> xs
 20       | xs, y :: ys -> append (y :: xs, ys)
 21     let rec mrg acc = function
 22       | [ ], zs | zs, [ ] -> append (zs,acc)
 23       | x :: xs, y :: ys  ->
 24         if less (x,y) then
 25           mrg (x :: acc) (xs, y :: ys)
 26         else
 27           mrg (y :: acc) (x :: xs, ys)
 28     mrg [ ] (xs,ys)
 29   
 30   let add x { less = less; size = n; segments = segs} =
 31     let rec add' seg segs n =
 32       if n % 2 = 0 then
 33         lazy (seg :: segs)
 34       else
 35         add' (merge' less seg (List.head segs)) (List.tail segs) (n / 2)
 36     { less = less; size = n + 1; segments = add' [x] (segs.Force()) n; }
 37   
 38   let sort { less = less; segments = segs} =
 39     let rec sort' = function
 40       | xs, [ ]         -> xs
 41       | xs, seg :: segs -> sort' (merge' less xs seg, segs)
 42     sort' ([],segs.Force())
 43   
 44   let sort' { less = less; segments = segs} =
 45     let rec foldl = function
 46       | f, c, [ ]     -> c
 47       | f, c, x :: xs -> foldl(f,f c x,xs)
 48     foldl(merge' less,[ ],segs.Force())
 49 
 50 module ScheduledBottomUpMergeSort =
 51   type 'a Stream   = Cons of 'a * 'a Stream Lazy | Nil
 52   type 'a Schedule = 'a Stream list
 53   type 'a Sortable =
 54     { less : 'a * 'a -> bool;
 55       size : int; 
 56       segments : ('a Stream * 'a Schedule) list }
 57   
 58   let merge less xs ys =
 59     let rec mrg = function
 60       | Nil,zs | zs, Nil -> zs
 61       | (Cons(x,xs) as xs'), (Cons(y,ys) as ys') ->
 62         if less (x,y) then
 63           Cons(x, lazy mrg (xs.Force(),ys'))
 64         else
 65           Cons(y, lazy mrg (xs',ys.Force()))
 66     mrg (xs,ys)
 67   
 68   let rec exec1 = function
 69     | [ ] -> [ ]
 70     | Nil :: sched -> exec1 sched
 71     | Cons(x,xs) :: sched -> (xs.Force()) :: sched
 72   
 73   // Don't use as it gives stack-overflow
 74   let rec exec2PerSeg = function
 75     | [ ] -> [ ]
 76     | (xs,sched) :: segs -> (xs, exec1 (exec1 sched)) :: exec2PerSeg segs
 77   
 78   // Use this instead as it is tail-recursive
 79   let rec exec2PerSeg' acc = function
 80     | [ ] -> acc
 81     | (xs,sched) :: segs -> exec2PerSeg' ((xs, exec1 (exec1 sched)) :: acc) segs
 82   
 83   let add x { less = less; size = n; segments = segs} =
 84     let rec add' xs segs n rsched =
 85       if n % 2 = 0 then
 86         (xs,xs :: rsched |> List.rev) :: segs
 87       else
 88         match segs with
 89         | [ ] -> [ ]
 90         | (xs',_) :: segs' ->
 91           add' (merge less xs xs') segs' (n / 2) (xs :: rsched)
 92     let segs' = add' (Cons(x,lazy Nil)) segs n [ ]
 93     { less = less; size = n + 1; segments = exec2PerSeg' [ ] segs'; }
 94   
 95   let sort { less = less; segments = segs } =
 96     let rec sort' = function
 97       | xs, [ ]         -> xs
 98       | xs, (xs',_) :: segs -> sort' (merge less xs xs', segs)
 99     // Don't use as it gives stack-overflow
100     let rec stream2list = function
101       | Nil -> [ ]
102       | Cons(x,xs) -> x :: stream2list (xs.Force())
103     // Use this instead as it is tail-recursive
104     let rec stream2list' acc = function
105       | Nil -> acc |> List.rev
106       | Cons(x,xs) -> stream2list' (x :: acc) (xs.Force())
107     (Nil,segs) |> sort' |> stream2list' [ ]
108 
109 module List =
110   type 'a S  = 'a BottomUpMergeSort.Sortable 
111   type 'a S' = 'a ScheduledBottomUpMergeSort.Sortable
112   
113   let puresort xs =
114     ({ S.less = (fun (x,y) -> x < y); S.size = 0; S.segments = lazy [] },xs)
115     ||> List.fold(fun a x -> a |> BottomUpMergeSort.add x)
116     |> BottomUpMergeSort.sort
117   
118   let puresort' xs =
119     ({ S.less = (fun (x,y) -> x < y); S.size = 0; S.segments = lazy [] },xs)
120     ||> List.fold(fun a x -> a |> BottomUpMergeSort.add x)
121     |> BottomUpMergeSort.sort'
122   
123   let puresort'' xs =
124     ({ S'.less = (fun (x,y) -> x < y); S'.size = 0; S'.segments = [] },xs)
125     ||> List.fold(fun a x -> a |> ScheduledBottomUpMergeSort.add x)
126     |> ScheduledBottomUpMergeSort.sort

Code output:

> 
module BottomUpMergeSort = begin
  type 'a Sortable =
    {less: 'a * 'a -> bool;
     size: int;
     segments: Lazy<'a list list>;}
  val merge : less:('a * 'a -> bool) -> xs:'a list -> ys:'a list -> 'a list
  val merge' : less:('a * 'a -> bool) -> xs:'a list -> ys:'a list -> 'a list
  val add : x:'a -> 'a Sortable -> 'a Sortable
  val sort : 'a Sortable -> 'a list
  val sort' : 'a Sortable -> 'a list
end
module ScheduledBottomUpMergeSort = begin
  type 'a Stream =
    | Cons of 'a * Lazy<'a Stream>
    | Nil
  type 'a Schedule = 'a Stream list
  type 'a Sortable =
    {less: 'a * 'a -> bool;
     size: int;
     segments: ('a Stream * 'a Schedule) list;}
  val merge :
    less:('a * 'a -> bool) -> xs:'a Stream -> ys:'a Stream -> 'a Stream
  val exec1 : _arg1:'a Stream list -> 'a Stream list
  val exec2PerSeg :
    _arg1:('a * 'b Stream list) list -> ('a * 'b Stream list) list
  val exec2PerSeg' :
    acc:('a * 'b Stream list) list ->
      _arg1:('a * 'b Stream list) list -> ('a * 'b Stream list) list
  val add : x:'a -> 'a Sortable -> 'a Sortable
  val sort : 'a Sortable -> 'a list
end
module List = begin
  type 'a S = 'a BottomUpMergeSort.Sortable
  type 'a S' = 'a ScheduledBottomUpMergeSort.Sortable
  val puresort : xs:'a list -> 'a list when 'a : comparison
  val puresort' : xs:'a list -> 'a list when 'a : comparison
  val puresort'' : xs:'a list -> 'a list when 'a : comparison
end

Verification Code Snippet:

 1 [100*1000 .. -1 .. 1] 
 2 |> List.puresort
 3 |> List.fold(fun acc x -> (x >= snd acc) && (fst acc),x) (true,0)
 4 
 5 [100*1000 .. -1 .. 1] 
 6 |> List.puresort'
 7 |> List.fold(fun acc x -> (x >= snd acc) && (fst acc),x) (true,0)
 8 
 9 [100*1000 .. -1 .. 1] 
10 |> List.puresort''
11 |> List.fold(fun acc x -> (x >= snd acc) && (fst acc),x) (true,0)

Verification Code output:

> val it : bool * int = (true, 100000)
> val it : bool * int = (true, 100000)
> val it : bool * int = (true, 100000)

Performance Code Snippet:

 1 #time
 2 
 3 [1000*1000 .. -1 .. 1] 
 4 |> List.puresort
 5 
 6 [1000*1000 .. -1 .. 1] 
 7 |> List.puresort'
 8 
 9 [1000*1000 .. -1 .. 1] 
10 |> List.puresort''

Performance Code output:

--> Timing now on

> Real: 00:00:12.407, CPU: 00:00:12.723, GC gen0: 265, gen1: 13
val it : int list =
  [1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21;
   22; 23; 24; 25; 26; 27; 28; 29; 30; 31; 32; 33; 34; 35; 36; 37; 38; 39; 40;
   41; 42; 43; 44; 45; 46; 47; 48; 49; 50; 51; 52; 53; 54; 55; 56; 57; 58; 59;
   60; 61; 62; 63; 64; 65; 66; 67; 68; 69; 70; 71; 72; 73; 74; 75; 76; 77; 78;
   79; 80; 81; 82; 83; 84; 85; 86; 87; 88; 89; 90; 91; 92; 93; 94; 95; 96; 97;
   98; 99; 100; ...]
> Real: 00:00:12.069, CPU: 00:00:12.335, GC gen0: 269, gen1: 10
val it : int list =
  [1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21;
   22; 23; 24; 25; 26; 27; 28; 29; 30; 31; 32; 33; 34; 35; 36; 37; 38; 39; 40;
   41; 42; 43; 44; 45; 46; 47; 48; 49; 50; 51; 52; 53; 54; 55; 56; 57; 58; 59;
   60; 61; 62; 63; 64; 65; 66; 67; 68; 69; 70; 71; 72; 73; 74; 75; 76; 77; 78;
   79; 80; 81; 82; 83; 84; 85; 86; 87; 88; 89; 90; 91; 92; 93; 94; 95; 96; 97;
   98; 99; 100; ...]
> Real: 00:01:10.638, CPU: 00:01:12.356, GC gen0: 428, gen1: 16
val it : int list =
  [1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21;
   22; 23; 24; 25; 26; 27; 28; 29; 30; 31; 32; 33; 34; 35; 36; 37; 38; 39; 40;
   41; 42; 43; 44; 45; 46; 47; 48; 49; 50; 51; 52; 53; 54; 55; 56; 57; 58; 59;
   60; 61; 62; 63; 64; 65; 66; 67; 68; 69; 70; 71; 72; 73; 74; 75; 76; 77; 78;
   79; 80; 81; 82; 83; 84; 85; 86; 87; 88; 89; 90; 91; 92; 93; 94; 95; 96; 97;
   98; 99; 100; ...]

References:

Code Snippet:

 1 module Random =
 2   open System
 3   let private r = new Random()
 4   let coinToss = fun _ -> r.Next(0,2)
 5 
 6 let printNumbers n =
 7   match n % 2 = 0 with
 8   | true  -> printfn "Even nr. %i" n
 9   | false -> printfn "Odd nr. %i" n
10 
11 let printNumbers' n =
12   // Missed "else" statement is found at runtime					
13   if n % 2 = 0
14   then printfn "Even nr. %i" n
15 
16 List.init 10 (Random.coinToss)
17 |> List.iter printNumbers
18 
19 List.init 10 (Random.coinToss)
20 |> List.iter printNumbers'

Code output:

>
module Random = begin
  val private r : System.Random
  val coinToss : 'a -> int
end
val printNumbers : n:int -> unit
val printNumbers' : n:int -> unit

> Even nr. 0
Odd nr. 1
Even nr. 0
Odd nr. 1
Even nr. 0
Odd nr. 1
Even nr. 0
Even nr. 0
Odd nr. 1
Odd nr. 1
val it : unit = ()

> Even nr. 0
Even nr. 0
Even nr. 0
Even nr. 0
Even nr. 0
val it : unit = ()

Code Snippet:

1 let printNumbers'' n =
2   // Missed "false" match is found at compile-time
3   match n % 2 = 0 with
4   | true  -> printfn "Even nr. %i" n
5 
6 List.init 10 (Random.coinToss)
7 |> List.iter printNumbers''

Code output:

>
/Users/mon/tmp/conditionalexpressionsVSpatternmatch.fsx(22,9): error FS0025: Incomplete pattern matches on this expression. For example, the value 'false' may indicate a case not covered by the pattern(s).

Configuration Emacs (~/.emacs.d/init.el):

All

Configuration Visual Studio:

All

References:

MVC + Agents (MailboxProcessor) + Immutable Model

All

Code Snippet:

  1 open System
  2 open System.Drawing
  3 open System.Windows.Forms
  4 
  5 type Agent<'a> = MailboxProcessor<'a>
  6 
  7 module Utils =
  8   let doEvents () = Application.DoEvents()
  9 
 10 module Model =
 11   type ('a) Model = { state: 'a; events: 'a list }
 12   // Add functions here to load/persist state and events
 13 
 14 module View =
 15   // Main form
 16   let title = @"Time Traveling Debugger"
 17   let width,height = 1024,768
 18   let form = 
 19     new Form(
 20       Visible=true, TopMost=true, ClientSize=Size(width,height),
 21       MaximizeBox=false, FormBorderStyle=FormBorderStyle.FixedDialog,Text=title)
 22   let canvas = new Rectangle(0, 0, width, height)
 23   form.Paint.Add(fun e -> e.Graphics.FillRectangle(Brushes.Black, canvas))
 24 
 25   // Time Traveling Debugger
 26   let debug = new TrackBar()
 27   debug.Location <- Point(0,height - 100)
 28   debug.TickStyle <- TickStyle.Both
 29   debug.AutoSize <- false
 30   debug.Width <- width
 31   debug.Height <- 100
 32   debug.Minimum <- 0
 33   debug.Maximum <- 0
 34   debug.Value <- 0
 35   form.Controls.Add(debug)
 36 
 37   // Time Traveling Debugger info text
 38   let debugText = new Label()
 39   debugText.Location <- Point(0, 50)
 40   debugText.Width <- width
 41   debugText.TextAlign <- ContentAlignment.MiddleCenter
 42   debug.Controls.Add(debugText)
 43 
 44   // Update functions "hardcoded" to above formular and formular controls
 45   let updateTitle point = form.Text <- sprintf "%s: %A" title point
 46   let updateCanvas p1 p2 =
 47     let prev = new Rectangle(fst p1, snd p1, 30, 30)
 48     form.Paint.Add(fun e -> e.Graphics.FillRectangle(Brushes.Black, prev))
 49     let next = new Rectangle(fst p2, snd p2, 30, 30)
 50     form.Paint.Add(fun e -> e.Graphics.FillRectangle(Brushes.LimeGreen, next))
 51     form.Invalidate(next)
 52     form.Invalidate(prev)
 53   let updateDebug n = 
 54     debug.Maximum <- n
 55     debug.Value <- n
 56   let updateDebugText n s p = 
 57     debugText.Text <- sprintf "Nr. events: %i\nDebug step: %i %A" (n+1) (s+1) p
 58 
 59 module Controller =
 60   open Model
 61   open View
 62 
 63   type Action = | Event of Event | Debug of Debug
 64   and Event = int * int
 65   and Debug = int
 66 
 67   // By using Agents, the model stays inmutable
 68   let agent = Agent.Start(fun inbox ->
 69     let rec loop model = async {
 70       let! msg = inbox.Receive()
 71       match msg with
 72       | Event(point) ->
 73         let model' = { model with state = point; events = point::model.events }
 74         let n = (model'.events |> List.length) - 1
 75         updateTitle model'.state
 76         updateCanvas model.state model'.state
 77         updateDebug n
 78         updateDebugText n n point
 79         return! loop model'
 80       | Debug(index) ->
 81         let n = (model.events |> List.length) - 1
 82         let point = model.events |> List.skip (n-index) |> List.head
 83         let model' = { model with state = point }
 84         updateTitle model'.state
 85         updateCanvas model.state model'.state
 86         updateDebugText n index point
 87         return! loop model' }
 88     loop { Model.state = (0,0); events = [] })
 89 
 90   // Hook-up model events
 91   form.MouseClick
 92   |> Event.add (fun e -> agent.Post (Action.Event(e.X,e.Y)))
 93 
 94   // Hook-up Time Traveling Debugger events
 95   debug.Scroll
 96   |> Event.add(fun _ -> agent.Post (Action.Debug(debug.Value)))
 97 
 98 // Program event loop, not to use with F# Interactive (FsiAnyCpu)
 99 open Utils
100 open View
101 
102 let rec main = function | true -> doEvents(); main form.Created | false -> ()
103 
104 main form.Created

Code output:

All

References: