Re: A style question

Ken Tilton wrote:

You refer of course to the Cello code to create a 3-D oblong button of
variable thickness with rounded corners of variable radius:

Yes, that's really ugly :-) Did you thought about using your dataflow
paradigm to create graphics? Something similar would be to use higher order
functions and combinators. The code below creates buttons like this:

http://www.frank-buss.de/tmp/buttons.png

In LispWorks 4.3.7 it is not very fast, but SBCL needs not many seconds :-)

(defparameter *width* 200)
(defparameter *height* 70)
(defstruct color
(r 0.0 :type single-float)
(g 0.0 :type single-float)
(b 0.0 :type single-float)
(a 0.0 :type single-float))

(defun rgb-2-color (rgb)
(declare (type fixnum rgb)
(make-color :r (/ (ldb (byte 8 16) rgb) 255.0)
:g (/ (ldb (byte 8 8) rgb) 255.0)
:b (/ (ldb (byte 8 0) rgb) 255.0)))

(defun middle (a b)
(/ (+ a b) 2.0))

(defconstant +transparent+ (make-color :r 1.0 :g 1.0 :b 1.0 :a 1.0))
(defconstant +white+ (make-color :r 1.0 :g 1.0 :b 1.0))

;(defconstant +color0+ (rgb-2-color #xeaeaa2))
;(defconstant +color1+ (rgb-2-color #xee4f23))

;(defconstant +color0+ (rgb-2-color #x999999))
;(defconstant +color1+ (rgb-2-color #x444444))

(defconstant +color0+ (rgb-2-color #xa2fafa))
(defconstant +color1+ (rgb-2-color #x23ee4f))

(defconstant +color-avg+
(make-color :r (middle (color-r +color0+) (color-r +color1+))
:g (middle (color-g +color0+) (color-g +color1+))
:b (middle (color-b +color0+) (color-b +color1+))))

(defun transparentp (color)
(= 1.0 (color-a color)))

(defun disc (&key x0 y0 radius)
(let ((r2 (* radius radius)))
(lambda (x y)
(let ((xc (- x x0))
(yc (- y y0)))
(let ((r (+ (* xc xc) (* yc yc))))
(<= r r2))))))

(defun rect (&key x0 y0 x1 y1)
(lambda (x y)
(and (>= x x0)
(<= x x1)
(>= y y0)
(<= y y1))))

(defun rounded-rect (&key x0 y0 x1 y1 radius)
(let ((x0-i (+ x0 radius))
(y0-i (+ y0 radius))
(x1-i (- x1 radius))
(y1-i (- y1 radius)))
(lambda (x y)
(let ((rect (rect :x0 x0 :y0 y0 :x1 x1 :y1 y1))
(top-left-disc (disc :x0 x0-i :y0 y0-i :radius radius))
(top-right-disc (disc :x0 x1-i :y0 y0-i :radius radius))
(bottom-left-disc (disc :x0 x0-i :y0 y1-i :radius radius))
(bottom-right-disc (disc :x0 x1-i :y0 y1-i :radius radius)))
(cond ((and (< x x0-i) (< y y0-i)) (funcall top-left-disc x y))
((and (> x x1-i) (< y y0-i)) (funcall top-right-disc x y))
((and (< x x0-i) (> y y1-i)) (funcall bottom-left-disc x y))
((and (> x x1-i) (> y y1-i)) (funcall bottom-right-disc x y))
(t (funcall rect x y)))))))

(defun gradient (&key color0 color1 x0 x1)
(let ((r0 (color-r color0))
(g0 (color-g color0))
(b0 (color-b color0))
(r1 (color-r color1))
(g1 (color-g color1))
(b1 (color-b color1))
(dx (- x1 x0)))
(lambda (x)
(cond ((< x x0) color0)
((>= x x1) color1)
(t (setf x (/ (- x x0) dx))
(make-color :r (+ (* (- r1 r0) x) r0)
:g (+ (* (- g1 g0) x) g0)
:b (+ (* (- b1 b0) x) b0)))))))

(defun blur (&key mask)
(lambda (x y)
(let ((sum 0.0))
(loop for xo from -4 to 4 do
(loop for yo from -4 to 4 do
(when (funcall mask (+ x xo) (+ y yo)) (incf sum (/ (+ (*
xo xo) (* yo yo) 2.0))))))
(/ sum 2.0))))

(defun add (fun1 fun2)
(lambda (x y)
(let ((c1 (funcall fun1 x y))
(c2 (funcall fun2 x y)))
(cond ((transparentp c1) c2)
((transparentp c2) c1)
(t (make-color :r (+ (color-r c1) (color-r c2))
:g (+ (color-g c1) (color-g c2))
:b (+ (color-b c1) (color-b c2))))))))

(defun neg-mul (color-fun channel-fun)
(lambda (x y)
(let ((color (funcall color-fun x y))
(channel (funcall channel-fun x y)))
(cond ((transparentp color) color)
(t (when (> channel 1) (setf channel 1))
(when (< channel 0) (setf channel 0))
(let ((channel2 (- 1 channel)))
(make-color :r (+ (* channel (color-r +color0+)) (*
channel2 (color-r color)))
:g (+ (* channel (color-g +color0+)) (* channel2 (color-g color)))
:b (+ (* channel (color-b +color0+)) (* channel2 (color-b color))))))))))

(defun fill-gradient-vertical (&key gradient function)
(lambda (x y)
(if (funcall function x y)
(funcall gradient y)
+transparent+)))

(defun fill-solid (&key function color)
(lambda (x y)
(if (funcall function x y)
color
+transparent+)))

(defun overlay (&key background foreground)
(lambda (x y)
(let ((foreground-color (funcall foreground x y)))
(if (transparentp foreground-color)
(funcall background x Y)
foreground-color))))

(defun xor (fun1 fun2)
(lambda (x y)
(not (eql (funcall fun1 x y) (funcall fun2 x y)))))

(defun channel-and (channel-fun binary-fun)
(lambda (x y)
(if (funcall binary-fun x y)
(funcall channel-fun x y)
0)))

(defun button (&key x0 y0 x1 y1)
(let* ((radius 15.0)
(stroke 1.0)
(outer-rect (rounded-rect :x0 (- x0 stroke) :y0 (- y0 stroke)
:x1 (+ x1 stroke) :y1 (+ y1 stroke)
:radius (+ radius stroke)))
(inner-rect (rounded-rect :x0 x0 :y0 y0
:x1 x1 :y1 y1
:radius radius))
(ring (xor outer-rect inner-rect))
(inner-glow (channel-and (blur :mask ring) inner-rect))
(gradient (gradient :color0 +color0+ :color1 +color1+ :x0 y0 :x1
y1))
(filled-outer-rect (fill-solid
:function outer-rect
:color +color-avg+))
(filled-inner-rect (fill-gradient-vertical
:gradient gradient
:function inner-rect)))
(overlay :background filled-outer-rect
:foreground (neg-mul filled-inner-rect inner-glow))))

(defun anti-alias (function)
(lambda (x y)
(let ((c0 (funcall function x y))
(c1 (funcall function (+ x 0.5) y))
(c2 (funcall function x (+ y 0.5)))
(c3 (funcall function (+ x 0.5) (+ y 0.5))))
(make-color :r (/ (+ (color-r c0) (color-r c1) (color-r c2) (color-r
c3)) 4.0)
:g (/ (+ (color-g c0) (color-g c1) (color-g c2) (color-g c3)) 4.0)
:b (/ (+ (color-b c0) (color-b c1) (color-b c2) (color-b c3)) 4.0)
:a (/ (+ (color-a c0) (color-a c1) (color-a c2) (color-a c3)) 4.0)))))

(defun color-byte (color)
(let ((result (floor (* 255.0 color))))
(cond ((> result 255) 255)
((< result 0) 0)
(t result))))

(defun red-byte (color)
(color-byte (color-r color)))

(defun green-byte (color)
(color-byte (color-g color)))

(defun blue-byte (color)
(color-byte (color-b color)))

(defun paint (function &optional (filename "c:/tmp/test.tga"))
(with-open-file
(tga filename
:direction :output
:if-exists :supersede
:element-type 'unsigned-byte)
(dolist (byte (list 0 0 2 0 0 0 0 0 0 0 0 0
(mod *width* 256) (floor *width* 256)
(mod *height* 256) (floor *height* 256) 24 0))
(write-byte byte tga))
(loop for y from (1- *height*) downto 0 do
(loop for x from 0 below *width* do
(let ((color (funcall function x y)))
(when (transparentp color) (setf color +white+))
(write-byte (blue-byte color) tga)
(write-byte (green-byte color) tga)
(write-byte (red-byte color) tga)))))
#+:lispworks (sys:call-system (format nil
"c:\\Programme\\Adobe\\Photoshop 7.0\\Photoshop.exe ~a" filename)))

(defun test ()
(paint (anti-alias (button :x0 10.0 :y0 10.0 :x1 190.0 :y1 60.0))))

--
Frank Buss, fb@xxxxxxxxxxxxx
http://www.frank-buss.de, http://www.it4-systems.de
.

Quantcast