← Back to branch summary

~ubuntu-branches/ubuntu/hardy/ocaml-doc/hardy

« back to all changes in this revision

Viewing changes to examples/hanoi/grahanoi-eng.ml

  • Committer: Bazaar Package Importer
  • Author(s): Samuel Mimram
  • Date: 2007-09-08 01:49:22 UTC
  • mfrom: (0.1.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070908014922-lvihyehz0ndq7suu
Tags: 3.10-1
* New upstream release.
* Removed camlp4 documentation since it is not up-to-date.
* Updated to standards version 3.7.2, no changes needed.
* Updated my email address.

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/hanoi/grahanoi-eng.ml
1
 
(***********************************************************************)
2
 
(*                                                                     *)
3
 
(*                           Objective Caml                            *)
4
 
(*                                                                     *)
5
 
(*               Pierre Weis, projet Cristal, INRIA Rocquencourt       *)
6
 
(*                                                                     *)
7
 
(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
8
 
(*  en Automatique.  All rights reserved.  This file is distributed    *)
9
 
(*  only by permission.                                                *)
10
 
(*                                                                     *)
11
 
(***********************************************************************)
12
 
open Graphics;;
13
 
 
14
 
open_graph "";;
15
 
 
16
 
remember_mode false;;
17
 
auto_synchronize true;;
18
 
 
19
 
type discus = {
20
 
  mutable x : int;
21
 
  mutable y : int;
22
 
  w : int;
23
 
  h : int;
24
 
  bg : image;
25
 
  fg : image;
26
 
};;
27
 
 
28
 
type pin = {
29
 
  mutable summit : int;
30
 
  discus : discus option array;
31
 
  xt : int;
32
 
};;
33
 
 
34
 
let wood_color = black;;
35
 
let text_color = black;;
36
 
 
37
 
let pin_width = (size_x () / 5);;
38
 
 
39
 
let wood_width = 1 + 2 * 5;;
40
 
 
41
 
let half_pin_width = (pin_width - wood_width) / 2;;
42
 
 
43
 
let text_size_x s = let x, _ = text_size s in x;;
44
 
let text_size_y s = let _, y = text_size s in y;;
45
 
 
46
 
let pin_height, wood_height, baseline, vtab =
47
 
    let y = text_size_y "Graphics" in
48
 
    let vtab i = i * y in
49
 
    let pin_height = size_y () - 8 * y in
50
 
    pin_height, pin_height, vtab 5, vtab;;
51
 
 
52
 
let center i =
53
 
    let eps = size_x () / 10 in
54
 
    let h = half_pin_width in
55
 
    eps +  h + (i - 1) * (eps + 2 * h);;
56
 
 
57
 
let empty_pin i nb_discus =
58
 
    {summit = -1;
59
 
     discus = Array.make nb_discus None;
60
 
     xt = center i;
61
 
    };;
62
 
 
63
 
let make_color i =
64
 
    let colors = [| black; red; green; blue; yellow; cyan; magenta |] in
65
 
    colors.(i mod 7);;
66
 
 
67
 
let draw_wood x y =
68
 
    let x = x - ((wood_width - 1) / 2) in
69
 
    set_color wood_color;
70
 
    fill_rect x y wood_width pin_height;;
71
 
 
72
 
let make_discus pin nb_discus i =
73
 
    let inc = half_pin_width / nb_discus in
74
 
    let h =
75
 
     let h1 = pin_height / (nb_discus + 1) in
76
 
     min h1 (3 * wood_width) in
77
 
    let r0 = h / 2 in
78
 
    let wr =
79
 
      let inc = half_pin_width / nb_discus in
80
 
      let hwr = (nb_discus - i) * inc in
81
 
      2 * hwr in
82
 
    let w = wr + 2 * r0 in
83
 
    let cur_bg = get_image 0 0 w (wood_height) in
84
 
    draw_wood (w / 2) 0;
85
 
    let bg = get_image 0 0 w h in
86
 
    let c = make_color i in
87
 
    set_color c;
88
 
    let x0 = r0 in
89
 
    fill_rect x0 0 wr h;
90
 
    fill_circle x0 r0 r0;
91
 
    fill_circle (x0 + wr) r0 r0;
92
 
    let fg = get_image 0 0 w h in
93
 
    let x = pin.xt - w / 2 in
94
 
    let y = baseline + i * h in
95
 
    let discus = { x = x; y = y; w = w; h = h; bg = bg; fg = fg} in
96
 
    draw_image cur_bg 0 0;
97
 
    discus;;
98
 
 
99
 
let full_pin i nb_discus =
100
 
    let t = empty_pin i nb_discus in
101
 
    for i = 0 to nb_discus - 1 do
102
 
     t.discus.(i) <- Some (make_discus t nb_discus i)
103
 
    done;
104
 
    t.summit <- nb_discus - 1;
105
 
    t;;
106
 
 
107
 
let pop_discus pin =
108
 
    let s = pin.summit in
109
 
    let discus =
110
 
     match pin.discus.(s) with
111
 
     | None -> assert false
112
 
     | Some d -> d in
113
 
    draw_image discus.bg discus.x discus.y;
114
 
    pin.discus.(s) <- None;
115
 
    pin.summit <- s - 1;
116
 
    discus;;
117
 
 
118
 
let push_discus pin discus =
119
 
    pin.summit <- pin.summit + 1;
120
 
    let s = pin.summit in
121
 
    let x = pin.xt - (discus.w / 2) in
122
 
    let y =
123
 
      if s = 0 then baseline else
124
 
      match pin.discus.(s - 1) with
125
 
      | None -> assert false
126
 
      | Some d -> d.y + discus.h in
127
 
    discus.x <- x;
128
 
    discus.y <- y;
129
 
    draw_image discus.fg discus.x discus.y;
130
 
    pin.discus.(pin.summit) <- Some discus;;
131
 
 
132
 
let move (start_name, start) (destination_name, destination) =
133
 
    let discus = pop_discus start in
134
 
    push_discus destination discus;;
135
 
 
136
 
let draw_pin t =
137
 
    draw_wood t.xt baseline;
138
 
    let discus = t.discus in
139
 
    for i = t.summit downto 0 do
140
 
      match discus.(i) with
141
 
      | None -> ()
142
 
      | Some d -> draw_image d.fg d.x d.y;
143
 
    done;;
144
 
 
145
 
let center_text s x y =
146
 
    let trans = text_size_x s / 2 in
147
 
    moveto (x - trans) y;
148
 
    draw_string s;;
149
 
 
150
 
let print_game title
151
 
    (name_left, left) (name_midle, midle) (name_right, right) =
152
 
    let baseline = vtab 1 in
153
 
    set_color text_color;
154
 
    center_text name_left left.xt baseline;
155
 
    center_text name_midle midle.xt baseline;
156
 
    center_text name_right right.xt baseline;
157
 
    center_text title midle.xt (vtab 3);
158
 
    draw_pin left;
159
 
    draw_pin midle;
160
 
    draw_pin right;;
161
 
 
162
 
let wait () =
163
 
    print_string "Press return to continue"; print_newline ();
164
 
    ignore (read_line ());;
165
 
 
166
 
let rec hanoi height start temp destination =
167
 
    if height > 0 then
168
 
     begin
169
 
       hanoi (height - 1) start destination temp;
170
 
       wait ();
171
 
       Printf.printf "Movement from %s to %s\n" (fst start) (fst destination);
172
 
       move start destination;
173
 
       hanoi (height - 1) temp start destination
174
 
     end;;
175
 
 
176
 
let game nb_discus =
177
 
    clear_graph ();
178
 
    let left = ("A", full_pin 1 nb_discus)
179
 
    and midle = ("B", empty_pin 2 nb_discus)
180
 
    and right = ("C", empty_pin 3 nb_discus) in
181
 
    print_game "Lucas productions present" left midle right;
182
 
    hanoi nb_discus left midle right;;
183
 
 
184
 
if !Sys.interactive then () else begin
185
 
   let l = Array.length Sys.argv in
186
 
   if l <= 1 then begin
187
 
     prerr_endline "Usage: hanoi <number of discusses>";
188
 
     exit 2 end;
189
 
   game (int_of_string (Sys.argv.(1)));
190
 
   wait ();
191
 
   exit 0
192
 
end;;