Permalink
Browse files

first commit

  • Loading branch information...
0 parents commit 52f6b91372b9383e84facfc54c73fe7017030ec5 @tpapp committed May 22, 2009
Showing with 1,020 additions and 0 deletions.
  1. +8 −0 Makefile
  2. +7 −0 README
  3. +14 −0 cl-colors.asd
  4. +670 −0 colornames.lisp
  5. +186 −0 colors.lisp
  6. +52 −0 introduction.txt
  7. +8 −0 package.lisp
  8. +48 −0 parse-x11.lisp
  9. +27 −0 test.lisp
@@ -0,0 +1,8 @@
+## note: this works on my system, you don't need to run it because the
+## distribution contains the generated file
+
+SBCL=/usr/bin/sbcl
+
+colornames.lisp: /usr/share/X11/rgb.txt parse-x11.lisp
+ rm -f colornames.lisp
+ $(SBCL) --load parse-x11.lisp --eval '(quit)'
7 README
@@ -0,0 +1,7 @@
+The purpose of this simple package to provide named colors that can be
+used by other packages. Each color is stored in a structure, and
+named colors are defined as constants (eg +black+, +blue+, +slateblue+
+etc). Currently, the colors were converted from X11's rgb.txt, but
+may be expanded in the future. Alpha channels and HSV conversion are
+supported. The library of course doesn't depend on X11, the converted
+file is included.
@@ -0,0 +1,14 @@
+(defpackage #:cl-colors-asd
+ (:use :cl :asdf))
+
+(in-package :cl-colors-asd)
+
+(defsystem #:cl-colors
+ :description "Simple color library for Common Lisp"
+ :version "0.1"
+ :author "Tamas K Papp"
+ :license "GPL"
+ :components ((:file "package")
+ (:file "colors" :depends-on ("package"))
+ (:file "colornames" :depends-on ("colors")))
+ :depends-on (:cl-utilities))

Large diffs are not rendered by default.

