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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Franois Pessaux, projet Cristal, INRIA Rocquencourt *)
(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
(* Jun Furuse, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1999,2000,2001,2002,2001,2002 *)
(* Institut National de Recherche en Informatique et en Automatique. *)
(* Distributed only by permission. *)
(* *)
(***********************************************************************)
open Image;;
open Format;;
let capabilities () =
printf "*******************************************************@.";
printf "Camlimages library capabilities currently available@.";
printf "bmp\t: %s@."
(if Camlimages.lib_bmp then "supported" else "not supported");
printf "ppm\t: %s@."
(if Camlimages.lib_ppm then "supported" else "not supported");
printf "gif\t: %s@."
(if Camlimages.lib_gif then "supported" else "not supported");
printf "jpeg\t: %s@."
(if Camlimages.lib_jpeg then "supported" else "not supported");
printf "tiff\t: %s@."
(if Camlimages.lib_tiff then "supported" else "not supported");
printf "png\t: %s@."
(if Camlimages.lib_png then "supported" else "not supported");
printf "xv thumbnails\t: %s@."
(if Camlimages.lib_xvthumb then "supported" else "not supported");
printf "postscript\t: %s@."
(if Camlimages.lib_ps then "supported" else "not supported");
printf "freetype\t: %s@."
(if Camlimages.lib_freetype then "supported" else "not supported");
printf "*******************************************************@.";
;;
let show_image img x y =
let gr_img = Graphics.make_image (Graphic_image.array_of_image img) in
Graphics.draw_image gr_img x y
;;
module FtDraw = Fttext.Make(Rgb24);;
let draw_string =
if Camlimages.lib_freetype then begin
(* Freetype library initialization *)
let library = Freetype.init () in
let face, face_info = Freetype.new_face library "micap.ttf" 0 in
Freetype.set_char_size face 18.0 18.0 72 72;
fun str x y ->
let str = Fttext.unicode_of_latin str in
let x1,y1,x2,y2 = Fttext.size face str in
let w = truncate (x2 -. x1) + 2
and h = truncate (y2 -. y1) + 2
in
let tmpbitmap = Rgb24.create w h in
for x = 0 to w - 1 do
for y = 0 to h - 1 do
Rgb24.unsafe_set tmpbitmap x y { r = 255; g = 255; b = 255 }
done
done;
FtDraw.draw_text face Fttext.func_darken_only tmpbitmap
(- (truncate x1)) (truncate y2) str;
show_image (Rgb24 tmpbitmap) x (y - h)
end else begin
fun _ _ _ -> ()
end
;;
let go_on () =
prerr_endline "Press return to proceed, s: save a screenshot, q: quit";
let s = input_char stdin in
(* save screen shot *)
if s = 's' then begin
prerr_endline "Saving screenshot";
let gr_img =
Graphic_image.get_image 0 0 (Graphics.size_x ()) (Graphics.size_y ()) in
Image.save "screen.bmp" (Some Bmp) [] (Rgb24 gr_img);
prerr_endline "done"
end;
s <> 'q';;
let images_default = [
"apbm.pbm"; "apgm.pgm"; "appm.ppm";
"pbm.pbm"; "pgm.pgm"; "ppm.ppm";
"jpg.jpg"; "png.png"; "bmp.bmp"; "tif.tif";
"xpm.xpm"; "eps.eps"; "gif.gif"; "mmm.anim.gif"
];;
let images =
let images = ref [] in
Arg.parse [] (fun x -> images := x :: !images) "test images";
if !images <> [] then List.rev !images
else List.map (fun x -> Filename.concat "images" x) images_default
;;
open Gif;;
let main () =
capabilities ();
Graphics.open_graph "";
try
List.iter (fun name ->
prerr_endline name;
try
prerr_endline "Analysing header...";
let format, header = Image.file_format name in
prerr_endline (Printf.sprintf "%s: %s format, %dx%d"
name (extension format)
header.header_width header.header_height);
begin match format with
| Gif ->
prerr_endline ("Loading " ^ name ^ "...");
let sequence = Gif.load name [] in
prerr_endline "Loaded";
let w = sequence.screen_width
and h = sequence.screen_height in
let w' = Graphics.size_x () - w
and h' = Graphics.size_y () - h in
let x = if w' > 0 then Random.int w' else 0
and y = if h' > 0 then Random.int h' else 0 in
draw_string name x y;
List.iter (fun frame ->
let put_x = x + frame.frame_left
and put_y = y + frame.frame_top in
show_image (Index8 frame.frame_bitmap) put_x put_y;
(* if not (go_on ()) then raise Exit *) )
sequence.frames;
begin
try
Gif.save "out.image" [] sequence;
prerr_endline "Saved";
with
| _ -> prerr_endline "Save failed"
end;
if not (go_on ()) then raise Exit
| _ ->
prerr_endline ("Loading " ^ name ^ "...");
let img = Image.load name [] in
prerr_endline "Loaded";
let w, h = Image.size img in
let w' = Graphics.size_x () - w
and h' = Graphics.size_y () - h in
let x = if w' > 0 then Random.int w' else 0
and y = if h' > 0 then Random.int h' else 0 in
show_image img x y;
draw_string name x y;
begin
try
Image.save "out.image" (Some format) [] img;
prerr_endline "Saved";
with
| _ -> prerr_endline "Save failed"
end;
if not (go_on ()) then raise Exit
end;
with
| Failure s -> prerr_endline s) images
with
| Exit -> exit 0
| End_of_file -> exit 0
| Sys.Break -> exit 2
;;
main ();;
|
