path: root/gdtest.ml

(* $Header: /home/cvs/gd4o/gdtest.ml,v 1.7 2003/11/25 01:02:32 matt Exp $ *)
(*
 * GD4O: An OCaml interface to the Gd graphics library.
 * Based on Shawn Wagner's OCamlGD 0.7.0.
 * Copyright (C) 2002  Shawn Wagner
 * Copyright (C) 2003  Matthew C. Gushee
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)

open Gd;;


let write_header ch title desc =
  output_string ch ("************************************" ^
                    "************************************\n\n");
  output_string ch (title ^ ":\n");
  output_string ch (desc ^ "\n\n");
  output_string ch ("------------------------------------" ^
                    "------------------------------------\n\n\n")

let write_footer ch msg =
  output_string ch ("\n\n" ^ msg ^ "\n");
  output_string ch ("====================================" ^
                    "====================================\n\n\n")

let ok n msg = "   " ^ string_of_int n ^ ": [--OK--]: " ^ msg ^ "\n"
let failed n msg = "   " ^ string_of_int n ^ ": [FAILED]: " ^ msg ^ "\n"

let skiplineRE = Str.regexp "^\\([ \t]*#.*\\|[ \t]*\\)$"

let deg2rad = ( *. ) (3.1415926535 /. 180.)

let tempdir =
  try
    Sys.getenv "TMP"
  with Not_found ->
    begin
      try
        Sys.getenv "TEMP"
      with Not_found ->
        if Sys.file_exists "/tmp" then "/tmp"
        else if Sys.file_exists "/var/tmp" then "/var/tmp"
        else Sys.getcwd ()
    end;;


