3 (***********************************************************************)
7 (* Fabrice Le Fessant, projet Para/SOR, INRIA Rocquencourt *)
9 (* Copyright 1999 Institut National de Recherche en Informatique et *)
10 (* Automatique. Distributed only by permission. *)
12 (***********************************************************************)
14 module Xtypes = struct
17 type colordef = RGB of int * int * int | NoColor | Color of string
24 exception BadFile of string * int
25 (* To buffer string literals *)
27 let initial_string_buffer = String.create 256
28 let string_buff = ref initial_string_buffer
29 let string_index = ref 0
30 let string_start_pos = ref 0
32 let reset_string_buffer () =
33 string_buff := initial_string_buffer;
36 let store_string_char c =
37 if !string_index >= String.length (!string_buff) then begin
38 let new_buff = String.create (String.length (!string_buff) * 2) in
39 String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff));
40 string_buff := new_buff
42 String.unsafe_set (!string_buff) (!string_index) c;
45 let get_stored_string () =
46 let s = String.sub (!string_buff) 0 (!string_index) in
47 string_buff := initial_string_buffer;
58 let hexcode lexbuf i =
59 let c = Char.lowercase (Lexing.lexeme_char lexbuf i) in
60 if c>= '0' && c <='9' then (Char.code c) - (Char.code '0')
62 if c>= 'a' && c <= 'f' then
63 Char.code c - Char.code 'a' + 10
65 raise (BadFile ("hexcode",Lexing.lexeme_start lexbuf))
69 let hex = [ '0'-'9' 'a'-'z' 'A'-'Z']
74 reset_string_buffer();
75 let string_start = Lexing.lexeme_start lexbuf in
76 string_start_pos := string_start;
78 lexbuf.Lexing.lex_start_pos <-
79 string_start - lexbuf.Lexing.lex_abs_pos;
81 | eof { raise (BadFile ("",Lexing.lexeme_start lexbuf))}
82 | _ { xpm_line lexbuf }
88 { raise (BadFile ("",Lexing.lexeme_start lexbuf)) }
90 { store_string_char(Lexing.lexeme_char lexbuf 0);
93 and first_line = parse
95 let dx = nombre lexbuf in
96 let dy = nombre lexbuf in
97 let colors = nombre lexbuf in
98 let nchars = nombre lexbuf in
100 (dx,dy,colors,nchars)
102 | "/*" { comment lexbuf; first_line lexbuf }
103 | eof { raise (BadFile ("",Lexing.lexeme_start lexbuf)) }
104 | _ { first_line lexbuf }
107 [ ' ' '\n' '\009' '\010' '\012'] { nombre lexbuf }
108 | [ '0' - '9' ] + { int_of_string(Lexing.lexeme lexbuf) }
109 | '-' [ '0' - '9' ] + { int_of_string(Lexing.lexeme lexbuf) }
110 | _ { raise (BadFile ("nombre",Lexing.lexeme_start lexbuf)) }
112 and ending_string = parse
114 | _ { ending_string lexbuf }
118 | eof { raise (BadFile ("",Lexing.lexeme_start lexbuf)) }
119 | _ { comment lexbuf }
121 and color_def = parse
122 "\"" { read_chars lexbuf; read_c lexbuf;
123 let color = read_color lexbuf in ending_string lexbuf;
125 | "/*" { comment lexbuf; color_def lexbuf }
126 | _ { color_def lexbuf }
128 and read_chars = parse
130 !code.[String.length !code - !read] <- Lexing.lexeme_char lexbuf 0;
132 if !read > 0 then read_chars lexbuf
134 | _ { raise (BadFile ("chars",Lexing.lexeme_start lexbuf)) }
137 [' ' '\009'] 'c' [' ' '\009'] { () }
138 | [ ^ '"'] { read_c lexbuf }
139 | _ { raise (BadFile (" c ",Lexing.lexeme_start lexbuf)) }
141 and read_color = parse
142 '#' hex hex hex hex hex hex hex hex hex hex hex hex {
143 let hex pos = hexcode lexbuf pos * 16 + hexcode lexbuf (pos+1) in
144 let r = hex 1 * 256 + hex 3 in
145 let g = hex 5 * 256 + hex 7 in
146 let b = hex 9 * 256 + hex 11 in
149 | '#' hex hex hex hex hex hex {
150 let hex pos = hexcode lexbuf pos * 16 + hexcode lexbuf (pos+1) in
151 let r = (hex 1) * 256 in
152 let g = (hex 3) * 256 in
153 let b = (hex 5) * 256 in
157 | ['n' 'N'] ['o' 'O'] ['n' 'N'] ['e' 'E'] { NoColor }
158 | ['A'-'Z' 'a'-'z' '_' '0'-'9'] + { Color(Lexing.lexeme lexbuf) }
159 | [ ' ' '\n' '\009' '\010' '\012'] { read_color lexbuf }
160 | _ { raise (BadFile ("color",Lexing.lexeme_start lexbuf)) }
163 "/*" { comment lexbuf; xbm_file lexbuf }
164 | "_width" { width := nombre lexbuf;
166 | "_height" { height := nombre lexbuf;
168 | "_x_hot" { hot_x := nombre lexbuf;
170 | "_y_hot" { hot_y := nombre lexbuf;
173 let len = (max (!width / 8) 1) * !height in
174 code := String.create len;
178 | eof { raise (BadFile ("looking for {",Lexing.lexeme_start lexbuf)) }
179 | _ { xbm_file lexbuf }
181 and read_bits = parse
182 "/*" { comment lexbuf; xbm_file lexbuf }
184 !code.[String.length !code - !read] <-
185 Char.chr (hexcode lexbuf 2 * 16 + hexcode lexbuf 3);
187 if !read > 0 then read_bits lexbuf }
188 | '}' | eof { raise (BadFile ("looking for 0x",Lexing.lexeme_start lexbuf)) }
189 | _ { read_bits lexbuf }
192 type bitmap_data = int * int * int * int * string
193 type pixmap_data = int * int * Xtypes.colordef array * int array array
195 type bitmap = Xtypes.size * Xtypes.size * coord * coord * Xtypes.pixmap
196 type pixmap = Xtypes.size * Xtypes.size * int * Xtypes.pixmap * Xtypes.pixmap
199 let readPixmapDataFromFile filename =
200 let ic = open_in filename in
202 let lexbuf = Lexing.from_channel ic in
203 let (dx,dy,ncolors,nchars) = first_line lexbuf in
204 let colors = Array.create ncolors NoColor in
205 let codes = Hashtbl.create ncolors in
206 for i = 0 to ncolors - 1 do
207 code := String.create nchars;
209 colors.(i) <- color_def lexbuf;
210 Hashtbl.add codes !code i;
212 let table = Array.init dy (fun _ -> Array.create dx 0) in
213 let code = String.create nchars in
214 for y = 0 to dy - 1 do
215 let line = xpm_line lexbuf in
216 if String.length line <> dx * nchars then raise (BadFile ("size",Lexing.lexeme_start lexbuf));
217 for x = 0 to dx - 1 do
218 for c = 0 to nchars - 1 do
219 code.[c] <- line.[x*nchars+c]
221 table.(y).(x) <- Hashtbl.find codes code
225 (dx,dy,colors, table)
227 _ -> close_in ic; raise (BadFile ("readPixmapDataFromFile",0))
229 let readBitmapDataFromFile filename =
234 let ic = open_in filename in
236 let lexbuf = Lexing.from_channel ic in
237 let _ = xbm_file lexbuf in
239 (!width,!height,!hot_x, !hot_y, !code)
241 e -> close_in ic; raise (BadFile ("readBitmapDataFromFile",0))
243 let test f = try f () with e -> lprintf "-"; raise e
245 let data_to_string data =
246 let s = ref "\n[|" in
247 for j = 0 to Array.length data - 1 do
248 let line = data.(j) in
249 s := !s ^ (if j > 0 then ";[|" else " [|");
250 for i = 0 to Array.length line - 1 do
251 s := Printf.sprintf "%s%s%d" !s (if i>0 then ";" else "") line.(i)
257 let colors_to_string colors =
259 for i = 0 to Array.length colors - 1 do
260 s := (match colors.(i) with
261 RGB(r,g,b) -> Printf.sprintf "%s%sXtypes.RGB(%d,%d,%d)\n"
262 !s (if i>0 then ";" else "")
264 | Color n -> Printf.sprintf "%s%sXtypes.Color(\"%s\")\n"
265 !s (if i>0 then ";" else "")
267 | NoColor -> Printf.sprintf "%s%sXtypes.NoColor\n"
268 !s (if i>0 then ";" else ""))
272 let createMLStringFromPixmapData pixmap pixmap_name =
273 let (dx,dy,colors,data) = pixmap in
274 Printf.sprintf "let %s = (%d,%d,\n(%s),\n(%s))\n" pixmap_name dx dy
275 (colors_to_string colors) (data_to_string data)
278 let oc = open_out (Sys.argv.(1) ^ ".ml") in
279 output_string oc (createMLStringFromPixmapData
280 (readPixmapDataFromFile Sys.argv.(2))
281 (Filename.basename Sys.argv.(1)));
292 let display = openDisplay ""
293 let screen = display.dpy_roots.(0)
294 let root = screen.scr_root
295 let white = Xutils.defaultWhite display
296 let black = Xutils.defaultBlack display
297 let cmap = Xutils.defaultColormap display
298 let depth = Xutils.defaultDepth display
301 let gc = X.createGC display root [GCforeground black; GCbackground white]
304 let (dx,dy,pix,_) = createPixmapFromFile display root cmap depth
306 X.copyArea display gc pix 0 0 root 10 10 dx dy;;
308 let data = readPixmapDataFromFile "xterm.xpm";;
309 let s = createMLStringFromPixmapData data "xterm_pix";;
310 let oc = open_out "/tmp/pix.ml"
311 let _ = output_string oc s
312 let _ = close_out oc;;