Source file color_brewery.ml

open Printf

type rgba = Gg.color
type cmyk = Gg.v4

(* Convert x ∈ [0,1] into an integer in [0, 255]. *)
let to_hex x =
  if x <= 0. then 0
  else if x >= 1. then 0xFF
  else truncate(x *. 255. +. 0x1.FFFFFFFFFFFFFp-2)

let to_int c =
  (to_hex(Gg.Color.r c) lsl 16) lor (to_hex(Gg.Color.g c) lsl 8)
  lor (to_hex(Gg.Color.b c))

let to_string c =
  sprintf "#%02x%02x%02x"
    (to_hex(Gg.Color.r c)) (to_hex(Gg.Color.g c)) (to_hex(Gg.Color.b c))

let of_int_exn ?(a=0.) i =
  if i < 0 || i > 0xFFFFFF then invalid_arg "Color_brewery.of_int_exn";
  let r = float(i lsr 16) /. 255. in
  let g = float((i lsr 8) land 0xFF) /. 255. in
  let b = float(i land 0xFF) /. 255. in
  Gg.Color.v r g b a

let of_int ?a i = try Some(of_int_exn ?a i) with _ -> None


let to_gray c =
  let x = 0.299 *. Gg.Color.r c +. 0.587 *. Gg.Color.g c
          +. 0.114 *. Gg.Color.b c in
  Gg.Color.v x x x (Gg.Color.a c)

let[@inline] cmyk_of_rgb c =
  let r, g, b = Gg.Color.(r c, g c, b c) in (* ∈ [0,1] *)
  let k' = max r (max g b) in
  let k = 1. -. k' in
  let c = (1. -. r -. k) /. k' in
  let m = (1. -. g -. k) /. k' in
  let y = (1. -. b -. k) /. k' in
  Gg.V4.v c m y k