let shapes_test msg_ch =
  write_header msg_ch "SHAPES"
    ( "Create an image displaying various interesting shapes.\n" ^
      "Save output as 'shapes_test.png'.");
  let msg = output_string msg_ch in
  let img =
    try
      let i = create 512 384 in
      msg (ok 1 "created image");
      i
    with _ -> failwith "Failed to create image." in
  let ca =
    try
      let c = img#colors in
      msg (ok 2 "obtained color allocator instance");
      c
    with _ -> failwith "Failed to get color allocator." in
  let white =
    try
      let w = ca#white in
      msg (ok 3 "allocated white");
      w
    with _ -> failwith "Failed to get white."
  and ltblue, maroon, orange, aqua, grey, brown =
    try
      let more =
        ca#create 127 127 255, ca#create 127 0 0, ca#create 191 127 0,
        ca#create 0 153 204, ca#create 153 153 153, ca#create 127 127 0 in
      msg (ok 4 "allocated additional colors");
      more
    with _ -> failwith "Failed to create additional colors." in
  begin
    try
      img#rectangle 10 10 180 140 maroon;
      msg (ok 5 "drew outline rectangle")
    with _ -> msg (failed 5 "Failed to draw outline rectangle.")
  end;
  begin
    try
      img#filled_rectangle 50 40 220 170 ltblue;
      msg (ok 6 "drew filled rectangle")
    with _ -> msg (failed 6 "Failed to draw filled rectangle.")
  end;
  begin
    try
      img#set_antialiased aqua;
      begin
        try
          img#arc ~cx:108 ~cy:276 ~w:192 ~h:128 ~s:0 ~e:270 
            ~pseudo:(ca#antialiased ()) aqua;
          msg (ok 7 "drew partial outline arc with antialiased pseudocolor")
        with _ -> msg (failed 7 "Failed to draw partial outline arc.")
      end
    with _ -> msg (failed 7 "Failed to set antialiased color.")
  end;
  begin
    try
      img#filled_ellipse 144 300 192 128 grey;
      msg (ok 8 "drew filled ellipse")
    with _ -> msg (failed 8 "Failed to draw filled ellipse.")
  end;
  begin
    try
      img#set_antialiased brown;
      begin
        try
          img#polygon
            ~pts:[|280,80;340,32;440,48;440,144;360,144;280,108;280,80|] 
            ~pseudo:(ca#antialiased ()) brown;
          msg (ok 9 "drew outline polygon with antialiased pseudocolor")
        with _ -> msg (failed 9 "Failed to draw polygon.")
      end
    with _ -> msg (failed 9 "Failed to set antialiased color.")
  end;
  begin
    try
      img#filled_polygon 
        [|320,110;380,62;480,78;480,174;400,174;320,138;320,110|] orange;
      msg (ok 10 "drew filled polyon")
    with _ -> msg (failed 10 "Failed to draw filled polygon.")
  end;
  begin
    try
      img#string
        ~x:244 ~y:228 ~font:Gd.Font.giant 
        ~s:"As I was coming up the stair," orange;
      msg (ok 11 "drew string 1")
    with _ -> msg (failed 11 "Failed to draw string 1.")
  end;
  begin
    try
      img#string
        ~x:254 ~y:260 ~font:Gd.Font.large 
        ~s:"I met a man who wasn't there." grey;
      msg (ok 12 "drew string 2")
    with _ -> msg (failed 12 "Failed to draw string 2.")
  end;
  begin
    try
      img#string
        ~x:264 ~y:290 ~font:Gd.Font.medium
        ~s:"He wasn't there again today!" aqua;
      msg (ok 13 "drew string 3")
    with _ -> msg (failed 13 "Failed to draw string 3.")
  end;
  begin
    try
      img#string
        ~x:274 ~y:318 ~font:Gd.Font.small 
        ~s:"I wish, I wish, he'd go away." maroon;
      msg (ok 14 "drew string 4")
    with _ -> msg (failed 14 "Failed to draw string 4.")
  end;
  img#save_as_png (Filename.concat tempdir "shapes_test.png");
  write_footer msg_ch "END SHAPES"


let color_allocation_test msg_ch =
  write_header msg_ch "COLOR ALLOCATION"
    ("Create an 8-bit image and a truecolor image, and attempt to allocate\n"^
     "a large number of colors in each. The test should fail at index 256 \n"^
     "for the 8-bit image, and should *not* fail for the truecolor image.");
  let msg = output_string msg_ch in
  let rgbvals = [|0; 31; 63; 95; 127; 159; 191; 223; 255|] in
  let numvals = Array.length rgbvals in
  let last = numvals - 1 in
  let do_colors img is_tc testno =
    let (ca : color_allocator) = img#colors
    and index = ref 0 in
    try
      for r = 0 to last do
        for g = 0 to last do
          for b = 0 to last do
            index := (r * numvals * numvals + g * numvals + b);
            ignore (ca#create rgbvals.(r) rgbvals.(g) rgbvals.(b))
          done;
        done;
      done;
      if is_tc then
        msg (ok testno "Truecolor - all colors successfully allocated.")
      else
        msg (failed testno "8bit - too many colors allocated without error.")
    with
    | Too_many_colors ->
      if is_tc then
        msg (failed testno ("Truecolor - failed at index " ^ 
                             string_of_int !index ^ ".")) else
      if !index = 256 then
        msg (ok testno "8bit - failed at index 256.") 
      else
        msg (failed testno ("8bit - failed at index " ^ 
                             string_of_int !index ^ "."))
    | _ ->
      if is_tc then msg (failed testno ("Truecolor - unknown exception " ^ 
                                        "at index " ^
                                        string_of_int !index ^ "."))
      else msg (failed testno ("8bit - unknown exception at index " ^
                                string_of_int !index ^ ".")) in
  do_colors (create 256 256) false 1;
  do_colors (create_truecolor 256 256) true 2;
  write_footer msg_ch "END COLOR ALLOCATION"

      
let copy_resize_test msg_ch =
  write_header msg_ch "COPYING AND RESIZING"
    ( "Test copying and resizing functions.\n" ^
      "1. Copy a small image into a larger image with 'copy'.\n" ^
      "2. Copy a portion of an image into a larger image with 'copy'.\n" ^
      "3. Copy a small image into a larger image with 'copy_resized'.\n" ^
      "4. Copy a small image into a larger image with 'copy_resampled'.\n" ^
      "   Compare the output with that of test #2; details should be\n" ^
      "   smoother.\n" ^
      "5. Copy a small image into a larger image with 'copy_rotated'.\n" ^
      "6. Copy a small image into a larger image with 'copy_merge'.\n" ^
      "7. Copy a small image into a larger image with 'copy_merge_gray'.\n" ^
      "8. Create a new image, copy the palette from an existing image,\n" ^
      "   then copy the contents of the second image. If the palette is\n" ^
      "   copied correctly, this should produce a copy whose colors and\n" ^
      "   dimensions are identical to the original.\n");
  let msg = output_string msg_ch in
  let indexed_img1 = "yotei02-8.png"
  and truecolor_img1 = "yotei02-t.png"
  and indexed_img2 = "driver01-8.png"
  and truecolor_img2 = "driver01-t.png"
  and indexed_img3 = "kamokamogawa04-8.png"
  and truecolor_img3 = "kamokamogawa04-t.png" in
  let img_path name = 
    Filename.concat "." (Filename.concat "samples" name) in

  let get_dims dst src = dst#width, dst#height, src#width, src#height in
  
  let test1 img1 img2 =
    let dst = open_png (img_path img1)
    and src = open_png (img_path img2) in
    try
      let outfile = "copy.png" in
      let dw, dh, sw, sh = get_dims dst src in    
      dst#copy src ~x:((dw - sw) / 2) ~y:((dh - sh) / 2)
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 1 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 1 "image#copy test failed.")

  and test2 img1 img2 =
    let dst = open_png (img_path img1)
    and src = open_png (img_path img2) in
    try
      let outfile = "copy(crop).png" in
      let dw, dh, sw, sh = get_dims dst src in    
      let crop_x = int_of_float ((float_of_int sw) *. 0.35)
      and crop_y = int_of_float ((float_of_int sh) *. 0.35) in
      dst#copy src ~x:(dw / 2) ~y:(dh / 2)
        ~src_x:crop_x ~src_y:crop_y ~w:(sw / 2) ~h:(sh / 2);
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 2 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 2 "image#copy cropping test failed.")

  and test3 img1 img2 =
    let dst = open_png (img_path img1)
    and src = open_png (img_path img2) in
    try
      let outfile = "copy_resized.png" in 
      let dw, dh, sw, sh = get_dims dst src in    
      let new_w = (int_of_float ((float_of_int sw) *. 0.75))
      and new_h = (int_of_float ((float_of_int sh) *. 1.1)) in
      dst#copy_resized src ~x:((dw - new_w) / 2) ~y:((dh - new_h) / 2)
        ~src_x:0 ~src_y:0 ~src_w:sw ~src_h:sh ~w:new_w ~h:new_h;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 3 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 3 "image#copy_resized test failed.")

  and test4 img1 img2 =
    let dst = open_png (img_path img1)
    and src = open_png (img_path img2) in
    try
      let outfile = "copy_resampled.png" in
      let dw, dh, sw, sh = get_dims dst src in    
      let new_w = (int_of_float ((float_of_int sw) *. 0.75))
      and new_h = (int_of_float ((float_of_int sh) *. 1.1)) in
      dst#copy_resampled src ~x:((dw - new_w) / 2) ~y:((dh - new_h) / 2)
        ~src_x:0 ~src_y:0 ~src_w:sw ~src_h:sh ~w:new_w ~h:new_h;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 4 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 4 "image#copy_resampled test failed.")

  and test5 img1 img2 =
    let dst = open_png (img_path img1)
    and src = open_png (img_path img2) in
    try
      let outfile = "copy_rotated.png" in
      let dw, dh, sw, sh = get_dims dst src in    
      let cx = (float_of_int dw) /. 2.
      and cy = (float_of_int dh) /. 2. in
      dst#copy src ~x:((dw - sw) / 2) ~y:((dh - sh) / 2)
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh;
      dst#copy_rotated src ~x:cx ~y:cy
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh ~angle:30;
      dst#copy_rotated src ~x:cx ~y:cy
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh ~angle:60;
      dst#copy_rotated src ~x:cx ~y:cy
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh ~angle:90;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 5 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 5 "image#copy_rotated test failed.")

  and test6 img =
    let src = open_png (img_path img) in
    let sw = src#width
    and sh = src#height in
    let dw = sw * 2
    and dh = sh * 2 in
    let dst = create ~x:dw ~y:dh in
    try
      let outfile = "copy_merge.png" in
      let dw, dh, sw, sh = get_dims dst src in
      let ca = dst#colors in
      ignore (ca#create 0 204 153);
      dst#copy_merge src ~x:((dw - sw) / 2) ~y:((dh - sh) / 2)
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh ~pct:50;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 6 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 6 "image#copy_merge test failed.")

  and test7 img =
    let src = open_png (img_path img) in
    let sw = src#width
    and sh = src#height in
    let dw = sw * 2
    and dh = sh * 2 in
    let dst = create ~x:dw ~y:dh in
    try
      let outfile = "copy_merge_gray.png" in
      let dw, dh, sw, sh = get_dims dst src in
      let ca = dst#colors in
      ignore (ca#create 0 204 153);
      dst#copy_merge_gray src ~x:((dw - sw) / 2) ~y:((dh - sh) / 2)
        ~src_x:0 ~src_y:0 ~w:sw ~h:sh ~pct:50;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 7 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 7 "image#copy_merge_gray test failed.")

  and test8 img =
    let src = open_png (img_path img) in
    let sw = src#width
    and sh = src#height in
    let dw = sw
    and dh = sh in
    let dst = create ~x:dw ~y:dh in
    try
      let outfile = "palette_copy.png" in
      let dw, dh, sw, sh = get_dims dst src in    
      dst#palette_copy src;
      dst#copy src ~x:0 ~y:0 ~src_x:0 ~src_y:0 ~w:sw ~h:sh;
      dst#save_as_png (Filename.concat tempdir outfile);
      msg (ok 8 ("Saved " ^ outfile ^ "."))
    with _ ->
      msg (failed 8 "image#palette_copy test failed.") in

  test1 indexed_img1 indexed_img2;
  test2 indexed_img1 indexed_img2;
  test3 truecolor_img1 indexed_img2;
  test4 truecolor_img1 indexed_img2;
  test5 truecolor_img1 truecolor_img2;
  test6 indexed_img2;
  test7 indexed_img2;
  test8 indexed_img3;

  write_footer msg_ch "END COPYING AND RESIZING"


