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
open Bimage
type input
type output
type spec
type error = [ Error.t | `File_not_found of string ]
type base_type =
| Unknown
| None
| UInt8
| Int8
| UInt16
| Int16
| UInt32
| Int32
| UInt64
| Int64
| Half
| Float
| Double
| String
| Ptr
let base_type_of_ty : type a b. (a, b) Type.t -> base_type =
fun (module T) ->
match T.kind with
| Float64 -> Double
| Float32 -> Float
| Int8_unsigned -> UInt8
| Int16_unsigned -> UInt16
| Int32 -> Int32
| Int64 -> Int64
| _ -> raise Unsupported
external image_spec : int -> int -> int -> base_type -> spec = "image_spec"
let make_spec ty color width height =
let base = base_type_of_ty ty in
image_spec width height (Color.channels color) base
external spec_shape : spec -> int * int * int = "spec_shape"
external spec_base_type : spec -> base_type = "spec_base_type"
external input_open : string -> input = "input_open"
external input_get_spec : input -> spec = "input_get_spec"
external input_read :
input -> channels:int -> index:int -> spec -> ('a, 'b) Data.t -> unit
= "input_read"
external output_create : string -> output = "output_create"
external output_open : output -> string -> spec -> bool -> unit = "output_open"
external output_write_image : output -> spec -> ('a, 'b) Data.t -> unit
= "output_write_image"
module Spec = struct
type 'a attr = Int : int attr | Float : float attr | String : string attr
external spec_get_attr : spec -> string -> 'a attr -> 'a option
= "spec_get_attr"
external spec_set_attr : spec -> string -> 'a attr -> 'a -> unit
= "spec_set_attr"
external spec_get_attr_names : spec -> string array = "spec_get_attr_names"
type t = spec
let shape t = spec_shape t
let base_type t = spec_base_type t
let make : ('a, 'b) Type.t -> 'c Color.t -> int -> int -> t = make_spec
let get_attr t name = spec_get_attr t name
let set_attr t name value = spec_set_attr t name value
let attr_names t = spec_get_attr_names t
end
module Input = struct
type t = input
let init filename =
try Ok (input_open filename) with Failure reason -> Error (`Msg reason)
let spec input = input_get_spec input
let read_image ?(index = 0) input image =
try
let w, h, _c = Image.shape image in
let spec = make_spec (Image.ty image) (Image.color image) w h in
Ok
(input_read input ~channels:(Image.channels image) ~index spec
(Image.data image))
with Failure reason -> Error (`Msg reason)
let read ?index input ty color =
let spec = spec input in
let width, height, channels = Spec.shape spec in
if channels > Color.channels color then Error `Invalid_color
else
let image = Image.v ty color width height in
match read_image ?index input image with
| Ok () -> Ok image
| Error e -> Error e
end
module Output = struct
type t = string * output
let create filename =
try Ok (filename, output_create filename)
with Failure reason -> Error (`Msg reason)
let open_ ?(append = false) (filename, output) spec =
output_open output filename spec append
let write ?spec ?(append = false) (filename, output) image =
try
let spec =
match spec with
| Some spec -> spec
| None ->
make_spec (Image.ty image) image.color image.width image.height
in
let () = open_ ~append (filename, output) spec in
let () = output_write_image output spec (Image.data image) in
Ok ()
with Failure reason -> Error (`Msg reason)
end
let write filename image =
match Output.create filename with
| Ok output -> Output.write output image
| Error e -> Error e
let read t c filename =
match Input.init filename with
| Ok input -> Input.read input t c
| Error e -> Error e