Source

camlimages / examples / tiffps / tiffps.ml

The default branch has multiple heads

  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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Jun Furuse, projet Cristal, INRIA Rocquencourt           *)
(*                                                                     *)
(*  Copyright 1999-2004,                                               *)
(*  Institut National de Recherche en Informatique et en Automatique.  *)
(*  Distributed only by permission.                                    *)
(*                                                                     *)
(***********************************************************************)

(* $Id: tiffps.ml,v 1.11 2008/05/17 19:55:50 furuse Exp $ *)

open Images;;
open Printf;;

(* String utilities *)

(* split a string according to char_sep predicate *)
let split_str char_sep str =
  let len = String.length str in
  if len = 0 then [] else
    let rec skip_sep cur =
      if cur >= len then cur else
      if char_sep str.[cur] then skip_sep (succ cur)
      else cur  in
    let rec split beg cur =
      if cur >= len then
        if beg = cur then []
        else [String.sub str beg (len - beg)] else
      if char_sep str.[cur] then
        let nextw = skip_sep cur in
        String.sub str beg (cur - beg) :: split nextw nextw else
      split beg (succ cur) in
    let wstart = skip_sep 0 in
    split wstart wstart;;

let inch_cm = 2.53012048193;;
let inch_pt = 72.0;;

let units = [ "mm", 0.1 /. inch_cm *. inch_pt;
              "cm", 1.0 /. inch_cm *. inch_pt;
              "pt", 1.0;
              "in", inch_pt ];;

let parse_length s = (* return in pt *)
  let v =
    let l = String.length s in
    let digit, unit =
      if l > 2 then String.sub s 0 2, String.sub s (l-2) 2 else "", "" in
    try
      List.assoc (String.lowercase unit) units *. float_of_string digit
    with
    | Not_found -> (* think it is in "pt" *) float_of_string s in
  prerr_endline (Printf.sprintf "%s -> %fpt" s v);
  v;;

(* Scanlined loader *)
type scanlined_loader = {
    read_next_line: (string -> unit);
    close: (unit -> unit)
  };;

let scanline_open name =
  match Images.file_format name with
  | Jpeg, _ ->
      let w,h,ic,_rev_markers = Jpeg.open_in name in
      let y = ref 0 in 
      w, h, 200.0,
      { read_next_line = (fun buf -> Jpeg.read_scanline ic buf !y; incr y);
        close = (fun () -> Jpeg.close_in ic) }
  | Tiff, _ ->
      let w, h, dpi, _, ic = Tiff.open_in name in
      let y = ref 0 in
      w, h, dpi,
      { read_next_line = (fun buf -> Tiff.read_scanline ic buf !y; incr y);
        close = (fun () -> Tiff.close_in ic) }
  | _ -> assert false;;

type rot = Rot0 | Rot90 | Rot180 | Rot270 | RotMax;;

type at =
   | TopLeft of float * float
   | TopRight of float * float
   | BottomLeft of float * float
   | BottomRight of float * float
   | Center of float * float
   | A4Center;;

type crop = {
   mutable cx : int;
   mutable cy : int;
   mutable cw : int;
   mutable ch : int;
};;

type size =
   | A4MaxSize
   | DPI of float
   | MaxBox of float * float
   | MinBox of float * float;;

type conf = {
   mutable name : string;
   mutable crop : crop option;
   mutable rot : rot;
   mutable size : size;
   mutable pos : at;
   mutable mirror : bool;
   mutable mono : bool;
};;