Oops, something went wrong.
@@ -0,0 +1,186 @@
+(in-package :cl-colors)
+
+;;;;
+;;;; rgb
+;;;;
+
+(defclass rgb ()
+ ((red :initform 0 :type (real 0 1) :initarg :red :accessor red)
+ (green :initform 0 :type (real 0 1) :initarg :green :accessor green)
+ (blue :initform 0 :type (real 0 1) :initarg :blue :accessor blue)))
+
+(defmethod print-object ((obj rgb) stream)
+ (print-unreadable-object (obj stream :type t)
+ (with-slots (red green blue) obj
+ (format stream "red: ~a green: ~a blue: ~a" red green blue))))
+
+(defmethod make-load-form ((obj rgb) &optional environment)
+ (make-load-form-saving-slots obj :environment environment))
+
+;;;;
+;;;; rgba
+;;;;
+
+(defclass rgba (rgb)
+ ((alpha :initform 1 :type (real 0 1) :initarg :alpha :accessor alpha)))
+
+(defmethod print-object ((obj rgba) stream)
+ (print-unreadable-object (obj stream :type t)
+ (with-slots (red green blue alpha) obj
+ (format stream "red: ~a green: ~a blue: ~a alpha: ~a"
+ red green blue alpha))))
+
+(defgeneric add-alpha (color alpha)
+ (:documentation "Add an alpha channel to a given color."))
+
+(defmethod add-alpha ((color rgb) alpha)
+ (make-instance 'rgba
+ :red (red color)
+ :green (green color)
+ :blue (blue color)
+ :alpha alpha))
+
+;;;;
+;;;; hsv
+;;;;
+
+(defclass hsv ()
+ ((hue :initform 0 :type (real 0 360) :initarg :hue :accessor hue)
+ (saturation :initform 0 :type (real 0 1) :initarg :saturation
+ :accessor saturation)
+ (value :initform 0 :type (real 0 1) :initarg :value :accessor value)))
+
+(defmethod print-object ((obj hsv) stream)
+ (print-unreadable-object (obj stream :type t)
+ (with-slots (hue saturation value) obj
+ (format stream "hue: ~a saturation: ~a value: ~a"
+ hue saturation value))))
+
+(defun normalize-hue (hue)
+ "Normalize hue into the interval [0,360)."
+ (mod hue 360))
+
+;;;;
+;;;; conversions
+;;;;
+
+(defun rgb->hsv (rgb &optional (undefined-hue 0))
+ "Convert RGB to HSV representation. When hue is undefined
+\(saturation is zero), undefined-hue will be assigned."
+ (with-slots (red green blue) rgb
+ (let* ((value (max red green blue))
+ (delta (- value (min red green blue)))
+ (saturation (if (plusp value)
+ (/ delta value)
+ 0)))
+ (flet ((normalize (constant right left)
+ (let ((hue (+ constant (/ (* 60 (- right left)) delta))))
+ (if (minusp hue)
+ (+ hue 360)
+ hue))))
+ (make-instance 'hsv
+ :hue (cond
+ ((zerop saturation) undefined-hue) ; undefined
+ ((= red value) (normalize 0 green blue)) ; dominant red
+ ((= green value) (normalize 120 blue red)) ; dominant green
+ (t (normalize 240 red green)))
+ :saturation saturation
+ :value value)))))
+
+(defun hsv->rgb (hsv)
+ "Convert HSV to RGB representation. When saturation is zero, hue is
+ignored."
+ (with-slots (hue saturation value) hsv
+ ;; if saturation=0, color is on the gray line
+ (when (zerop saturation)
+ (return-from hsv->rgb (make-instance 'rgb
+ :red value :green value :blue value)))
+ ;; nonzero saturation: normalize hue to [0,6)
+ (let ((h (/ (normalize-hue hue) 60)))
+ (multiple-value-bind (quotient remainder) (floor h)
+ (let ((p (* value (- 1 saturation)))
+ (q (* value (- 1 (* saturation remainder))))
+ (r (* value (- 1 (* saturation (- 1 remainder))))))
+ (multiple-value-bind (red green blue)
+ (case quotient
+ (0 (values value r p))
+ (1 (values q value p))
+ (2 (values p value r))
+ (3 (values p q value))
+ (4 (values r p value))
+ (t (values value p q)))
+ (make-instance 'rgb
+ :red red
+ :green green
+ :blue blue)))))))
+
+;;;;
+;;;; conversion with generic functions
+;;;;
+
+(defgeneric ->hsv (color &optional undefined-hue))
+
+(defmethod ->hsv ((color rgb) &optional (undefined-hue 0))
+ (rgb->hsv color undefined-hue))
+
+(defmethod ->hsv ((color hsv) &optional undefined-hue)
+ (declare (ignore undefined-hue))
+ color)
+
+(defgeneric ->rgb (color))
+
+(defmethod ->rgb ((color rgb))
+ color)
+
+(defmethod ->rgb ((color hsv))
+ (hsv->rgb color))
+
+;;;;
+;;;; convex combinations
+;;;;
+
+(defun convex-combination (a b alpha)
+ "Convex combination (1-alpha)*a+alpha*b."
+ (declare ((real 0 1) alpha))
+ (+ (* (- 1 alpha) a) (* alpha b)))
+
+(defun hue-combination (hue1 hue2 alpha &optional (positivep t))
+ "Return a convex combination of hue1 (with weight 1-alpha) and
+hue2 \(with weight alpha), in the positive or negative direction
+on the color wheel."
+ (cond
+ ((and positivep (> hue1 hue2))
+ (normalize-hue (convex-combination hue1 (+ hue2 360) alpha)))
+ ((and (not positivep) (< hue1 hue2))
+ (normalize-hue (convex-combination (+ hue1 360) hue2 alpha)))
+ (t (convex-combination hue1 hue2 alpha))))
+
+(defmacro with-convex-combination ((cc instance1 instance2 alpha)
+ &body body)
+ "Wrap body in a macrolet so that (cc #'accessor) returns the
+convex combination of the slots of instance1 and instance2
+accessed by accessor."
+ `(macrolet ((,cc (accessor)
+ (once-only (accessor)
+ `(convex-combination (funcall ,accessor ,',instance1)
+ (funcall ,accessor ,',instance2)
+ ,',alpha))))
+ ,@body))
+
+(defun rgb-combination (rgb1 rgb2 alpha)
+ "Convex combination in RGB space."
+ (with-convex-combination (cc rgb1 rgb2 alpha)
+ (make-instance 'rgb :red (cc #'red) :green (cc #'green) :blue (cc #'blue))))
+
+(defun rgba-combination (rgba1 rgba2 alpha)
+ "Convex combination in RGBA space."
+ (with-convex-combination (cc rgba1 rgba2 alpha)
+ (make-instance 'rgba :red (cc #'red)
+ :green (cc #'green) :blue (cc #'blue)
+ :alpha (cc #'alpha))))
+
+(defun hsv-combination (hsv1 hsv2 alpha &optional (positivep t))
+ (with-convex-combination (cc hsv1 hsv2 alpha)
+ (make-instance 'hsv
+ :hue (hue-combination (hue hsv1) (hue hsv2) alpha positivep)
+ :saturation (cc #'saturation) :value (cc #'value))))
@@ -0,0 +1,52 @@
+Color classes
+-------------
+
+The two main color classes are rgb and hsv, which have slots red,
+green, blue and hue, saturation, value respectively. There is also an
+rgb class with an alpha channel (slot alpha) called rgba. In the rgb
+class, valid slot values are from 0 to 1, while in the hsv class,
+saturation and value are in the interval [0,1], but hue is in [0,360).
+
+You can convert between rgb and hsv using rgb->hsv and hsv->rgb. Note
+that for the former, you need to specify what happens when the hue is
+undefined (ie the color is gray). By default, the hue of red (0) is
+assigned.
+
+Generic functions which find the appropriate conversion method are
+available with names ->rgb and ->hsv. Use these if you want your
+functions to handle various different color representations but
+eventually you need to work with a single one.
+
+
+
+Named colors
+------------
+
+Named colors, parsed from the X11 colors file, are loaded from
+colornames.lisp. As they are constants, names are between +'s. All
+named colors are rgb.
+
+
+
+Convex combinations
+-------------------
+
+Use hsv-combination or rgb-combination for taking convex combinations
+in the respective color space. Note that in the HSV space, you need
+to specify the direction on the color wheel, the default is positive.
+
+
+Example session
+---------------
+
+CL-COLORS> +blue+
+#<RGB red: 0.0d0 green: 0.0d0 blue: 1.0d0>
+CL-COLORS> (->hsv +blue+)
+#<HSV hue: 240.0d0 saturation: 1.0d0 value: 1.0d0>
+CL-COLORS> (rgb-combination +blue+ +green+ 0.5)
+#<RGB red: 0.0d0 green: 0.5d0 blue: 0.5d0>
+CL-COLORS> (->rgb (hsv-combination (->hsv +blue+) (->hsv +green+) 0.5))
+#<RGB red: 1.0d0 green: 0.0d0 blue: 0.0d0>
+CL-COLORS> (->rgb (hsv-combination (->hsv +blue+) (->hsv +green+) 0.5 nil))
+#<RGB red: 0.0d0 green: 1.0d0 blue: 1.0d0>
+
@@ -0,0 +1,8 @@
+(defpackage :cl-colors
+ (:use :common-lisp :cl-utilities)
+ (:export rgb red green blue
+ rgba alpha add-alpha
+ hsv hue saturation value
+ rgb->hsv hsv->rgb ->hsv ->rgb
+ convex-combination hue-combination rgb-combination
+ rgba-combination hsv-combination))
@@ -0,0 +1,48 @@
+;; parse X11's rgb.txt
+
+(require :cl-ppcre)
+
+(let ((color-scanner ; will only take names w/o spaces
+ (cl-ppcre:create-scanner
+ "^\\s*(\\d+)\\s+(\\d+)\\s+(\\d+)\\s+([\\s\\w]+\?)\\s*$"
+ :extended-mode t))
+ (comment-scanner
+ (cl-ppcre:create-scanner
+ "^\\s*!")))
+ (with-open-file (s "/usr/share/X11/rgb.txt"
+ :direction :input
+ :if-does-not-exist :error)
+ (with-open-file (colornames "colornames.lisp"
+ :direction :output
+ :if-exists :overwrite
+ :if-does-not-exist :create)
+ (format colornames ";;;; This file was generated automatically ~
+by parse-x11.lisp~%~
+;;;; Please do not edit directly.~%~
+ (in-package :cl-colors)~%~
+ (defmacro define-rgb-color (name red green blue)
+ `(progn
+ (defconstant ,name (if (boundp ',name)
+ (symbol-value ',name)
+ (make-instance 'rgb
+ :red ,red
+ :green ,green
+ :blue ,blue)))
+ (export ',name)))~%")
+ (labels ((string-to-float (string)
+ (let ((i (read-from-string string)))
+ (assert (and (typep i 'integer) (<= i 255)))
+ (/ i 255d0))))
+ (do ((line (read-line s nil nil) (read-line s nil nil)))
+ ((not line))
+ (unless (cl-ppcre:scan-to-strings comment-scanner line)
+ (multiple-value-bind (match registers)
+ (cl-ppcre:scan-to-strings color-scanner line)
+ (if (and match (not (find #\space (aref registers 3))))
+ (format colornames
+ "(define-rgb-color +~A+ ~A ~A ~A)~%"
+ (string-downcase (aref registers 3))
+ (string-to-float (aref registers 0))
+ (string-to-float (aref registers 1))
+ (string-to-float (aref registers 2)))
+ (format t "ignoring line ~A~%" line)))))))))
@@ -0,0 +1,27 @@
+(in-package :cl-colors)
+
+(defun rgb= (rgb1 rgb2 &optional (epsilon 1e-10))
+ (flet ((eps= (a b)
+ (<= (abs (- a b)) epsilon)))
+ (with-slots ((red1 red) (green1 green) (blue1 blue)) rgb1
+ (with-slots ((red2 red) (green2 green) (blue2 blue)) rgb2
+ (and (eps= red1 red2) (eps= green1 green2) (eps= blue1 blue2))))))
+
+(defun test-hsv-rgb ()
+ (let* ((rgb (make-instance 'rgb
+ :red (random 1d0)
+ :green (random 1d0)
+ :blue (random 1d0)))
+ (hsv (rgb->hsv rgb))
+ (rgb2 (hsv->rgb hsv))
+ (result (rgb= rgb rgb2)))
+ (unless result
+ (format t "~a does not equal ~a~%" rgb rgb2))
+ result))
+
+(dotimes (i 1000) (test-hsv-rgb))
+
+(defun test-hue-combination (from to positivep)
+ (dotimes (i 21)
+ (format t "~a " (hue-combination from to (/ i 20) positivep))))
+

0 comments on commit 52f6b91

Please sign in to comment.