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
type frame = {
x : int;
y : int;
patch : Rgba_image.t;
delay : float;
disposal : int;
palette : string;
min_code_size : int;
lzw : string;
}
let interlaced_rows (h : int) : int array =
let passes = [ (0, 8); (4, 8); (2, 4); (1, 2) ] in
passes
|> List.map (fun (start, step) -> List.init (max 0 ((h - start + step - 1) / step)) (fun k -> start + (k * step)))
|> List.concat |> Array.of_list
let frames (s : string) : (int * int) * frame list =
let len = String.length s in
let byte i = if i < len then Char.code s.[i] else failwith "GIF: the file ends early" in
let u16 i = byte i lor (byte (i + 1) lsl 8) in
if len < 13 || (String.sub s 0 6 <> "GIF87a" && String.sub s 0 6 <> "GIF89a") then failwith "GIF: not a GIF";
let width = u16 6 and height = u16 8 in
let palette_size flags = if flags land 0x80 <> 0 then 3 * (1 lsl (1 + (flags land 7))) else 0 in
let global_end = 13 + palette_size (byte 10) in
let global = if global_end > len then failwith "GIF: the file ends early" else String.sub s 13 (global_end - 13) in
let sub_blocks i =
let b = Buffer.create 256 in
let rec loop i =
let size = byte i in
if size = 0 then i + 1
else begin
if i + 1 + size > len then failwith "GIF: the file ends early";
Buffer.add_substring b s (i + 1) size;
loop (i + 1 + size)
end
in
let after = loop i in
(Buffer.contents b, after)
in
let rec loop i gce acc =
if i >= len then List.rev acc
else
match byte i with
| 0x3B -> List.rev acc
| 0x21 when byte (i + 1) = 0xF9 ->
let gce = (byte (i + 3), u16 (i + 4), byte (i + 6)) in
loop (snd (sub_blocks (i + 2))) gce acc
| 0x21 -> loop (snd (sub_blocks (i + 2))) gce acc
| 0x2C ->
let x = u16 (i + 1) and y = u16 (i + 3) and w = u16 (i + 5) and h = u16 (i + 7) in
let flags = byte (i + 9) in
let local_end = i + 10 + palette_size flags in
let palette = if flags land 0x80 <> 0 then String.sub s (i + 10) (local_end - i - 10) else global in
if palette = "" then failwith "GIF: a frame without a palette";
let data, after = sub_blocks (local_end + 1) in
let indices = Lzw.decode ~min_code_size:(byte local_end) data ~npixels:(w * h) in
let packed, delay, transparent = gce in
let transparent = if packed land 1 = 1 then transparent else -1 in
let rows = if flags land 0x40 <> 0 then interlaced_rows h else Array.init h (fun j -> j) in
let patch = Rgba_image.create ~width:w ~height:h in
for k = 0 to h - 1 do
for col = 0 to w - 1 do
let index = Char.code (Bytes.get indices ((k * w) + col)) in
let o = ((rows.(k) * w) + col) * 4 in
if index <> transparent then begin
let color c = if (3 * index) + 2 < String.length palette then Char.code palette.[(3 * index) + c] else 0 in
patch.rgba.{o} <- color 0;
patch.rgba.{o + 1} <- color 1;
patch.rgba.{o + 2} <- color 2;
patch.rgba.{o + 3} <- 255
end
done
done;
let frame =
{ x; y; patch; delay = (if delay <= 1 then 0.1 else float delay /. 100.); disposal = (packed lsr 2) land 7;
palette; min_code_size = byte local_end; lzw = data }
in
loop after (0, 0, 0) (frame :: acc)
| c -> failwith (Printf.sprintf "GIF: unexpected block 0x%02X at %d" c i)
in
((width, height), loop global_end (0, 0, 0) [])
let animation (s : string) : (Rgba_image.t * float) list =
let (w, h), frames = frames s in
let canvas = Rgba_image.create ~width:w ~height:h in
let copy (img : Rgba_image.t) : Rgba_image.t =
let c = Rgba_image.create ~width:img.width ~height:img.height in
Bigarray.Array1.blit img.rgba c.rgba;
c
in
let iter_patch (fr : frame) f =
for j = 0 to fr.patch.height - 1 do
for i = 0 to fr.patch.width - 1 do
let cx = fr.x + i and cy = fr.y + j in
if cx < w && cy < h then f (((cy * w) + cx) * 4) (((j * fr.patch.width) + i) * 4)
done
done
in
frames
|> List.map (fun (fr : frame) ->
let before = if fr.disposal = 3 then Some (copy canvas) else None in
let p = fr.patch.rgba in
iter_patch fr (fun co po -> if p.{po + 3} <> 0 then for k = 0 to 3 do canvas.rgba.{co + k} <- p.{po + k} done);
let snapshot = copy canvas in
(match (fr.disposal, before) with
| 2, _ -> iter_patch fr (fun co _ -> for k = 0 to 3 do canvas.rgba.{co + k} <- 0 done)
| 3, Some c -> Bigarray.Array1.blit c.rgba canvas.rgba
| _ -> ());
(snapshot, fr.delay))
let decode (s : string) : Rgba_image.t =
match animation s with
| (first, _) :: _ -> first
| [] -> failwith "GIF: no frame"