let io_test msg_ch =
  write_header msg_ch "INPUT/OUTPUT"
    ( "Test loading and saving functions.\n" ^
      "1. Save to PNG with 'save_to_png'.\n" ^
      "2. Save to JPEG with 'save_to_jpeg,' quality 100.\n" ^
      "3. Save to JPEG with 'save_to_jpeg,' quality 60.\n" ^
      "4. Save to PNG with 'open_out' -> 'out_as_png'.\n" ^
      "5. Save to JPEG with 'open_out' -> 'out_as_jpeg'.\n"); 
  let msg = output_string msg_ch in
  let draw () =
    let img = create 256 256 in
    let ca = img#colors in
    let white = ca#white
    and red = ca#create 255 0 0
    and black = ca#black in
    img#filled_ellipse 64 64 100 100 red;
    img#filled_ellipse 192 64 100 100 black;
    img#filled_ellipse 64 192 100 100 black;
    img#filled_ellipse 192 192 100 100 red;
    img in
  let fname = (Filename.concat tempdir "io_test-d.png")
  and im = draw () in
  begin
    try
      im#save_as_png fname;
      msg (ok 1 "Saved " ^ fname)
    with _ -> msg (failed 1 "Failed to save " ^ fname)
  end;
  
  let fname = Filename.concat tempdir "io_test-d-100.jpg"
  and im = draw () in
  begin
    try
      im#save_as_jpeg ~quality:100 fname;
      msg (ok 2 "Saved " ^ fname);
    with _ -> msg (failed 2 "Failed to save " ^ fname)
  end;
  
  let fname = Filename.concat tempdir "io_test-d-60.jpg"
  and im = draw () in
  begin
    try
      im#save_as_jpeg ~quality:60 fname;
      msg (ok 3 "Saved " ^ fname);
    with _ -> msg (failed 3 "Failed to save " ^ fname)
  end;
  
  let fname = Filename.concat tempdir "io_test-i.png"
  and im = draw ()
  and oc = open_out fname in
  begin
    try
      im#out_as_png oc;
      msg (ok 4 "Saved " ^ fname);
    with _ -> msg (failed 4 "Failed to save " ^ fname)
  end;
  close_out oc;
  
  let fname = Filename.concat tempdir "io_test-i.jpg"
  and im = draw ()
  and oc = open_out fname in
  begin
    try
      im#out_as_jpeg oc;
      msg (ok 5 "Saved " ^ fname);
    with _ -> msg (failed 5 "Failed to save " ^ fname)
  end;
  close_out oc;
  write_footer msg_ch "END INPUT/OUTPUT"


