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
open Util
open Images
type png_read_result =
| PNG_RGB24 of bytes array
| PNG_RGBA32 of bytes array
| PNG_INDEX8 of bytes array * rgb array
| PNG_INDEX16 of bytes array * rgb array
| PNG_INDEX4 of bytes array * rgb array
external read_as_rgb24 : string -> int * int * bytes array =
"read_png_file_as_rgb24"
external read : string -> int * int * png_read_result = "read_png_file"
external write_rgb : string -> bytes -> int -> int -> bool -> unit
= "write_png_file_rgb"
external write_index : string -> bytes -> rgb array -> int -> int -> unit
= "write_png_file_index"
let load_as_rgb24 name _opts =
let w, h, buf = read_as_rgb24 name in
Rgb24 (Rgb24.create_with_scanlines w h [] buf)
let load name _opts =
let w, h, res = read name in
match res with
| PNG_RGB24 buf -> Rgb24 (Rgb24.create_with_scanlines w h [] buf)
| PNG_RGBA32 buf -> Rgba32 (Rgba32.create_with_scanlines w h [] buf)
| PNG_INDEX8 (buf,cmap) ->
Index8 (Index8.create_with_scanlines w h [] { max = 255; map = cmap; } (-1) buf)
| PNG_INDEX16 (buf,cmap) ->
Index16 (Index16.create_with_scanlines w h [] { max = 65535; map = cmap } (-1) buf)
| PNG_INDEX4 (buf,cmap) ->
let buf' = Array.init h (fun _ -> Bytes.create w) in
for y = 0 to h - 1 do
let b = buf' >@! y in
for x = 0 to w - 1 do
b << x &
char_of_int
(let c = buf.(y) @% (x / 2) in
if x mod 2 = 0 then c lsr 4 else c mod 16)
done
done;
Index8 (Index8.create_with_scanlines w h [] { max = 16; map = cmap } (-1) buf')
let save name _opts image =
match image with
| Rgb24 bmp ->
write_rgb name
(Rgb24.dump bmp) bmp.Rgb24.width bmp.Rgb24.height false
| Rgba32 bmp ->
write_rgb name
(Rgba32.dump bmp) bmp.Rgba32.width bmp.Rgba32.height true
| Index8 bmp ->
write_index name (Index8.dump bmp) bmp.Index8.colormap.map
bmp.Index8.width bmp.Index8.height
| Index16 bmp ->
write_index name (Index16.dump bmp)
bmp.Index16.colormap.map
bmp.Index16.width bmp.Index16.height
| Cmyk32 _ -> failwith "Saving of CMYK not supported yet"
let filename =
let len = 24 in
let ic = open_in_bin filename in
try
let str = Bytes.create len in
really_input ic str 0 len;
close_in ic;
if Bytes.sub_string str 1 3 = "PNG" then begin
if Bytes.sub_string str 0 8 <> "\137PNG\013\010\026\010" then begin
{ header_width= -1;
header_height= -1;
header_infos= [Info_Corrupted]; }
end else begin
let belong str =
(str @% 0) lsl 24 +
(str @% 1) lsl 16 +
(str @% 2) lsl 8 +
(str @% 3) in
let w = belong (Bytes.sub str 16 4) in
let h = belong (Bytes.sub str 20 4) in
let bdepth = Info_Depth (str @% 12) in
let infos =
try
let colormodel =
match str @% 13 with
| 0 -> Info_ColorModel Gray
| 2 -> Info_ColorModel RGB
| 3 -> Info_ColorModel Index
| 4 -> Info_ColorModel GrayA
| 6 -> Info_ColorModel RGBA
| _ -> raise Not_found in
[colormodel; bdepth]
with
| Not_found -> [bdepth] in
{ header_width = w;
header_height = h;
header_infos = infos; }
end
end else raise Wrong_file_type
with
| _ -> close_in ic; raise Wrong_file_type
let () = add_methods Png {
check_header = check_header;
load = Some load;
save = Some save;
load_sequence = None;
save_sequence = None;
}