← Back to branch summary

~ubuntu-branches/ubuntu/karmic/ocaml-doc/karmic

« back to all changes in this revision

Viewing changes to examples/showsort/showsort.ml

  • Committer: Bazaar Package Importer
  • Author(s): Vanicat Rémi
  • Date: 2002-02-05 10:51:43 UTC
  • Revision ID: james.westby@ubuntu.com-20020205105143-a061tunf8tev07ne
Tags: 3.04-4
* New debian maintainer
* Split doc-base file
* Move to non-free
* Change the copyright file to the copyright of the documentation
* remove FAQs (their license prohibit their redistribution)
* corrected the examples

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/showsort/showsort.ml
 
1
(* Animation of sorting algorithms. *)
 
2
 
 
3
open Graphics;;
 
4
 
 
5
(* The status of a sorting process *)
 
6
 
 
7
type status =
 
8
  | Finished
 
9
  | Pause of (unit -> status)
 
10
;;
 
11
 
 
12
(* Information on a given sorting process *)
 
13
 
 
14
type graphic_context =
 
15
  { array : int array;                   (* Data to sort *)
 
16
    x0 : int;                            (* X coordinate, lower left corner *)
 
17
    y0 : int;                            (* Y coordinate, lower left corner *)
 
18
    width : int;                         (* Width in pixels *)
 
19
    height : int;                        (* Height in pixels *)
 
20
    nelts : int;                         (* Number of elements in the array *)
 
21
    maxval : int;                        (* Max value in the array + 1 *)
 
22
    rad : int;                           (* Dimension of the rectangles *)
 
23
    foreground : int;                    (* The color of the pen *)
 
24
    background : int;                    (* The color of the background *)
 
25
    mutable action : status              (* What to do next *)
 
26
  }
 
27
;;
 
28
 
 
29
(* Array assignment and exchange with screen update *)
 
30
 
 
31
let draw gc i v =
 
32
  fill_rect (gc.x0 + (gc.width * i) / gc.nelts)
 
33
            (gc.y0 + (gc.height * v) / gc.maxval)
 
34
            gc.rad gc.rad
 
35
;;
 
36
 
 
37
let assign gc i v =
 
38
  set_color gc.background; draw gc i gc.array.(i);
 
39
  set_color gc.foreground; draw gc i v;
 
40
  gc.array.(i) <- v
 
41
;;
 
42
 
 
43
let exchange gc i j =
 
44
  let val_i = gc.array.(i) in
 
45
  assign gc i gc.array.(j);
 
46
  assign gc j val_i
 
47
;;
 
48
 
 
49
(* Construction of a graphic context *)
 
50
 
 
51
let initialize name funct array maxval x y w h fg bg =
 
52
  let (_, label_height) = text_size name in
 
53
  let rad = (w - 2) / (Array.length array) - 1 in
 
54
  let gc =
 
55
    { array = Array.copy array;
 
56
      x0 = x + 1;                       (* Leave one pixel left for Y axis *)
 
57
      y0 = y + 1;                       (* Leave one pixel below for X axis *)
 
58
      width = w - 2;                    (* 1 pixel left, 1 pixel right *)
 
59
      height = h - 1 - label_height - rad;
 
60
      nelts = Array.length array;
 
61
      maxval = maxval;
 
62
      rad = rad;
 
63
      foreground = fg;
 
64
      background = bg;
 
65
      action = Finished } in
 
66
  moveto (gc.x0 - 1) (gc.y0 + gc.height);
 
67
  set_color gc.background;
 
68
  fill_rect (gc.x0) (gc.y0 + 1) (gc.width - 1) (gc.height - 1);
 
69
  set_color gc.foreground;
 
70
  lineto (gc.x0 - 1) (gc.y0 - 1);
 
71
  lineto (gc.x0 + gc.width) (gc.y0 - 1);
 
72
  moveto (gc.x0 - 1) (gc.y0 + gc.height);
 
73
  draw_string name;
 
74
  for i = 0 to Array.length array - 1 do
 