let ft_test msg_ch fonts =
  try
    let [ f1; f2; f3; f4 ] = fonts in
    write_header msg_ch "TRUETYPE FONT RENDERING"
      ( "Test of #image#string_ft. Create an image with a white\n" ^
        "background and four strings with the following properties:\n" ^
        "  1. 24pt, blue, start at x:60,y:236, slopes upward 30 deg.\n" ^
        "  2. 18pt, grey, start at x:60,y:272\n" ^
        "  3. 12pt, red, start at x:60,y:96\n" ^
        "  4. 8pt, black, start at x:60,y:316\n" ^
        "Save output as 'ft_test.png'.");
    let msg = output_string msg_ch in
    let im = create 512 384 in
    let ca = im#colors in
    let white = ca#white
    and black = ca#black
    and grey = ca#create 153 153 153
    and red = ca#create 204 0 0
    and blue = ca#create 47 47 255 in
    ignore (im#string_ft blue f1 24.0 (deg2rad 30.) 60 236 
      "As I was coming up the stair,");
    msg (ok 1 "Rendered first string.");
    ignore (im#string_ft grey f2 18.0 0.0 60 272 
      "I met a man who wasn't there.");
    msg (ok 2 "Rendered second string.");
    ignore (im#string_ft red f3 12.0 0.0 60 296 
      "He wasn't there again today!");
    msg (ok 3 "Rendered third string.");
    ignore (im#string_ft black f4 8.0 0.0 60 316 
      "I wish, I wish, he'd go away.");
    msg (ok 4 "Rendered fourth string.");
    im#save_as_png (Filename.concat tempdir "ft_test.png");
    write_footer msg_ch "END TRUETYPE FONT RENDERING"
  with Match_failure _ ->
    prerr_endline 
      "The TrueType font test requires a list of four font files."
      

