Some cleanup of the API pre-documentation

termenv/color.scm

@@ -7,61 +7,18 @@
   #:use-module (srfi srfi-9 gnu)
   #:export (make-foreground
             make-background
-            current-color-profile
             color-r
             color-g
             color-b
             color?
-            color-styled
-            rgb->hsl
-            rgb->cie-lab
-            hex->color
-            rgb->ansi
-            rgb->ansi-index
-            rgb->ansi256
-            rgb->ansi256-index
-            hsl-uv-distance))
 
-(define current-color-profile (make-parameter #f))
+            current-color-profile
-
+            color->sequence
-(define-immutable-record-type <color>
+            color->ansi
-  (make-color r g b type)
+            color->ansi-index
-  color?
+            color->ansi256
-  (r color-r)
+            color->ansi256-index
-  (g color-g)
+            hex->color))
-  (b color-b)
-  (type color-type))
-
-(define (make-foreground hex)
-  "Create a foreground color"
-  (hex->color hex 'foreground))
-
-(define (make-background hex)
-  "Create a background color"
-  (hex->color hex 'background))
-
-(define %FOREGROUND "38")
-(define %BACKGROUND "48")
-
-(define (color-styled color)
-  (define type-code
-    (if (eqv? 'foreground (color-type color))
-        %FOREGROUND
-        %BACKGROUND))
-
-  ;; if user has parameterized a profile we use that but otherwise we use the profile of the active output port
-  (define profile
-    (or (current-color-profile)
-        (color-profile (current-output-port))))
-
-  (case profile
-    ((true-color)
-     (format #f "~a;2;~a;~a;~a" type-code (color-r color) (color-g color) (color-b color)))
-    ((ansi256) (format #f "~a;5;~d" type-code (rgb->ansi256-index color)))
-    ((ansi) (format #f "~d" (rgb->ansi-index color)))
-    (else "")))
-
-;; TODO: probably could do oop goops and be neater
 
 (define %ANSI-COLOR-NAMES
   '(black
@@ -339,6 +296,14 @@
 	  "#e4e4e4"
 	  "#eeeeee"))
 
+(define-immutable-record-type <color>
+  (make-color r g b type)
+  color?
+  (r color-r)
+  (g color-g)
+  (b color-b)
+  (type color-type))
+
 (define %ANSI256-COLORS
   (map hex->color %ANSI256-HEX))
 
@@ -347,39 +312,43 @@
 (define %ANSI-COLORS
   (map hex->color %ANSI-HEX))
 
-;; https://stackoverflow.com/a/58426404/826692
-(define (rgb->hsl c)
-  (define r (/ (color-r c) 255.0))
-  (define g (/ (color-g c) 255.0))
-  (define b (/ (color-b c) 255.0))
-  (define c-min (min r g b))
-  (define c-max (max r g b))
-  (define delta (- c-max c-min))
-  (define h
-    (round
-     (* 60.0
-        (cond
-         ((= delta 0.0) 0.0)
-         ((= c-max r) (floor-remainder (/ (- g b) delta) 6.0))
 
-         (else (+ (/ (- r g) delta) 4.0))))))
+(define %FOREGROUND "38")
-  (when (< h 0.0)
+(define %BACKGROUND "48")
-    (set! h (+ h 360.0)))
 
-  (define l (/ (+ c-max c-min) 2.0))
+;; Parameter determining the color profile to use. Can be one of: 'true-color 'ansi256 'ansi 'ascii
+;; If #f, formatting will use the value returned by (color-profile (current-input-port))
+(define current-color-profile (make-parameter #f))
 
-  (define s
+(define (make-foreground hex)
-    (if (= delta 0.0)
+  "Create a foreground color from a hex code"
-        0.0
+  (hex->color hex 'foreground))
-        (/ delta (- 1.0 (abs (- (* 2.0 l) 1.0))))))
 
-  (set! s (* s 100.0))
+(define (make-background hex)
-  (set! l (* l 100.0))
+  "Create a background color from a hex code"
-  (values h s l))
+  (hex->color hex 'background))
 
+(define (color->sequence color)
+  "Function to transform the color into the sequence representing the color. Uses `current-color-profile` or the profile that `current-output-port` supports to determine the sequence to print"
+  (define type-code
+    (if (eqv? 'foreground (color-type color))
+        %FOREGROUND
+        %BACKGROUND))
+
+  ;; if user has parameterized a profile we use that but otherwise we use the profile of the active output port
+  (define profile
+    (or (current-color-profile)
+        (color-profile (current-output-port))))
+
+  (case profile
+    ((true-color)
+     (format #f "~a;2;~a;~a;~a" type-code (color-r color) (color-g color) (color-b color)))
+    ((ansi256) (format #f "~a;5;~d" type-code (color->ansi256-index color)))
+    ((ansi) (format #f "~d" (color->ansi-index color)))
+    (else "")))
 
 ;; http://www.easyrgb.com/en/math.php
-(define (rgb->cie-lab c)
+(define (color->cie-lab c)
   (define (modulate x)
     (if (> x 0.008856)
         (expt x 1/3)
@@ -393,27 +362,15 @@
           (* 500 (- x y))
           (* 200 (- y z))))
 
-(define (rgb->delta-e-cie c1 c2)
+(define (delta-e-cie c1 c2)
-  (define-values (cie-l1 cie-a1 cie-b1) (rgb->cie-lab c1))
+  "Given two colors, determine their E-CIE distance"
-  (define-values (cie-l2 cie-a2 cie-b2) (rgb->cie-lab c2))
+  (define-values (cie-l1 cie-a1 cie-b1) (color->cie-lab c1))
+  (define-values (cie-l2 cie-a2 cie-b2) (color->cie-lab c2))
 
   (sqrt (+ (expt (- cie-l1 cie-l2) 2)
            (expt (- cie-a1 cie-a2) 2)
            (expt (- cie-b1 cie-b2) 2))))
 
-
-(define (hsl-uv-distance c1 c2)
-  "the Euclidean distance in the HSLuv colorspace"
-  (define (sq x) (* x x))
-  (define-values (h1 s1 l1) (rgb->hsl c1))
-  (define-values (h2 s2 l2) (rgb->hsl c2))
-
-  (define dh (/ (min (abs (- h2 h1)) (- 360.0 (abs (- h2 h1)))) 180.0))
-  (define ds (abs (- s2 s1)))
-  (define dv (/ (abs (- l2 l1)) 255.0))
-
-  (sqrt (+ (sq (/ (- h1 h2) 100.0)) (sq (- s1 s2)) (sq (- l1 l2)))))
-
 (define* (hex->color str #:optional (type 'foreground))
   (define trimmed (string-trim str #\#))
   (define width (floor (/ (string-length trimmed) 3)))
@@ -431,31 +388,31 @@
    (locale-string->integer b 16)
    type))
 
-(define (rgb->ansi color)
+(define (color->ansi color)
   "Given a full color, convert to the nearest ansi color equivalent"
-  (rgb->table color %ANSI-COLORS))
+  (color->table color %ANSI-COLORS))
 
-(define (rgb->ansi256 color)
+(define (color->ansi256 color)
   "Given a full color, convert to the nearest ansi256 color equivalent"
-  (rgb->table color %ANSI256-COLORS))
+  (color->table color %ANSI256-COLORS))
 
-(define (rgb->table color table)
+(define (color->table color table)
-  (list-ref (rgb->table-index color table) table))
+  (list-ref (color->table-index color table) table))
 
-(define (rgb->ansi-index color)
+(define (color->ansi-index color)
   "Given a full color, convert to the index of the nearest ansi color equivalent"
-  (rgb->table-index color %ANSI-COLORS))
+  (color->table-index color %ANSI-COLORS))
 
-(define (rgb->ansi256-index color)
+(define (color->ansi256-index color)
   "Given a full color, convert to the index of the nearest ansi color equivalent"
-  (rgb->table-index color %ANSI256-COLORS))
+  (color->table-index color %ANSI256-COLORS))
 
-(define (rgb->table-index color table)
+(define (color->table-index color table)
   (define cur-min #f)
   (define min-index #f)
 
   (fold (λ (val acc)
-          (let ((min (rgb->delta-e-cie color val)))
+          (let ((min (delta-e-cie color val)))
             (unless (and cur-min (> min cur-min))
               (set! cur-min min)
               (set! min-index acc)))

termenv/screen.scm

@@ -76,15 +76,15 @@
 
 (define* (set-foreground-color hex #:optional (port #t))
   "Sets the default foreground color"
-  (format port (string-append %OSC %SET-FOREGROUND-COLOR) (color-styled (make-foreground hex))))
+  (format port (string-append %OSC %SET-FOREGROUND-COLOR) (color->sequence (make-foreground hex))))
 
 (define* (set-background-color hex #:optional (port #t))
   "Sets the default background color"
-  (format port (string-append %OSC %SET-BACKGROUND-COLOR) (color-styled (make-background hex))))
+  (format port (string-append %OSC %SET-BACKGROUND-COLOR) (color->sequence (make-background hex))))
 
 (define* (set-cursor-color hex #:optional (port #t))
   "Sets the cursor color"
-  (format port (string-append %OSC %SET-CURSOR-COLOR) (color-styled (make-foreground hex))))
+  (format port (string-append %OSC %SET-CURSOR-COLOR) (color->sequence (make-foreground hex))))
 
 (define* (restore-screen #:optional (port #t))
   "Restores a previously saved screen state"

termenv/style.scm

@@ -5,10 +5,7 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-9 gnu)
-  #:export (make-style
+  #:export (foreground
-            styled
-            style-sequences
-            foreground
             background
             bold
             faint
@@ -17,9 +14,7 @@
             overline
             blink
             reverse
-            cross-out
+            cross-out))
-            ;; get-width
-            ))
 
 (define %RESET "0")
 (define %BOLD "1")
@@ -33,7 +28,7 @@
 
 ;; Leaf node of style tree
 (define-immutable-record-type <style>
-  (_make-style string sequences)
+  (make-style string sequences)
   style?
   (string style-string)
   (sequences style-sequences set-style-sequences))
@@ -44,20 +39,17 @@
   style-node?
   (children style-node-children set-style-node-children))
 
-(define (style-node-styled node port)
+(define (style-node->sequence node port)
   (for-each
    (λ (n)
      (if (style? n)
-         (styled n port)
+         (style->sequence n port)
-         (style-node-styled n port)))
+         (style-node->sequence n port)))
    (style-node-children node)))
 
-(set-record-type-printer! <style-node> style-node-styled)
+(set-record-type-printer! <style-node> style-node->sequence)
 
-(define (make-style str)
+(define (style->sequence style port)
-  (_make-style str '()))
-
-(define (styled style port)
   (define str (style-string style))
   (define (just-str) (format port "~a" str))
 
@@ -65,7 +57,7 @@
   ;; Colors don't get resolved until we have the port because we don't know the color profile until then.
   (define (sequence->str seq)
     (if (color? seq)
-        (color-styled seq)
+        (color->sequence seq)
         seq))
 
   (cond
@@ -76,11 +68,11 @@
           (just-str)
           (format port "~a~am~a~a~am" %CSI seq str %CSI %RESET))))))
 
-(set-record-type-printer! <style> styled)
+(set-record-type-printer! <style> style->sequence)
 
 (define (cons-seq stylish sequence)
   (match stylish
-    ((? string? str) (_make-style str (list sequence)))
+    ((? string? str) (make-style str (list sequence)))
     ((style) (cons-seq style sequence))
     ((? list? l) (make-style-node (map (cut cons-seq <> sequence) l)))
     ((? style? style) (set-style-sequences style (cons* sequence (style-sequences style))))

termenv/unix.scm

@@ -3,6 +3,7 @@
   #:export (color-profile))
 
 (define (color-profile port)
+  "Get the best color profile supported by the given output port"
   (cond
    ((not (isatty? port)) 'ascii)
    ((equal? "true" (get-environment-variable "GOOGLE_CLOUD_SHELL")) 'true-color)