Source file color.ml

(** Colors. *)

open Tsdl

(** A color is a int32, with bytes representing red, green, blue and alpha (opacity).*)
type t = int32

let compare = Int32.compare
let pp ppf t = Format.fprintf ppf "%#lx" t

(** [to_int8s color] returns [(red, green, blue, alpha)] components of color.*)
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)

(** [of_rgba r g b a] returns a color from the given components.*)
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)
        )
       )
    )

(** [of_rgba_0_1 r g b a] returns a color from the given components as floats.
  Each component must be between [0.] and [1.] and is multiplicated by 255 to
  get the value on one byte for this component.
  Out of bounds values are corrected to be at least 0 and at most 255. *)
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)

(** [sdl_color_of_int32 n] creates a {!Tsdl.Sdl.color}. *)
let sdl_color_of_int32 n =
  let (r, g, b, a) = to_int8s n in
  Sdl.Color.create ~r ~g ~b ~a

(** Returns a color from a hexadecimal string representation.
  With each character being [0]..[9] or [a|A]..[f|F], accepted forms are:
  {ul
  {- ["rgb"], mapped to (rr,gg,bb,FF),}
  {- ["rgba"], mapped to (rr,gg,bb,aa),}
  {- ["rrggbb"], mapped to (rr,gg,bb,FF),}
  {- any other string [s] which can be parsed by [Int32.of_string ("0x"^s)].}
  }
  Raises [Failure] if the representation is invalid.*)
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

(** The transparent color. *)
let transparent = Int32.zero

(** Transparent color as [(r,g,b,a)] bytes. *)
let transparent_int8s = to_int8s transparent

(** Transparent SDL color. *)
let transparent_color =
  let (r,g,b,a) = transparent_int8s in
  Sdl.Color.create ~r ~g ~b ~a

(** {2 Named colors}

Thes named colors corresponds to the
{{:https://www.w3.org/TR/css-color-3/#svg-color}SVG color specification}.
*)

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

(** [of_name s] returns the color associated to the given string
  (case-sensitive). Else, if [s] begin with ['#'], the rest of the
  string is parsed with {!of_hexa}. If it fails or if the string
  does not start with ['#'], the {!black} color is returned. *)
let of_name = function
| "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
| s ->
    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

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

(** [random ()] returns a random color from the list of named colors. *)
let random =
  let colors = Array.of_list named_colors in
  let len = Array.length colors in
  fun () -> colors.(Random.int len)

(** {!Ocf.wrapper} for a color. *)
let ocf_wrapper : t Ocf.wrapper =
  let to_json ?(with_doc=false) c =
    `String (Printf.sprintf "%#lx" 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_name s
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json