#! /usr/bin/env ocaml
#directory "+libMagick/"
#load "magick.cma"

#directory "+xml-light/"
#load "xml-light.cma"

(* {{{ types *)

type layer = Magick.image_handle
type parameters = (string * string) list

type source = (parameters -> layer)
type filter = (layer -> parameters -> layer)
type compositor = (layer -> layer -> parameters -> layer)

type dag =
  | Source of source * parameters
  | Filter of filter * parameters * dag
  | Compositor of compositor * parameters * dag * dag
  (*
  | DeCompositor of ((string * dag) list) ref
  | DeCompositor of (string * dag) list
  *)
  | DeCompositor of string

(* }}} *)

(* {{{ sources *)

(* {{{ src_from_img *)

let src_from_img = (fun params ->
  let filename =
    try List.assoc "filename" params
    with Not_found -> invalid_arg "filename"
  in
  Magick.read_image filename : source)

(* }}} *)
(* {{{ src_from_scratch *)

let src_from_scratch = (fun params ->
  let width =
    try int_of_string (List.assoc "width" params)
    with Not_found -> invalid_arg "width"
  in
  let height =
    try int_of_string (List.assoc "height" params)
    with Not_found -> invalid_arg "height"
  in
  let pseudo_format =
    try List.assoc "pseudo_format" params
    with Not_found -> invalid_arg "pseudo_format"
  in
  Magick.create_image ~width ~height ~pseudo_format : source)

(* }}} *)

(* {{{ list of available sources *)

let sources = [
  ("read_file",    src_from_img);
  ("create_image", src_from_scratch);
]

(* }}} *)

(* }}} *)
(* {{{ filters *)

(* {{{ flt_blur *)

let flt_blur = (fun layout params ->
  let radius =
    try float_of_string (List.assoc "radius" params)
    with Not_found -> 0.0  (* default *)
  in
  let sigma =
    try float_of_string (List.assoc "sigma" params)
    with Not_found -> invalid_arg "sigma"
  in
  Magick.Fun.blur ~radius ~sigma () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_motion_blur *)

let flt_motion_blur = (fun layout params ->
  let radius =
    try float_of_string (List.assoc "radius" params)
    with Not_found -> 0.0  (* default *)
  in
  let sigma =
    try float_of_string (List.assoc "sigma" params)
    with Not_found -> invalid_arg "sigma"
  in
  let angle =
    try float_of_string (List.assoc "angle" params)
    with Not_found -> invalid_arg "angle"
  in
  Magick.Fun.motion_blur ~radius ~sigma ~angle () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_radial_blur *)

let flt_radial_blur = (fun layout params ->
  let angle =
    try float_of_string (List.assoc "angle" params)
    with Not_found -> invalid_arg "angle"
  in
  Magick.Fun.radial_blur ~angle () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_emboss *)

let flt_emboss = (fun layout params ->
  let radius =
    try float_of_string (List.assoc "radius" params)
    with Not_found -> 0.0  (* default *)
  in
  let sigma =
    try float_of_string (List.assoc "sigma" params)
    with Not_found -> invalid_arg "sigma"
  in
  Magick.Fun.emboss ~radius ~sigma () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_charcoal *)

let flt_charcoal = (fun layout params ->
  let radius =
    try float_of_string (List.assoc "radius" params)
    with Not_found -> 0.0  (* default *)
  in
  let sigma =
    try float_of_string (List.assoc "sigma" params)
    with Not_found -> invalid_arg "sigma"
  in
  Magick.Fun.charcoal ~radius ~sigma () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_edge *)

let flt_edge = (fun layout params ->
  let radius =
    try float_of_string (List.assoc "radius" params)
    with Not_found -> 0.0  (* default *)
  in
  Magick.Fun.edge ~radius () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_modulate *)

let flt_modulate = (fun layout params ->
  let brightness =
    try int_of_string (List.assoc "brightness" params)
    with Not_found -> 100  (* default *)
  in
  let saturation =
    try int_of_string (List.assoc "saturation" params)
    with Not_found -> 100  (* default *)
  in
  let hue =
    try int_of_string (List.assoc "hue" params)
    with Not_found -> 100  (* default *)
  in
  Magick.Fun.modulate ~brightness ~saturation ~hue () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_shade *)

let flt_shade = (fun layout params ->
  let azimuth =
    try float_of_string (List.assoc "azimuth" params)
    with Not_found -> invalid_arg "azimuth"
  in
  let elevation =
    try float_of_string (List.assoc "elevation" params)
    with Not_found -> invalid_arg "elevation"
  in
  let gray =
    try
      match String.lowercase (List.assoc "gray" params) with
      | "false" | "magickfalse"    -> Magick.MagickFalse
      | "true"  | "magicktrue" | _ -> Magick.MagickTrue
    with
      Not_found -> Magick.MagickTrue  (* this is the default value *)
  in
  Magick.Fun.shade ~gray ~azimuth ~elevation () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_swirl *)

let flt_swirl = (fun layout params ->
  let degrees =
    try float_of_string (List.assoc "degrees" params)
    with Not_found -> invalid_arg "degrees"
  in
  Magick.Fun.swirl ~degrees () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_normalize *)

let flt_normalize = (fun layout params ->
  Magick.Fun.normalize () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_enhance *)

let flt_enhance = (fun layout params ->
  Magick.Fun.enhance () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_negate *)

let flt_negate = (fun layout params ->
  let grayscale =
    try
      match String.lowercase (List.assoc "grayscale" params) with
      | "true"  | "magicktrue"      -> Magick.MagickTrue
      | "false" | "magickfalse" | _ -> Magick.MagickFalse
    with
      Not_found -> Magick.MagickFalse  (* default *)
  in
  Magick.Fun.negate ~grayscale () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_contrast *)

let flt_contrast = (fun layout params ->
  let sharpen =
    try
      match String.lowercase (List.assoc "sharpen" params) with
      | "true"  | "magicktrue"  -> Magick.MagickTrue
      | "false" | "magickfalse" -> Magick.MagickFalse
      | _ -> raise Not_found
    with
      Not_found -> invalid_arg "sharpen"
  in
  Magick.Fun.contrast ~sharpen () ~img:layout;
  : filter)

(* }}} *)
(* {{{ flt_equalize *)

let flt_equalize = (fun layout params ->
  Magick.Fun.equalize () ~img:layout;
  : filter)

(* }}} *)

(* {{{ flt_ *(

let flt_ = (fun layout params ->
  let  =
    try float_of_string (List.assoc "" params)
    with Not_found -> 0.0  (* default *)
    with Not_found -> invalid_arg ""
  in
  Magick.Fun.  () ~img:layout;
  : filter)

)* }}} *)

(* {{{ TODO  
MagickFalse increases the contrast, otherwise reduced it.
 
val despeckle : image_handle -> unit
 
val reduce_noise : image_handle -> radius:float -> unit
 
val median_filter : image_handle -> float -> unit
  
val level : image_handle -> string -> unit

}}} *)

(* {{{ list of available filters *)

let filters = [
  ("blur",        flt_blur);
  ("motion_blur", flt_motion_blur);
  ("radial_blur", flt_radial_blur);
  ("emboss",      flt_emboss);
  ("charcoal",    flt_charcoal);
  ("edge",        flt_edge);
  ("modulate",    flt_modulate);
  ("shade",       flt_shade);
  ("swirl",       flt_swirl);
  ("normalize",   flt_normalize);
  ("enhance",     flt_enhance);
  ("negate",      flt_negate);
  ("contrast",    flt_contrast);
  ("equalize",    flt_equalize);
  (*
  ("",   flt_);
  *)
]

(* }}} *)

(* }}} *)
(* {{{ compositors *)

(* {{{ cmp_composite *)

let cmp_composite = (fun layout_1  layout_2  params ->
  let x =
    try int_of_string (List.assoc "x" params)
    with Not_found -> 0  (* default *)
  in
  let y =
    try int_of_string (List.assoc "y" params)
    with Not_found -> 0  (* default *)
  in
  let compose =
    try Magick.Imper.composite_operator_of_string (List.assoc "compose" params)
    with Not_found -> invalid_arg "compose"
  in
  Magick.Imper.composite_image  layout_1  layout_2 ~compose ~x ~y ();
  layout_1 : compositor)

(* }}} *)

(* {{{ list of available compositors *)

let compositors = [
  ("composite", cmp_composite);
]

(* }}} *)

(* }}} *)

