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
type color = (int * int * int) option
type t = { name : string; colors : (char * color) list; rows : string list }
let fail fmt = Printf.ksprintf (fun s -> failwith ("XPM: " ^ s)) fmt
let rec find (s : string) (sub : string) (from : int) : int option =
if from + String.length sub > String.length s then None
else if String.sub s from (String.length sub) = sub then Some from
else find s sub (from + 1)
let strings (text : string) : string list =
let n = String.length text in
let rec go i acc =
if i >= n then List.rev acc
else if i + 1 < n && text.[i] = '/' && text.[i + 1] = '*' then
match find text "*/" (i + 2) with Some j -> go (j + 2) acc | None -> List.rev acc
else if text.[i] = '"' then (
let b = Buffer.create 16 in
let rec str j =
if j >= n then fail "a string is not closed"
else if text.[j] = '"' then j + 1
else if text.[j] = '\\' && j + 1 < n then (Buffer.add_char b text.[j + 1]; str (j + 2))
else (Buffer.add_char b text.[j]; str (j + 1))
in
let next = str (i + 1) in
go next (Buffer.contents b :: acc))
else go (i + 1) acc
in
go 0 []
let name (text : string) : string =
match find text "[]" 0 with
| None -> ""
| Some j ->
let is_ident c = c = '_' || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') in
let stop = ref j in
while !stop > 0 && text.[!stop - 1] = ' ' do decr stop done;
let start = ref !stop in
while !start > 0 && is_ident text.[!start - 1] do decr start done;
String.sub text !start (!stop - !start)
let words (s : string) : string list = String.split_on_char ' ' s |> List.concat_map (String.split_on_char '\t') |> List.filter (( <> ) "")
let hex (s : string) : int = match int_of_string_opt ("0x" ^ s) with Some v -> v | None -> fail "bad color #%s" s
let color_value (v : string) : color =
let n = String.length v in
match String.lowercase_ascii v with
| "none" -> None
| "black" -> Some (0, 0, 0)
| "white" -> Some (255, 255, 255)
| "red" -> Some (255, 0, 0)
| "green" -> Some (0, 255, 0)
| "blue" -> Some (0, 0, 255)
| _ when n = 7 && v.[0] = '#' -> Some (hex (String.sub v 1 2), hex (String.sub v 3 2), hex (String.sub v 5 2))
| _ when n = 13 && v.[0] = '#' -> Some (hex (String.sub v 1 2), hex (String.sub v 5 2), hex (String.sub v 9 2))
| _ -> fail "color %S not read (only #rrggbb, None and a few names)" v
let color_line (line : string) : char * color =
if line = "" then fail "an empty color line";
let rec value = function
| "c" :: v :: _ -> color_value v
| _ :: rest -> value rest
| [] -> fail "no 'c' color for %C" line.[0]
in
(line.[0], value (words (String.sub line 1 (String.length line - 1))))
let parse (text : string) : t =
match strings text with
| [] -> fail "no strings: not an XPM file"
| :: rest -> (
match List.map int_of_string_opt (words header) with
| Some w :: Some h :: Some ncolors :: Some cpp :: _ ->
if cpp <> 1 then fail "%d characters per pixel, only 1 read" cpp;
if List.length rest < ncolors + h then fail "%d strings, %d expected" (List.length rest) (ncolors + h);
let colors = List.filteri (fun i _ -> i < ncolors) rest |> List.map color_line in
let rows = List.filteri (fun i _ -> i >= ncolors && i < ncolors + h) rest in
rows
|> List.iteri (fun r row ->
if String.length row <> w then fail "row %d is %d wide, not %d" r (String.length row) w;
String.iter (fun c -> if not (List.mem_assoc c colors) then fail "%C in row %d is not in the palette" c r) row);
{ name = name text; colors; rows }
| _ -> fail "bad header %S, expected: width height colors characters-per-pixel" header)
let print (t : t) : string =
let w = List.fold_left (fun acc r -> max acc (String.length r)) 0 t.rows in
let color (c, v) =
match v with None -> Printf.sprintf "%c c None" c | Some (r, g, b) -> Printf.sprintf "%c c #%02x%02x%02x" c r g b
in
let lines = Printf.sprintf "%d %d %d 1" w (List.length t.rows) (List.length t.colors) :: List.map color t.colors @ t.rows in
Printf.sprintf "/* XPM */\nstatic char *%s[] = {\n%s\n};\n" t.name
(lines |> List.map (fun l -> "\"" ^ l ^ "\"") |> String.concat ",\n")