[closure-cvs] CVS closure/src/renderer
emarsden
emarsden at common-lisp.net
Sat Dec 30 15:13:56 UTC 2006
Update of /project/closure/cvsroot/closure/src/renderer
In directory clnet:/tmp/cvs-serv12910/src/renderer
Modified Files:
clim-draw.lisp renderer2.lisp x11.lisp
Log Message:
- use CL from Closure packages
- minor rod fixes
- move PARSE-X11-COLOR from clim-user to ws/x11 package
--- /project/closure/cvsroot/closure/src/renderer/clim-draw.lisp 2006/12/29 21:29:34 1.5
+++ /project/closure/cvsroot/closure/src/renderer/clim-draw.lisp 2006/12/30 15:13:55 1.6
@@ -4,7 +4,7 @@
;;; Created: 2003-03-08
;;; Author: Gilbert Baumann <gilbert at base-engineering.com>
;;; License: MIT style (see below)
-;;; $Id: clim-draw.lisp,v 1.5 2006/12/29 21:29:34 dlichteblau Exp $
+;;; $Id: clim-draw.lisp,v 1.6 2006/12/30 15:13:55 emarsden Exp $
;;; ---------------------------------------------------------------------------
;;; (c) copyright 1997-2003 by Gilbert Baumann
@@ -34,7 +34,7 @@
(defun css-color-ink (color)
;; xxx, we still sometimes wind up with bogus values here
(if (stringp color)
- (clim-user::parse-x11-color color)
+ (ws/x11::parse-x11-color color)
clim:+black+))
(defun 3d-light-color (base-color)
@@ -172,14 +172,14 @@
(case deco
(:underline
(clim:draw-line* clim-user::*pane*
- xx1 (+ yy 2) xx (+ yy 2) :ink (clim-user::parse-x11-color color)))
+ xx1 (+ yy 2) xx (+ yy 2) :ink (ws/x11::parse-x11-color color)))
(:overline
;; xxx hack
(clim:draw-line* clim-user::*pane*
- xx1 (- yy 12) xx (- yy 12) :ink (clim-user::parse-x11-color color)))
+ xx1 (- yy 12) xx (- yy 12) :ink (ws/x11::parse-x11-color color)))
(:line-through
(clim:draw-line* clim-user::*pane*
- xx1 (- yy 6) xx (- yy 6) :ink (clim-user::parse-x11-color color))) ))))
+ xx1 (- yy 6) xx (- yy 6) :ink (ws/x11::parse-x11-color color))) ))))
;;;; Runes
--- /project/closure/cvsroot/closure/src/renderer/renderer2.lisp 2006/12/29 21:29:39 1.16
+++ /project/closure/cvsroot/closure/src/renderer/renderer2.lisp 2006/12/30 15:13:55 1.17
@@ -4,7 +4,7 @@
;;; Created: somewhen late 2002
;;; Author: Gilbert Baumann <gilbert at base-engineering.com>
;;; License: MIT style (see below)
-;;; $Id: renderer2.lisp,v 1.16 2006/12/29 21:29:39 dlichteblau Exp $
+;;; $Id: renderer2.lisp,v 1.17 2006/12/30 15:13:55 emarsden Exp $
;;; ---------------------------------------------------------------------------
;;; (c) copyright 1997-2003 by Gilbert Baumann
@@ -158,7 +158,9 @@
(cond ((member name '(black-chunk))
`(progn
(defstruct (,name (:constructor
- ,(intern (format nil "CONS-~A" name))
+ ,(intern
+ (with-standard-io-syntax
+ (format nil "CONS-~A" name)))
(&key ,@(mapcar (lambda (slot)
(let ((slot (if (consp slot) (car slot) slot)))
slot))
@@ -182,27 +184,39 @@
(list :initarg (intern (symbol-name slot) :keyword))
;; emarsden2003-03-12
(unless (member :initform opts) (list :initform nil))
- (list :accessor (intern (format nil "~A-~A" name slot)))))))
+ (list :accessor (intern
+ (with-standard-io-syntax
+ (format nil "~A-~A" name slot))))))))
slots))
;;
- (defun ,(intern (format nil "CONS-~A" name))
+ (defun ,(intern
+ (with-standard-io-syntax
+ (format nil "CONS-~A" name)))
(&rest args)
(apply #'make-instance ',name args))
;;
- (defun ,(intern (format nil "~A-P" name))
+ (defun , (intern
+ (with-standard-io-syntax
+ (format nil "~A-P" name)))
(object)
(typep object ',name))
;;
- (defun ,(intern (format nil "~A-MODIF" name))
+ (defun ,(intern
+ (with-standard-io-syntax
+ (format nil "~A-MODIF" name)))
(.object. &key ,@(mapcar (lambda (slot)
(let ((slot (if (consp slot) (car slot) slot)))
- (list slot nil (intern (format nil ".P.~A" slot)))))
+ (list slot nil (intern
+ (with-standard-io-syntax
+ (format nil ".P.~A" slot))))))
slots))
(make-instance ',name
,@(mapcan (lambda (slot)
(let ((slot (if (consp slot) (car slot) slot)))
(list (intern (symbol-name slot) :keyword)
- `(if ,(intern (format nil ".P.~A" slot))
+ `(if ,(intern
+ (with-standard-io-syntax
+ (format nil ".P.~A" slot)))
,slot
(slot-value .object. ',slot)))))
slots))))) ))
@@ -2212,7 +2226,7 @@
(y1 (+ yy (loop for k below i sum (elt row-heights k)))))
(clim:draw-line* clim-user::*pane*
x1 y1 x2 y1
- :ink (clim-user::parse-x11-color color)
+ :ink (ws/x11::parse-x11-color color)
:line-thickness width)))))))
;; vertical borders
(loop for i from 0 below (array-dimension vborders 0) do
@@ -2226,7 +2240,7 @@
(x1 (+ x1 (loop for k below j sum (elt column-widths k)))))
(clim:draw-line* clim-user::*pane*
x1 y1 x1 y2
- :ink (clim-user::parse-x11-color color)
+ :ink (ws/x11::parse-x11-color color)
:line-thickness width)))))) )
;; Kludge, in our book a table also has a baseline. We set it up manually, since
;; we moved the rendered output of table cells.
@@ -3239,9 +3253,9 @@
(:none
rod)
(:uppercase
- (glisp::register-rod (map 'rod #'rune-upcase rod)))
+ (map 'rod #'rune-upcase rod))
(:lowercase
- (glisp::register-rod (map 'rod #'rune-downcase rod)))
+ (map 'rod #'rune-downcase rod))
(:capitalize
;; more complicated
(let ((res (make-rod (length rod))))
@@ -3249,8 +3263,8 @@
for d across rod
for i from 0 do
(setf (rune res i)
- (cond ((glisp::rune-upper-case-letter-p c) d)
- ((glisp::rune-lower-case-letter-p c) (rune-downcase d))
+ (cond ((runes::rune-upper-case-letter-p c) d)
+ ((runes::rune-lower-case-letter-p c) (rune-downcase d))
(t (rune-upcase d)))))
res))))
@@ -4969,7 +4983,13 @@
;; $Log: renderer2.lisp,v $
+;; Revision 1.17 2006/12/30 15:13:55 emarsden
+;; - use CL from Closure packages
+;; - minor rod fixes
+;; - move PARSE-X11-COLOR from clim-user to ws/x11 package
+;;
;; Revision 1.16 2006/12/29 21:29:39 dlichteblau
+;;
;; Use CXML's rune implementation and XML parser.
;;
;; Revision 1.15 2006/11/06 19:43:01 thenriksen
--- /project/closure/cvsroot/closure/src/renderer/x11.lisp 2005/07/17 09:41:35 1.9
+++ /project/closure/cvsroot/closure/src/renderer/x11.lisp 2006/12/30 15:13:55 1.10
@@ -1354,4 +1354,38 @@
;; environment.
+(defun parse-x11-color (string &aux sym r gb)
+ ;; ### pff this really needs to be more robust.
+ (cond ((and (= (length string) 4) (char= (char string 0) #\#))
+ (clim:make-rgb-color
+ (/ (parse-integer string :start 1 :end 2 :radix 16) #xF)
+ (/ (parse-integer string :start 2 :end 3 :radix 16) #xF)
+ (/ (parse-integer string :start 3 :end 4 :radix 16) #xF)))
+ ((and (= (length string) 7) (char= (char string 0) #\#))
+ (clim:make-rgb-color
+ (/ (parse-integer string :start 1 :end 3 :radix 16) #xFF)
+ (/ (parse-integer string :start 3 :end 5 :radix 16) #xFF)
+ (/ (parse-integer string :start 5 :end 7 :radix 16) #xFF)))
+ ((and (= (length string) 6) (every #'(lambda (x) (digit-char-p x 16)) string))
+ (let ((r (parse-integer (subseq string 0 2) :radix 16))
+ (g (parse-integer (subseq string 2 4) :radix 16))
+ (b (parse-integer (subseq string 4 6) :radix 16)))
+ (warn "Malformed color specifier: ~S" string)
+ (and r g b
+ (clim:make-rgb-color (/ r 255) (/ g 255) (/ b 255)))))
+ ((and (= (length string) 13) (char= (char string 0) #\#))
+ (clim:make-rgb-color
+ (/ (parse-integer string :start 1 :end 5 :radix 16) #xFFFF)
+ (/ (parse-integer string :start 5 :end 9 :radix 16) #xFFFF)
+ (/ (parse-integer string :start 9 :end 13 :radix 16) #xFFFF)))
+ ((and (setf sym (find-symbol (concatenate 'string "+" (string-upcase string) "+")
+ (find-package :clim)))
+ (boundp sym)
+ (clim:colorp (symbol-value sym)))
+ (symbol-value sym))
+ (t
+ (warn "Malformed color specifier: ~S" string)
+ clim:+red+)))
+
+
; LocalWords: colormap RGB
More information about the Closure-cvs
mailing list