driver/color.ml

   1 open Genlex
   2 open Base
   3
   4 exception Invalid_format of string
   5
   6 type t = {red:int; green:int; blue:int; alpha:float}
   7
   8 let rgb r g b = {
   9   red   = r;
  10   green = g;
  11   blue  = b;
  12   alpha = 1.0
  13 }
  14
  15 let red     = rgb 0xFF 0x00 0x00
  16 let lime    = rgb 0x00 0xFF 0x00
  17 let blue    = rgb 0x00 0x00 0xFF
  18 let white   = rgb 0xFF 0xFF 0xFF
  19 let maroon  = rgb 0x80 0x00 0x00
  20 let green   = rgb 0x00 0xFF 0x00
  21 let navy    = rgb 0x00 0x00 0x80
  22 let silver  = rgb 0xC0 0xC0 0xC0
  23 let yellow  = rgb 0xFF 0xFF 0x00
  24 let aqua    = rgb 0x00 0xFF 0xFF
  25 let fuchsia = rgb 0xFF 0x00 0xFF
  26 let gray    = rgb 0x80 0x80 0x80
  27 let olive   = rgb 0x80 0x80 0x00
  28 let teal    = rgb 0x00 0x80 0x80
  29 let purple  = rgb 0x80 0x00 0x80
  30 let black   = rgb 0x00 0x00 0x00
  31
  32 let name_table = [
  33   "red",red;
  34   "lime",lime;
  35   "blue",blue;
  36   "white",white;
  37   "maroon",maroon;
  38   "green",green;
  39   "navy",navy;
  40   "silver",silver;
  41   "yellow",yellow;
  42   "aqua",aqua;
  43   "fuchsia",fuchsia;
  44   "gray",gray;
  45   "olive",olive;
  46   "teal",teal;
  47   "purple",purple;
  48   "black",black]
  49
  50 let of_int n =
  51   rgb
  52     (n lsr 16 land 0xFF)
  53     (n lsr 8 land 0xFF)
  54     (n lsr 0 land 0xFF)
  55
  56 let to_int {red=r; green=g; blue=b} =
  57   (r lsl 16) lor  (g lsl 8) lor b
  58
  59 let p_name s =
  60   maybe (List.assoc @@ String.lowercase s) name_table
  61
  62 let hex =
  63   Str.regexp_case_fold
  64     "^#\\([0-9A-F][0-9A-F]\\)\\([0-9A-F][0-9A-F]\\)\\([0-9A-F][0-9A-F]\\)$"
  65
  66 let of_hex s =
  67   Scanf.sscanf s "%x" id
  68
  69 let p_hex s =
  70   if Str.string_match hex s 0 then
  71     Some (rgb (of_hex @@ Str.matched_group 1 s)
  72               (of_hex @@ Str.matched_group 2 s)
  73               (of_hex @@ Str.matched_group 3 s))
  74   else
  75     None
  76
  77 let r_rgb =
  78   Str.regexp_case_fold
  79     "^rgb( *\\([0-9]+\\) *, *\\([0-9]+\\) *, *\\([0-9]+\\) *)$"
  80
  81 let p_rgb s =
  82   if Str.string_match r_rgb s 0 then
  83     Some (rgb (int_of_string @@ Str.matched_group 1 s)
  84               (int_of_string @@ Str.matched_group 2 s)
  85               (int_of_string @@ Str.matched_group 3 s))
  86   else
  87     None
  88
  89 let parse s =
  90   [p_name;p_hex;p_rgb]
  91   +> List.map  (fun f -> lazy (f s))
  92   +> List.find (fun v -> Option.is_some (!$v))
  93   +> (!$)
  94   +> Option.get