Source file color.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    This program 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 General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Colors. *)

open Tsdl

type t = int32

module Map = Map.Make(Int32)

let compare = Int32.compare
let pp ppf t = Format.fprintf ppf "0x%08lx" t

let to_int8s n32 =
  let n = Int32.to_int n32 in
  let r = (n lsr 24) land 255 in
  let g = (n lsr 16) land 255 in
  let b = (n lsr 8) land 255 in
  let a = n land 255 in
  (r,g,b,a)

let of_rgba =
  let f n = Int32.of_int (max 0 (min n 255)) in
  fun r g b a ->
    Int32.(
     logor (shift_left (f r) 24)
       (logor (shift_left (f g) 16)
        (logor (shift_left (f b) 8)
         (f a)
        )
       )
    )

let of_rgba_0_1 r g b a =
  let f x =
    let n = truncate (x *. 255.) in
    max 0 (min 255 n)
  in
  of_rgba (f r) (f g) (f b) (f a)

let to_sdl_color n =
  let (r, g, b, a) = to_int8s n in
  Sdl.Color.create ~r ~g ~b ~a

let of_hexa =
  let of_small_hex s =
    let b = Buffer.create 8 in
    for i = 0 to 3 do
      Buffer.add_char b s.[i];
      Buffer.add_char b s.[i];
    done;
    Buffer.contents b
  in
  fun s ->
    let len = String.length s in
    let s =
      match len with
      | 3 -> of_small_hex (s^"f")
      | 4 -> of_small_hex s
      | 6 -> s^"ff"
      | _ -> s
    in
    let s = Printf.sprintf "0x%s" s in
    Int32.of_string s

let transparent = Int32.zero

let transparent_int8s = to_int8s transparent

let transparent_sdl =
  let (r,g,b,a) = transparent_int8s in
  Sdl.Color.create ~r ~g ~b ~a

