/[mcclim]/mcclim/design.lisp
ViewVC logotype

Contents of /mcclim/design.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (show annotations)
Mon Apr 14 16:46:37 2008 UTC (6 years ago) by thenriksen
Branch: MAIN
CVS Tags: McCLIM-0-9-6, HEAD
Changes since 1.28: +103 -11 lines
Converted MCCLIM-IMAGES to CLIM 2.2 bitmap functions (with extensions).

Includes new demo application.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2000 by Robert Strandh (strandh@labri.u-bordeaux.fr)
5 ;;; (c) copyright 1998,2002 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
6
7 ;;; This library is free software; you can redistribute it and/or
8 ;;; modify it under the terms of the GNU Library General Public
9 ;;; License as published by the Free Software Foundation; either
10 ;;; version 2 of the License, or (at your option) any later version.
11 ;;;
12 ;;; This library is distributed in the hope that it will be useful,
13 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;;; Library General Public License for more details.
16 ;;;
17 ;;; You should have received a copy of the GNU Library General Public
18 ;;; License along with this library; if not, write to the
19 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 ;;; Boston, MA 02111-1307 USA.
21
22 ;;;; Some Notes
23
24 ;; The design design has a pitfall:
25 ;;
26 ;; As drawing is specified, a design of class opacity carries no color
27 ;; and thus borrows its color from +foreground-ink+. So that
28 ;;
29 ;; (make-opacity v) == (compose-in +foreground-ink+ (make-opacity v))
30 ;;
31 ;; This implies, that an opacity is not neccessary uniform, it depends
32 ;; on the selected foreground ink.
33 ;;
34 ;; They halfway fix this by specifing that the mask argument of
35 ;; compose-in and compose-out is thought as to be drawn with
36 ;; +foreground-ink+ = +background-ink+ = +black+.
37 ;;
38 ;; But Is (make-opacity 1) really the same as +foreground-ink+?
39 ;; Or: Is
40 ;; (compose-in D +foreground-ink+) different from
41 ;; (compose-in D (make-opacity 1))?
42 ;;
43 ;; If the above equation is true, we get a funny algebra:
44 ;;
45 ;; (make-opacity 0) = +transparent-ink+ = +nowhere+
46 ;; (make-opacity 1) = +foreground-ink+ = +everywhere+
47 ;;
48 ;; --GB
49
50 ;; I agree with this interpretation. -Hefner
51
52 ;; It might be handy to have the equivalent of parent-relative
53 ;; backgrounds. We can specify new indirect inks:
54 ;;
55 ;; +parent-background+
56 ;; +parent-relative-background+
57 ;; +parent-foreground+
58 ;; +parent-relative-foreground+
59 ;;
60 ;; The relative one would have the same "absolute" origin as the
61 ;; relevant inks of the parent.
62 ;;
63 ;; When they are evaluated, they look at the parent's
64 ;; foreground/background ink. Though the relative variants are
65 ;; expensive, when you want to scroll them ...
66 ;;
67 ;;
68 ;; Further we really should specify some form of indirekt ink
69 ;; protocol.
70 ;;
71 ;; --GB
72
73 ;;;; Design Protocol
74
75 ;;
76 ;; DRAW-DESIGN already is all you need for a design protocol.
77 ;;
78 ;; --GB
79
80
81 (in-package :clim-internals)
82
83 (eval-when (:compile-toplevel :load-toplevel :execute)
84
85 (defgeneric color-rgb (color))
86
87 (defmethod print-object ((color color) stream)
88 (print-unreadable-object (color stream :identity nil :type t)
89 (multiple-value-call #'format stream "~,4F ~,4F ~,4F" (color-rgb color))))
90
91 ;;; standard-color
92
93 (defclass standard-color (color)
94 ((red :initarg :red
95 :initform 0
96 :type (real 0 1))
97 (green :initarg :green
98 :initform 0
99 :type (real 0 1))
100 (blue :initarg :blue
101 :initform 0
102 :type (real 0 1))))
103
104 (defmethod color-rgb ((color standard-color))
105 (with-slots (red green blue) color
106 (values red green blue)))
107
108 (defclass named-color (standard-color)
109 ((name :initarg :name
110 :initform "Unnamed color") ))
111
112 (defmethod print-object ((color named-color) stream)
113 (with-slots (name) color
114 (print-unreadable-object (color stream :type t :identity nil)
115 (format stream "~S" name))))
116
117 (defmethod make-load-form ((color named-color) &optional env)
118 (declare (ignore env))
119 (with-slots (name red green blue) color
120 `(make-named-color ',name ,red ,green ,blue)))
121
122 (eval-when (:compile-toplevel :load-toplevel :execute)
123 (defvar *color-hash-table* (make-hash-table :test #'eql)))
124
125 (defun compute-color-key (red green blue)
126 (+ (ash (round (* 255 red)) 16)
127 (ash (round (* 255 green)) 8)
128 (round (* 255 blue))))
129
130 (defun make-rgb-color (red green blue)
131 (let ((key (compute-color-key red green blue)))
132 (declare (type fixnum key))
133 (or (gethash key *color-hash-table*)
134 (setf (gethash key *color-hash-table*)
135 (make-instance 'named-color :red red :green green :blue blue)))))
136
137 (defun make-gray-color (intensity)
138 (make-rgb-color intensity intensity intensity))
139
140 (defun make-named-color (name red green blue)
141 (let* ((key (compute-color-key red green blue))
142 (entry (gethash key *color-hash-table*)))
143 (declare (type fixnum key))
144 (cond (entry
145 (when (string-equal (slot-value entry 'name) "Unnamed color")
146 (setf (slot-value entry 'name) name))
147 entry)
148 (t (setf (gethash key *color-hash-table*)
149 (make-instance 'named-color :name name :red red :green green :blue blue))))))
150 ) ; eval-when
151
152 ;;; ;;; For ihs to rgb conversion, we use the formula
153 ;;; ;;; i = (r+g+b)/3
154 ;;; ;;; s = 1-min(r,g,b)/i
155 ;;; ;;; h = 60(g-b)/(max(r,g,b)-min(r,g,b)) if r >= g,b
156 ;;; ;;; 120+60(b-r)/(max(r,g,b)-min(r,g,b)) if g >= r,b
157 ;;; ;;; 240+60(r-g)/(max(r,g,b)-min(r,g,b)) if b >= r,g
158 ;;; ;;; First, we introduce colors x, y, z such that x >= y >= z
159 ;;; ;;; We compute x, y, and z and then determine the correspondance
160 ;;; ;;; between x, y, and z on the one hand and r, g, and b on the other.
161 ;;; (defun make-ihs-color (i h s)
162 ;;; (assert (and (<= 0 i 1)
163 ;;; (<= 0 s 1)
164 ;;; (<= 0 h 360)))
165 ;;; (let ((ah (/ (abs (cond ((<= h 60) h)
166 ;;; ((<= h 180) (- h 120))
167 ;;; ((<= h 300) (- h 240))
168 ;;; (t (- h 360))))
169 ;;; 60)))
170 ;;; (let* ((z (* i (- 1 s)))
171 ;;; (y (/ (+ (* ah (- (* 3 i) (* 2 z))) z) (+ 1 ah)))
172 ;;; (x (- (* 3 i) y z)))
173 ;;; (assert (and (<= 0 x 1)
174 ;;; (<= 0 y 1)
175 ;;; (<= 0 z 1)))
176 ;;; (cond ((<= h 60) (make-rgb-color x y z))
177 ;;; ((<= h 120) (make-rgb-color y x z))
178 ;;; ((<= h 180) (make-rgb-color z x y))
179 ;;; ((<= h 240) (make-rgb-color z y x))
180 ;;; ((<= h 300) (make-rgb-color y z x))
181 ;;; (t (make-rgb-color x z y))))))
182 ;;;
183 ;;; (defmethod color-ihs ((color color))
184 ;;; (multiple-value-bind (r g b) (color-rgb color)
185 ;;; (let ((max (max r g b))
186 ;;; (min (min r g b))
187 ;;; (intensity (/ (+ r g b) 3)))
188 ;;; (if (= max min)
189 ;;; (values intensity 0 0)
190 ;;; (let* ((saturation (- 1 (/ min intensity)))
191 ;;; (diff (- max min))
192 ;;; (hue (* 60 (cond ((= max r) (/ (- g b) diff))
193 ;;; ((= max g) (+ 2 (/ (- b r) diff)))
194 ;;; (t (+ 4 (/ (- r g) diff)))))))
195 ;;; (when (< hue 0)
196 ;;; (incf hue 360))
197 ;;; (values intensity hue saturation))))))
198
199 ;;;
200 ;;; Below is a literal translation from Dylan's DUIM source code,
201 ;;; which was itself probably literal translation from some Lisp code.
202 ;;;
203
204 (defconstant +ihs-rgb-c1+ (sqrt (coerce 1/6 'double-float)))
205 (defconstant +ihs-rgb-c2+ (sqrt (coerce 1/2 'double-float)))
206 (defconstant +ihs-rgb-c3+ (sqrt (coerce 1/3 'double-float)))
207
208 (defun ihs-to-rgb (intensity hue saturation)
209 (let* ((hh (- (* (mod (- hue 1/2) 1) 2 pi) pi))
210 (c3 (cos saturation))
211 (s3 (sin saturation))
212 (cos-hh (cos hh))
213 (sin-hh (sin hh))
214 (x (* +ihs-rgb-c1+ s3 cos-hh intensity))
215 (y (* +ihs-rgb-c2+ s3 sin-hh intensity))
216 (z (* +ihs-rgb-c3+ c3 intensity)))
217 (declare (type (real #.(- pi) #.pi) hh))
218 (values (max 0 (min 1 (+ x x z)))
219 (max 0 (min 1 (+ y z (- x))))
220 (max 0 (min 1 (- z x y))))))
221
222 (defun rgb-to-ihs (red green blue)
223 (let* ((x (* +ihs-rgb-c1+ (- (* 2 red) blue green)))
224 (y (* +ihs-rgb-c2+ (- green blue)))
225 (z (* +ihs-rgb-c3+ (+ red green blue)))
226 (q (+ (* x x) (* y y)))
227 (intensity (sqrt (+ q (* z z))))) ;sqrt(r^2 + g^2 + b^2)
228 (if (zerop q)
229 ;; A totally unsaturated color
230 (values intensity 0 0)
231 (let* ((hue (mod (/ (atan y x) (* 2 pi)) 1))
232 (f1 (/ z intensity))
233 (f2 (sqrt (- 1 (* f1 f1))))
234 (saturation (atan f2 f1)))
235 (values intensity hue saturation)))))
236
237 (defgeneric color-ihs (color))
238
239 (defmethod color-ihs ((color color))
240 (multiple-value-call #'rgb-to-ihs (color-rgb color)))
241
242 (defun make-ihs-color (i h s)
243 (multiple-value-call #'make-rgb-color (ihs-to-rgb i h s)))
244
245
246 (defun make-contrasting-inks (n &optional k)
247 ;; Look +contrasting-colors+ up at runtime, because it has not yet been
248 ;; declared when this is compiled.
249 (let ((contrasting-colors (symbol-value '+contrasting-colors+)))
250 (if (> n (length contrasting-colors))
251 (error "The argument N is out of range [1-~D]" (length contrasting-colors)))
252 (if (null k)
253 (subseq contrasting-colors 0 n)
254 (aref contrasting-colors k))))
255
256 #||
257 ;;; I used this function to generate the predefined colors and names - mikemac@mikemac.com
258
259 (defun generate-named-colors ()
260 (with-open-file (out "X11-colors.lisp" :direction :output :if-exists :supersede)
261 (with-open-file (in "/usr/X11/lib/X11/rgb.txt" :direction :input)
262 (format out ";;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-~%~%")
263 (format out "(in-package :clim-internals)~%~%")
264 (loop with names = nil
265 for line = (read-line in nil nil)
266 until (null line)
267 do (if (eql (aref line 0) #\!)
268 (format out ";~A~%" (subseq line 1))
269 (multiple-value-bind (red index) (parse-integer line :start 0 :junk-allowed t)
270 (multiple-value-bind (green index) (parse-integer line :start index :junk-allowed t)
271 (multiple-value-bind (blue index) (parse-integer line :start index :junk-allowed t)
272 (let ((name (substitute #\- #\Space (string-trim '(#\Space #\Tab #\Newline) (subseq line index)))))
273 (format out "(defconstant +~A+ (make-named-color ~S ~,4F ~,4F ~,4F))~%" name name (/ red 255.0) (/ green 255.0) (/ blue 255.0))
274 (setq names (nconc names (list name))))))))
275 finally (format out "~%(defconstant +contrasting-colors+ (vector +black+ +red+ +green+ +blue+ +cyan+ +magenta+ +yellow+ +white+))~%~%")
276 (format out "(eval-when (eval compile load)~% (export '(")
277 (loop for name in names
278 for count = 1 then (1+ count)
279 do (format out "+~A+ " name)
280 (when (= count 4)
281 (format out "~% ")
282 (setq count 0)))
283 (format out "~% )))~%")
284 ))))
285
286 ||#
287
288 ;;;; Design <-> Region Equivalences
289
290 ;;; As Gilbert points in his notes, transparent ink is in every
291 ;;; respect interchangable with the nowhere region, and likewise
292 ;;; foreground ink is interchangable with the everywhere region.
293 ;;; By defining the following mixins and adding them to the
294 ;;; appropriate ink/region class pairs, we can reduce the number
295 ;;; of methods necessary.
296
297 (defclass everywhere-mixin () ())
298 (defclass nowhere-mixin () ())
299 ;;;;
300 ;;;; 13.6 Indirect Inks
301 ;;;;
302
303 (defclass indirect-ink (design) ())
304
305 (defclass %foreground-ink (indirect-ink everywhere-mixin) ())
306
307 (defvar +foreground-ink+ (make-instance '%foreground-ink))
308 (defvar +background-ink+ (make-instance 'indirect-ink))
309
310 (defmethod print-object ((ink (eql +foreground-ink+)) stream)
311 (format stream "#.~S" '+foreground-ink+))
312
313 (defmethod print-object ((ink (eql +background-ink+)) stream)
314 (format stream "#.~S" '+background-ink+))
315
316 ;;;;
317 ;;;; 13.4 Opacity
318 ;;;;
319
320 (defmethod print-object ((object opacity) stream)
321 (print-unreadable-object (object stream :identity nil :type t)
322 (format stream "~S" (opacity-value object))))
323
324 ;; Note: Though tempting, opacity is not a uniform-design!
325
326 (defclass standard-opacity (opacity)
327 ((value :initarg :value
328 :type (real 0 1)
329 :reader opacity-value)))
330
331 (defclass %transparent-ink (standard-opacity nowhere-mixin)
332 ()
333 (:default-initargs :value 0))
334
335 (defvar +transparent-ink+
336 (make-instance '%transparent-ink :value 0))
337
338 (defmethod opacity-value ((region everywhere-mixin))
339 (declare (ignore region))
340 1.0)
341
342 (defmethod opacity-value ((region nowhere-mixin))
343 (declare (ignore region))
344 0.0)
345
346 (defun make-opacity (value)
347 (setf value (clamp value 0 1)) ;defensive programming
348 (cond ((= value 0) +transparent-ink+)
349 ((= value 1) +everywhere+) ; used to say +foreground-ink+
350 (t
351 (make-instance 'standard-opacity :value value))))
352
353 ;;;;
354 ;;;; 13.7 Flipping Ink
355 ;;;;
356
357 (defclass standard-flipping-ink (design)
358 ((design1 :initarg :design1
359 :type design)
360 (design2 :initarg :design2
361 :type design)))
362
363 (defvar +flipping-ink+ (make-instance 'standard-flipping-ink
364 :design1 +foreground-ink+
365 :design2 +background-ink+))
366
367 (defmethod print-object ((ink (eql +flipping-ink+)) stream)
368 (format stream "#.~S" '+flipping-ink+))
369
370 (defmethod print-object ((flipper standard-flipping-ink) stream)
371 (with-slots (design1 design2) flipper
372 (print-unreadable-object (flipper stream :identity nil :type t)
373 (format stream "~S ~S" design1 design2))))
374
375 (defgeneric make-flipping-ink (design1 design2))
376
377 (defmethod make-flipping-ink ((design1 design) (design2 design))
378 (make-instance 'standard-flipping-ink :design1 design1 :design2 design2))
379
380 (defmethod make-flipping-ink ((design1 (eql +foreground-ink+))
381 (design2 (eql +background-ink+)))
382 +flipping-ink+)
383
384 (defmethod make-flipping-ink ((design1 (eql +background-ink+))
385 (design2 (eql +foreground-ink+)))
386 +flipping-ink+)
387
388 ;;;;
389 ;;;; 14 General Designs
390 ;;;;
391
392 (declaim (inline color-blend-function))
393 (defun color-blend-function (r1 g1 b1 o1 r2 g2 b2 o2)
394 (let* ((o3 (+ o1 (* (- 1 o1) o2)))
395 (r3 (/ (+ (* r1 o1) (* (- 1 o1) o2 r2)) o3))
396 (g3 (/ (+ (* g1 o1) (* (- 1 o1) o2 g2)) o3))
397 (b3 (/ (+ (* b1 o1) (* (- 1 o1) o2 b2)) o3)))
398 (values
399 r3 g3 b3 o3)))
400
401 (defgeneric compose-over (design1 design2))
402 (defgeneric compose-in (ink mask))
403 (defgeneric compose-out (ink mask))
404
405 ;;; RGB image designs, efficient support for truecolor images. ARGB
406 ;;; image data represented as an (unsigned-byte 32) array
407
408 (defclass rgb-image ()
409 ((width :initarg :width :accessor image-width)
410 (height :initarg :height :accessor image-height)
411 (data :initarg :data
412 :accessor image-data
413 :type (or null (simple-array (unsigned-byte 32) (* *))))
414 (alphap :initarg :alphap
415 :initform nil
416 :accessor image-alpha-p)))
417
418 ;; Applications (closure in particular) might want to cache any
419 ;; backend-specific data required to draw an RGB-IMAGE.
420 ;;
421 ;; To implement this caching, designs must be created separately for each
422 ;; medium, so that mediums can put their own data into them.
423
424 (defclass rgb-image-design (design)
425 ((medium :initform nil :initarg :medium)
426 (image :reader image
427 :initarg :image)
428 (medium-data :initform nil)))
429
430 (defun make-rgb-image-design (image)
431 (make-instance 'rgb-image-design :image image))
432
433
434 ;; Protocol to free cached data
435
436 (defgeneric medium-free-image-design (medium design))
437
438 (defun free-image-design (design)
439 (medium-free-image-design (slot-value design 'medium) design))
440
441
442 ;; Drawing protocol
443
444 (defgeneric medium-draw-image-design* (medium design x y))
445
446 ;; Fetching protocol
447
448 (defun sheet-rgb-image (sheet &key x y width height)
449 (multiple-value-bind (data alphap)
450 (sheet-rgb-data (port sheet)
451 sheet
452 :x x
453 :y y
454 :width width
455 :height height)
456 (destructuring-bind (height width)
457 (array-dimensions data)
458 (make-instance 'rgb-image
459 :width width
460 :height height
461 :data data
462 :alphap alphap))))
463
464 (defgeneric sheet-rgb-data (port sheet &key x y width height))
465
466 (defmethod draw-design
467 (medium (design rgb-image-design) &rest options
468 &key (x 0) (y 0) &allow-other-keys)
469 (with-medium-options (medium options)
470 (medium-draw-image-design* medium design x y)))
471
472 ;; PATTERN is just the an abstract class of all pattern-like design.
473
474 ;; For performance might consider to sort out pattern, which consists
475 ;; of uniform designs only and convert them to an RGBA-image.
476
477 (define-protocol-class pattern (design))
478
479 (defclass indexed-pattern (pattern)
480 ((array :initarg :array :reader pattern-array)
481 (designs :initarg :designs :reader pattern-designs)))
482
483 (defun make-pattern (array designs)
484 (make-instance 'indexed-pattern :array array :designs designs))
485
486 (defmethod pattern-width ((pattern indexed-pattern))
487 (array-dimension (pattern-array pattern) 1))
488
489 (defmethod pattern-height ((pattern indexed-pattern))
490 (array-dimension (pattern-array pattern) 0))
491
492 (defclass stencil (pattern)
493 ((array :initarg :array)))
494
495 (defun make-stencil (array)
496 (make-instance 'stencil :array array))
497
498 (defmethod pattern-width ((pattern stencil))
499 (with-slots (array) pattern
500 (array-dimension array 1)))
501
502 (defmethod pattern-height ((pattern stencil))
503 (with-slots (array) pattern
504 (array-dimension array 0)))
505
506 ;; These methods are included mostly for completeness and are likely
507 ;; of little use in practice.
508 (defmethod pattern-array ((pattern stencil))
509 (let ((array (make-array (list (pattern-height pattern)
510 (pattern-width pattern)))))
511 (dotimes (i (pattern-height pattern))
512 (dotimes (j (pattern-width pattern))
513 (setf (aref array i j) (+ (* i (array-dimension array 1)) j))))
514 array))
515
516 (defmethod pattern-designs ((pattern stencil))
517 (with-slots (array) pattern
518 (let ((designs (make-array (* (pattern-height pattern)
519 (pattern-width pattern)))))
520 (dotimes (i (length designs))
521 (setf (aref designs i) (make-opacity (row-major-aref array i))))
522 array)))
523
524 (defclass rgb-pattern (pattern rgb-image-design)
525 ())
526
527 (defmethod pattern-width ((pattern rgb-pattern))
528 (image-width (image pattern)))
529
530 (defmethod pattern-height ((pattern rgb-pattern))
531 (image-height (image pattern)))
532
533 ;; RGB-PATTERNs must be treated specially...
534 (defmethod medium-draw-pattern* (medium (pattern rgb-pattern) x y)
535 (medium-draw-image-design* medium pattern x y))
536
537 ;;;
538
539 (defclass transformed-design (design)
540 ((transformation
541 :initarg :transformation
542 :reader transformed-design-transformation)
543 (design
544 :initarg :design
545 :reader transformed-design-design)))
546
547 (defmethod transform-region (transformation (design design))
548 (make-instance 'transformed-design
549 :transformation transformation
550 :design design))
551
552 (defmethod transform-region (transformation (design pattern))
553 (make-instance 'transformed-design
554 :transformation transformation
555 :design design))
556
557 ;;;
558
559 (defclass rectangular-tile (design)
560 ((width :initarg :width :reader rectangular-tile-width)
561 (height :initarg :height :reader rectangular-tile-height)
562 (design :initarg :design :reader rectangular-tile-design)))
563
564 (defun make-rectangular-tile (design width height)
565 (make-instance 'rectangular-tile
566 :width width
567 :height height
568 :design design))
569
570 ;;;
571
572 (defclass masked-compositum (design)
573 ((ink :initarg :ink :reader compositum-ink)
574 (mask :initarg :mask :reader compositum-mask)))
575
576 (defmethod print-object ((object masked-compositum) stream)
577 (print-unreadable-object (object stream :identity nil :type t)
578 (format stream "~S ~S ~S ~S"
579 :ink (compositum-ink object)
580 :mask (compositum-mask object))))
581
582 (defclass in-compositum (masked-compositum) ())
583
584 (defmethod compose-in ((ink design) (mask design))
585 (make-instance 'in-compositum
586 :ink ink
587 :mask mask))
588
589 (defclass out-compositum (masked-compositum) ())
590
591 (defmethod compose-out ((ink design) (mask design))
592 (make-instance 'out-compositum
593 :ink ink
594 :mask mask))
595
596 (defclass over-compositum (design)
597 ((foreground :initarg :foreground :reader compositum-foreground)
598 (background :initarg :background :reader compositum-background)))
599
600 (defmethod compose-over ((foreground design) (background design))
601 (make-instance 'over-compositum
602 :foreground foreground
603 :background background))
604
605 (defclass uniform-compositum (in-compositum)
606 ;; we use this class to represent rgbo values
607 ())
608
609 ;;;
610 ;;; color
611 ;;; opacity
612 ;;; indirect-ink
613 ;;; in-compositum
614 ;;; over-compositum
615 ;;; out-compositum
616 ;;; uniform-compositum
617 ;;;
618
619
620 ;;;; ------------------------------------------------------------------------------------------
621 ;;;;
622 ;;;; COMPOSE-IN
623 ;;;;
624
625 (defun make-uniform-compositum (ink opacity-value)
626 (cond ((= opacity-value 0)
627 +transparent-ink+)
628 ((= opacity-value 1)
629 ink)
630 (t
631 (make-instance 'uniform-compositum
632 :ink ink
633 :mask (make-opacity opacity-value)))))
634 ;;; COLOR
635
636 (defmethod compose-in ((ink design) (mask color))
637 (declare (ignorable ink))
638 ink)
639
640 ;;; OPACITY
641
642 (defmethod compose-in ((ink opacity) (mask opacity))
643 (make-opacity (* (opacity-value ink) (opacity-value mask))))
644
645 (defmethod compose-in ((ink color) (mask opacity))
646 (make-uniform-compositum ink (opacity-value mask)))
647
648 ;;; UNIFORM-COMPOSITUM
649
650 (defmethod compose-in ((ink uniform-compositum) (mask uniform-compositum))
651 (make-uniform-compositum (compositum-ink ink)
652 (* (opacity-value (compositum-mask ink))
653 (opacity-value (compositum-mask mask)))))
654
655 (defmethod compose-in ((ink uniform-compositum) (mask opacity))
656 (make-uniform-compositum (compositum-ink ink)
657 (* (opacity-value (compositum-mask ink))
658 (opacity-value mask))))
659
660 (defmethod compose-in ((ink opacity) (mask uniform-compositum))
661 (make-opacity (* (opacity-value mask)
662 (opacity-value (compositum-mask mask)))))
663
664 (defmethod compose-in ((ink color) (mask uniform-compositum))
665 (make-uniform-compositum ink (opacity-value mask)))
666
667 (defmethod compose-in ((design design) (mask everywhere-mixin))
668 (declare (ignore mask))
669 design)
670
671 (defmethod compose-in ((design design) (mask nowhere-mixin))
672 (declare (ignore design mask))
673 +nowhere+)
674
675 ;;; IN-COMPOSITUM
676
677 ;; Since compose-in is associative, we can write it this way:
678 (defmethod compose-in ((ink in-compositum) (mask design))
679 (compose-in (compositum-ink ink)
680 (compose-in (compositum-mask ink)
681 mask)))
682
683 #+nyi
684 (defmethod compose-in ((ink opacity) (mask in-compositum))
685 (declare (ignorable ink mask))
686 )
687
688 #+nyi
689 (defmethod compose-in ((ink color) (mask in-compositum))
690 (declare (ignorable ink mask))
691 )
692
693
694 ;;; OUT-COMPOSITUM
695
696 #+nyi
697 (defmethod compose-in ((ink out-compositum) (mask out-compositum))
698 (declare (ignorable ink mask))
699 )
700
701 #+nyi
702 (defmethod compose-in ((ink out-compositum) (mask in-compositum))
703 (declare (ignorable ink mask))
704 )
705
706 #+nyi
707 (defmethod compose-in ((ink out-compositum) (mask uniform-compositum))
708 (declare (ignorable ink mask))
709 )
710
711 #+nyi
712 (defmethod compose-in ((ink out-compositum) (mask opacity))
713 (declare (ignorable ink mask))
714 )
715
716 #+nyi
717 (defmethod compose-in ((ink uniform-compositum) (mask out-compositum))
718 (declare (ignorable ink mask))
719 )
720
721 #+nyi
722 (defmethod compose-in ((ink opacity) (mask out-compositum))
723 (declare (ignorable ink mask))
724 )
725
726 #+nyi
727 (defmethod compose-in ((ink color) (mask out-compositum))
728 (declare (ignorable ink mask))
729 )
730
731
732 ;;; OVER-COMPOSITUM
733
734 #+nyi
735 (defmethod compose-in ((ink over-compositum) (mask over-compositum))
736 (declare (ignorable ink mask))
737 )
738
739 #+nyi
740 (defmethod compose-in ((ink over-compositum) (mask out-compositum))
741 (declare (ignorable ink mask))
742 )
743
744 #+nyi
745 (defmethod compose-in ((ink over-compositum) (mask in-compositum))
746 (declare (ignorable ink mask))
747 )
748
749 #+nyi
750 (defmethod compose-in ((ink over-compositum) (mask uniform-compositum))
751 (declare (ignorable ink mask))
752 )
753
754 #+nyi
755 (defmethod compose-in ((ink over-compositum) (mask opacity))
756 (declare (ignorable ink mask))
757 )
758
759 #+nyi
760 (defmethod compose-in ((ink out-compositum) (mask over-compositum))
761 (declare (ignorable ink mask))
762 )
763
764 #+nyi
765 (defmethod compose-in ((ink uniform-compositum) (mask over-compositum))
766 (declare (ignorable ink mask))
767 )
768
769 #+nyi
770 (defmethod compose-in ((ink opacity) (mask over-compositum))
771 (declare (ignorable ink mask))
772 )
773
774 #+nyi
775 (defmethod compose-in ((ink color) (mask over-compositum))
776 (declare (ignorable ink mask))
777 )
778
779 ;;;; ------------------------------------------------------------------------------------------
780 ;;;;
781 ;;;; Compose-Out
782 ;;;;
783
784 (defmethod compose-out ((design design) (mask everywhere-mixin))
785 (declare (ignore design mask))
786 +nowhere+)
787
788 (defmethod compose-out ((design design) (mask nowhere-mixin))
789 (declare (ignore mask))
790 design)
791
792 (defmethod compose-out ((design design) (mask color))
793 (declare (ignore design mask))
794 +nowhere+)
795
796 (defmethod compose-out ((design design) (mask uniform-compositum))
797 (compose-in design (make-opacity (- 1.0 (compositum-mask (opacity-value mask))))))
798
799 (defmethod compose-out ((design design) (mask standard-opacity))
800 (compose-in design (make-opacity (- 1.0 (opacity-value mask)))))
801
802 ;;;; ------------------------------------------------------------------------------------------
803 ;;;;
804 ;;;; Compose-Over
805 ;;;;
806
807 ;;; COLOR
808
809 (defmethod compose-over ((foreground color) (background design))
810 (declare (ignorable background))
811 foreground)
812
813 ;;; OPACITY
814
815 (defmethod compose-over ((foreground opacity) (background opacity))
816 (make-opacity
817 (+ (opacity-value foreground)
818 (* (- 1 (opacity-value foreground)) (opacity-value background)))))
819
820 (defmethod compose-over ((foreground opacity) (background color))
821 (make-instance 'over-compositum
822 :foreground foreground
823 :background background))
824
825 ;;; UNIFORM-COMPOSITUM
826
827 (defmethod compose-over ((foreground uniform-compositum) (background uniform-compositum))
828 (multiple-value-bind (r g b o)
829 (multiple-value-call #'color-blend-function
830 (color-rgb (compositum-ink foreground))
831 (opacity-value (compositum-mask foreground))
832 (color-rgb (compositum-ink background))
833 (opacity-value (compositum-mask background)))
834 (make-uniform-compositum
835 (make-rgb-color r g b)
836 o)))
837
838 (defmethod compose-over ((foreground uniform-compositum) (background opacity))
839 (make-instance 'over-compositum
840 :foreground foreground
841 :background background))
842
843 (defmethod compose-over ((foreground uniform-compositum) (background color))
844 (multiple-value-bind (r g b o)
845 (multiple-value-call #'color-blend-function
846 (color-rgb (compositum-ink foreground))
847 (opacity-value (compositum-mask foreground))
848 (color-rgb background)
849 1)
850 (make-uniform-compositum
851 (make-rgb-color r g b)
852 o)))
853
854 (defmethod compose-over ((foreground opacity) (background uniform-compositum))
855 (multiple-value-bind (r g b o)
856 (multiple-value-call #'color-blend-function
857 (color-rgb foreground)
858 (color-rgb (compositum-ink background))
859 (opacity-value (compositum-mask background)))
860 (make-uniform-compositum
861 (make-rgb-color r g b)
862 o)))
863
864 ;;; IN-COMPOSITUM
865
866 #+nyi
867 (defmethod compose-over ((foreground in-compositum) (background in-compositum))
868 (declare (ignorable foreground background))
869 )
870
871 #+nyi
872 (defmethod compose-over ((foreground in-compositum) (background uniform-compositum))
873 (declare (ignorable foreground background))
874 )
875
876 #+nyi
877 (defmethod compose-over ((foreground in-compositum) (background opacity))
878 (declare (ignorable foreground background))
879 )
880
881 #+nyi
882 (defmethod compose-over ((foreground in-compositum) (background color))
883 (declare (ignorable foreground background))
884 )
885
886 #+nyi
887 (defmethod compose-over ((foreground uniform-compositum) (background in-compositum))
888 (declare (ignorable foreground background))
889 )
890
891 #+nyi
892 (defmethod compose-over ((foreground opacity) (background in-compositum))
893 (declare (ignorable foreground background))
894 )
895
896 ;;; OUT-COMPOSITUM
897
898 #+nyi
899 (defmethod compose-over ((foreground out-compositum) (background out-compositum))
900 (declare (ignorable foreground background))
901 )
902
903 #+nyi
904 (defmethod compose-over ((foreground out-compositum) (background in-compositum))
905 (declare (ignorable foreground background))
906 )
907
908 #+nyi
909 (defmethod compose-over ((foreground out-compositum) (background uniform-compositum))
910 (declare (ignorable foreground background))
911 )
912
913 #+nyi
914 (defmethod compose-over ((foreground out-compositum) (background opacity))
915 (declare (ignorable foreground background))
916 )
917
918 #+nyi
919 (defmethod compose-over ((foreground out-compositum) (background color))
920 (declare (ignorable foreground background))
921 )
922
923 #+nyi
924 (defmethod compose-over ((foreground in-compositum) (background out-compositum))
925 (declare (ignorable foreground background))
926 )
927
928 #+nyi
929 (defmethod compose-over ((foreground uniform-compositum) (background out-compositum))
930 (declare (ignorable foreground background))
931 )
932
933 #+nyi
934 (defmethod compose-over ((foreground color) (background out-compositum))
935 (declare (ignorable foreground background))
936 )
937
938 ;;; OVER-COMPOSITUM
939
940 #+nyi
941 (defmethod compose-over ((foreground over-compositum) (background over-compositum))
942 (declare (ignorable foreground background))
943 )
944
945 #+nyi
946 (defmethod compose-over ((foreground over-compositum) (background out-compositum))
947 (declare (ignorable foreground background))
948 )
949
950 #+nyi
951 (defmethod compose-over ((foreground over-compositum) (background in-compositum))
952 (declare (ignorable foreground background))
953 )
954
955 #+nyi
956 (defmethod compose-over ((foreground over-compositum) (background uniform-compositum))
957 (declare (ignorable foreground background))
958 )
959
960 #+nyi
961 (defmethod compose-over ((foreground over-compositum) (background opacity))
962 (declare (ignorable foreground background))
963 )
964
965 #+nyi
966 (defmethod compose-over ((foreground over-compositum) (background color))
967 (declare (ignorable foreground background))
968 )
969
970 #+nyi
971 (defmethod compose-over ((foreground out-compositum) (background over-compositum))
972 (declare (ignorable foreground background))
973 )
974
975 #+nyi
976 (defmethod compose-over ((foreground in-compositum) (background over-compositum))
977 (declare (ignorable foreground background))
978 )
979
980 #+nyi
981 (defmethod compose-over ((foreground uniform-compositum) (background over-compositum))
982 (declare (ignorable foreground background))
983 )
984
985 #+nyi
986 (defmethod compose-over ((foreground opacity) (background over-compositum))
987 (declare (ignorable foreground background))
988 )
989
990 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
991
992 ;;; Comparison of designs.
993
994 (defgeneric design-equalp (design1 design2))
995
996 (defmethod design-equalp :around ((design1 t) (design2 t))
997 (or (eql design1 design2)
998 (call-next-method)))
999
1000 (defmethod design-equalp ((design1 t) (design2 t))
1001 nil)
1002
1003 (defmethod design-equalp ((design1 standard-color) (design2 standard-color))
1004 (multiple-value-bind (r1 g1 b1)
1005 (color-rgb design1)
1006 (multiple-value-bind (r2 g2 b2)
1007 (color-rgb design2)
1008 (and (= r1 r2)
1009 (= g1 g2)
1010 (= b1 b2)))))
1011
1012 ;;; The two default colors
1013
1014 (defconstant +white+ (make-named-color "white" 1.0000 1.0000 1.0000))
1015 (defconstant +black+ (make-named-color "black" 0.0000 0.0000 0.0000))
1016
1017 ;;; Color utilities
1018
1019 (defgeneric highlight-shade (ink)
1020 (:documentation
1021 "Produce an alternate shade of the given ink for the purpose of highlighting.
1022 Typically the ink will be brightened, but very light inks may be darkened."))
1023
1024 (defmethod highlight-shade (ink) ink)
1025
1026 (defmethod highlight-shade ((ink (eql +background-ink+)))
1027 +foreground-ink+)
1028
1029 (defmethod highlight-shade ((ink (eql +foreground-ink+)))
1030 +background-ink+)
1031
1032 (defmethod highlight-shade ((ink standard-color))
1033 (let ((brighten-factor 0.5)
1034 (darken-factor 0.15))
1035 (multiple-value-bind (r g b) (color-rgb ink)
1036 (multiple-value-bind (blend-ink factor)
1037 (if (> (- 3.0 r g b) 0.2)
1038 (values +white+ brighten-factor)
1039 (values +black+ darken-factor))
1040 (compose-over (compose-in blend-ink (make-opacity factor))
1041 ink)))))

  ViewVC Help
Powered by ViewVC 1.1.5