patch #7318
[mldonkey.git] / tools / xpm.mll
blob3e4a53bc089635c2589f2be639c624eab4f2161a
3 (***********************************************************************)
4 (*                                                                     *)
5 (*                             xlib                                    *)
6 (*                                                                     *)
7 (*       Fabrice Le Fessant, projet Para/SOR, INRIA Rocquencourt       *)
8 (*                                                                     *)
9 (*  Copyright 1999 Institut National de Recherche en Informatique et   *)
10 (*  Automatique.  Distributed only by permission.                      *)
11 (*                                                                     *)
12 (***********************************************************************)
14 module Xtypes = struct
16 type size = int
17 type colordef = RGB of int * int * int | NoColor | Color of string
18   type coord = int
20 end
22 open Xtypes
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
31   
32   let reset_string_buffer () =
33     string_buff := initial_string_buffer;
34     string_index := 0
35   
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
41       end;
42     String.unsafe_set (!string_buff) (!string_index) c;
43     incr string_index
44   
45   let get_stored_string () =
46     let s = String.sub (!string_buff) 0 (!string_index) in
47     string_buff := initial_string_buffer;
48     s
49     
50   let code = ref ""
51   let read = ref 0
52   
53   let width = ref 0
54   let height = ref 0
55   let hot_x = ref 0
56   let hot_y = ref 0
57   
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')
61     else
62     if c>= 'a' && c <= 'f' then
63       Char.code c - Char.code 'a' + 10
64     else
65       raise (BadFile ("hexcode",Lexing.lexeme_start lexbuf))
69 let hex = [ '0'-'9' 'a'-'z' 'A'-'Z']
71 rule xpm_line = parse
72     "\""
73     { 
74     reset_string_buffer();
75     let string_start = Lexing.lexeme_start lexbuf in
76     string_start_pos := string_start;
77     string lexbuf;
78     lexbuf.Lexing.lex_start_pos <-
79       string_start - lexbuf.Lexing.lex_abs_pos;
80     get_stored_string() }
81   | eof { raise (BadFile ("",Lexing.lexeme_start lexbuf))}
82   | _ { xpm_line lexbuf }
84 and string = parse
85     '"'
86     { () }
87   | eof
88       { raise (BadFile ("",Lexing.lexeme_start lexbuf))    }
89   | _
90       { store_string_char(Lexing.lexeme_char lexbuf 0);
91       string lexbuf }
93 and first_line = parse
94     "\"" { 
95     let dx = nombre lexbuf in
96     let dy = nombre lexbuf in
97     let colors = nombre lexbuf in
98     let nchars = nombre lexbuf in
99     ending_string lexbuf;
100     (dx,dy,colors,nchars)
101   }
102   | "/*" { comment lexbuf; first_line lexbuf }
103   | eof { raise (BadFile ("",Lexing.lexeme_start lexbuf)) }
104   | _ { first_line lexbuf }  
106 and nombre = parse
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
113     "\"" { () }
114   | _ { ending_string lexbuf }
116 and comment = parse
117     "*/" { () }
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;
124     color }
125   | "/*" { comment lexbuf; color_def lexbuf }
126   | _ { color_def lexbuf }
128 and read_chars = parse
129     [ ^ '"'] { 
130     !code.[String.length !code - !read] <- Lexing.lexeme_char lexbuf 0;
131     decr read;
132     if !read > 0 then read_chars lexbuf
133   } 
134   | _ { raise (BadFile ("chars",Lexing.lexeme_start lexbuf)) }
136 and read_c = parse
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
147     RGB(r,g,b)    
148   }
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
154     RGB(r,g,b)    
155   }
156   
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)) }
162 and xbm_file = parse
163     "/*" { comment lexbuf; xbm_file lexbuf }
164   | "_width" { width := nombre lexbuf;
165       xbm_file lexbuf }
166   | "_height" { height := nombre lexbuf;
167       xbm_file lexbuf }
168   | "_x_hot" { hot_x := nombre lexbuf;
169       xbm_file lexbuf }
170   | "_y_hot" { hot_y := nombre lexbuf;
171       xbm_file lexbuf }
172   | '{' { 
173       let len = (max (!width / 8) 1) * !height  in
174       code := String.create len;
175       read := len;
176       read_bits lexbuf
177     }
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 }
183   | "0x" _ _ { 
184       !code.[String.length !code - !read] <- 
185         Char.chr (hexcode lexbuf 2 * 16 + hexcode lexbuf 3);
186       decr read;
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
201   try
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;
208       read := nchars;
209       colors.(i) <- color_def lexbuf;
210       Hashtbl.add codes !code i;
211     done;
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]
220         done;
221         table.(y).(x) <- Hashtbl.find codes code
222       done
223     done;
224     close_in ic;
225     (dx,dy,colors, table)
226   with
227     _ -> close_in ic; raise (BadFile ("readPixmapDataFromFile",0))
229 let readBitmapDataFromFile filename =
230   width := 0;
231   height := 0;
232   hot_x := 0;
233   hot_y := 0;
234   let ic = open_in filename in
235   try
236     let lexbuf = Lexing.from_channel ic in
237     let _ = xbm_file lexbuf in
238     close_in ic;
239     (!width,!height,!hot_x, !hot_y, !code)
240   with
241     e -> close_in ic; raise (BadFile ("readBitmapDataFromFile",0))
242       
243 let test f = try f () with e -> lprintf "-"; raise e  
244   
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)
252     done;
253     s := !s ^ "|]\n"
254   done;
255   s := !s ^ " |]"; !s
257 let colors_to_string colors =
258   let s = ref "[|" in
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 "")
263           r g b
264     | Color n -> Printf.sprintf "%s%sXtypes.Color(\"%s\")\n"
265           !s (if i>0 then ";" else "")
266           n
267     | NoColor -> Printf.sprintf "%s%sXtypes.NoColor\n"
268           !s (if i>0 then ";" else ""))
269   done;
270   s := !s ^ " |]"; !s
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)
277 let _ =
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)));
282   close_out oc
284   (*
286   
287 open Xtypes
288 open X
289 open Xlib  
290 open Xutils
291   
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
299   
301 let gc = X.createGC display root [GCforeground black; GCbackground white]
303 let test filename =
304   let (dx,dy,pix,_) = createPixmapFromFile display root cmap depth
305       filename in
306   X.copyArea display gc pix 0 0 root 10 10 dx dy;;
307 open Xpm;;
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;;
313   #use "/tmp/pix.ml";;
315   *)