let main () =
  (* global options *)
  let files = ref []
  and justdpi = ref false
  and comments = ref true
  and showpage = ref true in

  let default_conf = {
    name = "noname";
    crop = None;
    rot = Rot0;
    size = A4MaxSize;
    pos = A4Center;
    mirror = false;
    mono = false;
  } in

  let conf = {
    name = "noname";
    crop = None;
    rot = Rot0;
    size = A4MaxSize;
    pos = A4Center;
    mirror = false;
    mono = false;
  } in

  let set_default () =
    conf.name <- default_conf.name;
    conf.crop <- default_conf.crop;
    conf.rot <- default_conf.rot;
    conf.size <- default_conf.size;
    conf.pos <- default_conf.pos;
    conf.mirror <- default_conf.mirror;
    conf.mono <- default_conf.mono in

  Arg.parse [
    "-justdpi", Arg.Unit (fun () -> justdpi := true),
      ": print dpi information and quit";
    "-nocomments", Arg.Unit (fun () -> comments := false),
      ": no comment lines";
    "-noshowpage", Arg.Unit (fun () -> showpage := false),
      ": no showpage command";

    "-crop", Arg.String (fun s ->
      match
        List.map int_of_string
         (split_str (function '+' | 'x' -> true | _ -> false) s) with
      | [w; h; x; y] ->
          conf.crop <- Some {cx = x; cy = y; cw = w; ch = h}
      | _ -> assert false),
      "?x?+?+? : cropping";
    "-a4max", Arg.Unit (fun () ->
      conf.size <- A4MaxSize;
      conf.pos <- A4Center),
      ": expand image to a4 paper";
    "-maxbox", Arg.String (fun s ->
      match
        List.map parse_length
         (split_str (function 'x' -> true | _ -> false ) s) with
      | [w; h] -> conf.size <- MaxBox (w, h)
      | _ -> assert false),
      "?x? : upper bound printing size";
    "-minbox", Arg.String (fun s ->
      match
        List.map parse_length
         (split_str (function 'x' -> true | _ -> false ) s) with
      | [w; h] -> conf.size <- MinBox(w, h)
      | _ -> assert false),
      "?x? : lower bound printing size";
    "-dpi", Arg.Float (fun x -> conf.size <- DPI x),
      "dpi : dpi setting";
    "-at", Arg.String (fun s ->
      match
        List.map parse_length
          (split_str (function 'x' -> true | _ -> false ) s) with
      | [x; y] -> conf.pos <- BottomLeft (x, y)
      | _ -> assert false),
      "?x? : at bottom-left";
    "-topleft", Arg.String (fun s ->
      match
        List.map parse_length
          (split_str (function 'x' -> true | _ -> false ) s) with
      | [x; y] -> conf.pos <- TopLeft (x, y)
      | _ -> assert false),
      "?x? : at top-left";
    "-bottomleft", Arg.String (fun s ->
      match
        List.map parse_length
          (split_str (function 'x' -> true | _ -> false ) s) with
      | [x; y] -> conf.pos <- BottomLeft (x, y)
      | _ -> assert false),
      "?x? : at bottom-left";
    "-topright", Arg.String (fun s ->
      match
        List.map parse_length
          (split_str (function 'x' -> true | _ -> false ) s) with
      | [x; y] -> conf.pos <- TopRight (x, y)
      | _ -> assert false),
      "?x? : at top-right";
    "-bottomright", Arg.String (fun s ->
      match
        List.map parse_length
          (split_str (function 'x' -> true | _ -> false ) s) with
      | [x; y] -> conf.pos <- BottomRight (x, y)
      | _ -> assert false),
      "?x? : at bottom-right";
    "-center", Arg.String (fun s ->
      match
         List.map parse_length
          (split_str (function 'x' -> true | _ -> false ) s) with
      | [x; y] -> conf.pos <- Center (x, y)
      | _ -> assert false),
      "?x? : at center";
    "-rot", Arg.Int (fun x ->
      let rot =
        match x with
        | 0 -> Rot0
        | 90 -> Rot90
        | 180 -> Rot180
        | 270 -> Rot270
        | _ -> invalid_arg "rotation must be 90*x" in
      conf.rot <- rot),
      "r : rotation (x90 only)";
    "-autorot", Arg.Unit (fun () -> conf.rot <- RotMax),
      ": auto rotate (to have larger image)";
    "-mono", Arg.Unit (fun () -> conf.mono <- true),
      ": monochrome";
    "-mirror", Arg.Unit (fun () -> conf.mirror <- true),
      ": mirror image"
    ]
    (fun x ->
      files := {conf with name = x} :: !files;
      set_default ()) "tiffps";

  let files = List.rev !files in

  (* paper properties *)
  let paper_width = 595.0
  and paper_height = 842.0
  and border = 15.0 in

  let bbx1 = ref 0.0
  and bby1 = ref 0.0
  and bbx2 = ref 0.0
  and bby2 = ref 0.0 in

  let first_image = ref true in
  let set_bbox x1 y1 x2 y2 =
    if !first_image then begin
      bbx1 := x1; bby1 := y1; bbx2 := x2; bby2 := y2; first_image := false
    end else begin
    if !bbx1 > x1 then bbx1 := x1;
    if !bby1 > y1 then bby1 := y1;
    if !bbx2 < x2 then bbx2 := x2;
    if !bby2 < y2 then bby2 := y2;
    end in

  (* printer *)
  let p = print_endline in

  let output_image_func conf =
    (* maximum printing area *)
    let limitw, limith =
      match conf.size with
      | MaxBox (w, h) -> w, h
      | MinBox (w, h) -> w, h
      | _ ->
        paper_width -. border *. 2.0,
        paper_height -. border *. 2.0 in

    (* open the file just to get the image size info. *)
    let imgw, imgh, _orgdpi, th = scanline_open conf.name in
    th.close ();

    (* cropping area *)
    let w, h, x1, y1 =
      match conf.crop with
      | Some crop ->
          (* check cropping area *)
          if crop.cx + crop.cw > imgw then crop.cw <- imgw - crop.cx;
          if crop.cy + crop.ch > imgh then crop.ch <- imgh - crop.cy;
          crop.cw, crop.ch, crop.cx, crop.cy
      | None -> imgw, imgh, 0, 0 in

    (* auto rotation *)
    if conf.rot = RotMax then begin
      let ratio0 =
        let rw = limitw /. (float w) and rh = limith /. (float h) in
        match conf.size with
        | MinBox _ -> if rw < rh then rh else rw
        | _ -> if rw > rh then rh else rw in
      let ratio90 =
        let rw = limith /. (float w) and rh = limitw /. (float h) in
        match conf.size with
        | MinBox _ -> if rw < rh then rh else rw
        | _ -> if rw > rh then rh else rw in
      match conf.size with
      | MinBox _ -> (* smaller is better *)
          conf.rot <- if ratio0 < ratio90 then Rot0 else Rot90
      | _ -> (* larger is better *)
          conf.rot <- if ratio0 > ratio90 then Rot0 else Rot90
    end;

    (* from the point of view of the image *)
    let limitw, limith =
      match conf.rot with
      | Rot0 | Rot180 -> limitw, limith
      | Rot90 | Rot270 -> limith, limitw
      | _ -> assert false in

    (* dpi *)
    let ratio =
      match conf.size with
      | DPI dpi ->
        prerr_endline (sprintf "%s : %f dpi" conf.name dpi);
        paper_width /. 8.26 /. dpi
      | _ ->
        let ratio =
          if limitw /. float w  *. float h < limith
          then limitw /. float w
          else limith /. float h in
        let dpi = paper_width /. 8.26 /. ratio in
        prerr_endline (sprintf "%s : %f dpi" conf.name dpi);
        ratio in

    (* if just for printing dpi, quit. *)
    if !justdpi then raise Exit;

    let rw = float w  *. ratio
    and rh = float h *. ratio in

    (* now on the paper ... *)
    let prw, prh =
      match conf.rot with
      | Rot0 | Rot180 -> rw, rh
      | Rot90 | Rot270 -> rh, rw
      | _ -> assert false in

    let paper_x1, paper_y1 =
      let x, y =
        match conf.pos with
        | BottomLeft (x, y) -> x, y
        | TopLeft (x, y) -> x, y -. prh
        | BottomRight (x, y) -> x +. prw, y
        | TopRight (x, y) -> x +. prw, y -. prh
        | Center (x, y) -> x -. prw /. 2.0 , y -. prh /. 2.0
        | A4Center ->
          (paper_width -. prw) /. 2.0,
          (paper_height -. prh) /. 2.0 in
      match conf.rot with
      | Rot0 -> x, y
      | Rot180 -> prw +. x, prh +. y
      | Rot90 -> x, prh +. y
      | Rot270 -> prw +. x, y
      | _ -> assert false in

    set_bbox paper_x1 paper_y1 (paper_x1 +. prw) (paper_y1 +. prh);

    (fun () ->
      (* reopen file *)
      let _, _, _, th = scanline_open conf.name in

      if !comments then p "% Translate for offset";
      p "gsave";
      p (sprintf "%f %f translate" paper_x1 paper_y1);
      p (sprintf "%d rotate"
           begin match conf.rot with
           | Rot0 -> 0
           | Rot90 -> -90
           | Rot180 -> -180
           | Rot270 -> -270
           | _ -> assert false
           end);
      p (sprintf "%f -%f scale" rw rh);
      if !comments then p "% Variable to keep one line of raster data";
      p (sprintf "/scanline %d 3 mul string def" w);
      if !comments then p "% Image geometry";
      p (sprintf "%d %d 8" w h);
      if !comments then p "% Transformation matrix";
      p (sprintf "[ %d 0 0 %d 0 %d ]" w h h);
      p "{ currentfile scanline readhexstring pop } false 3";
      p "colorimage";

      let buf = String.create (imgw * 3) in
      for y = 0 to y1 - 1 do th.read_next_line buf done;
      let prevperdec = ref (-1) in
      for y = y1 to y1 + h - 1 do
        let perdec = (y - y1) * 10 / h in
        if !prevperdec <> perdec then begin
          prerr_endline (sprintf "%d0 %% done" perdec);
          prevperdec := perdec
        end;
        th.read_next_line buf;
        let print_pixel =
          if not conf.mono then
            function x ->
              let adrs = x * 3 in
              for i = 0 to 2 do
                print_string (sprintf "%02x" (Char.code buf.[adrs+i]))
              done
          else
            let mono r g b =
              (r * 256 / 3 + g * 256 / 2 + b * 256 / 6) / 256 in
            function x ->
              let adrs = x * 3 in
              let m =
                mono (Char.code buf.[adrs])
                     (Char.code buf.[adrs + 1])
                     (Char.code buf.[adrs + 2]) in
              for i = 0 to 2 do print_string (sprintf "%02x" m) done in
        if not conf.mirror
        then for x = x1 to x1 + w - 1 do print_pixel x done
        else for x = x1 + w - 1 downto x1 do print_pixel x done;
        print_newline ()
      done;
      prerr_endline "100 % done";
      th.close ();
      p "grestore") in

  let funcs = List.map output_image_func files in

  (* Header *)
  if !comments then begin
    p "%!PS-Adobe-3.0";
    p "%%Creator: Tiffps by Jun FURUSE";
    p ("%%Title: "^
       (Mstring.catenate_sep "+" (List.map (fun f -> f.name) files)));
    p "%%DocumentData: Clean7Bit";
    p "%%Pages: 1";
    p (sprintf "%%%%BoundingBox: %f %f %f %f" !bbx1 !bby1 !bbx2 !bby2);
    p "%%EndComments";
    p "%%BeginProlog";
    p "% Use own dictionary to avoid conflicts";
    p "5 dict begin";
    p "%%EndProlog";
    if !showpage then p "%%Page: 1 1";
  end;

  List.iter (fun f -> f ()) funcs;

  if !showpage then p "showpage";
  if !comments then p "%%Trailer";
  p "end";
  if !comments then p "%%EOF";;

main ();;