From dlichteblau at common-lisp.net Mon May 1 21:21:39 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 1 May 2006 17:21:39 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060501212139.2A8DA22004@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv4825 Modified Files: BUGS event.lisp frame-manager.lisp medium.lisp Log Message: * medium.lisp (apply-flipping-ink): Unref the temporary pixmap ("oops"). * frame-manager.lisp (frob-stupid-type-spec): Allow specs like :VRACK-PANE. * event.lisp (button-handler): Ungrab the pointer in button press events, allowing CLIM menu panes to works. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/30 10:31:15 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/05/01 21:21:38 1.7 @@ -10,7 +10,7 @@ (FIXED) 3. The text cursor does not show the correct horizontal position in climacs. -4. +(FIXED) 4. Menus appear but do not really work. Worth fixing, even though we would rather want native menus in the long term. @@ -89,3 +89,9 @@ design.lisp. See comment there. clim-fix tried to reinstate it, but that doesn't work for gsharp when drawing ellipses. Find out what this is all about. + +18. + Flipping ink optimization: As suggested by Gilbert, make the temporary + pixmap just large enough for the clipping region and the currently + visible part of a (scrolled) sheet. Right now we're copying the + entire window around, which seems excessive. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/23 17:36:28 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/05/01 21:21:39 1.5 @@ -221,6 +221,9 @@ (define-signal button-handler (widget event) (cffi:with-foreign-slots ((type time button state x y x_root y_root) event gdkeventbutton) + (when (eql type GDK_BUTTON_PRESS) + ;; Hack alert: Menus don't work without this. + (gdk_pointer_ungrab GDK_CURRENT_TIME)) (enqueue (make-instance (if (eql type GDK_BUTTON_PRESS) 'pointer-button-press-event --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/04/23 17:36:28 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/05/01 21:21:39 1.3 @@ -31,7 +31,9 @@ (or (find-class (intern (concatenate 'string (symbol-name type) "-PANE") :climi) nil) - (find-class type)))) + (if (keywordp type) + (find-class (intern (symbol-name type) :climi)) + (find-class type))))) (defmethod make-pane-1 ((fm gtkairo-frame-manager) (frame application-frame) type &rest initargs) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/23 17:36:28 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/05/01 21:21:39 1.6 @@ -226,7 +226,9 @@ (cairo_surface_mark_dirty to-surface)) (cairo_destroy (cr medium)) (setf (cr medium) (flipping-original-cr medium)) - (setf (flipping-original-cr medium) nil)) + (setf (flipping-original-cr medium) nil) + (gdk_drawable_unref (flipping-pixmap medium)) + (setf (flipping-pixmap medium) nil)) (defmethod sync-ink (medium (design climi::standard-flipping-ink)) (setf (flipping-original-cr medium) (cr medium)) From dlichteblau at common-lisp.net Tue May 2 13:00:12 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 May 2006 09:00:12 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060502130012.40D1E22007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv25592 Modified Files: event.lisp gtk-ffi.lisp BUGS Log Message: Fixed those phantom gtkairo display glitches: * event.lisp (expose-handler): Clear the affected area using gdk. * gtk-ffi.lisp (gdk_window_clear_area): New function. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/05/01 21:21:39 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/05/02 13:00:11 1.6 @@ -130,6 +130,7 @@ (define-signal expose-handler (widget event) (enqueue (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) + (gdk_window_clear_area (gtkwidget-gdkwindow widget) x y width height) (make-instance 'window-repaint-event :timestamp (get-internal-real-time) :sheet (widget->sheet widget *port*) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/23 17:36:28 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/05/02 13:00:12 1.5 @@ -674,6 +674,14 @@ (window :pointer) (title :string)) +(defcfun "gdk_window_clear_area" + :void + (window :pointer) + (x :int) + (y :int) + (width :int) + (height :int)) + (defconstant GDK_EXPOSURE_MASK (ash 1 1)) (defconstant GDK_POINTER_MOTION_MASK (ash 1 2)) (defconstant GDK_POINTER_MOTION_HINT_MASK (ash 1 3)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/05/01 21:21:38 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/05/02 13:00:12 1.8 @@ -46,7 +46,7 @@ The frontend specifies background colors (*3d-normal-color*) where the gtk theme should take precedence. -9. +(FIXED) 9. Sometimes repaint seems to draw again without clearing the window first. For example, the header in demodemo gets darker with every repaint, until the originally antialiased text looks really crappy. From dlichteblau at common-lisp.net Tue May 2 13:02:09 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 2 May 2006 09:02:09 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060502130209.BE9382200A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv26810 Modified Files: clim-fix.lisp Log Message: ... and this turned out to be a similar but unrelated display glitch: * clim-fix.lisp (handle-repaint): Restored the first version of this method form Gilbert's original clim-fix.lisp, which draws background ink before each repaint. Doesn't seem elegant, but DEMODEMO wants it. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/04/30 09:24:40 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/05/02 13:02:09 1.4 @@ -24,8 +24,20 @@ ;;; :design design) ;;; (call-next-method)) -(defmethod clim:handle-repaint :after ((s clim:sheet-with-medium-mixin) r) - (medium-force-output (sheet-medium s))) +(defmethod clim:handle-repaint :around ((s clim:sheet-with-medium-mixin) r) + (let ((m (clim:sheet-medium s)) + (r (clim:bounding-rectangle + (clim:region-intersection r (clim:sheet-region s))))) + (unless (eql r clim:+nowhere+) + ;; Test case: Start CLIM-DEMO::DEMODEMO and watch the header string. + ;; At the beginning, the text is nicely antialiased. Then start any + ;; demo and move the new window around over the header. As the + ;; header gets exposed again, the text is apparently redrawn + ;; multiple times and looks like crap. This fixes it: + (clim:with-drawing-options (m :clipping-region r) + (clim:draw-design m r :ink clim:+background-ink+) + (call-next-method s r))) + (medium-force-output m))) ;; cairo hack: adjust rectangle coordinates by half a pixel each to avoid ;; anti-aliasing (and follow-up output artifacts) From crhodes at common-lisp.net Tue May 2 15:46:42 2006 From: crhodes at common-lisp.net (crhodes) Date: Tue, 2 May 2006 11:46:42 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20060502154642.779486D195@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv14348 Modified Files: freetype-ffi.lisp Log Message: In sbcl, load the versioned shared object --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-ffi.lisp 2006/03/15 22:56:55 1.4 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-ffi.lisp 2006/05/02 15:46:42 1.5 @@ -57,7 +57,7 @@ `(def-alien-routine , at rest)) #+sbcl -(load-shared-object #+darwin "/usr/X11R6/lib/libfreetype.dylib" #-darwin "libfreetype.so") +(load-shared-object #+darwin "/usr/X11R6/lib/libfreetype.6.dylib" #-darwin "libfreetype.so.6") (declaim (optimize (speed 3))) From afuchs at common-lisp.net Wed May 3 09:33:09 2006 From: afuchs at common-lisp.net (afuchs) Date: Wed, 3 May 2006 05:33:09 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060503093309.2006234024@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv24588 Modified Files: incremental-redisplay.lisp Log Message: Fix incremental-redisplay memory leak by removing the children-updating-output slot and related bookkeeping code. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/22 15:31:27 1.60 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/05/03 09:33:08 1.61 @@ -387,9 +387,6 @@ (stream :accessor updating-output-stream :initarg :stream :initform nil :documentation "Capture the screen in order to restrict update to visible records") - (children-updating-output :accessor children-updating-output :initform nil - :documentation "A list of updating-output records -that are children (but not necessarily direct) of this record.") (parent-updating-output :accessor parent-updating-output :initarg :parent-updating-output :initform nil :documentation "A backlink to the @@ -440,10 +437,7 @@ ;;; XXX still needed? (defmethod add-output-record :after ((child updating-output-record-mixin) record) - (declare (ignore record)) - (if (parent-updating-output child) - (push child (children-updating-output (parent-updating-output child))) - nil)) + (declare (ignore record child))) ;;; Prevent deleted output records from coming back from the dead. @@ -451,15 +445,10 @@ record &optional errorp) (declare (ignore record errorp)) - (let ((pcache (parent-cache child)) - (parent-updating (parent-updating-output child))) + (let ((pcache (parent-cache child))) (delete-from-map pcache (output-record-unique-id child) - (output-record-id-test child)) - (when parent-updating - (setf (children-updating-output parent-updating) - (delete child (children-updating-output parent-updating) - :test #'eq))))) + (output-record-id-test child)))) (defclass standard-updating-output-record (updating-output-record-mixin From crhodes at common-lisp.net Wed May 3 09:39:06 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 3 May 2006 05:39:06 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060503093906.E194C7D001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv24921 Modified Files: incremental-redisplay.lisp Log Message: Delete definitely not needed method. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/05/03 09:33:08 1.61 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/05/03 09:39:06 1.62 @@ -434,12 +434,6 @@ (let ((state (end-graphics-state record))) (setf (values (cursor-x state) (cursor-y state)) (values x y)))) -;;; XXX still needed? -(defmethod add-output-record :after - ((child updating-output-record-mixin) record) - (declare (ignore record child))) - - ;;; Prevent deleted output records from coming back from the dead. (defmethod delete-output-record :after ((child updating-output-record-mixin) record From dlichteblau at common-lisp.net Sun May 7 14:29:06 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 May 2006 10:29:06 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060507142906.278905B006@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv17296 Modified Files: event.lisp Log Message: Minor key event correction, still not quite there. I'd like to make this work without having to pull in clx/keysyms.lisp. * event.lisp (key-handler): Don't give :escape a character. Actually, CLX will return #\escape here on #+(or lispm excl), but it doesn't do that anywhere else and NIL is certainly better than #\{, which we used to return. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/05/02 13:00:11 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/05/07 14:29:06 1.7 @@ -194,11 +194,13 @@ (char string 0))) (sym (gethash keyval *keysyms*))) ;; McCLIM will #\a statt ^A sehen: - (when (and char - (< 0 (char-code char) 32) - ;; ...aber fuer return dann auf einmal doch - (not (eql char #\return))) - (setf char (code-char (+ (char-code char) 96)))) + (cond + ((null char)) + ((eql char #\return)) + ((eql char #\escape) + (setf char nil)) + ((< 0 (char-code char) 32) + (setf char (code-char (+ (char-code char) 96))))) (when (eq sym :backspace) (setf char #\backspace)) ;; irgendwas sagt mir, dass hier noch weitere Korrekturen From dlichteblau at common-lisp.net Sun May 7 14:30:24 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 May 2006 10:30:24 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060507143024.8DB795D0F6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv18841 Modified Files: gtk-ffi.lisp Log Message: * gtk-ffi.lisp: #+darwin library loading, thanks to Cyrus Harmon. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/05/02 13:00:12 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/05/07 14:30:24 1.6 @@ -19,12 +19,20 @@ (in-package :clim-gtkairo) -#-(or win32 mswindows windows) +#-(or win32 mswindows windows darwin) (eval-when (:compile-toplevel :load-toplevel :execute) (cffi:load-foreign-library "libcairo.so") (cffi:load-foreign-library "libgthread-2.0.so") (cffi:load-foreign-library "libgtk-x11-2.0.so")) +#+darwin +(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((cffi:*foreign-library-directories* + (cons "/opt/local/lib/" cffi:*foreign-library-directories*))) + (cffi:load-foreign-library "libcairo.dylib") + (cffi:load-foreign-library "libgthread-2.0.dylib") + (cffi:load-foreign-library "libgtk-x11-2.0.dylib"))) + #+(or win32 mswindows windows) (eval-when (:compile-toplevel :load-toplevel :execute) (cffi:load-foreign-library "libcairo-2.dll") From dlichteblau at common-lisp.net Sun May 7 14:33:04 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 May 2006 10:33:04 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060507143304.CC33E5D096@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv18990 Modified Files: BUGS Log Message: more bugs --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/05/02 13:00:12 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/05/07 14:33:04 1.9 @@ -62,7 +62,7 @@ The new flipping ink implementation is buggy, it produces garbage output in some cases. -12. +(FIXED) 12. In the address book, there are often wide grey borders instead of the narrow black ones. @@ -95,3 +95,11 @@ pixmap just large enough for the clipping region and the currently visible part of a (scrolled) sheet. Right now we're copying the entire window around, which seems excessive. + +19. + Key press events for modifier keys don't have the corresponding + modifier bit set; key release events do. This is opposite to what + CLIM-CLX does. + +20. + Very nasty duplicate keyboard events when typing in the listener. From dlichteblau at common-lisp.net Sun May 7 19:47:19 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 May 2006 15:47:19 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060507194719.B97182009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26624 Modified Files: mcclim.asd Log Message: Medium benchmark toy. * mcclim.asd (clim-examples): Added drawing-benchmark.lisp. * Examples/drawing-benchmark.lisp: New file. * Examples/demodemo.lisp (demodemo): Added Drawing Benchmark button. * Backends/gtkairo/port.lisp (port-force-output): Call gdk_flush. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/23 12:57:31 1.20 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/05/07 19:47:19 1.21 @@ -339,7 +339,8 @@ (:file "method-browser") (:file "dragndrop-translator") (:file "draggable-graph") - (:file "text-size-test"))) + (:file "text-size-test") + (:file "drawing-benchmark"))) (:module "Goatee" :components ((:file "goatee-test"))))) From dlichteblau at common-lisp.net Sun May 7 19:47:19 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 May 2006 15:47:19 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20060507194719.F2BCF305A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv26624/Examples Modified Files: demodemo.lisp Added Files: drawing-benchmark.lisp Log Message: Medium benchmark toy. * mcclim.asd (clim-examples): Added drawing-benchmark.lisp. * Examples/drawing-benchmark.lisp: New file. * Examples/demodemo.lisp (demodemo): Added Drawing Benchmark button. * Backends/gtkairo/port.lisp (port-force-output): Call gdk_flush. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/04/17 17:54:58 1.10 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/05/07 19:47:19 1.11 @@ -73,7 +73,9 @@ (make-demo-button "Scroll Test" 'Scroll-test) (make-demo-button "List Test" 'list-test) (make-demo-button "HBOX Test" 'hbox-test) - (make-demo-button "Text Size Test" 'text-size-test))))))))) + (make-demo-button "Text Size Test" 'text-size-test) + (make-demo-button "Drawing Benchmark" + 'drawing-benchmark))))))))) (defun demodemo () #+nil --- /project/mcclim/cvsroot/mcclim/Examples/drawing-benchmark.lisp 2006/05/07 19:47:19 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/drawing-benchmark.lisp 2006/05/07 19:47:19 1.1 ;;; -*- Mode: Lisp; -*- ;;; (c) 2006 David Lichteblau (david at lichteblau.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (define-application-frame drawing-benchmark () () (:panes (canvas :application :min-width 600 :incremental-redisplay nil :display-time nil) (mode (with-radio-box () (radio-box-current-selection (make-pane 'toggle-button :label "rectangle" :id :rectangle)) (make-pane 'toggle-button :label "text" :id :text))) (ink (with-radio-box () (radio-box-current-selection (make-pane 'toggle-button :label "random" :id :random)) (make-pane 'toggle-button :label "red" :id +red+) (make-pane 'toggle-button :label "flipping ink" :id +flipping-ink+)))) (:layouts (default (vertically () (horizontally () (labelling (:label "Mode") mode) (labelling (:label "Ink") ink)) canvas)))) (defmethod run-drawing-benchmark (frame stream) (setf (stream-recording-p stream) nil) (window-clear stream) (let* ((width (rectangle-width (sheet-region stream))) (height (rectangle-height (sheet-region stream))) (mode (gadget-id (gadget-value (find-pane-named frame 'mode)))) (ink (gadget-id (gadget-value (find-pane-named frame 'ink)))) (itups internal-time-units-per-second) (n 0) (start (get-internal-real-time)) (stop (+ start itups))) (do () ((>= (get-internal-real-time) stop)) (incf n) (let ((ink (if (eq ink :random) (clim:make-rgb-color (random 1.0d0) (random 1.0d0) (random 1.0d0)) ink))) (ecase mode (:rectangle (draw-rectangle* stream 10 10 (- width 10) (- height 10) :ink ink :filled t)) (:text (dotimes (x 10) (draw-text* stream "Bla blub hastenichgesehen noch viel mehr Text so fuellen wir eine Zeile." 0 (* x 20) :ink ink)))))) (finish-output stream) (medium-finish-output (sheet-medium stream)) (climi::port-force-output (car climi::*all-ports*)) (setf stop (get-internal-real-time)) (window-clear stream) (setf (stream-recording-p stream) t) (format stream "Score: ~A operations/s~%" (float (/ n (/ (- stop start) itups)))))) (define-drawing-benchmark-command (com-quit-drawing-benchmark :menu "Quit") () (frame-exit *application-frame*)) (define-drawing-benchmark-command (com-update :menu "Run") () (run-drawing-benchmark *application-frame* (frame-standard-output *application-frame*))) From dlichteblau at common-lisp.net Sun May 7 19:47:20 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 May 2006 15:47:20 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060507194720.34410305A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv26624/Backends/gtkairo Modified Files: port.lisp Log Message: Medium benchmark toy. * mcclim.asd (clim-examples): Added drawing-benchmark.lisp. * Examples/drawing-benchmark.lisp: New file. * Examples/demodemo.lisp (demodemo): Added Drawing Benchmark button. * Backends/gtkairo/port.lisp (port-force-output): Call gdk_flush. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/04/23 10:18:45 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/05/07 19:47:20 1.3 @@ -581,7 +581,11 @@ (defmethod port-force-output ((port gtkairo-port)) (with-gtk () - (gdk_display_flush (gdk_display_get_default)))) + (gdk_display_flush (gdk_display_get_default)) + ;; Don't know whether p-f-o is actually meant to XSync, which is + ;; what gdk_flush does. But it seems useful to have _some_ function + ;; for this, so let's use p-f-o until we find a better one. + (gdk_flush))) ;; FIXME: What happens when CLIM code calls tracking-pointer recursively? (defmethod port-grab-pointer ((port gtkairo-port) pointer sheet) From crhodes at common-lisp.net Tue May 9 14:01:10 2006 From: crhodes at common-lisp.net (crhodes) Date: Tue, 9 May 2006 10:01:10 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20060509140110.0B19367004@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv3467 Modified Files: clim-area.lisp Log Message: The commit on 2006-03-01 to clim-area claimed to add space for a visible cursor, but in fact added space for a cursor whether visible or not. Only add in the space for visible cursors. This fixes most of the text glitches in the clim listener; now where previously e.g. (* 2 3) RET would leave an extra space at the end of the bounding rectangle, the text is tightly bound. *package* RET still has a problem, as the RET there seems to open a new (empty) screen line. --- /project/mcclim/cvsroot/mcclim/Goatee/clim-area.lisp 2006/04/01 07:58:37 1.33 +++ /project/mcclim/cvsroot/mcclim/Goatee/clim-area.lisp 2006/05/09 14:01:09 1.34 @@ -219,11 +219,11 @@ (let ((cursor (cursor record))) (multiple-value-bind (x1 y1 x2 y2) (call-next-method) (values x1 y1 - (if cursor + (if (and cursor (eq (cursor-visibility cursor) :on)) (with-slots (climi::x climi::width) cursor (max x2 (+ climi::x climi::width))) x2) - (if cursor + (if (and cursor (eq (cursor-visibility cursor) :on)) (max y2 (+ y1 (climi::cursor-height cursor))) y2))))) From dlichteblau at common-lisp.net Tue May 9 20:07:54 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Tue, 9 May 2006 16:07:54 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20060509200754.85EB91400A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv22236 Modified Files: drawing-benchmark.lisp text-size-test.lisp Log Message: * text-size-test.lisp (com-update): Renamed to com-update-text-size-test. * drawing-benchmark.lisp (com-update): Renamed to com-run-drawing-benchmark. --- /project/mcclim/cvsroot/mcclim/Examples/drawing-benchmark.lisp 2006/05/07 19:47:19 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/drawing-benchmark.lisp 2006/05/09 20:07:54 1.2 @@ -90,6 +90,6 @@ (define-drawing-benchmark-command (com-quit-drawing-benchmark :menu "Quit") () (frame-exit *application-frame*)) -(define-drawing-benchmark-command (com-update :menu "Run") () +(define-drawing-benchmark-command (com-run-drawing-benchmark :menu "Run") () (run-drawing-benchmark *application-frame* (frame-standard-output *application-frame*))) --- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/04/19 11:43:31 1.2 +++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/05/09 20:07:54 1.3 @@ -109,6 +109,6 @@ (define-text-size-test-command (com-quit-text-size-test :menu "Quit") () (frame-exit *application-frame*)) -(define-text-size-test-command (com-update :menu "Update") () +(define-text-size-test-command (com-update-text-size-test :menu "Update") () (display-canvas *application-frame* (frame-standard-output *application-frame*))) From crhodes at common-lisp.net Wed May 10 11:18:42 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 10 May 2006 07:18:42 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060510111842.D96E654055@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv10052 Modified Files: presentation-defs.lisp Log Message: typo-in-comment fix --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/05/05 10:24:02 1.56 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/05/10 11:18:42 1.57 @@ -841,7 +841,7 @@ :default-type default-type) (funcall-presentation-generic-function accept type stream view)))) - ;; User entered activation or delimeter + ;; User entered activation or delimiter ;; gesture without any input. (if defaultp (progn From crhodes at common-lisp.net Wed May 10 11:19:33 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 10 May 2006 07:19:33 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20060510111933.828DD54060@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv10114 Modified Files: listener.lisp Log Message: Note a problem with the execute-frame-command method --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/03/29 10:43:37 1.25 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/05/10 11:19:33 1.26 @@ -121,6 +121,7 @@ (history-length :initform 25 :initarg :history-length :accessor history-length))) (defmethod execute-frame-command :after ((frame command-history-mixin) command) + ;; FIXME: not safe against commands sent from other frames. (push command (history frame)) (when (> (length (history frame)) (history-length frame)) (setf (history frame) From crhodes at common-lisp.net Fri May 12 10:24:32 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 12 May 2006 06:24:32 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060512102432.99F247065@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17798 Modified Files: commands.lisp Log Message: In accepting command names textually, suggest only one command per string name, and suggest ones from the child tables in preference. This allows command shadowing to behave as you might expect. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/04/21 12:03:23 1.62 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/05/12 10:24:32 1.63 @@ -1090,11 +1090,15 @@ &key) (flet ((generator (string suggester) (declare (ignore string)) - (map-over-command-table-names - (lambda (cline-name command-name) - (when (command-enabled command-name *application-frame*) - (funcall suggester cline-name command-name))) - command-table))) + (let ((possibilities nil)) + (map-over-command-table-names + (lambda (cline-name command-name) + (when (command-enabled command-name *application-frame*) + (pushnew (cons cline-name command-name) possibilities + :key #'car :test #'string=))) + command-table) + (loop for (cline-name . command-name) in possibilities + do (funcall suggester cline-name command-name))))) ;; Bind the frame's command table so that the command-enabled ;; test passes with this command table. (letf (((frame-command-table *application-frame*) From dlichteblau at common-lisp.net Fri May 12 22:40:51 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Fri, 12 May 2006 18:40:51 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20060512224051.D9A5A3300A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv27703 Modified Files: demodemo.lisp Log Message: * demodemo.lisp (demodemo): Removed the empty menu bar. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/05/07 19:47:19 1.11 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/05/12 22:40:51 1.12 @@ -43,6 +43,7 @@ (define-application-frame demodemo () () + (:menu-bar nil) (:layouts (default (vertically (:equalize-width t) From dlichteblau at common-lisp.net Sat May 13 00:03:41 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Fri, 12 May 2006 20:03:41 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060513000341.805EB5300F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5661 Modified Files: menu.lisp Log Message: Hack the MENU-BAR to draw its own 3d effect instead of wrapping a RAISED-PANE around it. This way the frame manager gets to decide on the appearance of the menu bar. * menu.lisp (MAKE-MENU-BAR): Don't wrap the menu bar pane in a raising. (HANDLE-REPAINT, COMPOSE-SPACE, BOX-LAYOUT-MIXIN/HORIZONTALLY-ALLOCATE-SPACE): New methods on menu-bar. --- /project/mcclim/cvsroot/mcclim/menu.lisp 2004/11/07 19:33:31 1.34 +++ /project/mcclim/cvsroot/mcclim/menu.lisp 2006/05/13 00:03:41 1.35 @@ -362,20 +362,55 @@ (max-width +fill+) max-height min-width min-height) (with-slots (menu) (find-command-table command-table) - (raising () - (make-pane-1 *pane-realizer* *application-frame* - 'menu-bar - :background *3d-normal-color* - :width width :height height - :max-width max-width :max-height max-height - :min-width min-width :min-height min-height - :contents - (append - (loop for item in menu - collect - (make-menu-button-from-menu-item - item nil - :bottomp t - :vertical nil - :command-table command-table)) - (list +fill+)))))) + (make-pane-1 *pane-realizer* *application-frame* + 'menu-bar + :background *3d-normal-color* + :width width :height height + :max-width max-width :max-height max-height + :min-width min-width :min-height min-height + :contents + (append + (loop for item in menu + collect + (make-menu-button-from-menu-item + item nil + :bottomp t + :vertical nil + :command-table command-table)) + (list +fill+))))) + +(defmethod handle-repaint ((pane menu-bar) region) + (declare (ignore region)) + (with-slots (border-width) pane + (multiple-value-call #'draw-bordered-rectangle* + pane + (bounding-rectangle* (sheet-region pane)) + :style :outset + :border-width 2))) + +(defmethod compose-space ((pane menu-bar) &key width height) + (declare (ignore width height)) + (space-requirement+ (call-next-method) + (make-space-requirement :height 4 :max-height 4))) + +(defmethod box-layout-mixin/horizontally-allocate-space + ((pane menu-bar) real-width real-height) + (with-slots (x-spacing) pane + (let ((widths + (box-layout-mixin/horizontally-allocate-space-aux* + pane real-width real-height)) + (x 2)) + (loop + for child in (box-layout-mixin-clients pane) + for width in widths + do + (when (box-client-pane child) + (layout-child (box-client-pane child) + :expand + :expand + x + 2 + width + (- real-height 4))) + (incf x width) + (incf x x-spacing))))) From dlichteblau at common-lisp.net Sat May 13 00:19:38 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Fri, 12 May 2006 20:19:38 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060513001938.206776102A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8095 Modified Files: menu.lisp Log Message: Oops, don't allow the menu bar to get smaller on resizes. * menu.lisp ((compose-space menu-bar)): Specify min-height. --- /project/mcclim/cvsroot/mcclim/menu.lisp 2006/05/13 00:03:41 1.35 +++ /project/mcclim/cvsroot/mcclim/menu.lisp 2006/05/13 00:19:36 1.36 @@ -390,8 +390,9 @@ (defmethod compose-space ((pane menu-bar) &key width height) (declare (ignore width height)) - (space-requirement+ (call-next-method) - (make-space-requirement :height 4 :max-height 4))) + (space-requirement+ + (call-next-method) + (make-space-requirement :height 4 :max-height 4 :min-height 4))) (defmethod box-layout-mixin/horizontally-allocate-space ((pane menu-bar) real-width real-height) From dlichteblau at common-lisp.net Sat May 13 19:37:29 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sat, 13 May 2006 15:37:29 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060513193729.E0ECC5C123@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv5822 Modified Files: BUGS cairo-ffi.lisp event.lisp frame-manager.lisp gadgets.lisp gtk-ffi.lisp medium.lisp port.lisp Log Message: Some flipping ink de-pessimisation. Good speedup in the drawing benchmark. Helps only with local X for me. Breaks totally on Windows, so not enabled there yet. * medium.lisp (FLIPPING-PIXMAP): Default to NIL. (SYNC-SHEET): Free flipping-pixmap. Use pushnew, not push. (DISPOSE-FLIPPING-PIXMAP): New function. (APPLY-FLIPPING-INK): Don't free flipping-pixmap (except on Windows, for now). Bugfix: Use sheet-mirror-region instead of GtkWidget.allocation. ((SYNC-INK flipping-ink)): Use the cached flipping pixmap if present. Bugfix like above. (DESTROY-CAIRO-MEDIUM): Free flipping-pixmap. * port.lisp (DESTROY-MEDIUMS): Free flipping-pixmap. Repair windows port: * medium.lisp (MEDIUM-DRAW-TEXT*): Don't pass empty strings to cairo. (CAIRO-TEXT-EXTENTS): Ditto (new function). (TEXT-SIZE, CLIMI::TEXT-BOUNDING-RECTANGLE*): Call cairo-text-extents. Native menus: * event.lisp (MENU-CLICKED-HANDLER): New function. * frame-manager.lisp (MAKE-PANE-2): New methods for MENU-BUTTON-LEAF-PANE, MENU-BUTTON-SUBMENU-PANE, and MENU-BAR. * port.lisp (GTK-MENU, GTK-NONMENU, GTK-MENU-BAR, MENU-MIRROR, NONMENU-MIRROR): New classes. ((REALIZE-MIRROR GTK-MENU), (REALIZE-MIRROR GTK-NONMENU), (DESTROY-MIRROR GTK-MENU), (DESTROY-MIRROR GTK-NONMENU)): New methods. * gtk-ffi.lisp (GTK_MENU_ITEM_NEW_WITH_LABEL, GTK_MENU_BAR_NEW, GTK_MENU_SHELL_APPEND, GTK_MENU_ITEM_SET_SUBMENU, GTK_MENU_NEW, GTK_SEPARATOR_MENU_ITEM_NEW): New foreign function declarations. * gadgets.lisp (MENU-CLICKED-EVENT): New class. ((REALIZE-NATIVE-WIDGET GTK-MENU-BAR), (CONNECT-NATIVE-SIGNALS GTK-MENU-BAR) (HANDLE-EVENT GTK-MENU MENU-CLICKED-EVENT) (HANDLE-EVENT GTK-NONMENU MAGIC-GADGET-EVENT), (COMPOSE-SPACE GTK-MENU-BAR)): New methods. (APPEND-MENU-ITEMS, MAKE-NATIVE-MENU-ITEM): New functions. Unsuccessful attempt at native context menus, checked in anyway in the hope that it's not broken beyond repair. Bugs: Doesn't get notified when the context menu is closed without an item having been selected (perhaps solvable through low-level hackery). Sometimes doesn't appear at all (fixme). Assertion fails on #+clim-mp (gna). * event.lisp (CONTEXT-MENU-CLICKED-HANDLER): New function. * frame-manager.lisp (FRAME-MANAGER-MENU-CHOOSE): New method, commented out for now. * gadgets.lisp (CONTEXT-MENU-CLICKED-EVENT, DUMMY-CONTEXT-MENU-SHEET, DUMMY-MENU-ITEM-SHEET): New classes. (DESTRUCTURE-MC-MENU-ITEM, MAKE-CONTEXT-MENU): New functions. * gtk-ffi.lisp (GTK_MENU_POPUP, GTK_GET_CURRENT_EVENT_TIME): New foreign function declarations. Fix climacs startup by always blocking in the native event loop. I cannot figure out what GTK+ does that sb-sys:wait-until-fd-usable didn't, so I am not entirely confident that this change is really the right thing. DESTROY-PORT seems broken now as a consequence of interrupting the native code. Anyway, in the name of short-term bug fixing: * event.lisp (GET-NEXT-EVENT): Disable the hack that was used to avoid blocking in foreign code. Misc: * cairo-ffi.lisp (*CAIRO-ERROR-MODE*): Removed. (DEF-CAIRO-FUN): Signal an ERROR, unconditionally. (cairo_get_font_face, cairo_font_face_status): New foreign function declarations. * medium.lisp (ASSERT-FONT-STATUS): New function. (SYNC-TEXT-STYLE): Check font error status. * event.lisp (KEY-HANDLER): Minor rearrangement. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/05/07 14:33:04 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/05/13 19:37:29 1.10 @@ -27,20 +27,28 @@ (FIXED) 5d. Default gadget values aren't being used. -6. - Should work on Windows but does not. Using the installer from - gimp-win.sf.net I see an address book window, but there are cairo - font warnings in the background and font metrik functions return - totally bogus values sometimes. - Although the hordes of sbcl/win32 hackers might contribute a native - Windows backend sooner or later, it would be nice to get Gtkairo - working on Windows, too. - -7. - (some?) drawing operations are rather slow. (Remote X to an ancient - server spends insane amounts of real (!) time doing XGetImage - requests. But even locally, where that isn't reproducable, it's not - really snappy. Just try scrolling in beirc.) +(FIXED) 6. + [Address book didn't work on windows.] + +6b. + On windows, something draws gray ink over the buttons in demodemo + after expose events. This should not happen, since the gtkbuttons + are in a gtkfixed with its own window. Thorough double buffering + of all output seems to be a viable workaround though. + +6c. + On windows, all we get is a sans serif font. No serif and notably + no monospace font, breaking climacs like bug 3 did. + +7a. + flipping ink takes time proportional to the with the size of the + window, not with the size of the shape being drawn + +7b. + flipping ink pixmap caching is broken on windows + +7c. + text drawing is noticably slower than with CLX 8. The frontend specifies background colors (*3d-normal-color*) where @@ -66,14 +74,14 @@ In the address book, there are often wide grey borders instead of the narrow black ones. -13. +(WONTFIX) 13. McCLIM seems to think that things like button panes have a maximum size equal to their preferred size. I don't agree and return the default gtk size as space-requirement :width and :height without giving a maximum or minimum size at all. Naturally, the existing demos look a little, erm, different with that. -14. +(FIXED?) 14. Climacs doesn't draw itself until the window is resized. (FIXED) 15. @@ -101,5 +109,11 @@ modifier bit set; key release events do. This is opposite to what CLIM-CLX does. -20. +(NOTABUG) 20. Very nasty duplicate keyboard events when typing in the listener. + +21. + Copy&paste needs to be implemented. + +22. + medium-draw-ellipse* needs a rewrite. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/04/23 17:36:28 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/05/13 19:37:29 1.4 @@ -25,9 +25,6 @@ (in-package :clim-gtkairo) -(defvar *cairo-error-mode* :warn - "NIL, :WARN, or :BREAK.") - (defmacro def-cairo-fun (name rtype &rest args) (let* ((str (string-upcase name)) (actual (intern (concatenate 'string "%-" str) :clim-gtkairo)) @@ -40,12 +37,9 @@ (defun ,wrapper ,argnames (multiple-value-prog1 (,actual , at argnames) - (when *cairo-error-mode* - (let ((status (cairo_status ,(car argnames)))) - (unless (eq status :success) - (warn "~A returned with status ~A" ,name status)) - (when (eq *cairo-error-mode* :break) - (break))))))))) + (let ((status (cairo_status ,(car argnames)))) + (unless (eq status :success) + (error "~A returned with status ~A" ,name status)))))))) ;; user-visible structures @@ -608,6 +602,14 @@ :void (cr :pointer)) +(def-cairo-fun "cairo_get_font_face" + :pointer + (cr :pointer)) + +(defcfun "cairo_font_face_status" + cairo_status + (font :pointer)) + ;;; Error status queries --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/05/07 14:29:06 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/05/13 19:37:29 1.8 @@ -101,9 +101,9 @@ (cond ((dequeue port)) (t - #+(and sbcl (not win32)) - (sb-sys:wait-until-fd-usable (gdk-xlib-fd) :input timeout) - (gtk-main-iteration port #-(and sbcl (not win32)) t) + #+clim-gtkairo::do-not-block-in-ffi + (sb-sys:wait-until-fd-usable (gdk-xlib-fd) :input 0.1) + (gtk-main-iteration port #-clim-gtkairo::do-not-block-in-ffi t) (dequeue port)))) (defmacro define-signal (name+options (widget event &rest args) &body body) @@ -193,18 +193,15 @@ ;; fixme: what about the other characters in `string'? (char string 0))) (sym (gethash keyval *keysyms*))) - ;; McCLIM will #\a statt ^A sehen: (cond + ((eq sym :backspace) + (setf char #\backspace)) ((null char)) ((eql char #\return)) ((eql char #\escape) (setf char nil)) ((< 0 (char-code char) 32) (setf char (code-char (+ (char-code char) 96))))) - (when (eq sym :backspace) - (setf char #\backspace)) - ;; irgendwas sagt mir, dass hier noch weitere Korrekturen - ;; werden folgen muessen. (enqueue (make-instance (if (eql type GDK_KEY_PRESS) 'key-press-event @@ -321,6 +318,23 @@ (make-instance 'magic-gadget-event :sheet (widget->sheet widget *port*))))) +(define-signal menu-clicked-handler (widget event) + (declare (ignore event)) + (let ((parent (cffi:foreign-slot-value widget 'gtkwidget 'parent))) + (enqueue + (make-instance 'menu-clicked-event + :sheet (widget->sheet parent *port*) + :item (widget->sheet widget *port*))))) + +(define-signal context-menu-clicked-handler (widget event) + (declare (ignore event)) + (let ((dummy-item (widget->sheet widget *port*))) + (enqueue + (make-instance 'context-menu-clicked-event + :sheet (dummy-menu-item-sheet-parent dummy-item) + :value (dummy-menu-item-sheet-value dummy-item) + :itemspec (dummy-menu-item-sheet-itemspec dummy-item))))) + #-sbcl (define-signal (scrollbar-change-value-handler :return-type :int) (widget (scroll gtkscrolltype) (value :double)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/05/01 21:21:39 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/05/13 19:37:29 1.4 @@ -50,6 +50,17 @@ (defmethod make-pane-2 ((type (eql 'push-button-pane)) &rest initargs) (apply #'make-instance 'gtk-button initargs)) +(defmethod make-pane-2 + ((type (eql 'climi::menu-button-leaf-pane)) &rest initargs) + (apply #'make-instance 'gtk-nonmenu initargs)) + +(defmethod make-pane-2 + ((type (eql 'climi::menu-button-submenu-pane)) &rest initargs) + (apply #'make-instance 'gtk-menu initargs)) + +(defmethod make-pane-2 ((type (eql 'climi::menu-bar)) &rest initargs) + (apply #'make-instance 'gtk-menu-bar initargs)) + ;;;(defmethod make-pane-2 ((type (eql 'clim:check-box-pane)) &rest initargs) ;;; (apply #'make-instance gtkairo-check-box-pane initargs)) ;;;(defmethod make-pane-2 ((type (eql 'clim:radio-box-pane)) &rest initargs) @@ -104,3 +115,37 @@ ((fm gtkairo-frame-manager) (frame climi::menu-frame)) (port-enable-sheet (car climi::*all-ports*) (slot-value frame 'climi::top-level-sheet))) + +#+(or) ;doesn't work yet +(defmethod frame-manager-menu-choose + ((frame-manager gtkairo-frame-manager) + items + &key associated-window printer presentation-type + (default-item nil default-item-p) + text-style label cache unique-id id-test cache-value cache-test + max-width max-height n-rows n-columns x-spacing y-spacing row-wise + cell-align-x cell-align-y scroll-bars pointer-documentation) + (declare + ;; XXX hallo? + (ignore printer presentation-type default-item default-item-p + text-style label cache unique-id id-test cache-value + cache-test max-width max-height n-rows n-columns x-spacing + y-spacing row-wise cell-align-x cell-align-y scroll-bars + pointer-documentation)) + (let* ((frame (if associated-window + (pane-frame associated-window) + *application-frame*)) + (port (port frame)) + (tls (slot-value frame 'climi::top-level-sheet)) + (tls-mirror (climi::port-lookup-mirror port tls)) + (sheet (make-instance 'dummy-context-menu-sheet)) + (menu (make-context-menu port sheet items))) + (gtk_menu_popup menu + (cffi:null-pointer) + (cffi:null-pointer) + (cffi:null-pointer) + (cffi:null-pointer) + 0 + (gtk_get_current_event_time)) + (let ((event (event-read sheet))) + (values (event-value event) (event-itemspec event) event)))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/30 10:31:15 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/05/13 19:37:29 1.5 @@ -26,9 +26,18 @@ ((scroll-type :initarg :scroll-type :accessor event-scroll-type) (value :initarg :value :accessor event-value))) +(defclass menu-clicked-event (gadget-event) + ((item :initarg :item :accessor event-item))) + +(defclass context-menu-clicked-event (gadget-event) + ((value :initarg :value :accessor event-value) + (itemspec :initarg :itemspec :accessor event-itemspec))) + ;;;; Classes +;; gtk-menu-* see port.lisp + (defclass gtk-button (native-widget-mixin push-button) ()) (defclass gtk-check-button (native-widget-mixin toggle-button) ()) @@ -61,6 +70,9 @@ (gtk-widget-modify-bg button (pane-background sheet))) button)) +(defmethod realize-native-widget ((sheet gtk-menu-bar)) + (gtk_menu_bar_new)) + (defmethod realize-native-widget ((sheet gtk-check-button)) (let ((widget (gtk_check_button_new_with_label (climi::gadget-label sheet)))) (gtk_toggle_button_set_active widget (if (gadget-value sheet) 1 0)) @@ -111,6 +123,94 @@ (if (eq sheet (gadget-value (gadget-client sheet))) 1 0)) result)) +(defun append-menu-items (port sheet menu command-table-name) + (let ((ct (find-command-table command-table-name))) + (dolist (menu-item (slot-value ct 'climi::menu)) + (let ((item (make-native-menu-item port sheet menu-item))) + (gtk_menu_shell_append menu item))))) + +(defun make-native-menu-item (port sheet menu-item) + (ecase (command-menu-item-type menu-item) + (:divider + (gtk_separator_menu_item_new)) + (:command + (let ((item + (gtk_menu_item_new_with_label + (climi::command-menu-item-name menu-item)))) + ;; naja, ein sheet ist das nicht + (setf (widget->sheet item port) menu-item) + (connect-signal item "activate" 'menu-clicked-handler) + item)) + (:menu + (let ((item + (gtk_menu_item_new_with_label + (climi::command-menu-item-name menu-item))) + (menu (gtk_menu_new))) + (setf (widget->sheet item port) sheet) + (setf (widget->sheet menu port) sheet) + (append-menu-items port sheet menu (command-menu-item-value menu-item)) + (gtk_menu_item_set_submenu item menu) + item)))) + +(defun destructure-mc-menu-item (x) + (cond + ((atom x) + (values :item x x nil)) + ((atom (cdr x)) + (values :item (car x) (cdr x) nil)) + (t + (destructuring-bind + (&key value style items documentation active type) + (cdr x) + (declare (ignore style documentation active)) + (values (if items :menu type) + (car x) + (or value (car x)) + items))))) + +;;(defclass dummy-context-menu-sheet (climi::clim-sheet-input-mixin sheet) ()) + +(defclass dummy-context-menu-sheet (climi::standard-sheet-input-mixin sheet) + ()) + +(defclass dummy-menu-item-sheet (sheet) + ((parent :initarg :parent :accessor dummy-menu-item-sheet-parent) + (value :initarg :value :accessor dummy-menu-item-sheet-value) + (itemspec :initarg :itemspec :accessor dummy-menu-item-sheet-itemspec))) + +(defun make-context-menu (port sheet items) + (let ((menu (gtk_menu_new))) + (dolist (itemspec items) + (multiple-value-bind (type display-object value sub-items) + (destructure-mc-menu-item itemspec) + (let* ((label (princ-to-string display-object)) + (gtkmenuitem + (ecase type + (:divider + (gtk_separator_menu_item_new)) + (:label + (gtk_menu_item_new_with_label label)) + (:item + (let ((item + (gtk_menu_item_new_with_label label))) + (setf (widget->sheet item port) + (make-instance 'dummy-menu-item-sheet + :parent sheet + :value value + :itemspec itemspec)) + (connect-signal item + "activate" + 'context-menu-clicked-handler) + item)) + (:menu + (let ((item (gtk_menu_item_new_with_label label)) + (menu (make-context-menu port sheet sub-items))) + (gtk_menu_item_set_submenu item menu) + item))))) + (gtk_menu_shell_append menu gtkmenuitem)))) + (gtk_widget_show_all menu) + menu)) + ;;;; Event definition @@ -124,6 +224,10 @@ ;; (connect-signal widget "value-changed" 'magic-clicked-handler) (connect-signal widget "change-value" 'scrollbar-change-value-handler)) +(defmethod connect-native-signals ((sheet gtk-menu-bar) widget) + ;; no signals + ) + ;;;; Event handling @@ -166,6 +270,17 @@ (:page_forward (scroll-down-page-callback pane (gadget-client pane) (gadget-id pane))))) +(defmethod handle-event + ((pane gtk-menu) (event menu-clicked-event)) + (let ((item (event-item event))) + (ecase (command-menu-item-type item) + (:command + (climi::throw-object-ptype item 'menu-item))))) + +(defmethod handle-event + ((pane gtk-nonmenu) (event magic-gadget-event)) + (funcall (gtk-nonmenu-callback pane) pane nil)) + ;;; COMPOSE-SPACE @@ -184,6 +299,10 @@ (unless widgetp (gtk_widget_destroy widget))))) +(defmethod compose-space ((gadget gtk-menu-bar) &key width height) + (declare (ignore width height)) + (make-space-requirement :height 20 :min-height 20 :max-height 20)) + ;;; Vermischtes --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/05/07 14:30:24 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/05/13 19:37:29 1.7 @@ -585,6 +585,46 @@ :pointer (label :string)) +(defcfun "gtk_menu_item_new_with_label" + :pointer + (label :string)) + +(defcfun "gtk_menu_bar_new" + :pointer + ) + +(defcfun "gtk_menu_shell_append" + :void + (menu :pointer) + (item :pointer)) + +(defcfun "gtk_menu_item_set_submenu" + :void + (item :pointer) + (menu :pointer)) + +(defcfun "gtk_menu_new" + :pointer + ) + +(defcfun "gtk_separator_menu_item_new" + :pointer + ) + +(defcfun "gtk_menu_popup" + :void + (menu :pointer) + (parent_menu_shell :pointer) + (parent_menu_item :pointer) + (func :pointer) + (data :pointer) + (button :unsigned-int) + (time :uint32)) + +(defcfun "gtk_get_current_event_time" + :uint32 + ) + (defcfun "gtk_button_set_label" :void (button :pointer) @@ -794,7 +834,7 @@ ;;; foo (defun test (&optional (port :gtkairo)) - (mapc #'climi::destroy-port climi::*all-ports*) +;;; (mapc #'climi::destroy-port climi::*all-ports*) (setf climi::*server-path-search-order* (list port)) (clim:run-frame-top-level (clim:make-application-frame 'clim-demo::address-book))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/05/01 21:21:39 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/05/13 19:37:29 1.7 @@ -33,7 +33,7 @@ ((port :initarg :port :accessor port) (cr :initform nil :initarg :cr :accessor cr) (flipping-original-cr :initform nil :accessor flipping-original-cr) - (flipping-pixmap :accessor flipping-pixmap) + (flipping-pixmap :initform nil :accessor flipping-pixmap) (surface :initarg :surface :accessor surface) (last-seen-sheet :accessor last-seen-sheet) (last-seen-region :accessor last-seen-region))) @@ -46,12 +46,6 @@ (defclass metrik-medium (gtkairo-medium) ()) -;; FIXME: turn this back on. -;; -;; Disabling antialiasing hides some visual artifacts. Some other -;; artifacts remain around lines that are blurry with antialiasing -;; enabled, which perhaps points to round-off error being the reason for -;; both blurryness and visual artifacts. Both need to be fixed. (defparameter *antialiasingp* t) (defun gtkwidget-gdkwindow (widget) @@ -86,11 +80,17 @@ (let* ((mirror (medium-mirror medium)) (drawable (mirror-drawable mirror))) (setf (cr medium) (gdk_cairo_create drawable)) - (push medium (mirror-mediums mirror)) + (dispose-flipping-pixmap medium) + (pushnew medium (mirror-mediums mirror)) (cairo_set_antialias (cr medium) (if *antialiasingp* 0 1))) (setf (last-seen-sheet medium) (medium-sheet medium)) (setf (last-seen-region medium) (sheet-region (medium-sheet medium)))))) +(defun dispose-flipping-pixmap (medium) + (when (flipping-pixmap medium) + (gdk_drawable_unref (flipping-pixmap medium)) + (setf (flipping-pixmap medium) nil))) + ;;;; ------------------------------------------------------------------------ ;;;; 8.3 Output Protocol @@ -215,20 +215,19 @@ (to-drawable (medium-gdkdrawable medium))) (cairo_surface_flush from-surface) (cairo_surface_flush to-surface) - (let ((gc (gdk_gc_new to-drawable))) + (let ((gc (gdk_gc_new to-drawable)) + (region (climi::sheet-mirror-region (medium-sheet medium)))) (gdk_gc_set_function gc :xor) - (cffi:with-foreign-slots ((allocation-width allocation-height) - (mirror-widget (medium-mirror medium)) - gtkwidget) - (gdk_draw_drawable to-drawable gc from-drawable 0 0 0 0 - allocation-width allocation-height)) + (gdk_draw_drawable to-drawable gc from-drawable 0 0 0 0 + (floor (bounding-rectangle-max-x region)) + (floor (bounding-rectangle-max-y region))) (gdk_gc_unref gc)) (cairo_surface_mark_dirty to-surface)) (cairo_destroy (cr medium)) (setf (cr medium) (flipping-original-cr medium)) (setf (flipping-original-cr medium) nil) - (gdk_drawable_unref (flipping-pixmap medium)) - (setf (flipping-pixmap medium) nil)) + #+(or win32 mswindows windows) ;fixme + (dispose-flipping-pixmap medium)) (defmethod sync-ink (medium (design climi::standard-flipping-ink)) (setf (flipping-original-cr medium) (cr medium)) @@ -237,11 +236,15 @@ (cffi:with-foreign-slots ((allocation-width allocation-height) (mirror-widget mirror) gtkwidget) - (let ((pixmap - (gdk_pixmap_new drawable allocation-width allocation-height -1))) + (let* ((region (climi::sheet-mirror-region (medium-sheet medium))) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region))) + (pixmap + (or (flipping-pixmap medium) + (setf (flipping-pixmap medium) + (gdk_pixmap_new drawable width height -1))))) (setf (cr medium) (gdk_cairo_create pixmap)) (cairo_paint (cr medium)) - (setf (flipping-pixmap medium) pixmap) (sync-transformation medium) (sync-ink medium +white+))))) @@ -348,6 +351,11 @@ ;;; text-style +(defun assert-font-status (cr str) + (let ((status (cairo_font_face_status (cairo_get_font_face cr)))) + (unless (eq status :success) + (error "status ~A after call to ~A" status str)))) + (defun sync-text-style (medium text-style transform-glyphs-p) (with-slots (cr) medium (multiple-value-bind (family face size) @@ -386,6 +394,7 @@ ((:bold :bold-italic :italic-bold :bold-oblique :oblique-bold) :bold))) + (assert-font-status cr "cairo_select_font_face") ;; (cond (transform-glyphs-p (cairo_set_font_size cr (df size))) @@ -403,7 +412,8 @@ ;;; (cairo_matrix_invert matrix) ;;; (cairo_transform_font cr matrix) ;;; )) - ))))) + )) + (assert-font-status cr "cairo_set_font_size")))) (defun sync-drawing-options (medium) (sync-transformation medium) @@ -609,21 +619,19 @@ (medium-default-text-style medium)) transform-glyphs) (cairo_move_to cr (df x) (df y)) - (cairo_show_text cr (subseq text start end)) ))) + (setf end (or end (length text))) + (unless (eql start end) ;empty string breaks cairo/windows + (cairo_show_text cr (subseq text start end)))))) (defmethod medium-finish-output ((medium gtkairo-medium)) (with-cairo-medium (medium) (when (cr medium) - (cairo_surface_flush (cairo_get_target (cr medium))) -;;; (port-force-output (port medium)) - ))) + (cairo_surface_flush (cairo_get_target (cr medium)))))) (defmethod medium-force-output ((medium gtkairo-medium)) (with-cairo-medium (medium) (when (cr medium) - (cairo_surface_flush (cairo_get_target (cr medium))) -;;; (port-force-output (port medium)) - ))) + (cairo_surface_flush (cairo_get_target (cr medium)))))) (defmethod medium-beep ((medium gtkairo-medium)) ;; fixme: visual beep? @@ -642,6 +650,20 @@ (defmacro slot (o c s) `(cffi:foreign-slot-value ,o ,c ,s)) +(defun cairo-text-extents (cr str res) + (cond + #+(or win32 mswindows windows) ;empty string breaks cairo/windows + ((string= str "") + (setf str " ") + (cairo_text_extents cr str res) + (cffi:with-foreign-slots + ((width x_advance x_bearing) res cairo_text_extents) + (setf width 0.0d0) + (setf x_advance 0.0d0) + (setf x_bearing 0.0d0))) + (t + (cairo_text_extents cr str res)))) + ;;; TEXT-STYLE-ASCENT @@ -777,9 +799,9 @@ (sync-text-style medium text-style t) (cffi:with-foreign-object (res 'cairo_text_extents) (let (i m) - (cairo_text_extents cr "i" res) + (cairo-text-extents cr "i" res) (setf i (slot res 'cairo_text_extents 'width)) - (cairo_text_extents cr "m" res) + (cairo-text-extents cr "m" res) (setf m (slot res 'cairo_text_extents 'width)) (= i m)))))) @@ -829,7 +851,7 @@ (cairo_identity_matrix cr) (sync-text-style medium text-style t) (cffi:with-foreign-object (res 'cairo_text_extents) - (cairo_text_extents cr + (cairo-text-extents cr (subseq string start (or end (length string))) res) (cffi:with-foreign-slots @@ -859,7 +881,7 @@ (cairo_identity_matrix cr) (sync-text-style medium text-style t) (cffi:with-foreign-object (res 'cairo_text_extents) - (cairo_text_extents cr + (cairo-text-extents cr (subseq string start (or end (length string))) res) ;; This used to be a straight call to TEXT-SIZE. Looking at @@ -965,11 +987,12 @@ (draw-rectangle* medium 0 0 600 600 :ink design))) ;; FIXME: this is some kind of special-purpose function for mediums -;; that aren't intended to be used again. Normal mediums are handled -;; by DESTROY-MEDIUMS. +;; created by MAKE-CAIRO-SURFACE. Normal mediums are handled by +;; DESTROY-MEDIUMS. (defun destroy-cairo-medium (medium) (cairo_destroy (cr medium)) (setf (cr medium) :destroyed) + (dispose-flipping-pixmap medium) (when (surface medium) (cairo_surface_destroy (surface medium)))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/05/07 19:47:20 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/05/13 19:37:29 1.4 @@ -240,6 +240,22 @@ (defclass native-widget-mixin () ((widget :initform nil :accessor native-widget))) +(defclass gtk-menu (basic-pane) + ((label :initarg :label :accessor gtk-menu-label) + (command-table :initform nil + :initarg :command-table + :accessor gtk-menu-command-table))) + +(defclass gtk-nonmenu (basic-pane) + ((label :initarg :label :accessor gtk-nonmenu-label) + (callback :initarg :value-changed-callback + :accessor gtk-nonmenu-callback))) + +(defclass gtk-menu-bar (native-widget-mixin + sheet-multiple-child-mixin + basic-pane) + ((contents :initarg :contents :accessor gtk-menu-bar-contents))) + (defmethod realize-mirror ((port gtkairo-port) (sheet native-widget-mixin)) (with-gtk () (setf (native-widget sheet) (realize-native-widget sheet)) @@ -268,6 +284,51 @@ (gtk_widget_show_all fixed)) mirror))) +(defclass menu-mirror (widget-mirror) + ((menu-item :initarg :menu-item :reader mirror-menu-item) + (menu :initarg :menu :reader mirror-menu))) + +(defclass nonmenu-mirror (widget-mirror) + ((menu-item :initarg :menu-item :reader mirror-menu-item))) + +(defmethod realize-mirror :after ((port gtkairo-port) (sheet gtk-menu-bar)) + (dolist (menu (gtk-menu-bar-contents sheet)) + (unless (integerp menu) ;? + (sheet-adopt-child sheet menu)))) + +(defmethod realize-mirror ((port gtkairo-port) (sheet gtk-menu)) + (unless (climi::port-lookup-mirror port sheet) + (with-gtk () + (let* ((menu-item (gtk_menu_item_new_with_label (gtk-menu-label sheet))) + (menu (gtk_menu_new)) + (parent (sheet-mirror (sheet-parent sheet))) + (mirror + (make-instance 'menu-mirror :menu menu :menu-item menu-item))) + (setf (widget->sheet menu-item port) sheet) + (setf (widget->sheet menu port) sheet) + (append-menu-items port sheet menu (gtk-menu-command-table sheet)) + (gtk_menu_item_set_submenu menu-item menu) + (gtk_menu_shell_append (mirror-widget parent) menu-item) + (climi::port-register-mirror (port sheet) sheet mirror) + (when (sheet-enabled-p sheet) + (gtk_widget_show_all menu-item)) + mirror)))) + +(defmethod realize-mirror ((port gtkairo-port) (sheet gtk-nonmenu)) + (unless (climi::port-lookup-mirror port sheet) + (with-gtk () + (let* ((menu-item + (gtk_menu_item_new_with_label (gtk-nonmenu-label sheet))) + (parent (sheet-mirror (sheet-parent sheet))) + (mirror (make-instance 'nonmenu-mirror :menu-item menu-item))) + (setf (widget->sheet menu-item port) sheet) + (connect-signal menu-item "activate" 'magic-clicked-handler) + (gtk_menu_shell_append (mirror-widget parent) menu-item) + (climi::port-register-mirror (port sheet) sheet mirror) + (when (sheet-enabled-p sheet) + (gtk_widget_show_all menu-item)) + mirror)))) + (defmethod realize-mirror ((port gtkairo-port) (pixmap-sheet climi::pixmap)) (unless (climi::port-lookup-mirror port pixmap-sheet) (let* ((drawable @@ -298,7 +359,8 @@ (dolist (medium (mirror-mediums mirror)) (when (cr medium) (cairo_destroy (cr medium)) - (setf (cr medium) nil))) + (setf (cr medium) nil) + (dispose-flipping-pixmap medium))) (setf (mirror-mediums mirror) '())) (defmethod destroy-mirror @@ -329,6 +391,18 @@ (gdk_drawable_unref (mirror-drawable mirror)) (climi::port-unregister-mirror port pixmap-sheet mirror))))) +(defmethod destroy-mirror ((port gtkairo-port) (pixmap-sheet gtk-menu)) + (with-gtk () + (let ((mirror (climi::port-lookup-mirror port pixmap-sheet))) + (when mirror + (climi::port-unregister-mirror port pixmap-sheet mirror))))) + +(defmethod destroy-mirror ((port gtkairo-port) (pixmap-sheet gtk-nonmenu)) + (with-gtk () + (let ((mirror (climi::port-lookup-mirror port pixmap-sheet))) + (when mirror + (climi::port-unregister-mirror port pixmap-sheet mirror))))) + ;;;; Positioning and resizing From rgoldman at common-lisp.net Thu May 25 19:23:22 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Thu, 25 May 2006 15:23:22 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20060525192322.8BC3A4507E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv21551 Added Files: freetype-cffi.lisp freetype-fonts-cffi.lisp freetype-package-cffi.lisp mcclim-freetype-cffi.asd Log Message: First shot at a CFFI-based freetype to replace sbcl/cmucl-specific original. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-cffi.lisp 2006/05/25 19:23:22 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-cffi.lisp 2006/05/25 19:23:22 1.1 ;;; automatically generated, hand tweaked, do not regenerate. (in-package :freetype) (define-foreign-library libfreetype (:unix (:or "libfreetype.so.6" "libfreetype")) (t (:default "libfreetype"))) (use-foreign-library libfreetype) (defmacro define-alien-type (&rest rest) ;; cffi seems to have a much simpler model of pointer ;; types... [2006/05/23:rpg] (cond ((and (= (length rest) 2) (eq (car (second rest)) '*)) `(defctype ,(first rest) :pointer)) ((error "Don't understand how to translate alien type definition ~S" `(define-alien-type , at rest))))) (defmacro define-alien-routine (name retval &rest args) `(defcfun ,name ,retval ,@(loop for (name type) in args for new-type = (if (and (listp type) (eq (car type) '*)) :pointer type) collect (list name new-type)))) (defmacro defcstruct (name &rest slots) `(cffi:defcstruct ,name ,@(loop for (name type) in slots for new-type = (if (and (listp type) (eq (car type) '*)) :pointer type) collect (list name new-type)))) (declaim (optimize (speed 3))) (define-alien-type freetype:memory (* (struct freetype::memory-rec-))) (define-alien-type freetype:stream (* (struct freetype::stream-rec-))) (define-alien-type freetype:raster (* (struct freetype::raster-rec-))) (define-alien-type freetype:list-node (* (struct freetype::list-node-rec-))) (define-alien-type freetype:list (* (struct freetype::list-rec-))) (define-alien-type freetype:library (* (struct freetype::library-rec-))) (define-alien-type freetype:module (* (struct freetype::module-rec-))) (define-alien-type freetype:driver (* (struct freetype::driver-rec-))) (define-alien-type freetype:renderer (* (struct freetype::renderer-rec-))) (define-alien-type freetype:char-map (* (struct freetype::char-map-rec-))) (define-alien-type freetype:face-internal (* (struct freetype::face-internal-rec-))) (define-alien-type freetype:slot-internal (* (struct freetype::slot-internal-rec-))) (define-alien-type freetype:size-internal (* (struct freetype::size-internal-rec-))) (defctype freetype:int16 :int16) (defctype freetype:uint16 :uint16) (defctype freetype:int32 :int32) (defctype freetype:uint32 :uint32) (defctype freetype:fast :int32) (defctype freetype:ufast :uint32) (defctype freetype:ptrdiff-t :int32) (defctype freetype:size-t :uint32) (defctype freetype:wchar-t :int32) (defctype freetype:wint-t :uint32) (defctype freetype:bool :uint8) (defctype freetype:fword :int16) (defctype freetype:ufword :uint16) (defctype freetype:char :int8) (defctype freetype:byte :uint8) (defctype freetype:string :int8) (defctype freetype:short :int16) (defctype freetype:ushort :uint16) (defctype freetype:int :int32) (defctype freetype:uint :uint32) (defctype freetype:long :long) (defctype freetype:ulong :unsigned-long) (defctype freetype:f2dot14 :int16) (defctype freetype:f26dot6 :long) (defctype freetype:fixed :long) (defctype freetype:error :int32) (defctype freetype:pointer :pointer) (defctype freetype:offset freetype:size-t) (defctype freetype:ptr-dist freetype:size-t) (define-alien-type freetype:face (* freetype:face-rec)) (defcenum mod-err (:mod-err-base #.#x000) (:mod-err-autohint #.#x100) (:mod-err-cache #.#x200) (:mod-err-cff #.#x300) (:mod-err-cid #.#x400) (:mod-err-pcf #.#x500) (:mod-err-psaux #.#x600) (:mod-err-psnames #.#x700) (:mod-err-raster #.#x800) (:mod-err-sfnt #.#x900) (:mod-err-smooth #.#xA00) (:mod-err-true-type #.#xB00) (:mod-err-type1 #.#xC00) (:mod-err-winfonts #.#xD00) :mod-err-max) (defcenum error-enum (:err-ok #.#x00) (:err-cannot-open-resource #.(+ #x01 0)) (:err-unknown-file-format #.(+ #x02 0)) (:err-invalid-file-format #.(+ #x03 0)) (:err-invalid-version #.(+ #x04 0)) (:err-lower-module-version #.(+ #x05 0)) (:err-invalid-argument #.(+ #x06 0)) (:err-unimplemented-feature #.(+ #x07 0)) (:err-invalid-glyph-index #.(+ #x10 0)) (:err-invalid-character-code #.(+ #x11 0)) (:err-invalid-glyph-format #.(+ #x12 0)) (:err-cannot-render-glyph #.(+ #x13 0)) (:err-invalid-outline #.(+ #x14 0)) (:err-invalid-composite #.(+ #x15 0)) (:err-too-many-hints #.(+ #x16 0)) (:err-invalid-pixel-size #.(+ #x17 0)) (:err-invalid-handle #.(+ #x20 0)) (:err-invalid-library-handle #.(+ #x21 0)) (:err-invalid-driver-handle #.(+ #x22 0)) (:err-invalid-face-handle #.(+ #x23 0)) (:err-invalid-size-handle #.(+ #x24 0)) (:err-invalid-slot-handle #.(+ #x25 0)) (:err-invalid-char-map-handle #.(+ #x26 0)) (:err-invalid-cache-handle #.(+ #x27 0)) (:err-invalid-stream-handle #.(+ #x28 0)) (:err-too-many-drivers #.(+ #x30 0)) (:err-too-many-extensions #.(+ #x31 0)) (:err-out-of-memory #.(+ #x40 0)) (:err-unlisted-object #.(+ #x41 0)) (:err-cannot-open-stream #.(+ #x51 0)) (:err-invalid-stream-seek #.(+ #x52 0)) (:err-invalid-stream-skip #.(+ #x53 0)) (:err-invalid-stream-read #.(+ #x54 0)) (:err-invalid-stream-operation #.(+ #x55 0)) (:err-invalid-frame-operation #.(+ #x56 0)) (:err-nested-frame-access #.(+ #x57 0)) (:err-invalid-frame-read #.(+ #x58 0)) (:err-raster-uninitialized #.(+ #x60 0)) (:err-raster-corrupted #.(+ #x61 0)) (:err-raster-overflow #.(+ #x62 0)) (:err-raster-negative-height #.(+ #x63 0)) (:err-too-many-caches #.(+ #x70 0)) (:err-invalid-opcode #.(+ #x80 0)) (:err-too-few-arguments #.(+ #x81 0)) (:err-stack-overflow #.(+ #x82 0)) (:err-code-overflow #.(+ #x83 0)) (:err-bad-argument #.(+ #x84 0)) (:err-divide-by-zero #.(+ #x85 0)) (:err-invalid-reference #.(+ #x86 0)) (:err-debug-op-code #.(+ #x87 0)) (:err-endf-in-exec-stream #.(+ #x88 0)) (:err-nested-defs #.(+ #x89 0)) (:err-invalid-code-range #.(+ #x8A 0)) (:err-execution-too-long #.(+ #x8B 0)) (:err-too-many-function-defs #.(+ #x8C 0)) (:err-too-many-instruction-defs #.(+ #x8D 0)) (:err-table-missing #.(+ #x8E 0)) (:err-horiz-header-missing #.(+ #x8F 0)) (:err-locations-missing #.(+ #x90 0)) (:err-name-table-missing #.(+ #x91 0)) (:err-cmap-table-missing #.(+ #x92 0)) (:err-hmtx-table-missing #.(+ #x93 0)) (:err-post-table-missing #.(+ #x94 0)) (:err-invalid-horiz-metrics #.(+ #x95 0)) (:err-invalid-char-map-format #.(+ #x96 0)) (:err-invalid-ppem #.(+ #x97 0)) (:err-invalid-vert-metrics #.(+ #x98 0)) (:err-could-not-find-context #.(+ #x99 0)) (:err-invalid-post-table-format #.(+ #x9A 0)) (:err-invalid-post-table #.(+ #x9B 0)) (:err-syntax-error #.(+ #xA0 0)) (:err-stack-underflow #.(+ #xA1 0)) :err-max) (defctype freetype:alloc-func :pointer) (defctype freetype:free-func :pointer) (defctype freetype:realloc-func :pointer) (defcstruct freetype::memory-rec- (freetype:user :pointer) (freetype:alloc freetype:alloc-func) (freetype:free freetype:free-func) (freetype:realloc freetype:realloc-func)) (defcunion freetype:stream-desc (freetype:value :long) (freetype:pointer :pointer)) (defctype freetype:stream-io :pointer) (defctype freetype:stream-close :pointer) (defcstruct freetype::stream-rec- (freetype:base (* :uint8)) (freetype:size freetype:ulong) (freetype:pos freetype:ulong) (freetype:descriptor freetype:stream-desc) (freetype:pathname freetype:stream-desc) (freetype:read freetype:stream-io) (freetype:close freetype:stream-close) (freetype:memory freetype:memory) (freetype:cursor (* :uint8)) (freetype:limit (* :uint8))) (defctype freetype:pos :long) (defcstruct freetype:vector (freetype:x freetype:pos) (freetype:y freetype:pos)) (defcstruct freetype:bbox (freetype:x-min freetype:pos) (freetype:y-min freetype:pos) (freetype:x-max freetype:pos) (freetype:y-max freetype:pos)) ;; seems like pixel-mode- might possibly be an alias for this... (defcenum freetype:pixel-mode (:ft-pixel-mode-none #.#o0) :ft-pixel-mode-mono :ft-pixel-mode-grays :ft-pixel-mode-pal2 :ft-pixel-mode-pal4 :ft-pixel-mode-pal8 :ft-pixel-mode-rgb15 :ft-pixel-mode-rgb16 :ft-pixel-mode-rgb24 :ft-pixel-mode-rgb32 :ft-pixel-mode-max) ;;; palette-mode- (defcenum freetype:palette-mode (:ft-palette-mode-rgb #.#o0) :ft-palette-mode-rgba :ft-palettte-mode-max) (defcstruct freetype:bitmap (freetype:rows :int32) (freetype:width :int32) (freetype:pitch :int32) (freetype:buffer (* :uint8)) (freetype:num-grays :int16) (freetype:pixel-mode :int8) (freetype:palette-mode :int8) (freetype:palette :pointer)) (defcstruct freetype:outline (freetype:n-contours :int16) (freetype:n-points :int16) (freetype:points (* freetype:vector)) (freetype:tags (* :int8)) (freetype:contours (* :int16)) (freetype:flags :int32)) (defcenum freetype:outline-flags (:ft-outline-none #.#o0) (:ft-outline-owner #.1) (:ft-outline-even-odd-fill #.2) (:ft-outline-reverse-fill #.4) (:ft-outline-ignore-dropouts #.8) (:ft-outline-high-precision #.256) (:ft-outline-single-pass #.512)) (defctype freetype:outline-move-to-func :pointer) (defctype freetype:outline-line-to-func :pointer) (defctype freetype:outline-conic-to-func :pointer) (defctype freetype:outline-cubic-to-func :pointer) (defcstruct freetype:outline-funcs (freetype:move-to freetype:outline-move-to-func) (freetype:line-to freetype:outline-line-to-func) (freetype:conic-to freetype:outline-conic-to-func) (freetype:cubic-to freetype:outline-cubic-to-func) (freetype:shift :int32) (freetype:delta freetype:pos)) (defcenum freetype:glyph-format (:ft-glyph-format-none #.(logior (logior (logior (ash #o0 24) (ash #o0 16)) (ash #o0 8)) #o0)) (:ft-glyph-format-composite #.(logior (logior (logior (ash #.(char-code #\c) 24) (ash #.(char-code #\o) 16)) (ash #.(char-code #\m) 8)) #.(char-code #\p))) (:ft-glyph-format-bitmap #.(logior (logior (logior (ash #.(char-code #\b) 24) (ash #.(char-code #\i) 16)) (ash #.(char-code #\t) 8)) #.(char-code #\s))) (:ft-glyph-format-outline #.(logior (logior (logior (ash #.(char-code #\o) 24) (ash #.(char-code #\u) 16)) (ash #.(char-code #\t) 8)) #.(char-code #\l))) (:ft-glyph-format-plotter #.(logior (logior (logior (ash #.(char-code #\p) 24) (ash #.(char-code #\l) 16)) (ash #.(char-code #\o) 8)) #.(char-code #\t)))) (defcstruct freetype:span (freetype:x :int16) (freetype:len :uint16) (freetype:coverage :uint8)) (defctype freetype:raster-span-func :pointer) (defctype freetype:raster-bit-test-func :pointer) (defctype freetype:raster-bit-set-func :pointer) (defcenum freetype:raster-flag (:ft-raster-flag-default #.#o0) (:ft-raster-flag-aa #.1) (:ft-raster-flag-direct #.2) (:ft-raster-flag-clip #.4)) (defcstruct freetype:raster-params (freetype:target (* freetype:bitmap)) (freetype:source :pointer) (freetype:flags :int32) (freetype:gray-spans freetype:raster-span-func) (freetype:black-spans freetype:raster-span-func) (freetype:bit-test freetype:raster-bit-test-func) (freetype:bit-set freetype:raster-bit-set-func) (freetype:user :pointer) (freetype:clip-box freetype:bbox)) (defctype freetype:raster-new-func :pointer) (defctype freetype:raster-done-func :pointer) (defctype freetype:raster-reset-func :pointer) (defctype freetype:raster-set-mode-func :pointer) (defctype freetype:raster-render-func :pointer) (defcstruct freetype:raster-funcs (freetype:glyph-format freetype:glyph-format) (freetype:raster-new freetype:raster-new-func) (freetype:raster-reset freetype:raster-reset-func) (freetype:raster-set-mode freetype:raster-set-mode-func) (freetype:raster-render freetype:raster-render-func) (freetype:raster-done freetype:raster-done-func)) (defcstruct freetype:unit-vector (freetype:x freetype:f2dot14) (freetype:y freetype:f2dot14)) (defcstruct freetype:matrix (freetype:xx freetype:fixed) (freetype:xy freetype:fixed) (freetype:yx freetype:fixed) (freetype:yy freetype:fixed)) (defctype freetype:generic-finalizer :pointer) (defcstruct freetype:generic (freetype:data :pointer) (freetype:finalizer freetype:generic-finalizer)) (defcstruct freetype:list-node-rec (freetype:prev freetype:list-node) (freetype:next freetype:list-node) (freetype:data :pointer)) (defcstruct freetype:list-rec (freetype:head freetype:list-node) (freetype:tail freetype:list-node)) (defcstruct freetype:glyph-metrics (freetype:width freetype:pos) (freetype:height freetype:pos) (freetype:hori-bearing-x freetype:pos) (freetype:hori-bearing-y freetype:pos) (freetype:hori-advance freetype:pos) (freetype:vert-bearing-x freetype:pos) (freetype:vert-bearing-y freetype:pos) (freetype:vert-advance freetype:pos)) (defcstruct freetype:bitmap-size (freetype:height freetype:short) (freetype:width freetype:short)) (defctype freetype:sub-glyph :pointer) ;; (struct freetype::sub-glyph-)) (defcstruct freetype:glyph-slot-rec (freetype:library freetype:library) (freetype:face (* (struct freetype::face-rec-))) (freetype:next (* (struct freetype::glyph-slot-rec-))) (freetype:flags freetype:uint) (freetype:generic freetype:generic) (freetype:metrics freetype:glyph-metrics) (freetype:linear-hori-advance freetype:fixed) (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) (freetype:control-data :pointer) (freetype:control-len :long) (freetype:other :pointer) (freetype:internal freetype:slot-internal)) (defcstruct freetype:size-metrics (freetype:x-ppem freetype:ushort) (freetype:y-ppem freetype:ushort) (freetype:x-scale freetype:fixed) (freetype:y-scale freetype:fixed) (freetype:ascender freetype:pos) (freetype:descender freetype:pos) (freetype:height freetype:pos) (freetype:max-advance freetype:pos)) (defcstruct freetype:size-rec (freetype:face (* (struct freetype::face-rec-))) (freetype:generic freetype:generic) (freetype:metrics freetype:size-metrics) (freetype:internal freetype:size-internal)) (defcstruct freetype:face-rec (freetype:num-faces freetype:long) (freetype:face-index freetype:long) (freetype:face-flags freetype:long) (freetype:style-flags freetype:long) (freetype:num-glyphs freetype:long) (freetype:family-name (* freetype:string)) (freetype:style-name (* freetype:string)) (freetype:num-fixed-sizes freetype:int) (freetype:available-sizes (* freetype:bitmap-size)) (freetype:num-charmaps freetype:int) (freetype:charmaps (* freetype:char-map)) (freetype:generic freetype:generic) (freetype:bbox freetype:bbox) (freetype:units-per-em freetype:ushort) (freetype:ascender freetype:short) (freetype:descender freetype:short) (freetype:height freetype:short) (freetype:max-advance-width freetype:short) (freetype:max-advance-height freetype:short) (freetype:underline-position freetype:short) (freetype:underline-thickness freetype:short) (freetype:glyph (* (struct freetype::glyph-slot-rec-))) (freetype:size_s (* (struct freetype:size-rec))) (freetype:charmap freetype:char-map) (freetype:driver freetype:driver) (freetype:memory freetype:memory) (freetype:stream freetype:stream) (freetype:sizes-list freetype:list-rec) (freetype:autohint freetype:generic) (freetype:extensions :pointer) (freetype:internal freetype:face-internal)) (defcstruct freetype:size-rec (freetype:face (* freetype:face-rec)) (freetype:generic freetype:generic) (freetype:metrics freetype:size-metrics) (freetype:internal freetype:size-internal)) (defcstruct freetype:glyph-slot-rec (freetype:library freetype:library) (freetype:face (* freetype:face-rec)) (freetype:next (* (struct freetype::glyph-slot-rec-))) (freetype:flags freetype:uint) (freetype:generic freetype:generic) (freetype:metrics freetype:glyph-metrics) (freetype:linear-hori-advance freetype:fixed) (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) (freetype:control-data :pointer) (freetype:control-len :long) (freetype:other :pointer) (freetype:internal freetype:slot-internal)) (define-alien-type freetype:glyph-slot (* freetype:glyph-slot-rec)) (define-alien-type freetype:size (* freetype:size-rec)) (define-alien-routine ("FT_Init_FreeType" freetype:init-free-type) freetype:error (freetype::alibrary (* freetype:library))) (define-alien-routine ("FT_Done_FreeType" freetype:done-free-type) freetype:error (freetype:library freetype:library)) (defcenum freetype:open-flags (:ft-open-memory #.1) (:ft-open-stream #.2) (:ft-open-pathname #.4) (:ft-open-driver #.8) (:ft-open-params #.16)) (defcstruct freetype:parameter (freetype:tag freetype:ulong) (freetype:data freetype:pointer)) (defcstruct freetype:open-args (freetype:flags freetype:open-flags) (freetype:memory-base (* freetype:byte)) (freetype:memory-size freetype:long) (freetype:pathname (* freetype:string)) (freetype:stream freetype:stream) (freetype:driver freetype:module) (freetype:num-params freetype:int) (freetype:params (* freetype:parameter))) (define-alien-routine ("FT_New_Face" freetype:new-face) freetype:error (freetype:library freetype:library) (freetype::filepathname :string) (freetype::face_index freetype:long) ;; this is a pointer to a pointer to a face-rec... (freetype::aface (* (* freetype:face-rec)))) (define-alien-routine ("FT_New_Memory_Face" freetype:new-memory-face) freetype:error (freetype:library freetype:library) (freetype::file_base (* freetype:byte)) (freetype::file_size freetype:long) (freetype::face_index freetype:long) (freetype::aface (* freetype:face))) (define-alien-routine ("FT_Open_Face" freetype:open-face) freetype:error (freetype:library freetype:library) (freetype::args (* freetype:open-args)) (freetype::face_index freetype:long) (freetype::aface (* freetype:face))) (define-alien-routine ("FT_Attach_File" freetype:attach-file) freetype:error (freetype:face freetype:face) (freetype::filepathname (* :int8))) (define-alien-routine ("FT_Attach_Stream" freetype:attach-stream) freetype:error (freetype:face freetype:face) (freetype::parameters (* freetype:open-args))) (define-alien-routine ("FT_Done_Face" freetype:done-face) freetype:error (freetype:face freetype:face)) (define-alien-routine ("FT_Set_Char_Size" freetype:set-char-size) freetype:error (freetype:face freetype:face) (freetype::char_width freetype:f26dot6) (freetype::char_height freetype:f26dot6) (freetype::horz_resolution freetype:uint) (freetype::vert_resolution freetype:uint)) (define-alien-routine ("FT_Set_Pixel_Sizes" freetype:set-pixel-sizes) freetype:error (freetype:face freetype:face) (freetype::pixel_width freetype:uint) (freetype::pixel_height freetype:uint)) (define-alien-routine ("FT_Load_Glyph" freetype:load-glyph) freetype:error (freetype:face freetype:face) (freetype::glyph_index freetype:uint) (freetype::load_flags freetype:int)) [90 lines skipped] --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts-cffi.lisp 2006/05/25 19:23:22 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts-cffi.lisp 2006/05/25 19:23:22 1.1 [725 lines skipped] --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-package-cffi.lisp 2006/05/25 19:23:22 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-package-cffi.lisp 2006/05/25 19:23:22 1.1 [807 lines skipped] --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype-cffi.asd 2006/05/25 19:23:22 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype-cffi.asd 2006/05/25 19:23:22 1.1 [893 lines skipped] From rgoldman at common-lisp.net Thu May 25 22:44:16 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Thu, 25 May 2006 18:44:16 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20060525224416.736A57D003@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv12504 Modified Files: mcclim-freetype-cffi.asd Log Message: modified font-finding for ACL and added cl-user variable to set it. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype-cffi.asd 2006/05/25 19:23:22 1.1 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype-cffi.asd 2006/05/25 22:44:16 1.2 @@ -47,6 +47,9 @@ ;;; Freetype autodetection (defun parse-fontconfig-output (s) + (when (stringp s) + (setf s + (make-string-input-stream s))) (let* ((match-string (concatenate 'string (string #\Tab) "file:")) (matching-line (loop for l = (read-line s nil nil) @@ -68,19 +71,53 @@ don't have them, get them from http://www.gnome.org/fonts/~%~%~%")) #+sbcl -(defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) +(defun find-bitstream-fonts () (let ((fc-match (sb-ext:find-executable-in-search-path "fc-match"))) (if (null fc-match) - (warn-about-unset-font-path) - (let* ((process (sb-ext:run-program fc-match `("-v" "Bitstream Vera") - :output :stream - :input nil)) - (font-path (parse-fontconfig-output (sb-ext:process-output process)))) - (if (null font-path) - (warn-about-unset-font-path) - (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) - font-path)))))) + nil + (let* ((process (sb-ext:run-program fc-match `("-v" "Bitstream Vera") + :output :stream + :input nil)) + (font-path (parse-fontconfig-output (sb-ext:process-output process)))) + font-path)))) + +#+allegro +(defun find-bitstream-fonts () + (let* ((fc-match (excl.osi:find-in-path "fc-match")) + (command (format nil "~A -v Bitstream Vera" fc-match))) + (if (null fc-match) + nil + (multiple-value-bind (output error-output exit-code) + (excl.osi:command-output + command + :whole t) + (if (not (= exit-code 0)) + (progn + (format t "~&Tried to autoset font path, but was unable to find Bitstream Vera fonts.~%~T~A error output was ~%~T~T~A~%" + command error-output) + nil) + (let ((font-path (parse-fontconfig-output output))) + (if (null font-path) + (progn + (format t "~&Tried to autoset font path, using command:~%~T~A~%~Tbut was unable to find Bitstream Vera fonts.~%" + command) + nil) + font-path))))))) + +;;;#-(or sbcl allegro) +;;;(defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) +;;; (warn-about-unset-font-path)) + +(defvar cl-user::*mcclim-freetype-font-path* nil + "Set this variable to tell mcclim-freetype where to find the bitstream +Vera fonts (instead of having it look for them.") -#-sbcl (defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) - (warn-about-unset-font-path)) + (let (font-path) + (cond (cl-user::*mcclim-freetype-font-path* + (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) + cl-user::*mcclim-freetype-font-path*)) + ((setf font-path (find-bitstream-fonts)) + (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) + font-path)) + (t (warn-about-unset-font-path))))) From crhodes at common-lisp.net Sun May 28 21:32:44 2006 From: crhodes at common-lisp.net (crhodes) Date: Sun, 28 May 2006 17:32:44 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060528213244.16EA41C006@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv1106 Modified Files: incremental-redisplay.lisp recording.lisp Log Message: Rework displayed-output-records. Instead of setting the medium graphics state, use with-drawing-options in :around methods (which resets the graphics state after replaying an output record, which allows the CLIM user to implement their own output record classes). Note the potential for changes in incremental-redisplay, as there's no need to capture the entire medium state, just the stream cursor position. (Fixes horizontal partial beams in gsharp) --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/05/05 10:24:02 1.63 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/05/28 21:32:43 1.64 @@ -307,6 +307,12 @@ (loop for (r) in move-overlapping do (setf res (region-union res r))) (replay history stream res)))) +;;; FIXME: although this inherits from COMPLETE-MEDIUM-STATE, in fact +;;; it needn't, as we only ever call SET-MEDIUM-CURSOR-POSITION on it. +;;; Until 2006-05-28, we did also use the various medium attributes, +;;; but with the reworking of REPLAY-OUTPUT-RECORD +;;; (STANDARD-DISPLAYED-OUTPUT-RECORD) to use around methods and +;;; WITH-DRAWING-OPTIONS, they are no longer necessary. (defclass updating-stream-state (complete-medium-state) ((cursor-x :accessor cursor-x :initarg :cursor-x :initform 0) (cursor-y :accessor cursor-y :initarg :cursor-y :initform 0))) @@ -325,7 +331,7 @@ (or (not y-supplied-p) (coordinate= (slot-value state 'cursor-y) cursor-y)))) -(defmethod set-medium-graphics-state :after +(defmethod set-medium-cursor-position ((state updating-stream-state) (stream updating-output-stream-mixin)) (setf (stream-cursor-position stream) (values (cursor-x state) (cursor-y state)))) @@ -931,7 +937,7 @@ record nil) (add-output-record record (stream-current-output-record stream)) - (set-medium-graphics-state (end-graphics-state record) stream) + (set-medium-cursor-position (end-graphics-state record) stream) (setf (parent-cache record) parent-cache) )) )))) record))) @@ -989,7 +995,7 @@ (unwind-protect (progn (letf (((do-note-output-record stream) nil)) - (set-medium-graphics-state (start-graphics-state record) stream) + (set-medium-cursor-position (start-graphics-state record) stream) (compute-new-output-records record stream) (when *dump-updating-output* (dump-updating record :both *trace-output*))) @@ -1006,7 +1012,7 @@ (incremental-redisplay stream nil erases moves draws erase-overlapping move-overlapping)) (delete-stale-updating-output record)) - (set-medium-graphics-state current-graphics-state stream))))) + (set-medium-cursor-position current-graphics-state stream))))) (defun erase-rectangle (stream bounding) (with-bounding-rectangle* (x1 y1 x2 y2) --- /project/mcclim/cvsroot/mcclim/recording.lisp 2006/05/05 10:24:02 1.126 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2006/05/28 21:32:43 1.127 @@ -470,16 +470,13 @@ ;; Is there a better value to bind to baseline? ((slot-value stream 'baseline) (slot-value stream 'baseline))) (with-sheet-medium (medium stream) - (let ((medium-state (make-instance 'complete-medium-state - :medium medium)) - (transformation (medium-transformation medium))) + (let ((transformation (medium-transformation medium))) (unwind-protect (progn (setf (medium-transformation medium) +identity-transformation+) (replay-output-record record stream region)) - (setf (medium-transformation medium) transformation) - (set-medium-graphics-state medium-state medium)))))))) + (setf (medium-transformation medium) transformation)))))))) (defmethod replay-output-record ((record compound-output-record) stream &optional region (x-offset 0) (y-offset 0)) @@ -1025,17 +1022,6 @@ (:documentation "Stores those parts of the medium/stream graphics state that need to be restored when drawing an output record")) -(defgeneric set-medium-graphics-state (state medium) - (:documentation "Sets the MEDIUM graphics state from STATE")) - -(defmethod set-medium-graphics-state (state medium) - (declare (ignore medium)) - state) - -(defmethod set-medium-graphics-state (state (stream output-recording-stream)) - (with-sheet-medium (medium stream) - (set-medium-graphics-state state medium))) - (defclass gs-ink-mixin (graphics-state) ((ink :initarg :ink :accessor graphics-state-ink))) @@ -1046,8 +1032,10 @@ (when (and medium (not (slot-boundp obj 'ink))) (setf (slot-value obj 'ink) (medium-ink medium)))) -(defmethod set-medium-graphics-state :after ((state gs-ink-mixin) medium) - (setf (medium-ink medium) (graphics-state-ink state))) +(defmethod replay-output-record :around + ((record gs-ink-mixin) stream &optional region x-offset y-offset) + (with-drawing-options (stream :ink (graphics-state-ink record)) + (call-next-method))) (defrecord-predicate gs-ink-mixin (ink) (if-supplied (ink) @@ -1057,7 +1045,6 @@ ((clip :initarg :clipping-region :accessor graphics-state-clip :documentation "Clipping region in stream coordinates."))) - (defmethod initialize-instance :after ((obj gs-clip-mixin) &key (stream nil) (medium (when stream @@ -1073,31 +1060,10 @@ (setq clip (transform-region (medium-transformation medium) clip-region)))))) -(defmethod set-medium-graphics-state :after ((state gs-clip-mixin) medium) - ;; - ;; This definition is kind of wrong. When output records are about to - ;; be replayed only a certain region of the stream should be affected.[1] - ;; Therefore I disabled this code, since this way only breaks the - ;; [not very frequent case] that the output record actually contains - ;; a clipping region different from +everywhere+, while having it in - ;; breaks redisplay of streams in just about every case. - ;; - ;; Most notably Closure is affected by this, as it does the equivalent of - ;; (draw-rectangle* medium 0 0 800 200 :ink +white+ :filled t) - ;; (draw-text* medium "Hello" 100 100) - ;; - ;; Having this code in a redisplay on the region - ;; (make-rectangle* 0 0 50 50) fills the drawing pane with a white - ;; rectangle obscuring the text. - ;; - ;; [1] it is of course debatable where this extra clipping because - ;; of redisplay should come from. Should replay-output-record set it - ;; up? Should handle-repaint do so? - ;; - ;; --GB 2003-03-14 - (declare (ignore medium)) - #+nil - (setf (medium-clipping-region medium) (graphics-state-clip state))) +(defmethod replay-output-record :around + ((record gs-clip-mixin) stream &optional region x-offset y-offset) + (with-drawing-options (stream :clipping-region (graphics-state-clip record)) + (call-next-method))) (defrecord-predicate gs-clip-mixin ((:clipping-region clip)) (if-supplied (clip) @@ -1123,8 +1089,10 @@ (unless (slot-boundp obj 'line-style) (setf (slot-value obj 'line-style) (medium-line-style medium))))) -(defmethod set-medium-graphics-state :after ((state gs-line-style-mixin) medium) - (setf (medium-line-style medium) (graphics-state-line-style state))) +(defmethod replay-output-record :around + ((record gs-line-style-mixin) stream &optional region x-offset y-offset) + (with-drawing-options (stream :line-style (graphics-state-line-style record)) + (call-next-method))) (defrecord-predicate gs-line-style-mixin (line-style) (if-supplied (line-style) @@ -1147,8 +1115,10 @@ (unless (slot-boundp obj 'text-style) (setf (slot-value obj 'text-style) (medium-text-style medium))))) -(defmethod set-medium-graphics-state :after ((state gs-text-style-mixin) medium) - (setf (medium-text-style medium) (graphics-state-text-style state))) +(defmethod replay-output-record :around + ((record gs-text-style-mixin) stream &optional region x-offset y-offset) + (with-drawing-options (stream :text-style (graphics-state-text-style record)) + (call-next-method))) (defrecord-predicate gs-text-style-mixin (text-style) (if-supplied (text-style) @@ -1187,17 +1157,6 @@ (record2 standard-displayed-output-record)) (region-equal record record2)) -;;; This is an around method so that more specific before methods can be -;;; defined for the various mixin classes, that modify the state after it has -;;; been set in the graphics state. - -(defmethod replay-output-record :around - ((record standard-displayed-output-record) stream - &optional region x-offset y-offset) - (declare (ignore region x-offset y-offset)) - (set-medium-graphics-state record stream) - (call-next-method)) - (defclass coord-seq-mixin () ((coord-seq :accessor coord-seq :initarg :coord-seq)) (:documentation "Mixin class that implements methods for records that contain @@ -1851,8 +1810,15 @@ substring (setf (stream-cursor-position stream) (values start-x start-y)) - (set-medium-graphics-state substring medium) - (stream-write-output stream string nil))) + ;; FIXME: a bit of an abstraction inversion. Should + ;; the styled strings here not simply be output + ;; records? Then we could just replay them and all + ;; would be well. -- CSR, 20060528. + (with-drawing-options (stream + :ink (graphics-state-ink substring) + :clipping-region (graphics-state-clip substring) + :text-style (graphics-state-text-style substring)) + (stream-write-output stream string nil)))) (when wrapped ; FIXME (draw-rectangle* medium (+ wrapped 0) start-y