closure-cvs

closure-cvs@common-lisp.net

208 discussions

[closure-cvs] CVS update: closure/src/renderer/tables.lisp closure/src/renderer/renderer2.lisp closure/src/renderer/clim-draw.lisp
by crhodes＠common-lisp.net 11 Jul '05

11 Jul '05

Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv7926/src/renderer Modified Files: tables.lisp renderer2.lisp clim-draw.lisp Log Message: Complete the renaming *MEDIUM* -> *PANE*. Panes are CLIM extended-streams, and remember output to them in output records. Mediums are much simpler, and don't have this kind of memory. So, though the same drawing functions (DRAW-TEXT, DRAW-LINE) can have the same initial effect applied to a pane and a medium, the output-record state is very different. Date: Mon Jul 11 17:57:57 2005 Author: crhodes Index: closure/src/renderer/tables.lisp diff -u closure/src/renderer/tables.lisp:1.3 closure/src/renderer/tables.lisp:1.4 --- closure/src/renderer/tables.lisp:1.3 Sun Mar 13 19:03:25 2005 +++ closure/src/renderer/tables.lisp Mon Jul 11 17:57:56 2005 @@ -943,8 +943,8 @@ (rc-first-line-tasks new-rc) nil (rc-left-floating-boxen new-rc) nil (rc-right-floating-boxen new-rc) nil) - (clim:with-new-output-record (clim-user::*medium* 'clim:standard-sequence-output-record record) - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) + (clim:with-new-output-record (clim-user::*pane* 'clim:standard-sequence-output-record record) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) (let* ((fake-parent (make-bbox)) (bbox (brender new-rc (cell-content cell) fake-parent))) (if bbox @@ -1030,15 +1030,15 @@ (defun render-table (rc pt parent-box) ;; Now, while we render a table, we unfortunatly have to disable ;; drawing. - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) ;;; xxx not yet correct - (funcall (if t ;(clim:stream-drawing-p clim-user::*medium*) + (funcall (if t ;(clim:stream-drawing-p clim-user::*pane*) #'clim:replay-output-record #'values) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) ;; why does drawp nest proper? (render-table-2 rc pt parent-box)) - clim-user::*medium* clim:+everywhere+ 0 0))) + clim-user::*pane* clim:+everywhere+ 0 0))) (defun render-table-2 (rc pt parent-box) (let ((table (parse-table pt)) Index: closure/src/renderer/renderer2.lisp diff -u closure/src/renderer/renderer2.lisp:1.8 closure/src/renderer/renderer2.lisp:1.9 --- closure/src/renderer/renderer2.lisp:1.8 Sun Jul 10 13:18:35 2005 +++ closure/src/renderer/renderer2.lisp Mon Jul 11 17:57:56 2005 @@ -4,7 +4,7 @@ ;;; Created: somewhen late 2002 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: renderer2.lisp,v 1.8 2005/07/10 11:18:35 emarsden Exp $ +;;; $Id: renderer2.lisp,v 1.9 2005/07/11 15:57:56 crhodes Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -435,8 +435,8 @@ (open-chunk-dy chunk)) ))) (when (eql pass 1) - (clim:draw-text* clim-user::*medium* q x y)) - (incf x (clim:text-size clim-user::*medium* q)))) + (clim:draw-text* clim-user::*pane* q x y)) + (incf x (clim:text-size clim-user::*pane* q)))) (push dy ys) (setf dy (open-chunk-dy chunk)) (push (bounding-chunk-style chunk) ss) @@ -451,7 +451,7 @@ (let (p q res.text-seen-p) (cond (link (clim:with-output-as-presentation - (clim-user::*medium* + (clim-user::*pane* (url:unparse-url (hyper-link-url (imap-area-link link))) 'clim-user::url @@ -470,8 +470,8 @@ (chunk-debug-name q) ""))) (when (eql pass 1) - (clim:draw-text* clim-user::*medium* q x y)) - (incf x (clim:text-size clim-user::*medium* q)) + (clim:draw-text* clim-user::*pane* q x y)) + (incf x (clim:text-size clim-user::*pane* q)) ))) (pop ss) @@ -483,7 +483,7 @@ ;; replaced objects are different to dimensions of regular ;; inline boxen. (cond (replaced-object-p - (draw-box-decoration clim-user::*medium* + (draw-box-decoration clim-user::*pane* x1 (- (+ y dy) (open-chunk-height oc) (cooked-style-padding-top (bounding-chunk-style oc)) (- (cooked-style-padding-top (bounding-chunk-style oc))) @@ -499,7 +499,7 @@ :right-halfp (not (bounding-chunk-halfp q)) )) (t - (draw-box-decoration clim-user::*medium* + (draw-box-decoration clim-user::*pane* x1 (- (+ y dy) (open-chunk-height oc) (cooked-style-padding-top (bounding-chunk-style oc))) x (+ (+ y dy) (open-chunk-depth oc) @@ -528,7 +528,7 @@ (when (eql pass 1) (setf (clim:medium-ink clim-user::*medium*) (css-color-ink (cooked-style-color (black-chunk-style chunk)))) - (clim-draw-runes* clim-user::*medium* + (clim-draw-runes* clim-user::*pane* x (+ dy y) (black-chunk-data chunk) 0 (length (black-chunk-data chunk)) @@ -539,7 +539,7 @@ (let ((ro (replaced-object-chunk-object chunk))) (when (eql pass 1) (closure/clim-device::medium-draw-ro* - clim-user::*medium* + clim-user::*pane* ro x (+ dy y))) (incf x (chunk-width chunk))) ))))) ;; @@ -1177,99 +1177,6 @@ (defvar *zzz* nil) (defvar *dyn-elm* nil) -#+emarsden2005-06-23 -(defun tata (mode) - (let ((clim-user::*medium* (clim:find-pane-named clim-user::*frame* 'clim-user::canvas)) - (closure-protocol:*document-language* - (make-instance 'r2::html-4.0-document-language)) - (closure-protocol:*user-agent* nil)) - (multiple-value-bind (x c) - (ignore-errors - ;; first find the chunk - (let ((offender *dyn-elm*) - (the-pb nil)) - (block suche - (labels ((walk (x) - (etypecase x - (marker-box) - (block-box - (mapc #'walk (block-box-content x))) - (para-box - (mapc #'(lambda (z) (walk-chunk x z)) (para-box-items x))))) - (walk-chunk (pb x) - (etypecase x - (floating-chunk) - (bounding-chunk - (setf (bounding-chunk-pt x) offender) - #+NIL - (when (eq (bounding-chunk-pt x) offender) - '(cond ((eql mode :highlight) - (setf (slot-value (bounding-chunk-style x) 'css::border-left-width) 1 - (slot-value (bounding-chunk-style x) 'css::border-left-style) :solid - (slot-value (bounding-chunk-style x) 'css::border-right-width) 1 - (slot-value (bounding-chunk-style x) 'css::border-right-style) :solid - (slot-value (bounding-chunk-style x) 'css::border-top-width) 1 - (slot-value (bounding-chunk-style x) 'css::border-top-style) :solid - (slot-value (bounding-chunk-style x) 'css::border-bottom-width) 1 - (slot-value (bounding-chunk-style x) 'css::border-bottom-style) :solid)) - (t - (setf (slot-value (bounding-chunk-style x) 'css::border-left-width) 0 - (slot-value (bounding-chunk-style x) 'css::border-left-style) :none - (slot-value (bounding-chunk-style x) 'css::border-right-width) 0 - (slot-value (bounding-chunk-style x) 'css::border-right-style) :none - (slot-value (bounding-chunk-style x) 'css::border-top-width) 0 - (slot-value (bounding-chunk-style x) 'css::border-top-style) :none - (slot-value (bounding-chunk-style x) 'css::border-bottom-width) 0 - (slot-value (bounding-chunk-style x) 'css::border-bottom-style) :none))) - '(setf (slot-value (bounding-chunk-style x) 'css::background-color) - (if (eq mode :highlight) - "#ccccff" - :transparent)) - '(setf (slot-value (bounding-chunk-style x) 'css::text-decoration) - (if (eq mode :highlight) - (list :underline) - :none)) - )) - (kern-chunk) - (disc-chunk - (mapc #'(lambda (x) (walk-chunk pb x)) - (disc-chunk-here x)) - (mapc #'(lambda (x) (walk-chunk pb x)) - (disc-chunk-after x)) - (mapc #'(lambda (x) (walk-chunk pb x)) - (disc-chunk-before x))) - (black-chunk - '(setf (slot-value (black-chunk-style x) 'css::color) - (if (eq mode :highlight) - "#ff0000" - "#000000")) - ) - (replaced-object-chunk - (when (typep (replaced-object-chunk-object x) - 'lazy-image) - (setf (replaced-object-chunk-object x) - (replaced-element-p *document* *device* (replaced-object-chunk-element x))) - (setf the-pb pb) - (return-from suche nil)) - )))) - (walk *zzz*))) - - (dprint "@@@@@@@ offender = ~S." offender) - (dprint "@@@@@@@ the-pb = ~S." the-pb) - (when the-pb - (let ( - (papa (clim:output-record-parent (para-box-output-record the-pb)))) - (dprint "@@@@@@@ papa = ~S." papa) - (clim:delete-output-record (para-box-output-record the-pb) papa) - ;; now clim is so inherently broken .... - (setf (para-box-output-record the-pb) - (clim:with-new-output-record (clim-user::*pane*) - (funcall (para-box-genesis the-pb))))) - (tata mode)) - )) - (when c - (dprint "Error: ~A." c))))) - (defun format-block (item x1 x2 ss before-markers #||# pos-vertical-margin neg-vertical-margin yy) (let (res) (setf (block-box-output-record item) @@ -1549,7 +1456,7 @@ (+ x2 pr) (- yy (cooked-style-border-bottom-width s) )) - (draw-box-decoration clim-user::*medium* x1 y1 x2 y2 block-style) + (draw-box-decoration clim-user::*pane* x1 y1 x2 y2 block-style) (incf y1 (cooked-style-padding-top s)) (decf y2 (cooked-style-padding-bottom s)) (when (realp (cooked-style-height s)) @@ -1558,7 +1465,7 @@ (error "Fubar"))) #+NIL (unless (or (= x1 x2) (= y1 y2)) - (clim:draw-rectangle* clim-user::*medium* x1 y1 x2 y2 + (clim:draw-rectangle* clim-user::*pane* x1 y1 x2 y2 :ink clim:+red+ :filled nil)) ) @@ -2162,7 +2069,7 @@ (unless (or (= x1 (+ x1 w)) (= yyy yy)) #-NIL - (clim:draw-rectangle* clim-user::*medium* + (clim:draw-rectangle* clim-user::*pane* x1 yyy (+ x1 w) yy :ink (elt *table-depth-color* (mod *table-depth* (length *table-depth-color*))) @@ -2272,7 +2179,7 @@ (let ((new-record (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) (clim:with-new-output-record (clim-user::*pane*) - (draw-box-decoration clim-user::*medium* (+ x1 xx1) y1 (+ x1 xx2) y2 + (draw-box-decoration clim-user::*pane* (+ x1 xx1) y1 (+ x1 xx2) y2 (block-box-style (table-cell-content cell))))))) (clim:delete-output-record new-record (clim:output-record-parent new-record)) (clim:add-output-record new-record bg-record))))))) @@ -2286,7 +2193,7 @@ (let ((new-record (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) (clim:with-new-output-record (clim-user::*pane*) - (draw-box-decoration clim-user::*medium* x1 y1 x2 y2 + (draw-box-decoration clim-user::*pane* x1 y1 x2 y2 (table-style table)))))) (clim:delete-output-record new-record (clim:output-record-parent new-record)) (clim:add-output-record new-record bg-record))) @@ -2303,7 +2210,7 @@ (multiple-value-bind (x1 x2) (table-column-coordinates table column-widths j) (let* ( (y1 (+ yy (loop for k below i sum (elt row-heights k))))) - (clim:draw-line* clim-user::*medium* + (clim:draw-line* clim-user::*pane* x1 y1 x2 y1 :ink (clim-user::parse-x11-color color) :line-thickness width))))))) @@ -2317,7 +2224,7 @@ (let* ((y1 (+ yy (loop for k below i sum (elt row-heights k)))) (y2 (+ y1 (elt row-heights i))) (x1 (+ x1 (loop for k below j sum (elt column-widths k))))) - (clim:draw-line* clim-user::*medium* + (clim:draw-line* clim-user::*pane* x1 y1 x1 y2 :ink (clim-user::parse-x11-color color) :line-thickness width)))))) ) @@ -5061,6 +4968,15 @@ ;; $Log: renderer2.lisp,v $ +;; Revision 1.9 2005/07/11 15:57:56 crhodes +;; Complete the renaming *MEDIUM* -> *PANE*. +;; +;; Panes are CLIM extended-streams, and remember output to them in output +;; records. Mediums are much simpler, and don't have this kind of +;; memory. So, though the same drawing functions (DRAW-TEXT, DRAW-LINE) +;; can have the same initial effect applied to a pane and a medium, the +;; output-record state is very different. +;; ;; Revision 1.8 2005/07/10 11:18:35 emarsden ;; Distinguish between pane and medium in the CLIM GUI. This should ;; fix image display. Index: closure/src/renderer/clim-draw.lisp diff -u closure/src/renderer/clim-draw.lisp:1.3 closure/src/renderer/clim-draw.lisp:1.4 --- closure/src/renderer/clim-draw.lisp:1.3 Sun Mar 13 22:39:19 2005 +++ closure/src/renderer/clim-draw.lisp Mon Jul 11 17:57:56 2005 @@ -4,7 +4,7 @@ ;;; Created: 2003-03-08 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-draw.lisp,v 1.3 2005/03/13 21:39:19 emarsden Exp $ +;;; $Id: clim-draw.lisp,v 1.4 2005/07/11 15:57:56 crhodes Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -171,14 +171,14 @@ (dolist (deco text-decoration) (case deco (:underline - (clim:draw-line* clim-user::*medium* + (clim:draw-line* clim-user::*pane* xx1 (+ yy 2) xx (+ yy 2) :ink (clim-user::parse-x11-color color))) (:overline ;; xxx hack - (clim:draw-line* clim-user::*medium* + (clim:draw-line* clim-user::*pane* xx1 (- yy 12) xx (- yy 12) :ink (clim-user::parse-x11-color color))) (:line-through - (clim:draw-line* clim-user::*medium* + (clim:draw-line* clim-user::*pane* xx1 (- yy 6) xx (- yy 6) :ink (clim-user::parse-x11-color color))) )))) ;;;; Runes

1 0

[closure-cvs] CVS update: closure/resources/patterns/deutsch.ptn closure/resources/patterns/english.ptn closure/resources/patterns/francais.ptn
by emarsden＠common-lisp.net 10 Jul '05

10 Jul '05

Update of /project/closure/cvsroot/closure/resources/patterns In directory common-lisp.net:/tmp/cvs-serv1089/patterns Added Files: deutsch.ptn english.ptn francais.ptn Log Message: Added pattern files for hyphenation (taken from Amaya sources). Date: Sun Jul 10 14:27:32 2005 Author: emarsden

1 0

[closure-cvs] CVS update: Directory change: closure/resources/patterns
by emarsden＠common-lisp.net 10 Jul '05

10 Jul '05

Update of /project/closure/cvsroot/closure/resources/patterns In directory common-lisp.net:/tmp/cvs-serv1056/patterns Log Message: Directory /project/closure/cvsroot/closure/resources/patterns added to the repository Date: Sun Jul 10 14:26:55 2005 Author: emarsden New directory closure/resources/patterns added

1 0

[closure-cvs] CVS update: closure/src/renderer/clim-device.lisp closure/src/renderer/renderer2.lisp
by emarsden＠common-lisp.net 10 Jul '05

10 Jul '05

Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv29764/renderer Modified Files: clim-device.lisp renderer2.lisp Log Message: Distinguish between pane and medium in the CLIM GUI. This should fix image display. Date: Sun Jul 10 13:18:35 2005 Author: emarsden Index: closure/src/renderer/clim-device.lisp diff -u closure/src/renderer/clim-device.lisp:1.10 closure/src/renderer/clim-device.lisp:1.11 --- closure/src/renderer/clim-device.lisp:1.10 Mon Jun 20 17:37:33 2005 +++ closure/src/renderer/clim-device.lisp Sun Jul 10 13:18:35 2005 @@ -31,7 +31,7 @@ (defclass clim-device () ((medium :accessor clim-device-medium :initarg :medium) (font-database :initform nil) - (zoom-factor :initform closure::*zoom-factor* :initarg :zoom-factor))) + (zoom-factor :initform gui:*zoom-factor* :initarg :zoom-factor))) (defmethod device-dpi ((device clim-device)) (with-slots (zoom-factor) device @@ -221,6 +221,7 @@ res)) (defun background-pixmap+mask (document drawable bg) + #+emarsden2005-06-23 (print `(background-pixmap+mask ,bg)) (cond ((r2::background-%pixmap bg) ;; already there @@ -243,6 +244,62 @@ (values (r2::background-%pixmap bg) (r2::background-%mask bg)))))) )) +(defun ws/x11::x11-put-pixmap-tiled (drawable ggc pixmap mask x y w h &optional (xo 0) (yo 0)) + (cond ((null mask) ;; xxx + (xlib:with-gcontext (ggc :exposures :off + :fill-style :tiled + :tile pixmap + :ts-x xo + :ts-y yo) + ;;mask wird momentan noch ignoriert! + (xlib:draw-rectangle drawable ggc x y w h t))) + (t + (let* ((old-clip-mask (car (or (ignore-errors (list (xlib:gcontext-clip-mask ggc))) + (list :none)))) + (clip-region (let ((q old-clip-mask)) + (if (consp q) + (region-from-x11-rectangle-list q) + +everywhere+))) + (paint-region (region-intersection + clip-region + (make-rectangle* x y (+ x w) (+ y h)))) ) + ;; There is a bug in CLX wrt to clip-x / clip-y + ;; Turning off caching helps + (setf (xlib:gcontext-cache-p ggc) nil) + + ;; we have to do our own clipping here. + (let ((iw (xlib:drawable-width pixmap)) + (ih (xlib:drawable-height pixmap))) + (loop for i from (floor (- x xo) iw) to (ceiling (- (+ x w) (+ xo iw)) iw) + do + (loop for j from (floor (- y yo) ih) to (ceiling (- (+ y h) (+ yo ih)) ih) + do + (let ((rect (make-rectangle* + (+ xo (* i iw)) + (+ yo (* j ih)) + (+ (+ xo (* i iw)) iw) + (+ (+ yo (* j ih)) ih)))) + (map-region-rectangles + (lambda (rx0 ry0 rx1 ry1) + (xlib:with-gcontext (ggc :exposures :off + :fill-style :tiled + :tile pixmap + :clip-mask mask + :clip-x (+ xo (* i iw)) + :clip-y (+ yo (* j ih)) + :ts-x xo + :ts-y yo) + (xlib:draw-rectangle drawable ggc + rx0 ry0 (max 0 (- rx1 rx0)) (max 0 (- ry1 ry0)) + t))) + (region-intersection paint-region rect))))) ) + ;; turn on caching again (see above) + (setf (xlib:gcontext-cache-p ggc) t) + ;; + ;; and xlib:with-gcontext also is broken! + (setf (xlib:gcontext-clip-mask ggc) old-clip-mask))))) + +#+emarsden #.((lambda (x) #+:CMU `(eval ',x) ;compiler bug #-:CMU x) @@ -396,8 +453,8 @@ (+ x (nth-value 0 (r2::ro/size ro))) (+ y 0))) -(defmethod medium-draw-ro* (medium (self ro/img) x y) - (ignore-errors ;xxx +(defmethod medium-draw-ro* ((medium clim:medium) (self ro/img) x y) + (progn ;; ignore-errors ;xxx (progn (assert (realp x)) (assert (realp y)) Index: closure/src/renderer/renderer2.lisp diff -u closure/src/renderer/renderer2.lisp:1.7 closure/src/renderer/renderer2.lisp:1.8 --- closure/src/renderer/renderer2.lisp:1.7 Sun Mar 13 19:03:25 2005 +++ closure/src/renderer/renderer2.lisp Sun Jul 10 13:18:35 2005 @@ -4,7 +4,7 @@ ;;; Created: somewhen late 2002 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: renderer2.lisp,v 1.7 2005/03/13 18:03:25 gbaumann Exp $ +;;; $Id: renderer2.lisp,v 1.8 2005/07/10 11:18:35 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -1177,6 +1177,7 @@ (defvar *zzz* nil) (defvar *dyn-elm* nil) +#+emarsden2005-06-23 (defun tata (mode) (let ((clim-user::*medium* (clim:find-pane-named clim-user::*frame* 'clim-user::canvas)) (closure-protocol:*document-language* @@ -1262,7 +1263,7 @@ (clim:delete-output-record (para-box-output-record the-pb) papa) ;; now clim is so inherently broken .... (setf (para-box-output-record the-pb) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) (funcall (para-box-genesis the-pb))))) (tata mode)) )) @@ -1272,8 +1273,7 @@ (defun format-block (item x1 x2 ss before-markers #||# pos-vertical-margin neg-vertical-margin yy) (let (res) (setf (block-box-output-record item) - (clim:with-new-output-record - (clim-user::*medium*) foo + (clim:with-new-output-record (clim-user::*pane*) foo (setf res (multiple-value-list (case (cooked-style-display (block-box-style item)) @@ -1313,7 +1313,7 @@ (yy0 nil) ;the inner top padding edge ; NIL initially to indicate that we do not know it for now. (bg-record - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) ))) ;; remember the output record of the decoration @@ -1427,7 +1427,7 @@ before-markers)))))) (setf (para-box-output-record item) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) (setf (values pos-vertical-margin neg-vertical-margin x1 x2 yy ss block-style) (funcall (para-box-genesis item))))) @@ -1538,9 +1538,9 @@ (minf neg-vertical-margin bm))) ;; - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) (let ((new-record - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) ;; (multiple-value-bind (x1 y1 x2 y2) (values (- x1 pl) (+ yy0 @@ -2112,7 +2112,7 @@ (values x1 (+ x1 actual-width)))))) - (let ((bg-record (clim:with-new-output-record (clim-user::*medium*)))) + (let ((bg-record (clim:with-new-output-record (clim-user::*pane*)))) (setf (table-decoration-output-record table) bg-record) (let ((yyy yy) (dangling-cells nil)) ;a list of (rowspan total-rowspan cell) pairs of cells whose row span @@ -2270,8 +2270,8 @@ (clim:clear-output-record bg-record) (multiple-value-bind (xx1 xx2) (table-column-coordinates table column-widths ci (table-cell-colspan cell)) (let ((new-record - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) + (clim:with-new-output-record (clim-user::*pane*) (draw-box-decoration clim-user::*medium* (+ x1 xx1) y1 (+ x1 xx2) y2 (block-box-style (table-cell-content cell))))))) (clim:delete-output-record new-record (clim:output-record-parent new-record)) @@ -2284,8 +2284,8 @@ (x1 x1) (x2 x2)) (let ((new-record - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) + (clim:with-new-output-record (clim-user::*pane*) (draw-box-decoration clim-user::*medium* x1 y1 x2 y2 (table-style table)))))) (clim:delete-output-record new-record (clim:output-record-parent new-record)) @@ -5061,6 +5061,10 @@ ;; $Log: renderer2.lisp,v $ +;; Revision 1.8 2005/07/10 11:18:35 emarsden +;; Distinguish between pane and medium in the CLIM GUI. This should +;; fix image display. +;; ;; Revision 1.7 2005/03/13 18:03:25 gbaumann ;; Gross license change ;;

1 0

[closure-cvs] CVS update: closure/src/gui/clim-gui.lisp
by emarsden＠common-lisp.net 10 Jul '05

10 Jul '05

Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv29764/gui Modified Files: clim-gui.lisp Log Message: Distinguish between pane and medium in the CLIM GUI. This should fix image display. Date: Sun Jul 10 13:18:34 2005 Author: emarsden Index: closure/src/gui/clim-gui.lisp diff -u closure/src/gui/clim-gui.lisp:1.18 closure/src/gui/clim-gui.lisp:1.19 --- closure/src/gui/clim-gui.lisp:1.18 Sun Jul 10 12:57:20 2005 +++ closure/src/gui/clim-gui.lisp Sun Jul 10 13:18:34 2005 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.18 2005/07/10 10:57:20 emarsden Exp $ +;;; $Id: clim-gui.lisp,v 1.19 2005/07/10 11:18:34 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,10 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.19 2005/07/10 11:18:34 emarsden +;; Distinguish between pane and medium in the CLIM GUI. This should +;; fix image display. +;; ;; Revision 1.18 2005/07/10 10:57:20 emarsden ;; Move a number of global variables from the CL-USER to the GUI package. ;; @@ -124,6 +128,7 @@ (:menu-bar menubar-command-table) (:panes (canvas (make-pane 'closure-pane + :name 'canvas :height 2000 :width 800 :display-time nil)) @@ -460,10 +465,10 @@ (url (and proxy (url:parse-url proxy)))) (cond ((and url (equal (url:url-protocol url) "http")) - (format t "~&;; Using HTTP proxy ~S port ~S~%" + (format t "~:[~&;; Using HTTP proxy ~S port ~S~%~;~]" + (setf netlib::*use-http-proxy-p* t) (setf netlib::*http-proxy-host* (url:url-host url)) - (setf netlib::*http-proxy-port* (url:url-port url)) - (setf netlib::*use-http-proxy-p* t))) + (setf netlib::*http-proxy-port* (url:url-port url)))) (t ;; we go without one: (setf netlib::*use-http-proxy-p* nil)))) @@ -507,76 +512,74 @@ (clim-sys:make-process (lambda () (with-simple-restart (forget "Just forget rendering this page.") - (let ((*package* (find-package :r2))) - (window-clear (find-pane-named *frame* 'canvas)) - (progn;;with-sheet-medium (medium *pane*) - (let ((*medium* (find-pane-named *frame* 'canvas))) - (let ((device (make-instance 'closure/clim-device::clim-device :medium *medium*))) - (setq url (r2::parse-url* url)) - (let ((request (clue-gui2::make-request :url url :method :get))) - (multiple-value-bind (io header) (clue-gui2::open-document-4 request) - (write-status "Fetching Document ...") - (let* ((doc (make-instance 'r2::document - :processes-hooks nil - :location - (r2::parse-url* url) - :http-header header - :pt (clue-gui2::make-pt-from-input - io - (netlib::get-header-field header :content-type) url) ))) - (write-status "Rendering ...") - (setf *current-document* doc) - (let ((closure-protocol:*document-language* - (if (sgml::pt-p (r2::document-pt doc)) - (make-instance 'r2::html-4.0-document-language) - (make-instance 'r2::xml-style-document-language) - )) - (closure-protocol:*user-agent* - nil) - (r2::*canvas-width* - (bounding-rectangle-width (sheet-parent *medium*)))) - (closure-protocol:render - closure-protocol:*document-language* - doc - device - (setf *current-pt* (r2::document-pt doc)) - 600 ;xxx width - t ;? - 0) - (let ((x2 (bounding-rectangle-max-x (stream-output-history (find-pane-named *frame* 'canvas)))) - (y2 (bounding-rectangle-max-y (stream-output-history (find-pane-named *frame* 'canvas))))) - (setf y2 (max y2 r2::*document-height*)) - (clim:change-space-requirements *medium* :width x2 :height y2) - ;; While we are at it, force a repaint - (handle-repaint *medium* (sheet-region (pane-viewport *medium*))) - (xlib:display-finish-output (clim-clx::clx-port-display (find-port))) ))))) - (write-status "Done.")))))) - (xlib:display-finish-output (clim-clx::clx-port-display (find-port))))))) + (let* ((*package* (find-package :r2)) + (*pane* (find-pane-named *frame* 'canvas)) + (*medium* (sheet-medium *pane*))) + (window-clear *pane*) + (progn ;; with-sheet-medium (*medium* *pane*) + (let ((device (make-instance 'closure/clim-device::clim-device :medium *pane*))) + (setq url (r2::parse-url* url)) + (let ((request (clue-gui2::make-request :url url :method :get))) + (multiple-value-bind (io header) (clue-gui2::open-document-4 request) + (write-status "Fetching Document ...") + (let* ((doc (make-instance 'r2::document + :processes-hooks nil + :location + (r2::parse-url* url) + :http-header header + :pt (clue-gui2::make-pt-from-input + io + (netlib::get-header-field header :content-type) url) ))) + (write-status "Rendering ...") + (setf *current-document* doc) + (let ((closure-protocol:*document-language* + (if (sgml::pt-p (r2::document-pt doc)) + (make-instance 'r2::html-4.0-document-language) + (make-instance 'r2::xml-style-document-language))) + (closure-protocol:*user-agent* nil) + (r2::*canvas-width* (bounding-rectangle-width (sheet-parent *pane*)))) + (closure-protocol:render + closure-protocol:*document-language* + doc + device + (setf *current-pt* (r2::document-pt doc)) + 600 ;xxx width + t ;? + 0) + (let ((x2 (bounding-rectangle-max-x (stream-output-history *pane*))) + (y2 (bounding-rectangle-max-y (stream-output-history *pane*)))) + (setf y2 (max y2 r2::*document-height*)) + (clim:change-space-requirements *pane* :width x2 :height y2) + ;; While we are at it, force a repaint + (handle-repaint *pane* (sheet-region (pane-viewport *pane*))) + (xlib:display-finish-output (clim-clx::clx-port-display (find-port)))))))) + #+nil (write-status "Done."))))) + #+nil (xlib:display-finish-output (clim-clx::clx-port-display (find-port))))))) (defun reflow () (let ((*standard-output* *trace-output*)) (funcall ;;clim-sys:make-process (lambda () (with-simple-restart (forget "Just forget rendering this page.") - (let ((*package* (find-package :r2))) - (window-clear (find-pane-named *frame* 'canvas)) - (let* ((*medium* (find-pane-named *frame* 'canvas)) ) + (let ((*package* (find-package :r2)) + (*pane* (find-pane-named *frame* 'canvas))) + (window-clear *pane*) + (with-sheet-medium (*medium* *pane*) (write-status "Rendering ...") (let ((closure-protocol:*document-language* (if (sgml::pt-p (r2::document-pt *current-document*)) (make-instance 'r2::html-4.0-document-language) (make-instance 'r2::xml-style-document-language) )) - (closure-protocol:*user-agent* - nil) + (closure-protocol:*user-agent* nil) (r2::*canvas-width* - (bounding-rectangle-width (sheet-parent *medium*)))) + (bounding-rectangle-width (sheet-parent *pane*)))) (r2::reflow) - (let ((x2 (bounding-rectangle-max-x (stream-output-history (find-pane-named *frame* 'canvas)))) - (y2 (bounding-rectangle-max-y (stream-output-history (find-pane-named *frame* 'canvas))))) + (let ((x2 (bounding-rectangle-max-x (stream-output-history *pane*))) + (y2 (bounding-rectangle-max-y (stream-output-history *pane*)))) (setf y2 (max y2 r2::*document-height*)) - (clim:change-space-requirements *medium* :width x2 :height y2) + (clim:change-space-requirements *pane* :width x2 :height y2) ;; While we are at it, force a repaint - (handle-repaint *medium* (sheet-region (pane-viewport *medium*))))) + (handle-repaint *pane* (sheet-region (pane-viewport *pane*))))) (write-status "Done.")))))))) (defvar *current-document*)