(* {{{ process_dag *)

let rec process_dag dag o =
  let rec dig dag =
    match dag with
    | Source (src_fun, params) -> src_fun  params
    | Filter (flt_fun, params, dag) -> flt_fun (dig dag) params
    | Compositor (cmp_fun, params, dag1, dag2) -> cmp_fun (dig dag1) (dig dag2) params
    | DeCompositor (str_ref) -> let dag = List.assoc str_ref o in dig dag
  in
  dig dag

(* }}} *)
(* {{{ xml_of_dag *)

let rev_assoc l =
  List.map (fun (a, b) -> (b, a)) l

(* {{{ xml_of_params *)

let xml_of_params params =
  let rec aux params p_xml =
    match params with
    | [] -> p_xml
    | (p_name, p_val)::t ->
        let p_nv = Printf.sprintf " %s='%s'" p_name p_val in
        aux t (p_xml ^ p_nv)
  in
  aux params ""

(* }}} *)

let xml_of_dag  dag  dag_assoc =
  (* {{{ utilities *)
  let src_names = rev_assoc sources
  and flt_names = rev_assoc filters
  and cmp_names = rev_assoc compositors
  in
  let src_tag_name src_fun = List.assq src_fun src_names
  and flt_tag_name flt_fun = List.assq flt_fun flt_names
  and cmp_tag_name flt_fun = List.assq flt_fun cmp_names
  in
  let indent = 3 in
  let pad depth =
    String.make (depth * indent) ' '
  in
  (* }}} *)
  (* {{{ dig dag depth *)
  let rec dig dag d =
    match dag with
    | Source (src_fun, params) ->
        Printf.sprintf "%s<%s%s />\n" (pad d) (src_tag_name src_fun) (xml_of_params params)
    | Filter (flt_fun, params, dag) ->
        let tag_name = flt_tag_name flt_fun in
        ((dig dag d) ^
         (Printf.sprintf "%s<%s%s />\n" (pad d) tag_name (xml_of_params params))
        )
    | Compositor (cmp_fun, params, dag1, dag2) ->
        let tag_name = cmp_tag_name cmp_fun in
        let padding = pad d
        and in_padding = pad (succ d)
        in
        ((Printf.sprintf "%s<%s>\n" padding tag_name) ^
         (Printf.sprintf "%s<layer%s>\n" in_padding (xml_of_params params)) ^
         (dig dag1 (d + 2)) ^
         (Printf.sprintf "%s</layer>\n" in_padding) ^
         (Printf.sprintf "%s<layer>\n" in_padding) ^
         (dig dag2 (d + 2)) ^
         (Printf.sprintf "%s</layer>\n" in_padding) ^
         (Printf.sprintf "%s</%s>\n" padding tag_name)
        )
    | DeCompositor (ref_key) ->
        let dag = List.assoc ref_key dag_assoc in
        dig dag (succ d)
  in
  (* }}} *)
  "<?xml version='1.0' ?>\n" ^
  (dig dag 0)

(* }}} *)


