diff --git a/css/ot_color_picker.css b/css/ot_color_picker.css new file mode 100644 index 00000000..f96f4a97 --- /dev/null +++ b/css/ot_color_picker.css @@ -0,0 +1,26 @@ +/* It regroups one table of colors */ +.ot-color-picker-table { +} + +.ot-color-picker-table-td { +} + +.ot-color-picker-table-tr { +} + +/* A class for the div contained in each table cell. It is used to display the + * color to select. */ +.ot-color-picker-square { + height: 0.9em; + width: 0.9em; + border-radius:0.1em; +} + +/* The set of tables of colors */ +.ot-color-picker-block { +} + + +/* A class for the div that displays the currently selected color. */ +.ot-color-picker-current-color { +} diff --git a/src/widgets/ot_color_picker.eliom b/src/widgets/ot_color_picker.eliom new file mode 100644 index 00000000..34497bf8 --- /dev/null +++ b/src/widgets/ot_color_picker.eliom @@ -0,0 +1,162 @@ +[%%shared + +open Eliom_content.Html +open Eliom_content.Html.F + +type div = Html_types.div Eliom_content.Html.D.elt +type t = (string ref * div * div list * div) + +let raise_color_samples_exception () = + let message = "Ot_color_picker.generate_color_samples, \ + the argument have to be greater than 1" in + invalid_arg message + +let generate_color_samples precision = + let color_list = + if precision <= 1 || precision > 256 then raise_color_samples_exception () + else + let step = 255 / (precision - 1) in + let rec aux_build nl v = + if (v > 255) + then nl + else aux_build ((Printf.sprintf "%02X" v)::nl) (v + step) + in aux_build [] 0 + in List.map (fun red -> + List.map (fun green -> + List.map (fun blue -> + String.concat "" ["#"; red; green; blue] + ) color_list ) color_list ) color_list + +(* Some pre-generated color samples in several precisions. *) +let color_samples_p2 = lazy (generate_color_samples 2) +let color_samples_p3 = lazy (generate_color_samples 3) +let color_samples_p4 = lazy (generate_color_samples 4) +let color_samples_p5 = lazy (generate_color_samples 5) +let color_samples_p6 = lazy (generate_color_samples 6) + +(* Some hand-mained color samples *) +let color_samples_10 = [[["#E03625"; "#FF4B3A"]; + ["#FF7E02"; "#FFC503"]; + ["#01CD64"; "#AF58B9"]; + ["#0198DD"; "#254760"]; + ["#FFFFFF"; "#000000"]]] + +let color_samples_6 = [[["#BEC3C7"; "#7A8E8D"]; + ["#1C3D50"; "#0280B4"]; + ["#00A385"; "#A444B2"]]] + + +(* Take a list of lists of lists of colors (strings) and returns a table list. + Also returns a div_color_list for launching start script detection. *) +let generate_color_table color_samples = + + let build_color_div color = + D.div ~a:[a_class["ot-color-picker-square"]; + a_title color; + a_style ("background-color: " ^ color ^ ";")] + [] + in + let build_td_color color_div = + td ~a:[a_class["ot-color-picker-table-td"]] [color_div] + in + let build_tr_color tds = + tr ~a:[a_class["ot-color-picker-table-tr"]] tds + in + + let rec build_table div_color_list tables = function + | [] -> div_color_list, tables + | head::tail -> + + let rec build_column div_color_list trs = function + | [] -> div_color_list, trs + | head::tail -> + + let rec build_line div_color_list tds = function + | [] -> div_color_list, tds + | color::tail -> + + let color_div = build_color_div color in + build_line + (color_div::div_color_list) + ((build_td_color color_div)::tds) + tail + in + + let div_color_list', tds = build_line div_color_list [] head in + build_column + div_color_list' + ((build_tr_color tds)::trs) + tail + in + + let div_color_list', trs = build_column div_color_list [] head in + let tbl = table ~a:[a_class["ot-color-picker-table"]] trs in + build_table + div_color_list' + (tbl::tables) + tail + in + + let div_color_list, tables = build_table [] [] color_samples in + div_color_list, tables + +let make ?(initial_color = 0, 0, 0) ?(color_samples = Lazy.force color_samples_p5) () = + let tbl, trl, tdl = initial_color in + let color_ref = ref (List.nth (List.nth (List.nth color_samples tbl) trl) tdl) in + let div_color_list, tables = generate_color_table color_samples in + let color_div = D.div ~a:[a_class["ot-color-picker-current-color"]; + a_title !color_ref; + a_style ("background-color: " ^ !color_ref ^ ";")] [] + in + let block = D.div ~a:[a_class["ot-color-picker-block"]] tables in + let type_t = (color_ref, color_div, div_color_list, block) in + type_t, color_div, block + +] + +[%%client + +open Lwt + +let fusion (color_ref, color_div, fst_list, block) (_, _, snd_list, _) = + (color_ref, color_div, fst_list@snd_list, block) + +let start (color_ref, color_div, color_list, _) = + let dom_color_div = Eliom_content.Html.To_dom.of_element color_div in + let rec aux = function + | [] -> () + | div_elt::tail -> + let dom_div = Eliom_content.Html.To_dom.of_element div_elt in + Lwt.async (fun () -> + Lwt_js_events.clicks dom_div (fun _ _ -> + Lwt.return + (let color = dom_div##.title in + dom_color_div##.style##.backgroundColor := color; + dom_color_div##.title := color; + color_ref := (Js.to_string color)))); + aux tail + in aux color_list + +let generate_and_append (color_ref, color_div, fst_list, block) new_list = + let div_color_list, tables = generate_color_table new_list in + let aux = function + | tbl::t -> Eliom_content.Html.Manip.appendChild block tbl + | [] -> () + in aux tables; + div_color_list + +let add_square_color color_picker new_list = + let color_ref, color_div, fst_list, block = color_picker in + color_ref, color_div, + fst_list@(generate_and_append color_picker new_list), block + +let add_square_color_and_start color_picker new_list = + let color_ref, color_div, fst_list, block = color_picker in + ignore (start (color_ref, color_div, + generate_and_append color_picker new_list, block)) + +let get_color (color_ref, _ , _, _) = !color_ref + +let get_square_color_div_list (_, _, color_list, _) = color_list + +] diff --git a/src/widgets/ot_color_picker.eliomi b/src/widgets/ot_color_picker.eliomi new file mode 100644 index 00000000..b5e01e4d --- /dev/null +++ b/src/widgets/ot_color_picker.eliomi @@ -0,0 +1,73 @@ +[%%shared.start] + +(** Ot_color_picker : this module allows to generate, client side, a color + selector. This selector consists of a color table and an html div that + displays the current selected color. *) + +(** The main type of Ot_color_picker module *) +type t +type div = Html_types.div Eliom_content.Html.D.elt + +(** The argument is the divisor of 255. It has to be greater than 1 *) +val generate_color_samples : int -> string list list list + +(** Some pre-generated color samples in several precision. Color samples + are list of lists of lists of colors represented in string of hexadecimal + values.*) + +val color_samples_p2 : string list list list Lazy.t +val color_samples_p3 : string list list list Lazy.t +val color_samples_p4 : string list list list Lazy.t +val color_samples_p5 : string list list list Lazy.t +val color_samples_p6 : string list list list Lazy.t + +(** Some hand-mained color samples. *) + +val color_samples_6 : string list list list (* 1 table 2 columns 5 lines *) +val color_samples_10 : string list list list (* 1 table 2 columns 3 lines *) + +(** Take one list (tables) of lists (columns) of lists (lines) of colors (string) + and builds the table of colors with it. + By default this list is initialised with color_samples_p5 + + It returns + - t for future actions, + - color_div, to display the currently selected color, + it is not mandatory to include it in the page + - and the block with all the color squares in the generated table *) +val make : + ?initial_color: int * int * int -> + ?color_samples: string list list list -> + unit -> + (t * div * div) + + + +[%%client.start] + +(** Get two color pickers to fusion in a single one. This new color picker uses + the color squares of both. + It uses color_div of the first color picker given in argument. It also keeps + a reference to the first color picker's block for appending a color in the + future. + This action has to be done before using the start function *) +val fusion : t -> t -> t + +(** It allows to add square color and to append directly in the block that + contains the square colors. + It has to be made before start *) +val add_square_color : t -> string list list list -> t + +(** Launch listeners *) +val start : t -> unit + +(** It allows to add square color after the start function. It have not to be + used before start *) +val add_square_color_and_start : t -> string list list list -> unit + +(** Get the currently selected color of the selector. The fusion or add_square + functions have no effects on it. *) +val get_color: t -> string + +(** get all square color div element *) +val get_square_color_div_list : t -> div list