(* $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 -> (
    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 ())

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 ~x:512 ~y: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 ltblue, maroon, orange, aqua, grey, brown =
    try
      let more =
        ( ca#create ~red:127 ~green:127 ~blue:255,
          ca#create ~red:127 ~green:0 ~blue:0,
          ca#create ~red:191 ~green:127 ~blue:0,
          ca#create ~red:0 ~green:153 ~blue:204,
          ca#create ~red:153 ~green:153 ~blue:153,
          ca#create ~red:127 ~green:127 ~blue:0 )
      in
      msg (ok 4 "allocated additional colors");
      more
    with _ -> failwith "Failed to create additional colors."
  in
  begin
    try
      img#rectangle ~x1:10 ~y1:10 ~x2:180 ~y2:140 maroon;
      msg (ok 5 "drew outline rectangle")
    with _ -> msg (failed 5 "Failed to draw outline rectangle.")
  end;
  begin
    try
      img#filled_rectangle ~x1:50 ~y1:40 ~x2:220 ~y2:170 ltblue;
      msg (ok 6 "drew filled rectangle")
    with _ -> msg (failed 6 "Failed to draw filled rectangle.")
  end;
  begin
    try
      img#set_antialiased aqua;
      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.")
    with _ -> msg (failed 7 "Failed to set antialiased color.")
  end;
  begin
    try
      img#filled_ellipse ~cx:144 ~cy:300 ~w:192 ~h:128 grey;
      msg (ok 8 "drew filled ellipse")
    with _ -> msg (failed 8 "Failed to draw filled ellipse.")
  end;
  begin
    try
      img#set_antialiased brown;
      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.")
    with _ -> msg (failed 9 "Failed to set antialiased color.")
  end;
  begin
    try
      img#filled_polygon
        ~pts:[|
          (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 ~red:rgbvals.(r) ~green:rgbvals.(g) ~blue: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 ~x:256 ~y:256) false 1;
  do_colors (create_truecolor ~x:256 ~y: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" 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 ~red:0 ~green:204 ~blue: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 ~red:0 ~green:204 ~blue: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 _, _, 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 ~x:256 ~y:256 in
    let ca = img#colors in
    let red = ca#create ~red:255 ~green:0 ~blue:0 and black = ca#black in
    img#filled_ellipse ~cx:64 ~cy:64 ~w:100 ~h:100 red;
    img#filled_ellipse ~cx:192 ~cy:64 ~w:100 ~h:100 black;
    img#filled_ellipse ~cx:64 ~cy:192 ~w:100 ~h:100 black;
    img#filled_ellipse ~cx:192 ~cy:192 ~w:100 ~h: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 = match fonts with
      | f1 :: f2 :: f3 :: f4 :: _ -> f1, f2, f3, f4
      | _ -> assert false
    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 ~x:512 ~y:384 in
    let ca = im#colors in
    let black = ca#black
    and grey = ca#create ~red:153 ~green:153 ~blue:153
    and red = ca#create ~red:204 ~green:0 ~blue:0
    and blue = ca#create ~red:47 ~green:47 ~blue:255 in
    ignore
      (im#string_ft ~fg:blue ~fname:f1 ~size:24.0 ~angle:(deg2rad 30.) ~x:60 ~y:236
         "As I was coming up the stair,");
    msg (ok 1 "Rendered first string.");
    ignore
      (im#string_ft ~fg:grey ~fname:f2 ~size:18.0 ~angle:0.0 ~x:60 ~y:272 "I met a man who wasn't there.");
    msg (ok 2 "Rendered second string.");
    ignore (im#string_ft ~fg:red ~fname:f3 ~size:12.0 ~angle:0.0 ~x:60 ~y:296 "He wasn't there again today!");
    msg (ok 3 "Rendered third string.");
    ignore
      (im#string_ft ~fg:black ~fname:f4 ~size:8.0 ~angle:0.0 ~x:60 ~y: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 ~x:512 ~y:384 in
    let ca = im#colors in
    let 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