75
    draw gc i array.(i)
 
76
  done;
 
77
  gc.action <- funct gc;
 
78
  gc
 
79
;;
 
80
 
 
81
(* Main animation function *)
 
82
 
 
83
let skip_key () = let _ = read_key () in ();;
 
84
 
 
85
let report_finished gc =
 
86
  set_color gc.foreground;
 
87
  moveto (gc.x0 + gc.width / 2) (gc.y0 + gc.height / 3);
 
88
  draw_string "Done";;
 
89
 
 
90
let display functs nelts maxval =
 
91
  let a = Array.make nelts 0 in
 
92
  for i = 0 to nelts - 1 do
 
93
    a.(i) <- Random.int maxval
 
94
  done;
 
95
  let q = Queue.create () in
 
96
  for i = 0 to Array.length functs - 1 do
 
97
    let (name, funct, x, y, w, h, fg, bg) = functs.(i) in
 
98
    Queue.add (initialize name funct a maxval x y w h fg bg) q
 
99
  done;
 
100
  let delay_of_char c = (int_of_char c - 48) * 500 in
 
101
  let delay = ref (delay_of_char '\080') in
 
102
  try
 
103
    while true do
 
104
      let gc = Queue.take q in
 
105
        begin match gc.action with
 
106
        | Finished -> report_finished gc
 
107
        | Pause f ->
 
108
            gc.action <- f ();
 
109
            for i = 0 to !delay do () done;
 
110
            Queue.add gc q
 
111
        end;
 
112
      if key_pressed () then begin
 
113
        match read_key () with
 
114
        | 'q' | 'Q' -> raise Exit
 
115
        | '0' .. '9' as c -> delay := delay_of_char c
 
116
        | _ -> ()
 
117
      end
 
118
    done
 
119
  with Exit -> ()
 
120
     | Queue.Empty -> skip_key ()
 
121
;;
 
122
 
 
123
(* The sorting functions.
 
124
   These functions are written in some kind of continuation-passing style
 
125
   so that whenever they are about to perform a comparison, they stop
 
126
   and return a function that does the remainder of the sort. *)
 
127
 
 
128
(* Bubble sort *)
 
129
 
 
130
let bubble_sort gc =
 
131
  let ordered = ref true in
 
132
  let rec sweep i =
 
133
    if i + 1 >= Array.length gc.array then
 
134
      if !ordered then
 
135
        Finished
 
136
      else begin
 
137
        ordered := true;
 
138
        sweep 0
 
139
      end
 
140
    else
 
141
      Pause(fun () ->
 
142
        if gc.array.(i + 1) < gc.array.(i) then begin
 
143
          exchange gc i (i + 1);
 
144
          ordered := false
 
145
        end;
 
146
        sweep(i + 1))
 
147
  in sweep 0
 
148
;;
 
149
 
 
150
(* Insertion sort *)
 
151
 
 
152
let insertion_sort gc =
 
153
  let rec loop1 i =
 
154
    if i >= Array.length gc.array then Finished else
 
155
    let val_i = gc.array.(i) in
 
156
    let rec loop2 j =
 
157
      if j < 1 then begin
 
158
        assign gc j val_i;
 
159
        loop1 (i + 1)
 
160
      end else
 
161
        Pause(fun () ->
 
162
          if val_i >= gc.array.(j - 1) then begin
 
163
            assign gc j val_i;
 
164
            loop1 (i + 1)
 
165
          end else begin
 
166
            assign gc j gc.array.(j - 1);
 
167
            loop2 (j - 1)
 
168
          end)
 
169
    in loop2 i
 
170
  in loop1 1
 
171
;;
 
172
 
 
173
(* Selection sort *)
 
174
 
 
175
let selection_sort gc =
 
176
  let rec loop1 i =
 
177
    if i + 1 >= Array.length gc.array then Finished else
 
178
    let min = ref i in
 
179
    let rec loop2 j =
 
180
      if j >= Array.length gc.array then begin
 
181
        exchange gc i !min;
 
182
        loop1 (i + 1)
 
