#directory "+libMagick/"
#load "magick.cma"
#directory "+xml-light/"
#load "xml-light.cma"
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
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)
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)
let sources = [
("read_file", src_from_img);
("create_image", src_from_scratch);
]
let flt_blur = (fun layout params ->
let radius =
try float_of_string (List.assoc "radius" params)
with Not_found -> 0.0
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)
let flt_motion_blur = (fun layout params ->
let radius =
try float_of_string (List.assoc "radius" params)
with Not_found -> 0.0
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)
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)
let flt_emboss = (fun layout params ->
let radius =
try float_of_string (List.assoc "radius" params)
with Not_found -> 0.0
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)
let flt_charcoal = (fun layout params ->
let radius =
try float_of_string (List.assoc "radius" params)
with Not_found -> 0.0
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)
let flt_edge = (fun layout params ->
let radius =
try float_of_string (List.assoc "radius" params)
with Not_found -> 0.0
in
Magick.Fun.edge ~radius () ~img:layout;
: filter)
let flt_modulate = (fun layout params ->
let brightness =
try int_of_string (List.assoc "brightness" params)
with Not_found -> 100
in
let saturation =
try int_of_string (List.assoc "saturation" params)
with Not_found -> 100
in
let hue =
try int_of_string (List.assoc "hue" params)
with Not_found -> 100
in
Magick.Fun.modulate ~brightness ~saturation ~hue () ~img:layout;
: filter)
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
in
Magick.Fun.shade ~gray ~azimuth ~elevation () ~img:layout;
: filter)
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)
let flt_normalize = (fun layout params ->
Magick.Fun.normalize () ~img:layout;
: filter)
let flt_enhance = (fun layout params ->
Magick.Fun.enhance () ~img:layout;
: filter)
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
in
Magick.Fun.negate ~grayscale () ~img:layout;
: filter)
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)
let flt_equalize = (fun layout params ->
Magick.Fun.equalize () ~img:layout;
: filter)
TODO
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);
]
let cmp_composite = (fun layout_1 layout_2 params ->
let x =
try int_of_string (List.assoc "x" params)
with Not_found -> 0
in
let y =
try int_of_string (List.assoc "y" params)
with Not_found -> 0
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)
let compositors = [
("composite", cmp_composite);
]
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
let rev_assoc l =
List.map (fun (a, b) -> (b, a)) l
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 =
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
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)
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
let _ =
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;
;;