July 2005 - closure-cvs@common-lisp.net - mailman3.common-lisp.net

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

17 Jul '05

Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv15903/renderer Modified Files: hyphenation.lisp Log Message: The hyphenation table can be referenced using an URL, rather than by an absolute filename. Date: Sun Jul 17 11:30:51 2005 Author: emarsden Index: closure/src/renderer/hyphenation.lisp diff -u closure/src/renderer/hyphenation.lisp:1.3 closure/src/renderer/hyphenation.lisp:1.4 --- closure/src/renderer/hyphenation.lisp:1.3 Sun Mar 13 19:03:24 2005 +++ closure/src/renderer/hyphenation.lisp Sun Jul 17 11:30:51 2005 @@ -4,7 +4,7 @@ ;;; Created: 2003-03-07 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: hyphenation.lisp,v 1.3 2005/03/13 18:03:24 gbaumann Exp $ +;;; $Id: hyphenation.lisp,v 1.4 2005/07/17 09:30:51 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1999-2003 by Gilbert Baumann @@ -174,18 +174,18 @@ ;;;; Reading Tables -(defun read-hyphen-table-file (filename &key (class 'tree-hyphenation-table)) - (with-open-file (input filename) - (let ((res (make-instance class - :filename filename))) - (read-line input nil nil) - (do ((line (read-line input nil nil) (read-line input nil nil))) - ((null line)) - (let* ((j (position #\space line)) - (pattern (map 'vector #'digit-char-p (subseq line (+ j 1))))) - (insert-hyphenation-pattern res (subseq line 0 j) pattern))) - res))) - +(defun read-hyphen-table (url &key (class 'tree-hyphenation-table)) + (let ((url (if (url:url-p url) url (url:parse-url url)))) + (netlib:with-open-document ((input mime-type) url) + (declare (ignore mime-type)) + (let ((res (make-instance class :filename url))) + (g/read-line input nil nil) + (do ((line (g/read-line input nil nil) (g/read-line input nil nil))) + ((null line)) + (let* ((j (position #\space line)) + (pattern (map 'vector #'digit-char-p (subseq line (+ j 1))))) + (insert-hyphenation-pattern res (subseq line 0 j) pattern))) + res)))) ;; 100,000x hyphenation of "argument": @@ -193,6 +193,10 @@ ;; new: .57s 2.400,000 bytes [technically zero] ;; $Log: hyphenation.lisp,v $ +;; Revision 1.4 2005/07/17 09:30:51 emarsden +;; The hyphenation table can be referenced using an URL, rather than by +;; an absolute filename. +;; ;; Revision 1.3 2005/03/13 18:03:24 gbaumann ;; Gross license change ;;

1 0

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

17 Jul '05

Update of /project/closure/cvsroot/closure/src In directory common-lisp.net:/tmp/cvs-serv15903 Modified Files: defpack.lisp Log Message: The hyphenation table can be referenced using an URL, rather than by an absolute filename. Date: Sun Jul 17 11:30:50 2005 Author: emarsden Index: closure/src/defpack.lisp diff -u closure/src/defpack.lisp:1.4 closure/src/defpack.lisp:1.5 --- closure/src/defpack.lisp:1.4 Sun Jul 10 12:57:19 2005 +++ closure/src/defpack.lisp Sun Jul 17 11:30:48 2005 @@ -40,6 +40,8 @@ #:scale-aimage #:pnm-stream->aimage) (:export + #:*tex-mode-p* + #:*hyphenate-p* #:device-font-ascent #:device-dpi #:device-font-descent @@ -128,8 +130,6 @@ (:export #:*home-page* #:*user-wants-images-p* - #:*tex-mode-p* - #:*hyphenate-p* #:*closure-dpi* #:*zoom-factor* #:*debug-submit-p*

1 0

[closure-cvs] CVS update: closure/src/net/http.lisp
by crhodes＠common-lisp.net 13 Jul '05

13 Jul '05

Update of /project/closure/cvsroot/closure/src/net In directory common-lisp.net:/tmp/cvs-serv23472/src/net Modified Files: http.lisp Log Message: Make the broken-image work under sbcl. * fix REALLY-PROBE-FILE, though we should probably be using some posixish functions instead of opening the file. Date: Wed Jul 13 17:13:05 2005 Author: crhodes Index: closure/src/net/http.lisp diff -u closure/src/net/http.lisp:1.5 closure/src/net/http.lisp:1.6 --- closure/src/net/http.lisp:1.5 Sun Mar 13 19:02:19 2005 +++ closure/src/net/http.lisp Wed Jul 13 17:13:05 2005 @@ -713,9 +713,10 @@ (unwind-protect (progn (setf stream (ignore-errors (open filename :direction :input - :if-does-not-exist nil))) + :element-type '(unsigned-byte 8) + :if-does-not-exist nil))) (and stream - (ignore-errors (read-char stream nil :eof)))) + (ignore-errors (read-byte stream nil :eof)))) (when stream (close stream)) )) ))

1 0

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

13 Jul '05

Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv16629/src/renderer Modified Files: clim-device.lisp renderer2.lisp x11.lisp Log Message: Make images work, more or less. * restore horrible grecording hack for (medium-)draw-ro* * make direct drawing of images to x11 work with my X server (32bpp even for 24-depth images) Obviously this should turn into proper clim support for images, at which point this horribleness can go away. However, this now basically works for me, modulo compiler consistency strangeness at startup. Date: Wed Jul 13 15:44:56 2005 Author: crhodes Index: closure/src/renderer/clim-device.lisp diff -u closure/src/renderer/clim-device.lisp:1.11 closure/src/renderer/clim-device.lisp:1.12 --- closure/src/renderer/clim-device.lisp:1.11 Sun Jul 10 13:18:35 2005 +++ closure/src/renderer/clim-device.lisp Wed Jul 13 15:44:55 2005 @@ -446,12 +446,17 @@ :actual-width (or width (r2::aimage-width aim)) :actual-height (or height (r2::aimage-height aim))))) -#+NIL -(climi::def-grecording draw-ro (() ro x y) - (values x - (- y (nth-value 1 (r2::ro/size ro))) - (+ x (nth-value 0 (r2::ro/size ro))) - (+ y 0))) +(climi::def-grecording draw-ro (() ro x y) () + (values x + (- y (nth-value 1 (r2::ro/size ro))) + (+ x (nth-value 0 (r2::ro/size ro))) + (+ y 0))) +(climi::def-graphic-op draw-ro (ro x y)) + +(defun draw-ro* (sheet ro x y &rest args) + (climi::with-medium-options (sheet args) + (medium-draw-ro* medium ro x y))) + (defmethod medium-draw-ro* ((medium clim:medium) (self ro/img) x y) (progn ;; ignore-errors ;xxx Index: closure/src/renderer/renderer2.lisp diff -u closure/src/renderer/renderer2.lisp:1.9 closure/src/renderer/renderer2.lisp:1.10 --- closure/src/renderer/renderer2.lisp:1.9 Mon Jul 11 17:57:56 2005 +++ closure/src/renderer/renderer2.lisp Wed Jul 13 15:44:55 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.9 2005/07/11 15:57:56 crhodes Exp $ +;;; $Id: renderer2.lisp,v 1.10 2005/07/13 13:44:55 crhodes Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -538,7 +538,7 @@ (replaced-object-chunk (let ((ro (replaced-object-chunk-object chunk))) (when (eql pass 1) - (closure/clim-device::medium-draw-ro* + (closure/clim-device::draw-ro* clim-user::*pane* ro x (+ dy y))) (incf x (chunk-width chunk))) ))))) @@ -4968,6 +4968,18 @@ ;; $Log: renderer2.lisp,v $ +;; Revision 1.10 2005/07/13 13:44:55 crhodes +;; Make images work, more or less. +;; +;; * restore horrible grecording hack for (medium-)draw-ro* +;; +;; * make direct drawing of images to x11 work with my X server (32bpp even +;; for 24-depth images) +;; +;; Obviously this should turn into proper clim support for images, at which +;; point this horribleness can go away. However, this now basically works +;; for me, modulo compiler consistency strangeness at startup. +;; ;; Revision 1.9 2005/07/11 15:57:56 crhodes ;; Complete the renaming *MEDIUM* -> *PANE*. ;; Index: closure/src/renderer/x11.lisp diff -u closure/src/renderer/x11.lisp:1.7 closure/src/renderer/x11.lisp:1.8 --- closure/src/renderer/x11.lisp:1.7 Sun Jul 10 12:57:23 2005 +++ closure/src/renderer/x11.lisp Wed Jul 13 15:44:56 2005 @@ -486,10 +486,16 @@ (let* ((width (imagelib:aimage-width aimage)) (height (imagelib:aimage-height aimage)) (idata (imagelib:aimage-data aimage)) - (xdata (make-array (list height width) :element-type `(unsigned-byte ,depth))) + ;; FIXME: this (and the :BITS-PER-PIXEL, below) is a hack on + ;; top of a hack. At some point in the past, XFree86 and/or + ;; X.org decided that they would no longer support pixmaps + ;; with 24 bpp, which seems to be what most AIMAGEs want to + ;; be. For now, force everything to a 32-bit pixmap. + (xdata (make-array (list height width) :element-type '(unsigned-byte 32))) (ximage (xlib:create-image :width width :height height :depth depth + :bits-per-pixel 32 :data xdata))) (declare (type (simple-array (unsigned-byte 32) (* *)) idata) #+NIL(type (simple-array (unsigned-byte 8) (* *)) xdata)

1 0

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

11 Jul '05

Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv7926/src/gui Modified Files: clim-gui.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:58:04 2005 Author: crhodes Index: closure/src/gui/clim-gui.lisp diff -u closure/src/gui/clim-gui.lisp:1.19 closure/src/gui/clim-gui.lisp:1.20 --- closure/src/gui/clim-gui.lisp:1.19 Sun Jul 10 13:18:34 2005 +++ closure/src/gui/clim-gui.lisp Mon Jul 11 17:58:03 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.19 2005/07/10 11:18:34 emarsden Exp $ +;;; $Id: clim-gui.lisp,v 1.20 2005/07/11 15:58:03 crhodes Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,15 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.20 2005/07/11 15:58:03 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.19 2005/07/10 11:18:34 emarsden ;; Distinguish between pane and medium in the CLIM GUI. This should ;; fix image display. @@ -128,7 +137,6 @@ (:menu-bar menubar-command-table) (:panes (canvas (make-pane 'closure-pane - :name 'canvas :height 2000 :width 800 :display-time nil)) @@ -620,17 +628,6 @@ ;;;; ---------------------------------------------------------------------------------------------------- -#+NIL -(define-closure-command com-reflow () - (window-clear (find-pane-named *frame* 'canvas)) - (let ((*medium* (find-pane-named *frame* 'canvas))) - (let ((device (make-instance 'closure/clim-device::clim-device :medium *medium*))) - (let ((closure-protocol:*document-language* - (make-instance 'r2::html-4.0-document-language)) - (closure-protocol:*user-agent* - nil)) - (r2::reflow))))) - (define-presentation-translator url-from-string (string url closure) (x) @@ -684,7 +681,7 @@ (min (gadget-max-value scrollbar) (+ current-y (* 0.9 window-height)))))) (define-closure-command (com-redraw :name t :keystroke (#\r :control)) () - (let* ((*medium* (find-pane-named *frame* 'canvas)) ) - (handle-repaint *medium* (sheet-region (pane-viewport *medium*)))) + (let* ((*pane* (find-pane-named *frame* 'canvas)) ) + (handle-repaint *pane* (sheet-region (pane-viewport *pane*)))) (xlib:display-finish-output (clim-clx::clx-port-display (find-port))))

1 0

[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