← Back to branch summary

~ubuntu-branches/debian/sid/ocaml/sid

« back to all changes in this revision

Viewing changes to testsuite/interactive/lib-graph-3/sorts.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu
  • Date: 2011-04-21 21:35:08 UTC
  • mfrom: (1.1.11 upstream) (12.1.14 sid)
  • Revision ID: james.westby@ubuntu.com-20110421213508-kg34453aqmb0moha
* Fixes related to -output-obj with g++ (in debian/patches):
  - add Declare-primitive-name-table-as-const-char
  - add Avoid-multiple-declarations-in-generated-.c-files-in
  - fix Embed-bytecode-in-C-object-when-using-custom: the closing
    brace for extern "C" { ... } was missing in some cases

Show diffs side-by-side

added added

removed removed

Lines of Context:
testsuite/interactive/lib-graph-3/sorts.ml
 
1
(* Animation of sorting algorithms. *)
 
2
 
 
3
open Graphics
 
4
 
 
5
(* Information on a given sorting process *)
 
6
 
 
7
type graphic_context =
 
8
  { array: int array;                   (* Data to sort *)
 
9
    x0: int;                            (* X coordinate, lower left corner *)
 
10
    y0: int;                            (* Y coordinate, lower left corner *)
 
11
    width: int;                         (* Width in pixels *)
 
12
    height: int;                        (* Height in pixels *)
 
13
    nelts: int;                         (* Number of elements in the array *)
 
14
    maxval: int;                        (* Max val in the array + 1 *)
 
15
    rad: int                            (* Dimension of the rectangles *)
 
16
  }
 
17
 
 
18
(* Array assignment and exchange with screen update *)
 
19
 
 
20
let screen_mutex = Mutex.create()
 
21
 
 
22
let draw gc i v =
 
23
  fill_rect (gc.x0 + (gc.width * i) / gc.nelts)
 
24
            (gc.y0 + (gc.height * v) / gc.maxval)
 
25
            gc.rad gc.rad
 
26
 
 
27
let assign gc i v =
 
28
  Mutex.lock screen_mutex;
 
29
  set_color background; draw gc i gc.array.(i);
 
30
  set_color foreground; draw gc i v;
 
31
  gc.array.(i) <- v;
 
32
  Mutex.unlock screen_mutex
 
33
 
 
34
let exchange gc i j =
 
35
  let val_i = gc.array.(i) in
 
36
  assign gc i gc.array.(j);
 
37
  assign gc j val_i
 
38
 
 
39
(* Construction of a graphic context *)
 
40
 
 
41
let initialize name array maxval x y w h =
 
42
  let (_, label_height) = text_size name in
 
43
  let rad = (w - 2) / (Array.length array) - 1 in
 
44
  let gc =
 
45
    { array = Array.copy array;
 
46
      x0 = x + 1;                       (* Leave one pixel left for Y axis *)
 
47
      y0 = y + 1;                       (* Leave one pixel below for X axis *)
 
48
      width = w - 2;                    (* 1 pixel left, 1 pixel right *)
 
49
      height = h - 1 - label_height - rad;
 
50
      nelts = Array.length array;
 
51
      maxval = maxval;
 
52
      rad = rad } in
 
53
  moveto (gc.x0 - 1) (gc.y0 + gc.height);
 
54
  lineto (gc.x0 - 1) (gc.y0 - 1);
 
55
  lineto (gc.x0 + gc.width) (gc.y0 - 1);
 
56
  moveto (gc.x0 - 1) (gc.y0 + gc.height);
 
57
  draw_string name;
 
58
  for i = 0 to Array.length array - 1 do
 
59
    draw gc i array.(i)
 
60
  done;
 
61
  gc
 
62
 
 
63
(* Main animation function *)
 
64
 
 
65
let display functs nelts maxval =
 
66
  let a = Array.create nelts 0 in
 
67
  for i = 0 to nelts - 1 do
 
68
    a.(i) <- Random.int maxval
 
69
  done;
 
70
  let num_finished = ref 0 in
 
71
  let lock_finished = Mutex.create() in
 
72
  let cond_finished = Condition.create() in
 
73
  for i = 0 to Array.length functs - 1 do
 
74
    let (name, funct, x, y, w, h) = functs.(i) in
 
75
    let gc = initialize name a maxval x y w h in
 
76
    Thread.create
 
77
      (fun () ->
 
78
        funct gc;
 
79
        Mutex.lock lock_finished;
 
80
        incr num_finished;
 
81
        Mutex.unlock lock_finished;
 
82
        Condition.signal cond_finished)
 
83
      ()
 
84
  done;
 
85
  Mutex.lock lock_finished;
 
86
  while !num_finished < Array.length functs do
 
87
    Condition.wait cond_finished lock_finished
 
88
  done;
 
89
  Mutex.unlock lock_finished;
 
90
  read_key()
 