1 0

[closure-cvs] CVS update: closure/src/renderer/x11.lisp
by emarsden＠common-lisp.net 10 Jul '05

10 Jul '05

Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv27902/renderer Modified Files: x11.lisp Log Message: Move a number of global variables from the CL-USER to the GUI package. Date: Sun Jul 10 12:57:23 2005 Author: emarsden Index: closure/src/renderer/x11.lisp diff -u closure/src/renderer/x11.lisp:1.6 closure/src/renderer/x11.lisp:1.7 --- closure/src/renderer/x11.lisp:1.6 Sun Mar 13 19:03:25 2005 +++ closure/src/renderer/x11.lisp Sun Jul 10 12:57:23 2005 @@ -952,9 +952,8 @@ (defclass x11-device () ((font-database :initform nil) (display :initarg :display) - (dpi :initarg :dpi :initform cl-user::*closure-dpi*) - (scale-font-desc-cache :initform (make-hash-table :test #'equal)) - )) + (dpi :initarg :dpi :initform gui:*closure-dpi*) + (scale-font-desc-cache :initform (make-hash-table :test #'equal)))) (defmethod r2::device-dpi ((self x11-device)) (slot-value self 'dpi))

1 0

[closure-cvs] CVS update: closure/src/html/html-style.lisp
by emarsden＠common-lisp.net 10 Jul '05

10 Jul '05

Update of /project/closure/cvsroot/closure/src/html In directory common-lisp.net:/tmp/cvs-serv27902/html Modified Files: html-style.lisp Log Message: Move a number of global variables from the CL-USER to the GUI package. Date: Sun Jul 10 12:57:21 2005 Author: emarsden Index: closure/src/html/html-style.lisp diff -u closure/src/html/html-style.lisp:1.5 closure/src/html/html-style.lisp:1.6 --- closure/src/html/html-style.lisp:1.5 Mon Jun 13 12:14:22 2005 +++ closure/src/html/html-style.lisp Sun Jul 10 12:57:21 2005 @@ -484,7 +484,7 @@ elm) (declare (ignorable language user-agent)) (values-list - (cond ((and (not closure:*user-wants-images-p*) + (cond ((and (not gui:*user-wants-images-p*) (member (element-gi elm) '(:IMG))) nil) ((member (element-gi elm) '(:IMG))

1 0

[closure-cvs] CVS update: closure/src/gui/clim-gui.lisp closure/src/gui/clue-input.lisp closure/src/gui/gui.lisp
by emarsden＠common-lisp.net 10 Jul '05

10 Jul '05

Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv27902/gui Modified Files: clim-gui.lisp clue-input.lisp gui.lisp Log Message: Move a number of global variables from the CL-USER to the GUI package. Date: Sun Jul 10 12:57:20 2005 Author: emarsden Index: closure/src/gui/clim-gui.lisp diff -u closure/src/gui/clim-gui.lisp:1.17 closure/src/gui/clim-gui.lisp:1.18 --- closure/src/gui/clim-gui.lisp:1.17 Tue Apr 12 12:28:55 2005 +++ closure/src/gui/clim-gui.lisp Sun Jul 10 12:57:20 2005 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.17 2005/04/12 10:28:55 tdalyjr Exp $ +;;; $Id: clim-gui.lisp,v 1.18 2005/07/10 10:57:20 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,9 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.18 2005/07/10 10:57:20 emarsden +;; Move a number of global variables from the CL-USER to the GUI package. +;; ;; Revision 1.17 2005/04/12 10:28:55 tdalyjr ;; Since closure-frame-top-level is no longer used, comment it out. ;; @@ -101,13 +104,11 @@ ;;;;;;; (defvar *medium*) +(defvar *frame*) +(defvar *pane*) (defvar *initial-url* nil) -(defvar closure:*home-page* "http://www.stud.uni-karlsruhe.de/~unk6/closure/user.html") -(defvar closure:*user-wants-images-p* t) -(defvar closure::*zoom-factor* 1.0) - (defvar *closure-process* nil) (defclass closure-pane (application-pane) @@ -337,11 +338,11 @@ (foo (first *back-history*)))))) (define-closure-command (com-images-off :name t) () - (setf closure:*user-wants-images-p* nil) + (setf gui:*user-wants-images-p* nil) (format *query-io* "Images are now off.~%")) (define-closure-command (com-images-on :name t) () - (setf closure:*user-wants-images-p* t) + (setf gui:*user-wants-images-p* t) (format *query-io* "Images are now on. You may want to reload.~%")) (define-closure-command (com-quit :name t) () @@ -364,7 +365,7 @@ (com-visit-url (make-google-search-url what))) (define-closure-command (com-home :name t) () - (com-visit-url closure:*home-page*)) + (com-visit-url gui:*home-page*)) (define-presentation-translator fofo (url command closure @@ -420,7 +421,7 @@ #'(lambda () (apply command args))))) -(defun closure:visit (&optional (url closure:*home-page*)) +(defun closure:visit (&optional (url gui:*home-page*)) (and url (setf url (parse-url* url))) (cond ((and (null *closure-process*) (null url)) (setf *initial-url* url) @@ -453,9 +454,6 @@ *closure-inited-p*))))) -(defvar *frame*) -(defvar *pane*) - (defun run-closure () ;; Care for proxy (let* ((proxy (glisp:getenv "http_proxy")) @@ -651,18 +649,18 @@ (define-closure-command (com-zoom-100% :name t) () - (setq closure::*zoom-factor* 1.0) + (setq gui:*zoom-factor* 1.0) (send-closure-command 'com-reflow)) ;; FIXME the :shift here is a McCLIM bug (define-closure-command (com-zoom-in :name t :keystroke (#\+ :control :shift)) () (write-status "Zooming in...") - (setq closure::*zoom-factor* (* closure::*zoom-factor* 1.2)) + (setq gui:*zoom-factor* (* gui:*zoom-factor* 1.2)) (send-closure-command 'com-reflow)) (define-closure-command (com-zoom-out :name t :keystroke (#\- :control :shift)) () (write-status "Zooming out...") - (setq closure::*zoom-factor* (* closure::*zoom-factor* 0.8)) + (setq gui:*zoom-factor* (* gui:*zoom-factor* 0.8)) (send-closure-command 'com-reflow)) (define-closure-command (com-page-up :name t Index: closure/src/gui/clue-input.lisp diff -u closure/src/gui/clue-input.lisp:1.4 closure/src/gui/clue-input.lisp:1.5 --- closure/src/gui/clue-input.lisp:1.4 Sun Mar 13 19:01:37 2005 +++ closure/src/gui/clue-input.lisp Sun Jul 10 12:57:20 2005 @@ -45,9 +45,6 @@ (in-package :CLUE-GUI2) -(defparameter cl-user::*debug-submit-p* nil - "Whether to dump the values about to be submit by a <FORM> to the server on the listener.") - ;;; Input elements ;; Input elements as such are replaced objects and obey to the robj Index: closure/src/gui/gui.lisp diff -u closure/src/gui/gui.lisp:1.5 closure/src/gui/gui.lisp:1.6 --- closure/src/gui/gui.lisp:1.5 Sun Mar 13 19:01:37 2005 +++ closure/src/gui/gui.lisp Sun Jul 10 12:57:20 2005 @@ -43,6 +43,23 @@ (in-package :GUI) +(defparameter *home-page* "http://common-lisp.net/project/closure/") + +(defvar *user-wants-images-p* t) + +(defvar *closure-dpi* 96) + +(defvar *zoom-factor* 1.0) + +(defparameter *debug-submit-p* nil + "Whether to dump the values about to be submit by a <FORM> to the server on the listener.") + +;; experimental code that is not activated by default +(defvar *tex-mode-p* nil) +(defvar *hyphenate-p* nil) + + + (defstruct display-list document items)

1 0

[closure-cvs] CVS update: closure/src/defpack.lisp
by emarsden＠common-lisp.net 10 Jul '05

10 Jul '05

Update of /project/closure/cvsroot/closure/src In directory common-lisp.net:/tmp/cvs-serv27902 Modified Files: defpack.lisp Log Message: Move a number of global variables from the CL-USER to the GUI package. Date: Sun Jul 10 12:57:19 2005 Author: emarsden Index: closure/src/defpack.lisp diff -u closure/src/defpack.lisp:1.3 closure/src/defpack.lisp:1.4 --- closure/src/defpack.lisp:1.3 Sun Mar 13 19:00:56 2005 +++ closure/src/defpack.lisp Sun Jul 10 12:57:19 2005 @@ -126,6 +126,14 @@ #:make-rectangle*) (:export + #:*home-page* + #:*user-wants-images-p* + #:*tex-mode-p* + #:*hyphenate-p* + #:*closure-dpi* + #:*zoom-factor* + #:*debug-submit-p* + #:display-list #:display-list-p #:display-list-document

1 0

[closure-cvs] CVS update: closure/src/xml/xml-parse.lisp
by emarsden＠common-lisp.net 10 Jul '05

10 Jul '05

Update of /project/closure/cvsroot/closure/src/xml In directory common-lisp.net:/tmp/cvs-serv26925 Modified Files: xml-parse.lisp Log Message: Fix trivial bugs in debug output. Date: Sun Jul 10 12:37:53 2005 Author: emarsden Index: closure/src/xml/xml-parse.lisp diff -u closure/src/xml/xml-parse.lisp:1.4 closure/src/xml/xml-parse.lisp:1.5 --- closure/src/xml/xml-parse.lisp:1.4 Tue Jul 8 17:41:48 2003 +++ closure/src/xml/xml-parse.lisp Sun Jul 10 12:37:53 2005 @@ -2304,8 +2304,6 @@ (format t "~&**** Test failed on ~S." filename) (fresh-line) (format t "** me: ~A" res) - (fresh-line) - (format t "** he: " res) (finish-output) (with-open-file (in out-filename :direction :input :element-type 'character) (do ((c (read-char in nil nil) (read-char in nil nil))) @@ -2520,7 +2518,7 @@ (unless e (error "Entity '~A' is not defined." (rod-string name))) (unless (eq :internal (cadr e)) - (error "Entity '~A' is not an internal entity.")) + (error "Entity '~A' is not an internal entity." (rod-string name))) (or (cadddr e) (car (setf (cdddr e)

1 0

← Newer
1
...
13
14
15
16
17
18
19
20
21
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

closure-cvs