let aliceblue : t = 0xf0f8ffffl
let antiquewhite : t = 0xfaebd7ffl
let aqua : t = 0x00ffffffl
let aquamarine : t = 0x7fffd4ffl
let azure : t = 0xf0ffffffl
let beige : t = 0xf5f5dcffl
let bisque : t = 0xffe4c4ffl
let black : t = 0x000000ffl
let blanchedalmond : t = 0xffebcdffl
let blue : t = 0x0000ffffl
let blueviolet : t = 0x8a2be2ffl
let brown : t = 0xa52a2affl
let burlywood : t = 0xdeb887ffl
let cadetblue : t = 0x5f9ea0ffl
let chartreuse : t = 0x7fff00ffl
let chocolate : t = 0xd2691effl
let coral : t = 0xff7f50ffl
let cornflowerblue : t = 0x6495edffl
let cornsilk : t = 0xfff8dcffl
let crimson : t = 0xdc143cffl
let cyan : t = 0x00ffffffl
let darkblue : t = 0x00008bffl
let darkcyan : t = 0x008b8bffl
let darkgoldenrod : t = 0xb8860bffl
let darkgray : t = 0xa9a9a9ffl
let darkgreen : t = 0x006400ffl
let darkgrey : t = 0xa9a9a9ffl
let darkkhaki : t = 0xbdb76bffl
let darkmagenta : t = 0x8b008bffl
let darkolivegreen : t = 0x556b2fffl
let darkorange : t = 0xff8c00ffl
let darkorchid : t = 0x9932ccffl
let darkred : t = 0x8b0000ffl
let darksalmon : t = 0xe9967affl
let darkseagreen : t = 0x8fbc8fffl
let darkslateblue : t = 0x483d8bffl
let darkslategray : t = 0x2f4f4fffl
let darkslategrey : t = 0x2f4f4fffl
let darkturquoise : t = 0x00ced1ffl
let darkviolet : t = 0x9400d3ffl
let deeppink : t = 0xff1493ffl
let deepskyblue : t = 0x00bfffffl
let dimgray : t = 0x696969ffl
let dimgrey : t = 0x696969ffl
let dodgerblue : t = 0x1e90ffffl
let firebrick : t = 0xb22222ffl
let floralwhite : t = 0xfffaf0ffl
let forestgreen : t = 0x228b22ffl
let fuchsia : t = 0xff00ffffl
let gainsboro : t = 0xdcdcdcffl
let ghostwhite : t = 0xf8f8ffffl
let gold : t = 0xffd700ffl
let goldenrod : t = 0xdaa520ffl
let gray : t = 0x808080ffl
let green : t = 0x008000ffl
let greenyellow : t = 0xadff2fffl
let grey : t = 0x808080ffl
let honeydew : t = 0xf0fff0ffl
let hotpink : t = 0xff69b4ffl
let indianred : t = 0xcd5c5cffl
let indigo : t = 0x4b0082ffl
let ivory : t = 0xfffff0ffl
let khaki : t = 0xf0e68cffl
let lavender : t = 0xe6e6faffl
let lavenderblush : t = 0xfff0f5ffl
let lawngreen : t = 0x7cfc00ffl
let lemonchiffon : t = 0xfffacdffl
let lightblue : t = 0xadd8e6ffl
let lightcoral : t = 0xf08080ffl
let lightcyan : t = 0xe0ffffffl
let lightgoldenrodyellow : t = 0xfafad2ffl
let lightgray : t = 0xd3d3d3ffl
let lightgreen : t = 0x90ee90ffl
let lightgrey : t = 0xd3d3d3ffl
let lightpink : t = 0xffb6c1ffl
let lightsalmon : t = 0xffa07affl
let lightseagreen : t = 0x20b2aaffl
let lightskyblue : t = 0x87cefaffl
let lightslategray : t = 0x778899ffl
let lightslategrey : t = 0x778899ffl
let lightsteelblue : t = 0xb0c4deffl
let lightyellow : t = 0xffffe0ffl
let lime : t = 0x00ff00ffl
let limegreen : t = 0x32cd32ffl
let linen : t = 0xfaf0e6ffl
let magenta : t = 0xff00ffffl
let maroon : t = 0x800000ffl
let mediumaquamarine : t = 0x66cdaaffl
let mediumblue : t = 0x0000cdffl
let mediumorchid : t = 0xba55d3ffl
let mediumpurple : t = 0x9370dbffl
let mediumseagreen : t = 0x3cb371ffl
let mediumslateblue : t = 0x7b68eeffl
let mediumspringgreen : t = 0x00fa9affl
let mediumturquoise : t = 0x48d1ccffl
let mediumvioletred : t = 0xc71585ffl
let midnightblue : t = 0x191970ffl
let mintcream : t = 0xf5fffaffl
let mistyrose : t = 0xffe4e1ffl
let moccasin : t = 0xffe4b5ffl
let navajowhite : t = 0xffdeadffl
let navy : t = 0x000080ffl
let oldlace : t = 0xfdf5e6ffl
let olive : t = 0x808000ffl
let olivedrab : t = 0x6b8e23ffl
let orange : t = 0xffa500ffl
let orangered : t = 0xff4500ffl
let orchid : t = 0xda70d6ffl
let palegoldenrod : t = 0xeee8aaffl
let palegreen : t = 0x98fb98ffl
let paleturquoise : t = 0xafeeeeffl
let palevioletred : t = 0xdb7093ffl
let papayawhip : t = 0xffefd5ffl
let peachpuff : t = 0xffdab9ffl
let peru : t = 0xcd853fffl
let pink : t = 0xffc0cbffl
let plum : t = 0xdda0ddffl
let powderblue : t = 0xb0e0e6ffl
let purple : t = 0x800080ffl
let red : t = 0xff0000ffl
let rosybrown : t = 0xbc8f8fffl
let royalblue : t = 0x4169e1ffl
let saddlebrown : t = 0x8b4513ffl
let salmon : t = 0xfa8072ffl
let sandybrown : t = 0xf4a460ffl
let seagreen : t = 0x2e8b57ffl
let seashell : t = 0xfff5eeffl
let sienna : t = 0xa0522dffl
let silver : t = 0xc0c0c0ffl
let skyblue : t = 0x87ceebffl
let slateblue : t = 0x6a5acdffl
let slategray : t = 0x708090ffl
let slategrey : t = 0x708090ffl
let snow : t = 0xfffafaffl
let springgreen : t = 0x00ff7fffl
let steelblue : t = 0x4682b4ffl
let tan : t = 0xd2b48cffl
let teal : t = 0x008080ffl
let thistle : t = 0xd8bfd8ffl
let tomato : t = 0xff6347ffl
let turquoise : t = 0x40e0d0ffl
let violet : t = 0xee82eeffl
let wheat : t = 0xf5deb3ffl
let white : t = 0xffffffffl
let whitesmoke : t = 0xf5f5f5ffl
let yellow : t = 0xffff00ffl
let yellowgreen : t = 0x9acd32ffl