183
      end else
 
184
        Pause(fun () ->
 
185
          if gc.array.(j) < gc.array.(!min) then min := j;
 
186
          loop2 (j + 1))
 
187
    in loop2 (i + 1)
 
188
  in loop1 0
 
189
;;
 
190
 
 
191
(* Quick sort *)
 
192
 
 
193
let quick_sort gc =
 
194
  let rec quick lo hi cont =
 
195
    if lo >= hi then cont () else begin
 
196
      let p = gc.array.(hi) in
 
197
      let rec loop1 i j =
 
198
        if i >= j then begin
 
199
          exchange gc hi i;
 
200
          quick lo (i - 1) (fun () -> quick (i + 1) hi cont)
 
201
        end else begin
 
202
          let rec loop3 i j =
 
203
            if j <= lo then begin
 
204
              if i < j then exchange gc i j;
 
205
              loop1 i j
 
206
            end else
 
207
              Pause(fun () ->
 
208
                if p <= gc.array.(j) then
 
209
                  loop3 i (j - 1)
 
210
                else begin
 
211
                  if i < j then exchange gc i j;
 
212
                  loop1 i j
 
213
                end) in
 
214
          let rec loop2 i j =
 
215
            if i >= hi then loop3 i j else
 
216
              Pause(fun () ->
 
217
                if gc.array.(i) <= p then
 
218
                  loop2 (i + 1) j
 
219
                else
 
220
                  loop3 i j)
 
221
          in loop2 i j
 
222
        end
 
223
      in loop1 lo hi
 
224
    end
 
225
  in quick 0 (Array.length gc.array - 1) (fun () -> Finished)
 
226
;;
 
227
 
 
228
(* Heap sort *)
 
229
 
 
230
let heap_sort gc =
 
231
 
 
232
  let father n = (n - 1) / 2
 
233
  and left_son n = n + n + 1
 
234
  and right_son n = n + n + 2 in
 
235
 
 
236
  let rec from_bottom i last cont =
 
237
    if i == 0 then cont () else begin
 
238
      let j = father i in
 
239
      let ls = left_son j and rs = right_son j in
 
240
      if rs > last then
 
241
        Pause(fun () ->
 
242
          if gc.array.(j) < gc.array.(ls) then exchange gc j ls;
 
243
          from_bottom j last cont)
 
244
      else
 
245
        Pause(fun () ->
 
246
          if gc.array.(j) < gc.array.(ls) then
 
247
            Pause(fun () ->
 
248
              if gc.array.(rs) <= gc.array.(ls) then
 
249
                exchange gc j ls
 
250
              else
 
251
                exchange gc j rs;
 
252
              from_bottom j last cont)
 
253
          else
 
254
            Pause(fun () ->
 
255
              if gc.array.(j) < gc.array.(rs) then
 
256
                Pause(fun () ->
 
257
                  if gc.array.(rs) <= gc.array.(ls) then
 
258
                    exchange gc j ls
 
259
                  else
 
260
                    exchange gc j rs;
 
261
                  from_bottom j last cont)
 
262
              else
 
263
                from_bottom j last cont))
 
264
    end in
 
265
 
 
266
  let rec from_top i last cont =
 
267
    let ls = left_son i and rs = right_son i in
 
268
    if ls > last then
 
269
      cont ()
 
270
    else if rs > last then
 
271
      Pause(fun () ->
 
272
        if gc.array.(ls) <= gc.array.(i) then
 
273
          cont ()
 
274
        else begin
 
275
          exchange gc i ls;
 
276
          from_top ls last cont
 
277
        end)
 
278
    else
 
