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@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@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