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
let max_codes = 4096
type step = { code : int; width : int; start : int; length : int; added : int option }
let run ~(on_step : step -> unit) ~(min_code_size : int) (data : string) ~(npixels : int) : Bytes.t =
if min_code_size < 1 || min_code_size > 8 then
failwith (Printf.sprintf "LZW: a minimum code size of %d" min_code_size);
let clear = 1 lsl min_code_size in
let end_ = clear + 1 in
let prefix = Array.make max_codes (-1) in
let suffix = Array.init max_codes (fun i -> if i < clear then i else 0) in
let first = Array.copy suffix in
let length = Array.make max_codes 1 in
let out = Bytes.make npixels '\000' in
let outpos = ref 0 in
let emit code =
let len = length.(code) in
let c = ref code in
for k = len - 1 downto 0 do
if !outpos + k < npixels then Bytes.set out (!outpos + k) (Char.chr suffix.(!c));
c := prefix.(!c)
done;
outpos := !outpos + len
in
let pos = ref 0 and bitbuf = ref 0 and bitcnt = ref 0 in
let read width =
while !bitcnt < width && !pos < String.length data do
bitbuf := !bitbuf lor (Char.code data.[!pos] lsl !bitcnt);
incr pos;
bitcnt := !bitcnt + 8
done;
if !bitcnt < width then None
else begin
let v = !bitbuf land ((1 lsl width) - 1) in
bitbuf := !bitbuf lsr width;
bitcnt := !bitcnt - width;
Some v
end
in
let step code width ~start ~added = on_step { code; width; start; length = !outpos - start; added } in
let rec loop ~width ~next ~prev =
if !outpos < npixels then
match read width with
| None -> ()
| Some code when code = clear ->
step code width ~start:!outpos ~added:None;
loop ~width:(min_code_size + 1) ~next:(end_ + 1) ~prev:(-1)
| Some code when code = end_ -> step code width ~start:!outpos ~added:None
| Some code when prev < 0 ->
if code >= clear then failwith "LZW: the first code after a clear is not a color";
let start = !outpos in
emit code;
step code width ~start ~added:None;
loop ~width ~next ~prev:code
| Some code ->
if code > next || (code = next && next >= max_codes) then
failwith (Printf.sprintf "LZW: code %d, beyond the dictionary (%d)" code next);
let start = !outpos and added = if next < max_codes then Some next else None in
let next =
if next >= max_codes then next
else begin
prefix.(next) <- prev;
suffix.(next) <- (if code = next then first.(prev) else first.(code));
first.(next) <- first.(prev);
length.(next) <- length.(prev) + 1;
next + 1
end
in
emit code;
step code width ~start ~added;
let width = if next = 1 lsl width && width < 12 then width + 1 else width in
loop ~width ~next ~prev:code
in
loop ~width:(min_code_size + 1) ~next:(end_ + 1) ~prev:(-1);
out
let decode ~(min_code_size : int) (data : string) ~(npixels : int) : Bytes.t =
run ~on_step:(fun _ -> ()) ~min_code_size data ~npixels
let steps ~(min_code_size : int) (data : string) ~(npixels : int) : step list * Bytes.t =
let acc = ref [] in
let pixels = run ~on_step:(fun s -> acc := s :: !acc) ~min_code_size data ~npixels in
(List.rev !acc, pixels)