let hue_pct h =
  (* h ∈ [0, 1[ instead of the usual h ∈ [0, 360[. *)
  let f, hi = modf (abs_float h *. 6.) in
  match mod_float hi 6. with
  | 0. -> Gg.Color.v 1.        f        0.       1. (* alpha = 1 *)
  | 1. -> Gg.Color.v (1. -. f)  1.       0.       1.
  | 2. -> Gg.Color.v 0.        1.       f        1.
  | 3. -> Gg.Color.v 0.        (1. -. f) 1.       1.
  | 4. -> Gg.Color.v f         0.       1.       1.
  | 5. -> Gg.Color.v 1.        0.       (1. -. f) 1.
  | _ -> assert false

let hue h = hue_pct(h *. 360.)

module Gradient = struct
  (** The functions can assume that the float ∈ [0,1]. *)
  type t = { rgba: float -> rgba;
             cmyk: float -> cmyk }
  type two_colors = { l0: float;  c0: float;  h0: float;  a0: float;
                      dl: float;  dc: float;  dh: float;  da: float }

  let pi = 0x1.921fb54442d18p+1
  let two_pi = 0x1.921fb54442d18p+2

  let from_2_colors c0 c1 =
    let open Gg in
    let lch0 = Color.to_lch_ab c0 in
    let lch1 = Color.to_lch_ab c1 in
    let dl = V4.x lch1 -. V4.x lch0 in
    let dc = V4.y lch1 -. V4.y lch0 in
    let h0 = V4.z lch0 in
    let h1 = V4.z lch1 in
    let dh = if h1 > h0 && h1 -. h0 > pi then h1 -. (h0 +. two_pi)
             else if h1 < h0 && h0 -. h1 > pi then h1 +. two_pi -. h0
             else h1 -. h0 in
    let da = V4.w lch1 -. V4.w lch0 in
    { l0 = V4.x lch0;  c0 = V4.y lch0;  h0;  a0 = V4.w lch0;
      dl; dh; dc; da }

  let rgba_unsafe g t =
    let lch = Gg.V4.v (g.l0 +. t *. g.dl) (g.c0 +. t *. g.dc)
                (g.h0 +. t *. g.dh) (g.a0 +. t *. g.da) in
    Gg.Color.(clamp(of_lch_ab lch))

  let v c0 c1 =
    let g = from_2_colors c0 c1 in
    let rgba = rgba_unsafe g in
    let cmyk t = cmyk_of_rgb(rgba t) in
    { rgba; cmyk }

  let rgba g t =
    let t = if t < 0. then 0. else if t > 1. then 1. else t in
    g.rgba t

  let cmyk g t =
    let t = if t < 0. then 0. else if t > 1. then 1. else t in
    g.cmyk t
end

(* FIXME: generate color ranges between arbitrary colors.  *)
let range ?grad ~n a b =
  let d1 = 1. /. float(n - 1) in
  let dx = (b -. a) *. d1 in
  let l = ref [] in
  let color = match grad with None -> hue_pct
                            | Some g -> g.Gradient.rgba in
  for i = n - 1 downto 0 do
    l := (a +. float i *. dx,  color(float i *. d1)) :: !l
  done;
  !l

let with_colors ?grad l =
  let n = float(List.length l) in
  let color = match grad with None -> hue_pct
                            | Some g -> g.Gradient.rgba in
  List.mapi (fun i a -> (a, color (float i /. n))) l



module Palette = struct
  include Palette_t
  include Palettes (* Generated by make_brewer.ml *)
  (* The important types are defined in the included module. *)

  let length m = m.length
  let ty m = m.ty
  let blind m = m.blind
  let print m = m.print
  let copy m = m.copy
  let lcd m = m.screen

  let rgb m =
    Array.to_list m.rgb (* do not allow modifying the array *)

  let get_rgb m i =
    if i < 0 || i > m.length then invalid_arg "Color_brewery.Palette.get_rgb";
    m.rgb.(i)

  let cmyk m = Array.to_list m.cmyk

  let get_cmyk m i =
    if i < 0 || i > m.length then invalid_arg "Color_brewery.Palette.get_cmyk";
    m.cmyk.(i)

  let unsafe_gradient_truncate colors t =
    let n = Array.length colors in
    let i = truncate (t *. float n) in
    if i < n then colors.(i) else colors.(n - 1)

  let interpolate_palette colors =
    Array.init (Array.length colors - 1) (fun i ->
        Gradient.from_2_colors colors.(i) colors.(i+1))

  let gradient_interpolate interp t =
    let n = Array.length interp in
    let t', i = modf (t *. float n) in
    let i = truncate i in
    if i < n then Gradient.rgba_unsafe interp.(i) t'
    else Gradient.rgba_unsafe interp.(n - 1) 1.

  let gradient ?(interpolate=false) m =
    if interpolate then
      let interp = interpolate_palette m.rgb in
      let rgba t = gradient_interpolate interp t in
      let cmyk t = cmyk_of_rgb(rgba t) in
      { Gradient.rgba = rgba;  Gradient.cmyk = cmyk }
    else
      { Gradient.rgba = unsafe_gradient_truncate m.rgb;
        Gradient.cmyk = unsafe_gradient_truncate m.cmyk }

  let satisfy specified prop =
    match specified with
    | `Yes -> (match prop with
               | `Yes -> true
               | `No | `Maybe -> false)
    | `Maybe -> (match prop with
                 | `Yes | `Maybe -> true
                 | `No -> false)
    | `No -> true

  let find ?ty ?(blind = `No) ?(print = `No) ?(copy = `No)
        ?(lcd = `No) length =
    if length <= 0 then []
    else (
      let is_of_type = match ty with
        | Some ty -> (fun m -> m.ty = ty)
        | None -> (fun _ -> true) in
      let filter m =
        m.length >= length
        && is_of_type m
        && satisfy blind m.blind
        && satisfy print m.print
        && satisfy copy m.copy
        && satisfy lcd m.screen in
      List.filter filter all_maps
    )
end

(** {2 Color blindness}  *)

(* http://vision.psychol.cam.ac.uk/jdmollon/papers/colourmaps.pdf
   https://www.mapbox.com/blog/colorblind-simulation/
   http://colororacle.org/ — https://github.com/nvkelso/colora-oracle-java
 *)

;;