Browse code
initial commit
fiddlerwoaroof authored on 03/09/2015 14:08:48Showing 5 changed files
| 0 | 10 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,111 @@ |
| 1 |
+;;;; colors.lisp |
|
| 2 |
+(defpackage #:colors |
|
| 3 |
+ (:use #:cl) |
|
| 4 |
+ (:export #:colorscheme #:palette *palette* |
|
| 5 |
+ #:invert-palette |
|
| 6 |
+ #:let-palette #:with-palette |
|
| 7 |
+ #:accentize |
|
| 8 |
+ #:colorscheme-bg #:colorscheme-bg-highlight |
|
| 9 |
+ #:colorscheme-fg-deemph #:colorscheme-fg #:colorscheme-fg-highlight |
|
| 10 |
+ #:colorscheme-accent |
|
| 11 |
+ #:colorscheme-hover-highlight)) |
|
| 12 |
+ |
|
| 13 |
+(in-package #:colors) |
|
| 14 |
+(declaim (optimize (debug 2) (safety 2) (speed 0))) |
|
| 15 |
+ |
|
| 16 |
+;;; Generic utility macro TODO: separate these out!!! |
|
| 17 |
+(defmacro initialize-to (obj1-v obj2-v &body slot-swaps) |
|
| 18 |
+ (alexandria:with-gensyms (obj1 obj2) |
|
| 19 |
+ `(let* ((,obj1 ,obj1-v) |
|
| 20 |
+ (,obj2 ,obj2-v)) |
|
| 21 |
+ ,@(loop for (to from) in slot-swaps |
|
| 22 |
+ collect `(setf (,to ,obj1) (,from ,obj2)))))) |
|
| 23 |
+ |
|
| 24 |
+;;; This macro connects the "-" prefixed slots in the colorscheme class |
|
| 25 |
+;;; To the appropriate palette |
|
| 26 |
+(defmacro def-palette-accessor (scheme-slot scheme palette ) |
|
| 27 |
+ `(progn |
|
| 28 |
+ (defgeneric ,scheme-slot (,scheme)) |
|
| 29 |
+ (defmethod ,scheme-slot ((,scheme colorscheme)) |
|
| 30 |
+ (slot-value ,palette (,(intern (concatenate 'string "-" (symbol-name scheme-slot))) ,scheme))))) |
|
| 31 |
+ |
|
| 32 |
+ |
|
| 33 |
+;; &group interfaces |
|
| 34 |
+;;; Palette class and methods &group |
|
| 35 |
+ |
|
| 36 |
+(defclass palette () ; solarized http://ethanschoonover.com/solarized |
|
| 37 |
+ ((base03 :accessor palette-base03 :initform "#002b36") |
|
| 38 |
+ (base02 :accessor palette-base02 :initform "#073642") |
|
| 39 |
+ (base01 :accessor palette-base01 :initform "#586e75") |
|
| 40 |
+ (base00 :accessor palette-base00 :initform "#657b83") |
|
| 41 |
+ (base0 :accessor palette-base0 :initform "#839496") |
|
| 42 |
+ (base1 :accessor palette-base1 :initform "#93a1a1") |
|
| 43 |
+ (base2 :accessor palette-base2 :initform "#eee8d5") |
|
| 44 |
+ (base3 :accessor palette-base3 :initform "#fdf6e3") |
|
| 45 |
+ (yellow :accessor palette-yellow :initform "#b58900") |
|
| 46 |
+ (orange :accessor palette-orange :initform "#cb4b16") |
|
| 47 |
+ (red :accessor palette-red :initform "#dc322f") |
|
| 48 |
+ (magenta :accessor palette-magenta :initform "#d33682") |
|
| 49 |
+ (violet :accessor palette-violet :initform "#6c71c4") |
|
| 50 |
+ (blue :accessor palette-blue :initform "#268bd2") |
|
| 51 |
+ (cyan :accessor palette-cyan :initform "#2aa198") |
|
| 52 |
+ (green :accessor palette-green :initform "#859900"))) |
|
| 53 |
+ |
|
| 54 |
+(defgeneric invert-palette (palette)) |
|
| 55 |
+ |
|
| 56 |
+;;; The palette var: this defaults to the solarized palette defined |
|
| 57 |
+;;; above, but can (and should) be temporarily rebound via the |
|
| 58 |
+;;; with-palette macro below. |
|
| 59 |
+(defparameter *palette* (make-instance 'palette)) |
|
| 60 |
+ |
|
| 61 |
+(defmacro let-palette (palette &body body) |
|
| 62 |
+ "Set custom palette in end-user code" |
|
| 63 |
+ `(let ((*palette* ,palette)) |
|
| 64 |
+ ,@body)) |
|
| 65 |
+ |
|
| 66 |
+(defmacro with-palette ((place) &body body) |
|
| 67 |
+ "Access the current palette" |
|
| 68 |
+ `(let ((,place *palette*)) |
|
| 69 |
+ ,@body)) |
|
| 70 |
+ |
|
| 71 |
+;;; &endgroup |
|
| 72 |
+;;; &group Color scheme |
|
| 73 |
+(defclass colorscheme () |
|
| 74 |
+ ((bg :accessor -colorscheme-bg :initform 'base03) |
|
| 75 |
+ (bg-highlight :accessor -colorscheme-bg-highlight :initform 'base02) |
|
| 76 |
+ (fg-deemph :accessor -colorscheme-fg-deemph :initform 'base01) |
|
| 77 |
+ (fg :accessor -colorscheme-fg :initform 'base0 ) |
|
| 78 |
+ (fg-highlight :accessor -colorscheme-fg-highlight :initform 'base1 ) |
|
| 79 |
+ (hover-highlight :accessor -colorscheme-hover-highlight :initform 'base3 ) |
|
| 80 |
+ (accent :accessor -colorscheme-accent :initform 'violet))) |
|
| 81 |
+ |
|
| 82 |
+(defgeneric accentize (colorscheme accent)) |
|
| 83 |
+ |
|
| 84 |
+(def-palette-accessor colorscheme-bg scheme *palette*) |
|
| 85 |
+(def-palette-accessor colorscheme-bg-highlight scheme *palette*) |
|
| 86 |
+(def-palette-accessor colorscheme-fg-deemph scheme *palette*) |
|
| 87 |
+(def-palette-accessor colorscheme-fg scheme *palette*) |
|
| 88 |
+(def-palette-accessor colorscheme-fg-highlight scheme *palette*) |
|
| 89 |
+(def-palette-accessor colorscheme-accent scheme *palette*) |
|
| 90 |
+(def-palette-accessor colorscheme-hover-highlight scheme *palette*) |
|
| 91 |
+ |
|
| 92 |
+;;; &endgroup |
|
| 93 |
+;; &endgroup |
|
| 94 |
+ |
|
| 95 |
+(defmethod invert-palette ((palette palette)) |
|
| 96 |
+ (let ((result (make-instance 'palette))) |
|
| 97 |
+ (initialize-to result palette |
|
| 98 |
+ (palette-base03 palette-base3) |
|
| 99 |
+ (palette-base02 palette-base2) |
|
| 100 |
+ (palette-base01 palette-base1) |
|
| 101 |
+ (palette-base00 palette-base0) |
|
| 102 |
+ (palette-base0 palette-base00) |
|
| 103 |
+ (palette-base1 palette-base01) |
|
| 104 |
+ (palette-base2 palette-base02) |
|
| 105 |
+ (palette-base3 palette-base03)) |
|
| 106 |
+ result)) |
|
| 107 |
+ |
|
| 108 |
+(defmethod accentize ((colorscheme colorscheme) accent) |
|
| 109 |
+ (setf (colorscheme-accent colorscheme) (funcall accent colorscheme))) |
|
| 110 |
+ |
|
| 111 |
+; vim: foldmethod=marker foldmarker=&group,&endgroup foldlevel=0 : |