(* {{{ print_xml_struc *)

let print_xml_struct  xml_data =
  let indent = 2 in
  let pad depth =
    String.make (depth * indent) ' '
  in
  let rec aux d x =
    match x with
    | Xml.PCData data -> Printf.printf "%s[%s]\n" (pad d) data
    | Xml.Element (tag, attrs_list, childrens) ->
        Printf.printf "%s%s {\n" (pad d) tag;
        List.iter (fun (attr_name, attr_value) ->
          Printf.printf "%s  (%s->%s)\n" (pad d) attr_name attr_value
        ) attrs_list;
        List.iter (aux (succ d)) childrens;
        Printf.printf "%s}\n" (pad d);
  in
  aux 0 xml_data;
  flush stdout

(* }}} *)
(* {{{ main *)

let _ =
  (* {{{ dag datas *)
  let dag_1 =
    (Filter (flt_modulate, [("saturation","60")],
      (Filter (flt_blur, [("sigma","4.0")],
        (Filter (flt_edge, [("radius","8.0")],
          (Source (src_from_scratch,
            [("width","300"); ("height","225"); ("pseudo_format","plasma:fractal")] ))
        ))
      ))
    ))
  in
  let dag_2 =
    (Filter (flt_shade, [("azimuth","270"); ("elevation","30")],
      (Filter (flt_modulate, [("brightness","40")],
        (Source (src_from_scratch,
          [("width","300"); ("height","225"); ("pseudo_format","pattern:hexagons")] ))
      ))
    ))
  in
  let dag_3 =
    (Compositor (cmp_composite, [("compose","HardLight")], dag_1, dag_2))
  in
  let dag_4 =
    (Filter (flt_enhance, [],
      (Filter (flt_normalize, [],
        (Source (src_from_scratch,
          [("width","300"); ("height","225"); ("pseudo_format","gradient:#DB4-#26E")] ))
      ))
    ))
  in
  let dag_5 =
    (Compositor (cmp_composite, [("compose","Blend")],
      (Filter (flt_swirl, [("degrees","80")], dag_3)),
      dag_4
    ))
  in
  (* }}} *)
  let references = [("dag_1",dag_1); ("dag_2",dag_2); ("dag_3",dag_3)] in

  let xml = (xml_of_dag dag_5 references) in
  let xml_dag = Xml.parse_string xml in

  print_endline (Xml.to_string_fmt  xml_dag);
  print_newline();

  print_xml_struct  xml_dag;

  let img = process_dag dag_5 references in
  Magick.display img;
;;

(* }}} *)


(* vim: sw=2 sts=2 ts=2 et fdm=marker
 *)