hexcolors.lisp 2.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475
  1. (in-package #:cl-colors2)
  2. ;;; parsing and printing of CSS-like colors
  3. (defun print-hex-rgb (color &key short (hash T) alpha destination)
  4. "Converts a COLOR to its hexadecimal RGB string representation. If
  5. SHORT is specified each component gets just one character.
  6. A hash character (#) is prepended if HASH is true (default).
  7. If ALPHA is set it is included as an ALPHA component.
  8. DESTINATION is the first argument to FORMAT, by default NIL."
  9. (flet ((c (x factor) (round (* x factor))))
  10. (let* ((rgb (as-rgb color))
  11. (red (rgb-red rgb))
  12. (green (rgb-green rgb))
  13. (blue (rgb-blue rgb))
  14. (factor (if short 15 255)))
  15. (format destination (if short
  16. "~@[~C~]~X~X~X~@[~X~]"
  17. "~@[~C~]~2,'0X~2,'0X~2,'0X~@[~X~]")
  18. (and hash #\#)
  19. (c red factor)
  20. (c green factor)
  21. (c blue factor)
  22. (and alpha (c alpha factor))))))
  23. ;; TODO: a JUNK-ALLOWED parameter, like for PARSE-INTEGER, would be nice
  24. (defun parse-hex-rgb (string &key (start 0) end)
  25. "Parses a hexadecimal RGB(A) color string. Returns a new RGB color value
  26. and an alpha component if present."
  27. (let* ((length (length string))
  28. (end (or end length))
  29. (sub-length (- end start)))
  30. (cond
  31. ;; check for valid range, we need at least three and accept at most
  32. ;; nine characters
  33. ((and (<= #.(length "fff") sub-length)
  34. (<= sub-length #.(length "#ffffff00")))
  35. (when (char= (char string start) #\#)
  36. (incf start)
  37. (decf sub-length))
  38. (labels ((parse (string index offset)
  39. (parse-integer string :start index :end (+ offset index)
  40. :radix 16))
  41. (short (string index)
  42. (/ (parse string index 1) 15))
  43. (long (string index)
  44. (/ (parse string index 2) 255)))
  45. ;; recognize possible combinations of alpha component and length
  46. ;; of the rest of the encoded color
  47. (multiple-value-bind (shortp alphap)
  48. (case sub-length
  49. (#.(length "fff") (values T NIL))
  50. (#.(length "fff0") (values T T))
  51. (#.(length "ffffff") (values NIL NIL))
  52. (#.(length "ffffff00") (values NIL T)))
  53. (if shortp
  54. (values
  55. (rgb
  56. (short string start)
  57. (short string (+ 1 start))
  58. (short string (+ 2 start)))
  59. (and alphap (short string (+ 3 start))))
  60. (values
  61. (rgb
  62. (long string start)
  63. (long string (+ 2 start))
  64. (long string (+ 4 start)))
  65. (and alphap (long string (+ 6 start))))))))
  66. (T
  67. (error "not enough or too many characters in indicated sequence: ~A"
  68. (subseq string start end))))))