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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
module BottomUpMergeSort =
  type 'a Sortable =
    { less : 'a * 'a -> bool; size : int; segments : 'a list list Lazy}
  
  // Don't use as it gives stack-overflow
  let merge less xs ys =
    let rec mrg = function
      | [ ], zs | zs, [ ] -> zs
      | x :: xs, y :: ys ->
        if less (x,y) then
          x :: mrg (xs, y :: ys)
        else
          y :: mrg (x :: xs, ys)
    mrg (xs,ys)
  
  // Use this instead as it is tail-recursive
  let merge' less xs ys =
    let rec append = function
      | xs, [ ]     -> xs
      | xs, y :: ys -> append (y :: xs, ys)
    let rec mrg acc = function
      | [ ], zs | zs, [ ] -> append (zs,acc)
      | x :: xs, y :: ys  ->
        if less (x,y) then
          mrg (x :: acc) (xs, y :: ys)
        else
          mrg (y :: acc) (x :: xs, ys)
    mrg [ ] (xs,ys)
  
  let add x { less = less; size = n; segments = segs} =
    let rec add' seg segs n =
      if n % 2 = 0 then
        lazy (seg :: segs)
      else
        add' (merge' less seg (List.head segs)) (List.tail segs) (n / 2)
    { less = less; size = n + 1; segments = add' [x] (segs.Force()) n; }
  
  let sort { less = less; segments = segs} =
    let rec sort' = function
      | xs, [ ]         -> xs
      | xs, seg :: segs -> sort' (merge' less xs seg, segs)
    sort' ([],segs.Force())
  
  let sort' { less = less; segments = segs} =
    let rec foldl = function
      | f, c, [ ]     -> c
      | f, c, x :: xs -> foldl(f,f c x,xs)
    foldl(merge' less,[ ],segs.Force())

module ScheduledBottomUpMergeSort =
  type 'a Stream   = Cons of 'a * 'a Stream Lazy | Nil
  type 'a Schedule = 'a Stream list
  type 'a Sortable =
    { less : 'a * 'a -> bool;
      size : int; 
      segments : ('a Stream * 'a Schedule) list }
  
  let merge less xs ys =
    let rec mrg = function
      | Nil,zs | zs, Nil -> zs
      | (Cons(x,xs) as xs'), (Cons(y,ys) as ys') ->
        if less (x,y) then
          Cons(x, lazy mrg (xs.Force(),ys'))
        else
          Cons(y, lazy mrg (xs',ys.Force()))
    mrg (xs,ys)
  
  let rec exec1 = function
    | [ ] -> [ ]
    | Nil :: sched -> exec1 sched
    | Cons(x,xs) :: sched -> (xs.Force()) :: sched
  
  // Don't use as it gives stack-overflow
  let rec exec2PerSeg = function
    | [ ] -> [ ]
    | (xs,sched) :: segs -> (xs, exec1 (exec1 sched)) :: exec2PerSeg segs
  
  // Use this instead as it is tail-recursive
  let rec exec2PerSeg' acc = function
    | [ ] -> acc
    | (xs,sched) :: segs -> exec2PerSeg' ((xs, exec1 (exec1 sched)) :: acc) segs
  
  let add x { less = less; size = n; segments = segs} =
    let rec add' xs segs n rsched =
      if n % 2 = 0 then
        (xs,xs :: rsched |> List.rev) :: segs
      else
        match segs with
        | [ ] -> [ ]
        | (xs',_) :: segs' ->
          add' (merge less xs xs') segs' (n / 2) (xs :: rsched)
    let segs' = add' (Cons(x,lazy Nil)) segs n [ ]
    { less = less; size = n + 1; segments = exec2PerSeg' [ ] segs'; }
  
  let sort { less = less; segments = segs } =
    let rec sort' = function
      | xs, [ ]         -> xs
      | xs, (xs',_) :: segs -> sort' (merge less xs xs', segs)
    // Don't use as it gives stack-overflow
    let rec stream2list = function
      | Nil -> [ ]
      | Cons(x,xs) -> x :: stream2list (xs.Force())
    // Use this instead as it is tail-recursive
    let rec stream2list' acc = function
      | Nil -> acc |> List.rev
      | Cons(x,xs) -> stream2list' (x :: acc) (xs.Force())
    (Nil,segs) |> sort' |> stream2list' [ ]

module List =
  type 'a S  = 'a BottomUpMergeSort.Sortable 
  type 'a S' = 'a ScheduledBottomUpMergeSort.Sortable
  
  let puresort xs =
    ({ S.less = (fun (x,y) -> x < y); S.size = 0; S.segments = lazy [] },xs)
    ||> List.fold(fun a x -> a |> BottomUpMergeSort.add x)
    |> BottomUpMergeSort.sort
  
  let puresort' xs =
    ({ S.less = (fun (x,y) -> x < y); S.size = 0; S.segments = lazy [] },xs)
    ||> List.fold(fun a x -> a |> BottomUpMergeSort.add x)
    |> BottomUpMergeSort.sort'
  
  let puresort'' xs =
    ({ S'.less = (fun (x,y) -> x < y); S'.size = 0; S'.segments = [] },xs)
    ||> List.fold(fun a x -> a |> ScheduledBottomUpMergeSort.add x)
    |> ScheduledBottomUpMergeSort.sort

> 
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

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

[100*1000 .. -1 .. 1] 
|> List.puresort'
|> List.fold(fun acc x -> (x >= snd acc) && (fst acc),x) (true,0)

[100*1000 .. -1 .. 1] 
|> List.puresort''
|> List.fold(fun acc x -> (x >= snd acc) && (fst acc),x) (true,0)

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

1
2
3
4
5
6
7
8
9
10
#time

[1000*1000 .. -1 .. 1] 
|> List.puresort

[1000*1000 .. -1 .. 1] 
|> List.puresort'

[1000*1000 .. -1 .. 1] 
|> List.puresort''

--> 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; ...]