tools/xpm.mll

   1 {
   2
   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 (***********************************************************************)
  13
  14 module Xtypes = struct
  15
  16 type size = int
  17 type colordef = RGB of int * int * int | NoColor | Color of string
  18   type coord = int
  19
  20 end
  21
  22 open Xtypes
  23
  24   exception BadFile of string * int
  25 (* To buffer string literals *)
  26
  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))
  66
  67 }
  68
  69 let hex = [ '0'-'9' 'a'-'z' 'A'-'Z']
  70
  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 }
  83
  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 }
  92
  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 }
 105
 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)) }
 111
 112 and ending_string = parse
 113     "\"" { () }
 114   | _ { ending_string lexbuf }
 115
 116 and comment = parse
 117     "*/" { () }
 118   | eof { raise (BadFile ("",Lexing.lexeme_start lexbuf)) }
 119   | _ { comment lexbuf }
 120
 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 }
 127
 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)) }
 135
 136 and read_c = parse
 137     [' ' '\009'] 'c' [' ' '\009'] { () }
 138   | [ ^ '"'] { read_c lexbuf }
 139   | _ { raise (BadFile (" c ",Lexing.lexeme_start lexbuf)) }
 140
 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)) }
 161
 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 }
 180
 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 }
 190
 191 {
 192 type bitmap_data = int * int * int * int * string
 193 type pixmap_data = int * int * Xtypes.colordef array * int array array
 194 (*
 195 type bitmap = Xtypes.size * Xtypes.size * coord * coord * Xtypes.pixmap
 196 type pixmap = Xtypes.size * Xtypes.size * int * Xtypes.pixmap * Xtypes.pixmap
 197 *)
 198
 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))
 228
 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
 256
 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
 271
 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)
 276
 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
 283
 284   (*
 285
 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
 300
 301 let gc = X.createGC display root [GCforeground black; GCbackground white]
 302
 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";;
 314
 315   *)
 316
 317 }
 318