OO framework

private/rgba.rkt

@@ -0,0 +1,128 @@
+#lang racket/base
+
+(require racket/contract
+         racket-sprintf
+         )
+
+(provide rgba
+         hex->rgba
+         rgba->hex
+         rgba?
+         rgba-blue
+         rgba-red
+         rgba-green
+         rgba-alpha
+         rgba-blue!
+         rgba-red!
+         rgba-green!
+         rgba-alpha!
+         )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data structures
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-struct rgba*
+  ([red #:mutable] [green #:mutable] [blue #:mutable] [alpha #:mutable])
+  #:transparent
+  )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (between-0-255? x)
+  (and (integer? x)
+       (>= x 0)
+       (<= x 255)))
+
+
+(define (optional-between-0-255? x)
+  (write x)
+  (newline)
+  (or (null? x)
+      (and (= (length x) 1)
+           (between-0-255? (car x)))))
+
+(define (hex2->int str)
+  (let ((s (string-downcase str))
+        (sub (- (char->integer #\a) 10))
+        (subnum (char->integer #\0)))
+    (let ((ac (string-ref s 0))
+          (bc (string-ref s 1)))
+      (let ((a (- (char->integer ac) (if (char>=? ac #\a) sub subnum)))
+            (b (- (char->integer bc) (if (char>=? bc #\a) sub subnum))))
+        (+ (* a 16) b)))))
+
+(define (hex-color? c)
+  (let ((re #px"[#]?([0-9a-fA-F]{2})([0-9a-fA-F]{2})([0-9a-fA-F]{2})([0-9a-fA-F]{2})?"))
+    (let ((m (regexp-match re c)))
+      (not (eq? m #f)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; API
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (rgba? c)
+  (rgba*? c))
+
+(define/contract (rgba r g b . a)
+  (->* (between-0-255? between-0-255? between-0-255?) (between-0-255?) rgba?)
+  (make-rgba* r g b (if (null? a) 255 (car a)))
+  )
+
+(define/contract (hex->rgba h)
+  (-> hex-color? rgba?)
+  (let ((re #px"[#]?([0-9a-fA-F]{2})([0-9a-fA-F]{2})([0-9a-fA-F]{2})([0-9a-fA-F]{2})?"))
+    (let ((m (regexp-match re h)))
+      (if (eq? m #f)
+          (error "Not a CSS hex color string")
+          (rgba (hex2->int (list-ref m 1))
+                (hex2->int (list-ref m 2))
+                (hex2->int (list-ref m 3))
+                (if (eq? (list-ref m 4) #f)
+                    255
+                    (hex2->int (list-ref m 4))))))))
+
+(define/contract (rgba->hex c)
+  (-> rgba? string?)
+  (string-append 
+      (sprintf "#%02x%02x%02x" (rgba-red c) (rgba-green c) (rgba-blue c))
+      (if (= (rgba-alpha c) 255)
+          ""
+          (sprintf "%02x" (rgba-alpha c)))))
+
+
+(define/contract (rgba-red! c r)
+  (-> rgba? between-0-255? rgba?)
+  (set-rgba*-red! c r))
+
+(define/contract (rgba-green! c g)
+  (-> rgba? between-0-255? rgba?)
+  (set-rgba*-green! c g))
+
+(define/contract (rgba-blue! c b)
+  (-> rgba? between-0-255? rgba?)
+  (set-rgba*-blue! c b))
+
+(define/contract (rgba-alpha! c a)
+  (-> rgba? between-0-255? rgba?)
+  (set-rgba*-alpha! c a))
+
+(define/contract (rgba-red c)
+  (-> rgba? between-0-255?)
+  (rgba*-red c))
+
+(define/contract (rgba-green c)
+  (-> rgba? between-0-255?)
+  (rgba*-green c))
+
+(define/contract (rgba-blue c)
+  (-> rgba? between-0-255?)
+  (rgba*-blue c))
+
+(define/contract (rgba-alpha c)
+  (-> rgba? between-0-255?)
+  (rgba*-alpha c))
+
+