91
 
 
92
(*****
 
93
  let delay = ref 0 in
 
94
  try
 
95
    while true do
 
96
      let gc = Queue.take q in
 
97
        begin match gc.action with
 
98
          Finished -> ()
 
99
        | Pause f ->
 
100
            gc.action <- f ();
 
101
            for i = 0 to !delay do () done;
 
102
            Queue.add gc q
 
103
        end;
 
104
      if key_pressed() then begin
 
105
        match read_key() with
 
106
          'q'|'Q' ->
 
107
            raise Exit
 
108
        | '0'..'9' as c ->
 
109
            delay := (Char.code c - 48) * 500
 
110
        | _ ->
 
111
            ()
 
112
      end
 
113
    done
 
114
  with Exit -> ()
 
115
     | Queue.Empty -> read_key(); ()
 
116
*****)
 
117
 
 
118
(* The sorting functions. *)
 
119
 
 
120
(* Bubble sort *)
 
121
 
 
122
let bubble_sort gc =
 
123
  let ordered = ref false in
 
124
  while not !ordered do
 
125
    ordered := true;
 
126
    for i = 0 to Array.length gc.array - 2 do
 
127
      if gc.array.(i+1) < gc.array.(i) then begin
 
128
        exchange gc i (i+1);
 
129
        ordered := false
 
130
      end
 
131
    done
 
132
  done
 
133
 
 
134
(* Insertion sort *)
 
135
 
 
136
let insertion_sort gc =
 
137
  for i = 1 to Array.length gc.array - 1 do
 
138
    let val_i = gc.array.(i) in
 
139
    let j = ref (i - 1) in
 
140
    while !j >= 0 && val_i < gc.array.(!j) do
 
141
      assign gc (!j + 1) gc.array.(!j);
 
142
      decr j
 
143
    done;
 
144
    assign gc (!j + 1) val_i
 
145
  done
 
146
 
 
147
(* Selection sort *)
 
148
 
 
149
let selection_sort gc =
 
150
  for i = 0 to Array.length gc.array - 1 do
 
151
    let min = ref i in
 
152
    for j = i+1 to Array.length gc.array - 1 do
 
153
      if gc.array.(j) < gc.array.(!min) then min := j
 
154
    done;
 
155
    exchange gc i !min
 
156
  done
 
157
 
 
158
(* Quick sort *)
 
159
 
 
160
let quick_sort gc =
 
161
  let rec quick lo hi =
 
162
    if lo < hi then begin
 
163
      let i = ref lo in
 
164
      let j = ref hi in
 
165
      let pivot = gc.array.(hi) in
 
166
      while !i < !j do
 
167
        while !i < hi && gc.array.(!i) <= pivot do incr i done;
 
168
        while !j > lo && gc.array.(!j) >= pivot do decr j done;
 
169
        if !i < !j then exchange gc !i !j
 
170
      done;
 
171
      exchange gc !i hi;
 
172
      quick lo (!i-1);
 
173
      quick (!i+1) hi
 
174
    end
 
175
  in quick 0 (Array.length gc.array - 1)
 
176
 
 
177
(* Merge sort *)
 
178
 
 
179
let merge_sort gc =
 
180
  let rec merge i l1 l2 =
 
181
    match (l1, l2) with
 
182
      ([], []) ->
 
183
        ()
 
184
    | ([], v2::r2) ->
 
185
        assign gc i v2; merge (i+1) l1 r2
 
186
    | (v1::r1, []) ->
 
187
        assign gc i v1; merge (i+1) r1 l2
 
188
    | (v1::r1, v2::r2) ->
 
189
        if v1 < v2
 
190
        then begin assign gc i v1; merge (i+1) r1 l2 end
 
191
        else begin assign gc i v2; merge (i+1) l1 r2 end in
 
192
  let rec msort start len =
 
193
    if len < 2 then () else begin
 
194
      let m = len / 2 in
 
195
      msort start m;
 
196
      msort (start+m) (len-m);
 
197
      merge start
 
198
            (Array.to_list (Array.sub gc.array start m))
 
199
            (Array.to_list (Array.sub gc.array (start+m) (len-m)))
 
200
    end in
 
201
  msort 0 (Array.length gc.array)
 
202
 
 
203
(* Main program *)
 
204
 
 
205
let animate() =
 
206
  open_graph "";
 
207
  moveto 0 0; draw_string "Press a key to start...";
 
208
  let seed = ref 0 in
 
209
  while not (key_pressed()) do incr seed done;
 
210
  read_key();
 
211
  Random.init !seed;
 
212
  clear_graph();
 
213
  let prompt = "0: fastest ... 9: slowest, press 'q' to quit" in
 
214
  moveto 0 0; draw_string prompt;
 
215
  let (_, h) = text_size prompt in
 
216
  let sx = size_x() / 2 and sy = (size_y() - h) / 3 in
 
217
  display [| "Bubble", bubble_sort, 0, h, sx, sy;
 
218
             "Insertion", insertion_sort, 0, h+sy, sx, sy;
 
219
             "Selection", selection_sort, 0, h+2*sy, sx, sy;
 
220
             "Quicksort", quick_sort, sx, h, sx, sy;
 
221
             (** "Heapsort", heap_sort, sx, h+sy, sx, sy; **)
 
222
             "Mergesort", merge_sort, sx, h+2*sy, sx, sy |]
 
223
          100 1000;
 
224
  close_graph()
 
225
 
 
226
let _ = if !Sys.interactive then () else begin animate(); exit 0 end
 
227
 
 
228
;;