279
      Pause(fun () ->
 
280
        if gc.array.(ls) <= gc.array.(i) then
 
281
          Pause(fun () ->
 
282
            if gc.array.(rs) <= gc.array.(i) then
 
283
              cont ()
 
284
            else
 
285
              Pause(fun () ->
 
286
                if gc.array.(rs) <= gc.array.(ls) then begin
 
287
                  exchange gc i ls; from_top ls last cont
 
288
                end else begin
 
289
                  exchange gc i rs; from_top rs last cont
 
290
                end))
 
291
        else
 
292
          Pause(fun () ->
 
293
            if gc.array.(rs) <= gc.array.(ls) then begin
 
294
              exchange gc i ls; from_top ls last cont
 
295
            end else begin
 
296
              exchange gc i rs; from_top rs last cont
 
297
            end)) in
 
298
 
 
299
  let rec loop1 last cont =
 
300
    if last >= Array.length gc.array
 
301
    then cont ()
 
302
    else from_bottom last last (fun () -> loop1 (last + 1) cont) in
 
303
 
 
304
  let rec loop2 last cont =
 
305
    if last < 0 then cont () else begin
 
306
      exchange gc 0 (last + 1);
 
307
      from_top 0 last (fun () -> loop2 (last - 1) cont)
 
308
    end in
 
309
 
 
310
  loop1 1 (fun () -> loop2 (Array.length gc.array - 2) (fun () -> Finished))
 
311
;;
 
312
 
 
313
(* Merge sort *)
 
314
 
 
315
let merge_sort gc =
 
316
  let rec merge i l1 l2 cont =
 
317
    match (l1, l2) with
 
318
    | ([], []) ->
 
319
        cont ()
 
320
    | ([], v2 :: r2) ->
 
321
        assign gc i v2; merge (i + 1) l1 r2 cont
 
322
    | (v1 :: r1, []) ->
 
323
        assign gc i v1; merge (i + 1) r1 l2 cont
 
324
    | (v1 :: r1, v2 :: r2) ->
 
325
        Pause(fun () ->
 
326
          if v1 < v2
 
327
          then begin assign gc i v1; merge (i + 1) r1 l2 cont end
 
328
          else begin assign gc i v2; merge (i + 1) l1 r2 cont end) in
 
329
  let rec msort start len cont =
 
330
    if len < 2 then cont () else begin
 
331
      let m = len / 2 in
 
332
      msort start m (fun () ->
 
333
        msort (start + m) (len - m) (fun () ->
 
334
          merge start
 
335
                (Array.to_list (Array.sub gc.array start m))
 
336
                (Array.to_list (Array.sub gc.array (start + m) (len - m)))
 
337
                cont))
 
338
    end in
 
339
  msort 0 (Array.length gc.array) (fun () -> Finished)
 
340
;;
 
341
 
 
342
(* Main program *)
 
343
 
 
344
let animate () =
 
345
  open_graph "";
 
346
  moveto 0 0; draw_string "Press a key to start...";
 
347
  let seed = ref 0 in
 
348
  while not (key_pressed ()) do incr seed done;
 
349
  skip_key ();
 
350
  Random.init !seed;
 
351
  clear_graph ();
 
352
  let prompt = "0: fastest ... 9: slowest, press 'q' to quit" in
 
353
  moveto 0 0; draw_string prompt;
 
354
  let (_, h) = text_size prompt in
 
355
  let sx = size_x () / 2 and sy = (size_y () - h) / 3 in
 
356
  let grey c = c + (c lsl 8) + (c lsl 16) in
 
357
  display [|
 
358
    "Bubble", bubble_sort, 0, h, sx, sy, cyan, (grey 0x70);
 
359
    "Insertion", insertion_sort, 0, h + sy, sx, sy, blue, (grey 0xA0);
 
360
    "Selection", selection_sort, 0, h + 2 * sy, sx, sy, green, (grey 0x80);
 
361
    "Quicksort", quick_sort, sx, h, sx, sy, magenta, (grey 0xD0);
 
362
    "Heapsort", heap_sort, sx, h + sy, sx, sy, black, (grey 0xE0);
 
363
    "Mergesort", merge_sort, sx, h + 2 * sy, sx, sy, red, (grey 0xF0) |]
 
364
    100 1000;
 
365
  close_graph ()
 
366
;;
 
367
 
 
368
if !Sys.interactive then () else begin animate (); exit 0 end;;