(* The list of predefined named colors. *)
let named_colors = [
    aliceblue, "aliceblue";
    antiquewhite, "antiquewhite";
    aqua, "aqua";
    aquamarine, "aquamarine";
    azure, "azure";
    beige, "beige";
    bisque, "bisque";
    black, "black";
    blanchedalmond, "blanchedalmond";
    blue, "blue";
    blueviolet, "blueviolet";
    brown, "brown";
    burlywood, "burlywood";
    cadetblue, "cadetblue";
    chartreuse, "chartreuse";
    chocolate, "chocolate";
    coral, "coral";
    cornflowerblue, "cornflowerblue";
    cornsilk, "cornsilk";
    crimson, "crimson";
    cyan, "cyan";
    darkblue, "darkblue";
    darkcyan, "darkcyan";
    darkgoldenrod, "darkgoldenrod";
    darkgray, "darkgray";
    darkgreen, "darkgreen";
    darkgrey, "darkgrey";
    darkkhaki, "darkkhaki";
    darkmagenta, "darkmagenta";
    darkolivegreen, "darkolivegreen";
    darkorange, "darkorange";
    darkorchid, "darkorchid";
    darkred, "darkred";
    darksalmon, "darksalmon";
    darkseagreen, "darkseagreen";
    darkslateblue, "darkslateblue";
    darkslategray, "darkslategray";
    darkslategrey, "darkslategrey";
    darkturquoise, "darkturquoise";
    darkviolet, "darkviolet";
    deeppink, "deeppink";
    deepskyblue, "deepskyblue";
    dimgray, "dimgray";
    dimgrey, "dimgrey";
    dodgerblue, "dodgerblue";
    firebrick, "firebrick";
    floralwhite, "floralwhite";
    forestgreen, "forestgreen";
    fuchsia, "fuchsia";
    gainsboro, "gainsboro";
    ghostwhite, "ghostwhite";
    gold, "gold";
    goldenrod, "goldenrod";
    gray, "gray";
    green, "green";
    greenyellow, "greenyellow";
    grey, "grey";
    honeydew, "honeydew";
    hotpink, "hotpink";
    indianred, "indianred";
    indigo, "indigo";
    ivory, "ivory";
    khaki, "khaki";
    lavender, "lavender";
    lavenderblush, "lavenderblush";
    lawngreen, "lawngreen";
    lemonchiffon, "lemonchiffon";
    lightblue, "lightblue";
    lightcoral, "lightcoral";
    lightcyan, "lightcyan";
    lightgoldenrodyellow, "lightgoldenrodyellow";
    lightgray, "lightgray";
    lightgreen, "lightgreen";
    lightgrey, "lightgrey";
    lightpink, "lightpink";
    lightsalmon, "lightsalmon";
    lightseagreen, "lightseagreen";
    lightskyblue, "lightskyblue";
    lightslategray, "lightslategray";
    lightslategrey, "lightslategrey";
    lightsteelblue, "lightsteelblue";
    lightyellow, "lightyellow";
    lime, "lime";
    limegreen, "limegreen";
    linen, "linen";
    magenta, "magenta";
    maroon, "maroon";
    mediumaquamarine, "mediumaquamarine";
    mediumblue, "mediumblue";
    mediumorchid, "mediumorchid";
    mediumpurple, "mediumpurple";
    mediumseagreen, "mediumseagreen";
    mediumslateblue, "mediumslateblue";
    mediumspringgreen, "mediumspringgreen";
    mediumturquoise, "mediumturquoise";
    mediumvioletred, "mediumvioletred";
    midnightblue, "midnightblue";
    mintcream, "mintcream";
    mistyrose, "mistyrose";
    moccasin, "moccasin";
    navajowhite, "navajowhite";
    navy, "navy";
    oldlace, "oldlace";
    olive, "olive";
    olivedrab, "olivedrab";
    orange, "orange";
    orangered, "orangered";
    orchid, "orchid";
    palegoldenrod, "palegoldenrod";
    palegreen, "palegreen";
    paleturquoise, "paleturquoise";
    palevioletred, "palevioletred";
    papayawhip, "papayawhip";
    peachpuff, "peachpuff";
    peru, "peru";
    pink, "pink";
    plum, "plum";
    powderblue, "powderblue";
    purple, "purple";
    red, "red";
    rosybrown, "rosybrown";
    royalblue, "royalblue";
    saddlebrown, "saddlebrown";
    salmon, "salmon";
    sandybrown, "sandybrown";
    seagreen, "seagreen";
    seashell, "seashell";
    sienna, "sienna";
    silver, "silver";
    skyblue, "skyblue";
    slateblue, "slateblue";
    slategray, "slategray";
    slategrey, "slategrey";
    snow, "snow";
    springgreen, "springgreen";
    steelblue, "steelblue";
    tan, "tan";
    teal, "teal";
    thistle, "thistle";
    tomato, "tomato";
    turquoise, "turquoise";
    violet, "violet";
    wheat, "wheat";
    white, "white";
    whitesmoke, "whitesmoke";
    yellow, "yellow";
    yellowgreen, "yellowgreen";
    transparent, "transparent";
  ]

