overhaul colour/ordering system for coherency

squash

bin/main.ml

@@ -1,3 +1,3 @@
 open Culr
 
-let () = Pipes.read_all Env.colours Env.order
+let () = Pipes.read_all Env.get_colours

lib/env.ml

@@ -1,17 +1,78 @@
+open Types
 open Seq
 
-let to_sixteen f = ints 0 |> take 16 |> f |> Array.of_seq
+let match_env_order =
+  let open Types in
+  function
+  | "rainbow-pair" -> RainbowPair
+  | "rainbow-split" -> RainbowSplit
+  | "tonepair" -> TonePair
+  | "straight" -> Straight
+  | "default" -> Default
+  | "random" -> Random
+  | s -> (
+      let parse = Parse.parse_env_order s in
+      parse |> function [||] -> Straight | e -> Explicit e)
+
 let ( >>= ) = Option.bind
-let ( =!? ) = fun el col -> not (Array.mem el col)
 
-let colours =
-  let init_default = to_sixteen (map (fun x -> Types.Simple x)) in
-  Sys.getenv_opt "CULRS"
-  >>= (fun s -> if String.length s > 0 then Some s else None)
-  |> Option.fold ~none:init_default ~some:Parse.parse_env_colours
+let get_env_colours =
+  Sys.getenv_opt "CULRS" >>= fun s ->
+  if String.length s > 0 then Some s else None
 
-let order =
-  let init_default = to_sixteen (filter (fun i -> i =!? [| 0; 8 |])) in
-  Sys.getenv_opt "CULR_ORDER"
-  >>= (fun s -> if String.length s > 0 then Some s else None)
-  |> Option.fold ~none:init_default ~some:Parse.parse_env_order
+let get_env_order =
+  Sys.getenv_opt "CULR_ORDER" >>= fun s ->
+  if String.length s > 0 then Some s else None
+
+let to_sixteen f = ints 0 |> take 16 |> f |> Array.of_seq
+
+let permute (order : order) (colours : colour array) =
+  let open Array in
+  let make_simple = map (fun i -> Simple i) in
+  match order with
+  | Explicit e ->
+      let clen = length colours in
+      e
+      |> map (fun index ->
+             if index < clen then colours.(index) else Simple index)
+  | RainbowPair ->
+      [| 0; 8; 1; 9; 3; 11; 2; 10; 6; 14; 4; 12; 5; 13; 7; 15 |] |> make_simple
+  | RainbowSplit ->
+      [| 0; 8; 1; 3; 2; 6; 4; 5; 9; 11; 10; 14; 12; 13; 7; 15 |] |> make_simple
+  | TonePair ->
+      let open Seq in
+      let lows = ints 0 |> take 8 in
+      let highs = lows |> map (fun i -> i + 8) in
+      interleave lows highs |> Array.of_seq |> make_simple
+  | Straight ->
+      let open Seq in
+      ints 0 |> take 16 |> Array.of_seq |> make_simple
+  | Default ->
+      let open Seq in
+      ints 0 |> take 16
+      |> filter (fun i -> not (i = 0 || i = 8))
+      |> Array.of_seq |> make_simple
+  | Random ->
+      Random.self_init ();
+      shuffle ~rand:Random.int colours;
+      colours
+
+let get_colours =
+  let colours = get_env_colours
+  and order = get_env_order
+  and init_default_colours = to_sixteen (map (fun x -> Types.Simple x))
+  and init_order_for_colours c =
+    let open Seq in
+    ints 0 |> take (Array.length c) |> Array.of_seq
+  in
+  match (colours, order) with
+  | None, None -> permute Default init_default_colours
+  | None, Some o -> permute (match_env_order o) init_default_colours
+  | Some c, None ->
+      let colours = Parse.parse_env_colours c in
+      permute (Explicit (init_order_for_colours colours)) colours
+  | Some c, Some o -> (
+      let colours = Parse.parse_env_colours c and order = match_env_order o in
+      match order with
+      | Explicit _ | Random -> permute order colours
+      | _ -> colours)

lib/env.mli

@@ -1,2 +1 @@
-val colours : Types.colour array
-val order : int array
+val get_colours : Types.colour array

lib/pipes.ml

@@ -1,13 +1,13 @@
 open Processing
 
-let read_all colours order =
+let read_all colours =
   In_channel.set_binary_mode stdin true;
   let open Types in
-  let t = Emitter.create and culr = Culriser.create order [] colours in
+  let t = Emitter.create and culr = Culriser.create colours in
   Emitter.serialise t (Ansi [ Fg (Culriser.next culr) ]);
   Angstrom_unix.parse_many ~buf_size:4096 Parse.culr_parse
     (fun c -> c |> ansi_filter |> Culriser.serialise_with_colour culr t)
     stdin
   |> function
   | _, Ok _ -> Emitter.flush t
-  | _ -> ()
+  | _, Error e -> prerr_endline ("error encountered:" ^ e)

lib/processing.ml

@@ -10,22 +10,6 @@ let ansi_filter s =
            a)
   | n -> n
 
-let permute (order : int array) (colours : colour array) =
-  let olen = length order and clen = length colours in
-  match (olen, clen) with
-  (* nothing provided, take default 16 pal colours *)
-  | 0, 0 -> Seq.ints 0 |> Seq.take 16 |> Seq.map (fun i -> Simple i) |> of_seq
-  (* colours provided with no order, take them as is *)
-  | 0, _ -> colours
-  (* order provided with no colours, map to palette colours *)
-  | _, 0 -> order |> map (fun o -> Simple o)
-  (* order and colours provided, apply order to colours and sub palette where
-  order index exceeds colour array length *)
-  | _, _ ->
-      order
-      |> mapi (fun i o ->
-             if order.(i) < clen then colours.(order.(i)) else Simple o)
-
 (* TODO: implement this so cli can use a dsl to specify colourising patterns *)
 type culr = { colours : colour array; sz : int; mutable current : int }
 
@@ -36,13 +20,12 @@ module Culriser = struct
   let run_filters (f : filter) el =
     List.fold_left (fun res filt -> if not (filt el) then false else res) true f
 
-  let create s f (c : colour array) =
+  let create ?(filters = []) (c : colour array) =
     let ( @ ) = append in
     let colours =
-      c |> permute s |> fun c ->
-      if List.length f > 0 then
+      if List.length filters > 0 then
         fold_left
-          (fun acc el -> if run_filters f el then acc @ [| el |] else acc)
+          (fun acc el -> if run_filters filters el then acc @ [| el |] else acc)
           [||] c
       else c
     in

lib/types.ml

@@ -10,3 +10,12 @@ type chunk =
   | Separator of string
   | Delimiter of string
   | Ansi of ansi_gfx list
+
+type order =
+  | Explicit of int array
+  | RainbowPair
+  | RainbowSplit
+  | TonePair
+  | Straight
+  | Random
+  | Default