let ftex_test msg_ch fonts =
  try
    let fnt = List.hd fonts in
    write_header msg_ch "TRUETYPE FONT EXTENDED RENDERING"
      ( "Test of #image#string_ftex. Create an image with a white\n" ^
        "background and a four-line poem in black 14pt type, widely\n" ^
        "spaced (2.5 * line height); save output as 'ftex_test.png'.");
    let msg = output_string msg_ch in
    let im = create 512 384 in
    let ca = im#colors in
    let white = ca#white
    and black = ca#black in
    let poem = ( "As I was coming up the stair,\n" ^ 
      "I met a man who wasn't there.\n" ^
      "He wasn't there again today!\n" ^
      "I wish, I wish he'd go away." ) in
    ignore (im#string_ftex ~fg:black ~fname:fnt ~size:14.0 ~angle:0.0
      ~x:100 ~y:80 ~flags:[|FTExSetSpacing|] ~spacing:2.5 poem);
    msg (ok 1 "Rendered poem.");
    im#save_as_png (Filename.concat tempdir "ftex_test.png");
    msg (ok 2 "Saved to 'ftex_test.png'");
    write_footer msg_ch "END TRUETYPE FONT EXTENDED RENDERING"
  with Match_failure _ ->
    prerr_endline 
      "The TrueType font test requires a list of four font files."

let ft_tests msg_ch =
  let rec getfonts ch fnts =
    if List.length fnts >= 4 then fnts
    else
      ( try
          let line = input_line ch in
          if Str.string_match skiplineRE line 0 then
            getfonts ch fnts
          else
            getfonts ch (line :: fnts)
        with End_of_file -> fnts ) in
  if Sys.file_exists "font.list" then
    let ic = open_in "font.list" in
    let fonts = List.rev (getfonts ic []) in
    close_in ic;
    ft_test msg_ch fonts;
    ftex_test msg_ch fonts
  else
    prerr_endline
      ( "IMPORTANT: if you wish to run the TrueType font rendering tests,\n" ^
        "you must have a file named 'font.list' which contains the full\n" ^
        "pathnames of four font files that exist on your system. For an\n" ^
        "example, see 'font_list.txt'" )
      

let test msg_ch =
  color_allocation_test msg_ch;
  shapes_test msg_ch;
  copy_resize_test msg_ch;
  io_test msg_ch;
  ft_tests msg_ch


let _ =
  prerr_endline ("::::::::::::::::::::::::::::::::::::" ^
                 "::::::::::::::::::::::::::::::::::::");
  prerr_endline ("Starting tests. Files will be saved in " ^ tempdir ^ ".");
  prerr_endline ("::::::::::::::::::::::::::::::::::::" ^
                 "::::::::::::::::::::::::::::::::::::");
  if Array.length Sys.argv >= 2 then
    let logfile = Sys.argv.(1) in
    let msgchannel = open_out logfile in
    test msgchannel;
    prerr_endline ("Tests completed. For details, see " ^ logfile ^ ".");
    close_out msgchannel
  else
    begin
      test stderr;
      prerr_endline "Tests completed."
    end