let color_by_name = ref Smap.empty
let name_by_color = ref Map.empty

let to_string ?(as_name=true) c =
  if not as_name then
    Printf.sprintf "0x%08lx" c
  else
    match Map.find_opt c !name_by_color with
    | None -> Printf.sprintf "0x%08lx" c
    | Some name -> name

let register name c =
  (match Smap.find_opt name !color_by_name with
  | None -> ()
  | Some c0 ->
      Log.warn (fun m -> m "Color name %S was previously used for %s (replacing with %s)"
         name (to_string ~as_name:false c0) (to_string ~as_name:false c))
  );
  (match Map.find_opt c !name_by_color with
  | None -> ()
  | Some name0 ->
      Log.warn (fun m -> m "Color %s was previously named %S (replacing with %S)"
         (to_string ~as_name:false c) name0 name)
  );
  color_by_name := Smap.add name c !color_by_name;
  name_by_color := Map.add c name !name_by_color

let () = List.iter (fun (c,name) -> register name c) named_colors

let registered () = Smap.bindings !color_by_name

let of_string s =
  match Smap.find_opt s !color_by_name with
  | Some c -> c
  | None ->
      let len = String.length s in
      try
        if len > 1 && String.get s 0 = '#' then
          of_hexa (String.sub s 1 (len-1))
        else
          raise Not_found
      with
      | _ ->
          Log.warn (fun m -> m "invalid color %S" s); black

let random () =
  let colors = Array.of_list (registered ()) in
  let len = Array.length colors in
  snd colors.(Random.int len)

let ocf_wrapper : t Ocf.wrapper =
  let to_json ?(with_doc=false) c =
    `String (to_string c)
  in
  let from_json ?def = function
  | `String s ->
      let len = String.length s in
      if len > 2 &&
        String.get s 0 = '0' &&
          (match String.get s 1 with 'x'|'X' -> true | _ -> false)
      then
        match Int32.of_string_opt s with
        | None -> 0x000000FFl
        | Some n -> n
      else
        of_string s
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json