r5326: *** empty log message ***

[wol.git] / color-picker.lisp

diff --git a/color-picker.lisp b/color-picker.lisp
new file mode 100644 (file)
index 0000000..2122e9e
--- /dev/null
+++ b/color-picker.lisp
@@ -0,0 +1,46 @@
+(defun luminance (r g b)
+  (+ (* r 0.299) (* g 0.587) (* b 0.114)))
+
+(defun std-pick-color-html-fn ()
+  (flet ((color-td (r g b)
+           (let ((color (format nil "#~2,'0x~2,'0x~2,'0x" r g b)))
+             (html ((:td :bgcolor color
+                        :fformat (:onclick "f42('~a');"
+                                           color))"   ")))))
+    (let* ((colors nil))
+      (dotimes (r 6)
+        (dotimes (g 6)
+          (dotimes (b 6)
+            (push (list (* r 51) (* g 51) (* b 51)(luminance r g b))
+                 colors))))
+      (setf colors (sort colors #'> :key 'fourth))
+      (html
+       (:head
+        (:title "Choose a color")
+        ((:link :rel "stylesheet" :type "text/css" :href "/pcol.css")))
+       (:body
+        :br
+        (:h1 "Choose a color")
+        (:jscript "function
+f42(d){window.opener.change_color(d);window.close();};")
+        ((:table :class "pcolt" :align "center")
+         (loop for x below 18
+               for row = (loop repeat 12 collect (pop colors))
+               for bl = (round (* 255 (- 1 (/ x 17))))
+               do
+               (html
+                (:tr
+                 (color-td  bl bl bl)
+                 (color-td  bl  0  0)
+                 (color-td   0 bl  0)
+                 (color-td   0  0 bl)
+                 (color-td   0 bl bl)
+                 (color-td  bl  0 bl)
+                 (color-td  bl bl  0)
+                 (loop for (r g b l) in row
+                       do (color-td r g b))))))
+        :br
+        ((:div :align "center")
+         ((:a :class "call" :href "javascript:window.close();")
+         "Close")))))))
+