From tmoore at common-lisp.net Sat Apr 1 07:58:36 2006 From: tmoore at common-lisp.net (tmoore) Date: Sat, 1 Apr 2006 02:58:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060401075836.F41687A001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26959 Modified Files: presentation-defs.lisp Log Message: Change the input editing text cursor from the disturbing outline to solid. Do something a bit more intelligent with presentation-type-of and structure objects. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/20 08:15:26 1.54 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/04/01 07:58:36 1.55 @@ -100,8 +100,9 @@ (defmethod presentation-type-of ((object structure-object)) (multiple-value-bind (name lambda-list) (get-ptype-from-class-of object) - (if (or (null lambda-list) - (member lambda-list lambda-list-keywords)) + (if (and name + (or (null lambda-list) + (member lambda-list lambda-list-keywords))) name (call-next-method)))) From tmoore at common-lisp.net Sat Apr 1 07:58:37 2006 From: tmoore at common-lisp.net (tmoore) Date: Sat, 1 Apr 2006 02:58:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20060401075837.52BE9111C7@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv26959/Goatee Modified Files: clim-area.lisp Log Message: Change the input editing text cursor from the disturbing outline to solid. Do something a bit more intelligent with presentation-type-of and structure objects. --- /project/mcclim/cvsroot/mcclim/Goatee/clim-area.lisp 2006/03/01 21:51:54 1.32 +++ /project/mcclim/cvsroot/mcclim/Goatee/clim-area.lisp 2006/04/01 07:58:37 1.33 @@ -26,7 +26,8 @@ ;;; cheat and use this McCLIM internal class :) (defclass screen-area-cursor (clim-internals::cursor-mixin cursor) - ((screen-line :accessor screen-line :initarg :screen-line))) + ((screen-line :accessor screen-line :initarg :screen-line)) + (:default-initargs :appearance :solid)) (defmethod* (setf cursor-position) (nx ny (cursor screen-area-cursor)) (declare (ignore nx ny)) From crhodes at common-lisp.net Sat Apr 1 21:07:05 2006 From: crhodes at common-lisp.net (crhodes) Date: Sat, 1 Apr 2006 16:07:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/PostScript Message-ID: <20060401210705.2C66A1C00E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv29250/Backends/PostScript Modified Files: sheet.lisp Log Message: Fix for EPS output from postscript backend. (From David Lewis) --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/sheet.lisp 2006/03/29 10:43:38 1.14 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/sheet.lisp 2006/04/01 21:07:04 1.15 @@ -74,11 +74,11 @@ ((:eps) (let ((record (stream-output-history stream))) (multiple-value-bind (lx ly ux uy) (bounding-rectangle* record) - (setf translate-x (- (ceiling lx)) + (setf translate-x (- (floor lx)) translate-y (ceiling uy)) (format file-stream "%%BoundingBox: ~A ~A ~A ~A~%" 0 0 - (+ translate-x (floor lx)) + (+ translate-x (ceiling ux)) (- translate-y (floor ly)))))) (t (multiple-value-bind (width height) From crhodes at common-lisp.net Mon Apr 10 09:48:40 2006 From: crhodes at common-lisp.net (crhodes) Date: Mon, 10 Apr 2006 05:48:40 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060410094840.78FBA5E0CC@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20167 Modified Files: graph-formatting.lisp mcclim.asd Log Message: Andy Hefner's code for keeping track of graph edges, and demo code for draggable graphs. I've been running with this for about a year now, and I'm bored of having to snip it out of diffs all the time. (Also add the drag-and-drop-translator demo to demodemo) --- /project/mcclim/cvsroot/mcclim/graph-formatting.lisp 2006/03/10 21:58:13 1.17 +++ /project/mcclim/cvsroot/mcclim/graph-formatting.lisp 2006/04/10 09:48:40 1.18 @@ -3,7 +3,7 @@ ;;; Title: Graph Formatting ;;; Created: 2002-08-13 ;;; License: LGPL (See file COPYING for details). -;;; $Id: graph-formatting.lisp,v 1.17 2006/03/10 21:58:13 tmoore Exp $ +;;; $Id: graph-formatting.lisp,v 1.18 2006/04/10 09:48:40 crhodes Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -240,6 +240,8 @@ :initarg :graph-children :initform nil :accessor graph-node-children) + (edges-from :initform (make-hash-table)) + (edges-to :initform (make-hash-table)) (object :initarg :object :reader graph-node-object) @@ -405,6 +407,15 @@ (incf v within-generation-separation))) (graph-root-nodes graph-output-record))))))))))) +;;;; Edges + +(defclass standard-edge-output-record (standard-sequence-output-record) + ((stream) + (arc-drawer) + (arc-drawing-options) + (from-node :initarg :from-node) + (to-node :initarg :to-node))) + (defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record) stream arc-drawer arc-drawing-options) @@ -526,7 +537,7 @@ (with-slots (root-nodes orientation) graph-output-record (let ((hash (make-hash-table))) (labels ((walk (node) - (unless (gethash node hash) + (unless (gethash node hash) (setf (gethash node hash) t) (dolist (k (graph-node-children node)) (with-bounding-rectangle* (x1 y1 x2 y2) node @@ -551,6 +562,55 @@ (walk k))))) (map nil #'walk root-nodes))))) +(defun layout-edges (graph node stream arc-drawer arc-drawing-options) + (dolist (k (graph-node-children node)) + (layout-edge graph node k stream arc-drawer arc-drawing-options))) + +(defun ensure-edge-record (graph major-node minor-node) + (let ((edges-from (slot-value major-node 'edges-from)) + (edges-to (slot-value minor-node 'edges-to))) + (assert (eq (gethash minor-node edges-from) + (gethash major-node edges-to))) + (or (gethash minor-node edges-from) + (let ((record (make-instance 'standard-edge-output-record + :from-node major-node :to-node minor-node))) + (setf (gethash minor-node edges-from) record + (gethash major-node edges-to) record) + (add-output-record record graph) + record)))) + +(defun layout-edge-1 (graph major-node minor-node) + (let ((edge-record (ensure-edge-record graph major-node minor-node))) + (with-slots (stream arc-drawer arc-drawing-options) edge-record + (with-bounding-rectangle* (x1 y1 x2 y2) major-node + (with-bounding-rectangle* (u1 v1 u2 v2) minor-node + (clear-output-record edge-record) ;;; FIXME: repaint? + (letf (((stream-current-output-record stream) edge-record)) + (ecase (slot-value graph 'orientation) + ((:horizontal) + (multiple-value-bind (from to) (if (< x1 u1) + (values x2 u1) + (values x1 u2)) + (apply arc-drawer stream major-node minor-node + from (/ (+ y1 y2) 2) + to (/ (+ v1 v2) 2) + arc-drawing-options))) + ((:vertical) + (multiple-value-bind (from to) (if (< y1 v1) + (values y2 v1) + (values y1 v2)) + (apply arc-drawer stream major-node minor-node + (/ (+ x1 x2) 2) from + (/ (+ u1 u2) 2) to + arc-drawing-options)))))))))) + +(defun layout-edge (graph major-node minor-node stream arc-drawer arc-drawing-options) + (let ((edge-record (ensure-edge-record graph major-node minor-node))) + (setf (slot-value edge-record 'stream) stream + (slot-value edge-record 'arc-drawer) arc-drawer + (slot-value edge-record 'arc-drawing-options) arc-drawing-options) + (layout-edge-1 graph major-node minor-node))) + (defmethod layout-graph-edges ((graph standard-graph-output-record) stream arc-drawer arc-drawing-options) (with-slots (orientation) graph @@ -562,26 +622,7 @@ (traverse-graph-nodes graph (lambda (node children continuation) (unless (eq node graph) - (dolist (k children) - (with-bounding-rectangle* (x1 y1 x2 y2) node - (with-bounding-rectangle* (u1 v1 u2 v2) k - (ecase orientation - ((:horizontal) - (multiple-value-bind (from to) (if (< x1 u1) - (values x2 u1) - (values x1 u2)) - (apply arc-drawer stream node k - from (/ (+ y1 y2) 2) - to (/ (+ v1 v2) 2) - arc-drawing-options))) - ((:vertical) - (multiple-value-bind (from to) (if (< y1 v1) - (values y2 v1) - (values y1 v2)) - (apply arc-drawer stream node k - (/ (+ x1 x2) 2) from - (/ (+ u1 u2) 2) to - arc-drawing-options)))))))) + (layout-edges graph node stream arc-drawer arc-drawing-options)) (map nil continuation children)))))) (defmethod layout-graph-edges :around ((graph-output-record tree-graph-output-record) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/29 10:43:37 1.16 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/10 09:48:40 1.17 @@ -315,7 +315,8 @@ #+clx (:file "gadget-test") (:file "accepting-values") (:file "method-browser") - (:file "dragndrop-translator"))) + (:file "dragndrop-translator") + (:file "draggable-graph"))) (:module "Goatee" :components ((:file "goatee-test"))))) From crhodes at common-lisp.net Mon Apr 10 09:48:41 2006 From: crhodes at common-lisp.net (crhodes) Date: Mon, 10 Apr 2006 05:48:41 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20060410094841.2F77E650A3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv20167/Examples Modified Files: demodemo.lisp Added Files: draggable-graph.lisp Log Message: Andy Hefner's code for keeping track of graph edges, and demo code for draggable graphs. I've been running with this for about a year now, and I'm bored of having to snip it out of diffs all the time. (Also add the drag-and-drop-translator demo to demodemo) --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/03/29 10:43:43 1.8 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/04/10 09:48:40 1.9 @@ -63,7 +63,9 @@ (make-demo-button "Gadget Test" 'gadget-test) (make-demo-button "Drag and Drop" 'dragndrop) (make-demo-button "Colorslider" 'colorslider) - (make-demo-button "Goatee Test" 'goatee::goatee-test))) + (make-demo-button "Goatee Test" 'goatee::goatee-test) + (make-demo-button "D&D Translator" 'drag-test) + (make-demo-button "Draggable Graph" 'draggable-graph-demo))) (labelling (:label "Tests") (vertically (:equalize-width t) (make-demo-button "Label Test" 'label-test) --- /project/mcclim/cvsroot/mcclim/Examples/draggable-graph.lisp 2006/04/10 09:48:41 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/draggable-graph.lisp 2006/04/10 09:48:41 1.1 ;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2005 by ;;; Andy Hefner (ahefner at gmail.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) ;;; Demo of draggable graph nodes (define-application-frame draggable-graph-demo () () (:pane (make-pane 'application-pane :width :compute :height :compute :display-function 'generate-graph :display-time t))) (defun generate-graph (frame pane) (format-graph-from-roots (list (find-class 'number)) (lambda (object stream) (present (clim-mop:class-name object) (presentation-type-of object) :stream stream)) #'clim-mop:class-direct-subclasses :stream pane)) (defun record-parent-chain (record) (and record (cons record (record-parent-chain (output-record-parent record))))) (defun find-graph-node (record) "Searches upward until a graph node parent of the supplied output record is found." (find-if #'graph-node-output-record-p (record-parent-chain record))) (defun node-edges (node) (let (edges) (maphash (lambda (child edge) (declare (ignore child)) (push edge edges)) (slot-value node 'climi::edges-from)) (maphash (lambda (parent edge) (declare (ignore parent)) (push edge edges)) (slot-value node 'climi::edges-to)) edges)) (defun redisplay-edges (graph edges) (dolist (edge edges) (with-slots (climi::from-node climi::to-node) edge (climi::layout-edge-1 graph climi::from-node climi::to-node)))) ;;; (AH) McCLIM bug of the day: ;;; ;;; (I haven't looked in detail at the spec or McCLIM to confirm my ;;; assumptions here, but as I understand things..) CLIM regions are ;;; immutable. Output records ARE mutable. A McCLIM output record can ;;; be used as a rectangular region corresponding to its bounding ;;; rectangle. But this bounding rectangle is not immutable! So, ;;; region operations such as region-union may build a rectangle-set ;;; capturing the mutable output-record object, violating the ;;; immutability of regions and causing widespread panic and ;;; confusion. (defun stupid-copy-rectangle (region) (with-bounding-rectangle* (x0 y0 x1 y1) region (make-rectangle* x0 y0 x1 y1))) (define-draggable-graph-demo-command (com-drag-node) ((record t) (x 'real) (y 'real)) (let* ((graph-node (find-graph-node record)) (edges (node-edges graph-node)) (erase-region (stupid-copy-rectangle (reduce (lambda (x &optional y) (if y (region-union x y) x)) edges)))) (multiple-value-bind (px py) (output-record-position graph-node) (let ((graph (output-record-parent graph-node)) (x-offset (- x px)) (y-offset (- y py))) (assert (typep graph 'graph-output-record)) (erase-output-record graph-node *standard-output*) (dolist (edge edges) (clear-output-record edge)) (when edges (repaint-sheet *standard-output* erase-region)) (multiple-value-bind (final-x final-y) (drag-output-record *standard-output* graph-node :erase-final t :finish-on-release t) (setf (output-record-position graph-node) (values (- final-x x-offset) (- final-y y-offset))) (add-output-record graph-node graph) (redisplay-edges graph edges) (repaint-sheet *standard-output* graph-node)))))) (define-presentation-to-command-translator record-dragging-translator (t com-drag-node draggable-graph-demo :tester ((presentation) (find-graph-node presentation))) (presentation x y) (list presentation x y)) ;;; (CSR) This demo code is quite cool; visually, it's a little ;;; disconcerting to have the edges disappear when dragging, but ;;; that's acceptable, though I think it might be possible to preserve ;;; them by having a feedback function for the call to ;;; DRAG-OUTPUT-RECORD. From rgoldman at common-lisp.net Mon Apr 10 13:58:10 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Mon, 10 Apr 2006 09:58:10 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060410135810.B163E18003@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22293 Modified Files: input-editing.lisp Log Message: Changed the way possibilities are presented when complete-from-generator is used in the command reader. Now the list of possibilities generated will be sorted alphabetically. This solution is possibly not ideal, but I thought any better solution would require more widespread changes. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2006/03/10 21:58:13 1.49 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2006/04/10 13:58:10 1.50 @@ -767,7 +767,7 @@ ;;; The possibilities action is different enough that I don't want to add to ;;; the spaghetti above... -(defun complete-from-generator-possibilities +(defun complete-from-generator-possibilities (initial-string generator predicate) (let ((possibilities nil) (nmatches 0) @@ -783,12 +783,13 @@ (funcall generator initial-string #'suggester) (if (and (eql nmatches 1) (string-equal initial-string (caar possibilities))) + ;; return values are as from complete-from-generator, qv. (values (caar possibilities) t (cdar possibilities) nmatches possibilities) - (values initial-string nil nil nmatches possibilities))))) + (values initial-string nil nil nmatches (sort possibilities #'string-lessp :key #'car)))))) (defun complete-from-possibilities (initial-string completions delimiters &key (action :complete) From crhodes at common-lisp.net Mon Apr 10 21:24:54 2006 From: crhodes at common-lisp.net (crhodes) Date: Mon, 10 Apr 2006 17:24:54 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20060410212454.1E37A4007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv20022 Modified Files: dev-commands.lisp Log Message: Slightly better editability in the listener: now fboundp (setf foo) things stand a chance of having the Edit Definition command work. Printing methods with EQL specializers works better. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/03/29 10:43:37 1.34 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/04/10 21:24:53 1.35 @@ -37,10 +37,20 @@ ;;; Presentation types -(define-presentation-type class () :inherit-from 'expression) +(define-presentation-type specializer () :inherit-from 'expression) +(define-presentation-type class () :inherit-from 'specializer) +(define-presentation-type eql-specializer () :inherit-from 'specializer) (define-presentation-type class-name () :inherit-from 'symbol) (define-presentation-type slot-definition () :inherit-from 'expression) -(define-presentation-type function-name () :inherit-from 'symbol) + +(define-presentation-type-abbreviation function-name () + `(and expression (satisfies legal-and-fboundp))) + +(defun legal-and-fboundp (object) + (and #+sbcl (sb-int:valid-function-name-p object) + #-sbcl (typep object '(or symbol (cons (eql setf)))) + (fboundp object))) + (define-presentation-type process () :inherit-from 'expression) (define-presentation-type generic-function () :inherit-from 't) @@ -67,9 +77,7 @@ (define-presentation-type package-name () :inherit-from 'string) (define-presentation-method presentation-typep (object (type package-name)) - (find-package 'object)) - - + (find-package object)) ;;; Presentation methods @@ -98,8 +106,10 @@ (write-char #\( stream) (present arg 'symbol :stream stream) (write-char #\space stream) - (with-output-as-presentation (stream spec 'class) - (format stream "~S" (clim-mop:class-name spec))) + (with-output-as-presentation (stream spec 'specializer) + (if (typep spec 'class) + (format stream "~S" (clim-mop:class-name spec)) + (format stream "~S" `(eql ,(clim-mop:eql-specializer-object spec))))) (write-char #\) stream)))) (when optional (format stream " &optional ~{~A ~^ ~}" optional)) @@ -187,13 +197,31 @@ (object) (clim-mop:class-name object)) +(define-presentation-translator expression-to-function-name + (expression function-name lisp-dev-commands + :documentation ((object stream) (format stream "~A" object)) + :gesture t + :tester ((object) (legal-and-fboundp object)) + :tester-definitive t) + (object) + object) (define-presentation-translator symbol-to-function-name (symbol function-name lisp-dev-commands - :documentation ((object stream) (format stream "Function ~A" object)) + :documentation ((object stream) (format stream "~A" object)) :gesture t - :tester ((object) (fboundp object)) + :tester ((object) (legal-and-fboundp object)) :tester-definitive t) - (object) object) + (object) + object) +#+nil ; doesn't work for some reason +(define-presentation-translator sequence-to-function-name + ((sequence t) function-name lisp-dev-commands + :documentation ((object stream) (format stream "~A" object)) + :gesture t + :tester ((object) (legal-and-fboundp object)) + :tester-definitive t) + (object) + object) ;;; Application commands @@ -336,7 +364,7 @@ :command-table lisp-commands :menu t :provide-output-destination-keyword nil) - ((fsym 'function-name :prompt "function-name")) + ((fsym 'function-name :prompt "function name")) (if (fboundp fsym) (progn (eval `(trace ,fsym)) @@ -347,7 +375,7 @@ :command-table lisp-commands :menu t :provide-output-destination-keyword nil) - ((fsym 'symbol :prompt "function name")) + ((fsym 'function-name :prompt "function name")) (if (fboundp fsym) (progn (eval `(untrace ,fsym)) @@ -572,10 +600,16 @@ (note "No accessors") (progn (with-ink (readers) - (if readers (dolist (reader readers) (format t "~A~%" reader)) - (note "No readers~%"))) + (if readers + (dolist (reader readers) + (hackish-present reader) + (terpri)) + (note "No readers~%"))) (with-ink (writers) - (if writers (dolist (writer writers) (format t "~A~%" writer)) + (if writers + (dolist (writer writers) + (hackish-present writer) + (terpri)) (note "No writers")))))) (fcell (documentation :left) @@ -1379,19 +1413,14 @@ :command-table lisp-commands :menu t :provide-output-destination-keyword nil) - ((symbol 'symbol :prompt "function-name")) - (clim-sys:make-process (lambda () (ed symbol)))) - -(defun editable-definition-p (symbol) - (fboundp symbol)) + ((function-name 'function-name :prompt "function name")) + (clim-sys:make-process (lambda () (ed function-name)))) (define-presentation-to-command-translator edit-definition - (symbol com-edit-definition lisp-commands :gesture :select + (function-name com-edit-definition lisp-commands :gesture :select :pointer-documentation ((object stream) (format stream "Edit Definition of ~A" object)) - :documentation ((stream) (format stream "Edit Definition")) - :tester ((object) - (editable-definition-p object))) + :documentation ((stream) (format stream "Edit Definition"))) (object) (list object)) From dlichteblau at common-lisp.net Mon Apr 17 17:54:58 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 17 Apr 2006 13:54:58 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060417175458.C3A9625003@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8858 Modified Files: mcclim.asd Log Message: * Examples/text-size-test.lisp: New file. Visual test for the TEXT-SIZE function. * Examples/demodemo.lisp: Added a button for text-size-test. * mcclim.asd (clim-examples): Added text-size-test.lisp. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/10 09:48:40 1.17 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/17 17:54:58 1.18 @@ -316,7 +316,8 @@ (:file "accepting-values") (:file "method-browser") (:file "dragndrop-translator") - (:file "draggable-graph"))) + (:file "draggable-graph") + (:file "text-size-test"))) (:module "Goatee" :components ((:file "goatee-test"))))) From dlichteblau at common-lisp.net Mon Apr 17 17:54:59 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 17 Apr 2006 13:54:59 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20060417175459.076602814E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv8858/Examples Modified Files: demodemo.lisp Added Files: text-size-test.lisp Log Message: * Examples/text-size-test.lisp: New file. Visual test for the TEXT-SIZE function. * Examples/demodemo.lisp: Added a button for text-size-test. * mcclim.asd (clim-examples): Added text-size-test.lisp. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/04/10 09:48:40 1.9 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/04/17 17:54:58 1.10 @@ -72,7 +72,8 @@ (make-demo-button "Table Test" 'table-test) (make-demo-button "Scroll Test" 'Scroll-test) (make-demo-button "List Test" 'list-test) - (make-demo-button "HBOX Test" 'hbox-test))))))))) + (make-demo-button "HBOX Test" 'hbox-test) + (make-demo-button "Text Size Test" 'text-size-test))))))))) (defun demodemo () #+nil --- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/04/17 17:54:59 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/04/17 17:54:59 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 text-size-test () () (:panes (canvas :application :min-width 600 :display-time t :display-function 'display-canvas) (text (make-pane 'text-field :value "ytmM")) (family (with-radio-box () (make-pane 'toggle-button :label "Fixed" :id :fixed) (radio-box-current-selection (make-pane 'toggle-button :label "Serif" :id :serif)) (make-pane 'toggle-button :label "Sans Serif" :id :sans-serif))) (face (with-radio-box (:type :some-of) (make-pane 'toggle-button :label "Bold" :id :bold) (make-pane 'toggle-button :label "Italic" :id :italic))) (size (make-pane 'slider :orientation :horizontal :value 200 :min-value 1 :max-value 1000))) (:layouts (default (vertically () (labelling (:label "Text") text) (horizontally () (labelling (:label "Family") family) (labelling (:label "Face") face)) (labelling (:label "Size") size) canvas)))) (defmethod display-canvas (frame stream) (window-clear stream) (let* ((pane-width (rectangle-width (sheet-region stream))) (pane-height (rectangle-height (sheet-region stream))) (str (gadget-value (find-pane-named frame 'text))) (size (gadget-value (find-pane-named frame 'size))) (family (gadget-id (gadget-value (find-pane-named frame 'family)))) (faces (mapcar #'gadget-id (gadget-value (find-pane-named frame 'face)))) (face (if (cdr faces) '(:bold :italic) (car faces))) (style (make-text-style family face size))) (multiple-value-bind (width height final-x final-y baseline) (text-size stream str :text-style style) (let ((x1 (/ (- pane-width width) 2)) (y1 (/ (- pane-height height) 2))) (draw-line* stream 0 (+ y1 baseline) pane-width (+ y1 baseline) :ink +green+) (draw-text* stream str x1 (+ y1 baseline) :text-style style) ;; Here an attempt at testing text with newlines, results are garbage ;; even with CLIM-CLX: ;;; (setf (stream-cursor-position stream) (values x1 y1)) ;;; (with-text-style (stream style) ;;; (write-string str stream)) (draw-rectangle* stream x1 y1 (+ x1 width) (+ y1 height) :ink +red+ :filled nil) (draw-rectangle* stream x1 y1 (+ x1 final-x) (+ y1 final-y) :ink +blue+ :filled nil))))) (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") () (display-canvas *application-frame* (frame-standard-output *application-frame*))) From dlichteblau at common-lisp.net Mon Apr 17 18:12:16 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 17 Apr 2006 14:12:16 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20060417181216.9A2283300F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv11135 Modified Files: medium.lisp Log Message: * Backends/CLX/medium.lisp (climi::text-bounding-rectangle*): Do not error out when the string contains newlines. [Whether the return values are right is a different matter...] --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/03/23 11:59:00 1.73 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/04/17 18:12:16 1.74 @@ -757,7 +757,7 @@ font-ascent font-descent direction first-not-done)) (multiple-value-bind (minx miny maxx maxy) - (text-bounding-rectangle* + (climi::text-bounding-rectangle* medium string :text-style text-style :start (1+ position-newline) :end end) (values (min minx left) (- ascent) From dlichteblau at common-lisp.net Mon Apr 17 18:37:21 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 17 Apr 2006 14:37:21 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060417183721.A2CD97E022@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14900 Modified Files: gadgets.lisp Log Message: * gadgets.lisp (dis-/armed-callback text-field-pane): Added a hack to ensure initialization of the text field before it is being used. Needed to make the gadget test start up with the gtkairo backend. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/03/30 12:07:59 1.99 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/04/17 18:37:21 1.100 @@ -2562,6 +2562,7 @@ (let ((port (port gadget))) (setf (previous-focus gadget) (port-keyboard-input-focus port)) (setf (port-keyboard-input-focus port) gadget)) + (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :solid)))) @@ -2571,6 +2572,7 @@ (let ((port (port gadget))) (setf (port-keyboard-input-focus port) (previous-focus gadget)) (setf (previous-focus gadget) nil)) + (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :hollow)))) From dlichteblau at common-lisp.net Mon Apr 17 18:37:41 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 17 Apr 2006 14:37:41 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060417183741.BA1277E026@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv14955/gtkairo Log Message: Directory /project/mcclim/cvsroot/mcclim/Backends/gtkairo added to the repository From dlichteblau at common-lisp.net Mon Apr 17 18:40:27 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 17 Apr 2006 14:40:27 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060417184027.556E7431B8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14999 Modified Files: mcclim.asd ports.lisp Log Message: * Backends/gtkairo: New directory: Experimental GTK+ backend. * mcclim.asd (clim-gtkairo): New system. (clim-looks): Depend on clim-gtkairo if the gtkairo feature has been set by the user. * ports.lisp (*server-path-search-order*): s/gtk/gtkairo/ --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/17 17:54:58 1.18 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/17 18:40:27 1.19 @@ -258,6 +258,26 @@ (:file "graft" :depends-on ("port" "package")) (:file "frame-manager" :depends-on ("medium" "port" "package")))))) +(defsystem :clim-gtkairo + :depends-on (:clim :cffi) + :components + ((:module "Backends/gtkairo" + :pathname #.(make-pathname :directory '(:relative "Backends" "gtkairo")) + :serial t ;asf wird's ja richten + :components + ((:file "clim-fix") + (:file "package") + (:file "gtk-ffi") + (:file "cairo-ffi") + (:file "port") + (:file "event") + (:file "keysymdef") + (:file "medium") + (:file "pixmap") + (:file "graft") + (:file "frame-manager") + (:file "gadgets"))))) + ;;; TODO/asf: I don't have the required libs to get :clim-opengl to load. tough. (clim-defsystem (:clim-opengl :depends-on (:clim)) "Backends/OpenGL/opengl-x-frame-manager" @@ -283,6 +303,8 @@ ;; cope with possible bugs. ;; #+(or openmcl mcl) :clim-beagle + #+gtkairo :clim-gtkairo + ;; null backend :clim-null ) --- /project/mcclim/cvsroot/mcclim/ports.lisp 2006/03/27 10:44:34 1.51 +++ /project/mcclim/cvsroot/mcclim/ports.lisp 2006/04/17 18:40:27 1.52 @@ -25,7 +25,7 @@ (defvar *default-server-path* nil) -(defvar *server-path-search-order* '(:genera :ms-windows :gtk :clx :x11 :opengl :beagle :null)) +(defvar *server-path-search-order* '(:genera :ms-windows :gtkairo :clx :x11 :opengl :beagle :null)) (defun find-default-server-path () (loop for port in *server-path-search-order* From dlichteblau at common-lisp.net Mon Apr 17 18:40:27 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 17 Apr 2006 14:40:27 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060417184027.A56DC4707B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv14999/Backends/gtkairo Added Files: .cvsignore NOTES cairo-ffi.lisp clim-fix.lisp event.lisp frame-manager.lisp gadgets.lisp graft.lisp gtk-ffi.lisp keysymdef.lisp medium.lisp package.lisp pixmap.lisp port.lisp Log Message: * Backends/gtkairo: New directory: Experimental GTK+ backend. * mcclim.asd (clim-gtkairo): New system. (clim-looks): Depend on clim-gtkairo if the gtkairo feature has been set by the user. * ports.lisp (*server-path-search-order*): s/gtk/gtkairo/ --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/.cvsignore 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/.cvsignore 2006/04/17 18:40:27 1.1 *.fasl --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/NOTES 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/NOTES 2006/04/17 18:40:27 1.1 Gilbert Baumann's notes, copied from clim-cairo-2005-03-20/cairo-medium.lisp. ;; - blitting ;; ;; The X11 Cairo backend currently crashes my X server when blittering from ;; one surface to itself. [That is, if we draw to a surface using very same ;; surface as the pattern]. [ Well, no X11 here anywore. Is anything like this still relevant? ] ;; - pixmaps ;; ;; These should be easy to provide. [ David: done ] ;; - alpha impedance mismatch ;; ;; Cairo uses pre-multiplied alpha while CLIM doesn't. So we need to convert ;; things around as needed. [ David: ??? ] ;; - real general designs and optimization short cuts ;; - new drawing options: ;; - :transform-glyphs-p ;; - :alu ;; - MEDIUM-DRAW-ELLIPSE* ;; Need to find a good bezier approximation of circles. ;; - MEDIUM-BEEP [ David: nix is, gepiepe kann ich nicht leiden. ;-) Ein "visual beep" waere aber schick. Vielleicht kann man da ja was basteln? ] ;; - device text styles ;; - find a substitue for CAIRO-FONT-SET-TRANSFORM ;; - abolish this silly CLIM-INTERNALS::DO-GRAPHICS-WITH-OPTIONS ;; - INVOKE-WITH-DRAWING-OPTIONS ;; - care for the proper text transformations. ;; - we need a systematic overview about what drawing option components are ;; transformed under what circumstances in cairo and in clim. ;; - i believe a "cr" is really nothing more than a kind of graphics context, so ;; this time implement a proper cache for those, so that we spend less time ;; tossing options around. [ David: Hmm, let's do some profiling before setting up a cache. Cairo people seem to recommend creating a cairo context for each and every redraw and then throwing it away, and we only create one for every medium, so that shouldn't be too slow. What's important is to not leak the cairo context. Right now I let the sheet destroy contexts when the mirror is destroyed, is that the right thing to do? ] ;; - more alu operations in clim ;; ;; For CAD applications it is really handy to have an OR operation. (Which ;; could be approximated in effect with :saturate). We would need to extend ;; the CLIM general design specification to include alu operations. [As ;; currently there really are only the OVER and FLIPPING operators available]. ;; - More proper separation of a vanilla Cairo media and specific Cario medium ;; like X11, Glitz, PNG, PDF etc. ;; - a WITH-CAIRO macro which can setup the proper FPU mode to make it break ;; less. [ David: oh yes, that's what I had to do in WITH-GTK. Terrible. ] ;;;; NOTES ;; RESOURCES, WHO TO FREE IT? -- It seems that if you destroy a window, a Render ;; picture associated with said window is also destroyed. ;; CAIRO-SET-TARGET-DRAWABLE and perhaps CAIRO-DESTROY do want to destroy that ;; picture on their own. So when we destroy a window we need to know all cairo ;; contexts floating around which associate to the window at hand and target ;; them at the root window (or better the spare window, more below) before we ;; destroy a window. And we need to do this recursively. And we need the extra ;; book keeping. [ David: nix verstehen. Was ist denn ein render picture? Hilfe! ] ;; UNGRAFTED MEDIA -- It happens that an application wants to use a medium ;; before its sheet is grafted. In those situations we'd need a spare window to ;; target the associated cairo medium at. We could use the root window, but bad ;; things happen if the user actually does some drawing instead of merely ;; querying stuff like text extents. So I want to allocate a specific unmapped ;; spare window for those occasions. ;; ;; [There really are two situations: a) using an ungrafted medium, b) ;; using a medium that is grafted to a sheet which itself is not ;; grafted]. [ David: I'm using the root window for text size operations (harmless) and completely ignore drawing operations otherwise. ] ;; FLIPPING INKS -- Cairo can't and for ideological reasons perhaps never will ;; support flipping inks. I myself hate flipping inks even more so than ;; bit-blittering, but there are still a few ancient applications around, which ;; use it. So we'd need to think about some way to support it. One idea is to ;; render the shape to an A1 temporary pixmap surface and use good old X11 to ;; make that pixmap flip pixels around. This breaks some abtractions established ;; by Cairo and will perhaps stop working around 2012. The fun thing is: ;; Flipping will now turn into a rather slow operation. [ David: Das ginge auch mit Cairo, ja. ] ;; - flipping ink ;; ;; Below is some example code to make Cairo render the alpha channel to a one ;; bit depth pixmap on the server. This pixmap can then later be used with X ;; Core requests to flip pixels around. Still, in general flipping inks don't ;; play nice when you have an alpha channel. ;; ;; But: A flippink can't be solved by just setting up the proper Cairo pattern ;; to a Cairo context, but drawing the shape itself must happen on our ;; temporary surface. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/04/17 18:40:27 1.1 ;;; -*- Mode: Lisp; -*- ;;; (c) copyright 2005 by Gilbert Baumann ;;; (c) copyright 2006 David Lichteblau (david at lichteblau.com) ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (in-package :clim-gtkairo) ;; user-visible structures (cffi:defcstruct cairo_text_extents (x_bearing :double) (y_bearing :double) (width :double) (height :double) (x_advance :double) (y_advance :double)) (cffi:defcstruct cairo_font_extents (ascent :double) (descent :double) (height :double) (max_x_advance :double) (max_y_advance :double)) (cffi:defcstruct cairo_glyph (index :unsigned-int) (x :double) (y :double)) (cffi:defcstruct cairo_matrix_t (xx :double) (yx :double) (xy :double) (yy :double) (x0 :double) (y0 :double)) ;; enums (cffi:defcenum cairo_format :argb32 :rgb24 :a8 :a1) (cffi:defcenum cairo_operator :clear :src :over :in :out :atop :dest :dest_over :dest_in :dest_out :dest_atop :xor :add :saturate) (cffi:defcenum cairo_fill_rule :winding :even_odd) (cffi:defcenum cairo_line_cap :butt :round :square) (cffi:defcenum cairo_line_join :miter :round :bevel) (cffi:defcenum cairo_font_slant :normal :italic :oblique) (cffi:defcenum cairo_font_weight :normal :bold) (cffi:defcenum cairo_status :success :no_memory :invalid_restore :invalid_pop_group :no_current_point :invalid_matrix :invalid_status :null_pointer :invalid_string :invalid_path_data :read_error :write_error :surface_finished :surface_type_mismatch :pattern_type_mismatch :invalid_content :invalid_format :invalid_visual :file_not_found :invalid_dash) (cffi:defcenum cairo_filter :fast :good :best :nearest :bilinear :gaussian) (cffi:defcenum cairo_extend :none :repeat :reflect) ;;; Functions for manipulating state objects (defcfun "cairo_create" :pointer (surface :pointer)) (defcfun "cairo_reference" :void (cr :pointer)) (defcfun "cairo_destroy" :void (cr :pointer)) (defcfun "cairo_save" :void (cr :pointer)) (defcfun "cairo_restore" :void (cr :pointer)) ;;; XXX: Replace with cairo_current_gstate/cairo_set_gstate ;;;(defcfun "cairo_copy" ;;; :void ;;; (destination :pointer) ;;; (source :pointer)) ;;; Modify state ;;;(defcfun "cairo_set_target_surface" ;;; :void ;;; (cr :pointer) ;;; (surface :pointer)) ;;; ;;;(defcfun "cairo_set_target_image" ;;; :void ;;; (cr :pointer) ;;; (data :pointer) ;(* (unsigned 8)) ;;; (format cairo_format) ;;; (width :int) ;;; (height :int) ;;; (stride :int)) (defcfun "cairo_set_operator" :void (cr :pointer) (op cairo_operator)) ;;; Colors (defcfun "cairo_set_source_rgb" :void (cr :pointer) (red :double) (green :double) (blue :double)) (defcfun "cairo_set_source_rgba" :void (cr :pointer) (red :double) (green :double) (blue :double) (alpha :double)) (defcfun "cairo_set_source" :void (cr :pointer) (pattern :pointer)) (defcfun "cairo_set_tolerance" :void (cr :pointer) (tolerance :double)) (defcfun "cairo_set_fill_rule" :void (cr :pointer) (fill_rule cairo_fill_rule)) (defcfun "cairo_set_line_width" :void (cr :pointer) (w :double)) (defcfun "cairo_set_line_cap" :void (cr :pointer) (line_cap cairo_line_cap)) (defcfun "cairo_set_line_join" :void (cr :pointer) (line_join cairo_line_join)) (defcfun "cairo_set_dash" :void (cr :pointer) (dashes :pointer) ;*double (ndash :int) (offset :double)) (defcfun "cairo_set_miter_limit" :int (cr :pointer) (limit :double)) ;;; Transformations (defcfun "cairo_translate" :void (cr :pointer) (tx :double) (ty :double)) (defcfun "cairo_scale" :void (cr :pointer) (sx :double) (sy :double)) (defcfun "cairo_rotate" :void (cr :pointer) (angle :double)) (defcfun "cairo_set_matrix" :void (cr :pointer) (matrix :pointer)) (defcfun "cairo_identity_matrix" :void (cr :pointer)) ;;;(defcfun "cairo_transform_point" ;;; :void ;;; (cr :pointer) ;;; (x :pointer) ;*double ;;; (y :pointer) ;*double ;;; ) ;;;(defcfun "cairo_transform_distance" ;;; :void ;;; (cr :pointer) ;;; (dx :pointer) ;*double ;;; (dy :pointer) ;*double ;;; ) ;;;(defcfun "cairo_inverse_transform_point" ;;; :void ;;; (cr :pointer) ;;; (x :pointer) ;*double ;;; (y :pointer) ;*double ;;; ) ;;; ;;;(defcfun "cairo_inverse_transform_distance" [537 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/04/17 18:40:27 1.1 [563 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/17 18:40:27 1.1 [860 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/04/17 18:40:27 1.1 [967 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/17 18:40:27 1.1 [1135 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/graft.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/graft.lisp 2006/04/17 18:40:27 1.1 [1178 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/17 18:40:27 1.1 [1913 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keysymdef.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keysymdef.lisp 2006/04/17 18:40:27 1.1 [3699 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/17 18:40:27 1.1 [4610 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/package.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/package.lisp 2006/04/17 18:40:27 1.1 [4616 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pixmap.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pixmap.lisp 2006/04/17 18:40:27 1.1 [4717 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/04/17 18:40:27 1.1 [5336 lines skipped] From dlichteblau at common-lisp.net Mon Apr 17 18:46:19 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 17 Apr 2006 14:46:19 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060417184619.08E974C013@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv16577/Backends/gtkairo Modified Files: event.lisp gtk-ffi.lisp Log Message: * Backends/gtkairo/gtk-ffi.lisp (gtkwidget, gtkobject): Moved header into its own structure declaration for correct alignment on 64 bit architectures. (gtkwidget-header): New function. (gtkwidget-flags): New accessor functions. * Backends/gtkairo/event.lisp (connect-signals): Use gtkwidget-flags. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/17 18:46:18 1.2 @@ -40,9 +40,8 @@ GDK_ENTER_NOTIFY_MASK GDK_LEAVE_NOTIFY_MASK #+nil GDK_STRUCTURE_MASK)) - (setf (cffi:foreign-slot-value widget 'gtkwidget 'flags) - (logior (cffi:foreign-slot-value widget 'gtkwidget 'flags) - GTK_CAN_FOCUS)) + (setf (gtkwidget-flags widget) + (logior (gtkwidget-flags widget) GTK_CAN_FOCUS)) (connect-signal widget "expose-event" 'expose-handler) (connect-signal widget "motion-notify-event" 'motion-notify-handler) (connect-signal widget "button-press-event" 'button-handler) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/17 18:46:18 1.2 @@ -112,14 +112,20 @@ (gdk_threads_leave))))) -;; GROVELME +;;; GROVELME -(cffi:defcstruct gtkwidget +;; must be a separate structure definition in order for padding on AMD64 +;; to work properly. +(cffi:defcstruct gtkobject (gtype :unsigned-long) ;GTypeInstance (ref_count :unsigned-int) ;GObject (qdata :pointer) ; -"- (flags :uint32) ;GtkObject - (private_flags :uint16) ;von hier an endlich GtkWidget + ) + +(cffi:defcstruct gtkwidget + (header gtkobject) + (private_flags :uint16) (state :uint8) (saved_state :uint8) (name :pointer) @@ -133,6 +139,16 @@ (gdkwindow :pointer) (parent :pointer)) +(defun gtkwidget-header (widget) + (cffi:foreign-slot-value widget 'gtkwidget 'header)) + +(defun gtkwidget-flags (widget) + (cffi:foreign-slot-value (gtkwidget-header widget) 'gtkobject 'flags)) + +(defun (setf gtkwidget-flags) (newval widget) + (setf (cffi:foreign-slot-value (gtkwidget-header widget) 'gtkobject 'flags) + newval)) + (cffi:defcstruct gdkeventexpose (type :int) (gdkwindow :pointer) From dlichteblau at common-lisp.net Mon Apr 17 18:48:52 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 17 Apr 2006 14:48:52 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060417184852.66A7B4E006@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv16648 Modified Files: medium.lisp Log Message: * Backends/gtkairo/medium.lisp (TEXT-STYLE-WIDTH): return max_x_advance instead of computing 1 em. Fixes the cursor position problem in Climacs. (TEXT-SIZE): changed return values almost completely. See comments there. (CLIMI::TEXT-BOUNDING-RECTANGLE*): Reimplemented to look more like what CLIM-CLX does. No real insight, but cannot be worse than it was. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/17 18:48:52 1.2 @@ -590,6 +590,18 @@ ;;; TEXT-STYLE-ASCENT +;; FIXME: Cairo documentation states that these numbers, AIUI, are not +;; exact measurements but rather values tweaked by the font designer for +;; better visual effect. +;; +;; What this seems to mean in practise is that, say, ASCENT is nearly +;; identical to text_extent.height in the tests I tried. +;; +;; So which one does CLIM want? What are these function actually being +;; used for? +;; +;; --DFL + (let ((hash (make-hash-table))) (defmethod text-style-ascent :around (text-style (medium gtkairo-medium)) (or (gethash text-style hash) @@ -653,6 +665,11 @@ (cairo_font_extents cr res) ;; ### let's hope that cairo respects ;; height = ascent + descent. + ;; + ;; No, it expressly doesn't. Cairo documentation states that + ;; height includes additional space that is meant to give more + ;; aesthetic line spacing than ascent+descent would. Is that a + ;; problem for us? --DFL (slot res 'cairo_font_extents 'height)))))) @@ -673,9 +690,13 @@ (sync-sheet medium) (cairo_identity_matrix cr) (sync-text-style medium text-style t) - (cffi:with-foreign-object (res 'cairo_text_extents) - (cairo_text_extents cr "m" res) - (slot res 'cairo_text_extents 'width)))))) + ;; This didn't work well for Climacs. --DFL +;;; (cffi:with-foreign-object (res 'cairo_text_extents) +;;; (cairo_text_extents cr "m" res) +;;; (slot res 'cairo_text_extents 'width)) + (cffi:with-foreign-object (res 'cairo_font_extents) + (cairo_font_extents cr res) + (slot res 'cairo_font_extents 'max_x_advance)))))) ;;; TEXT-STYLE-FIXED-WIDTH-P @@ -717,6 +738,27 @@ :start start :end (or end (length string))))) +(defmethod climi::text-bounding-rectangle* + ((medium gtkairo-medium) string &key text-style (start 0) end) + (with-gtk () + (when (characterp string) (setf string (string string))) + (setf text-style (or text-style (medium-text-style medium))) + (setf text-style + (merge-text-styles text-style (medium-default-text-style medium))) + (climi::text-bounding-rectangle* (metrik-medium (port medium)) + string + :text-style text-style + :start start + :end (or end (length string))))) + +;; FIXME: TEXT-SIZE [and presumably TEXT-BOUNDING-RECTANGLE*, too] are +;; supposed to take newlines into account. The CLX backend code was +;; written to support that but does not -- T-B-R errors out and T-S +;; doesn't return what WRITE-STRING on the sheet actually does. So +;; let's not steal code from CLIM-CLX when it's broken. Doesn't +;; actually look like anyone has been depending on this after all. +;; -- DFL + (defmethod text-size ((medium metrik-medium) string &key text-style (start 0) end) (with-cairo-medium (medium) @@ -733,17 +775,46 @@ (subseq string start (or end (length string))) res) (cffi:with-foreign-slots - ((width height x_advance y_advance) res cairo_text_extents) - (values (ceiling width) - (ceiling height) - (ceiling x_advance) - (ceiling y_advance) - ;; baseline? - (ceiling (text-style-ascent text-style medium)))))))) + ((x_advance height y_bearing) res cairo_text_extents) + (values + ;; use x_advance instead of width, since CLIM wants to trailing + ;; spaces to be taken into account. + (ceiling x_advance) + (ceiling height) + ;; Sames values again here: The CLIM spec states that these + ;; values differ only for multi-line text. And y_advance is 0 + ;; for european text, which is not what we want. --DFL + (ceiling x_advance) + (ceiling height) + ;; This used to be TEXT-STYLE-ASCENT, but see comment there. + (abs (ceiling y_bearing)))))))) (defmethod climi::text-bounding-rectangle* - ((medium gtkairo-medium) string &key text-style (start 0) end) - (text-size medium string :text-style text-style :start start :end end)) + ((medium metrik-medium) string &key text-style (start 0) end) + (with-cairo-medium (medium) + ;; -> left ascent right descent + (when (characterp string) (setf string (string string))) + (setf text-style (or text-style (make-text-style nil nil nil))) + (setf text-style + (merge-text-styles text-style (medium-default-text-style medium))) + (with-slots (cr) medium + (cairo_identity_matrix cr) + (sync-text-style medium text-style t) + (cffi:with-foreign-object (res 'cairo_text_extents) + (cairo_text_extents cr + (subseq string start (or end (length string))) + res) + ;; This used to be a straight call to TEXT-SIZE. Looking at + ;; what CLIM-CLX does, this looks better to me, but I'm not sure + ;; whether it's 100% right: + ;; --DFL + (cffi:with-foreign-slots + ((height x_advance y_advance x_bearing y_bearing) + res cairo_text_extents) + (values (ceiling x_bearing) + (ceiling y_bearing) + (ceiling x_advance) + (ceiling (+ height y_bearing)))))))) ;;;; ------------------------------------------------------------------------ ;;;; General Designs From crhodes at common-lisp.net Wed Apr 19 11:43:31 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 19 Apr 2006 07:43:31 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20060419114331.745CC7A002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv28012/Examples Modified Files: text-size-test.lisp Log Message: Add text-bounding-rectangle* mode to text-size-test --- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/04/17 17:54:58 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/04/19 11:43:31 1.2 @@ -37,6 +37,11 @@ (with-radio-box (:type :some-of) (make-pane 'toggle-button :label "Bold" :id :bold) (make-pane 'toggle-button :label "Italic" :id :italic))) + (rectangle + (with-radio-box () + (radio-box-current-selection + (make-pane 'toggle-button :label "Text-Size" :id :text-size)) + (make-pane 'toggle-button :label "Text-Bounding-Rectangle" :id :text-bounding-rectangle))) (size (make-pane 'slider :orientation :horizontal @@ -49,7 +54,8 @@ (labelling (:label "Text") text) (horizontally () (labelling (:label "Family") family) - (labelling (:label "Face") face)) + (labelling (:label "Face") face) + (labelling (:label "Rectangle") rectangle)) (labelling (:label "Size") size) canvas)))) @@ -62,6 +68,7 @@ (family (gadget-id (gadget-value (find-pane-named frame 'family)))) (faces (mapcar #'gadget-id (gadget-value (find-pane-named frame 'face)))) + (rectangle (gadget-id (gadget-value (find-pane-named frame 'rectangle)))) (face (if (cdr faces) '(:bold :italic) (car faces))) (style (make-text-style family face size))) (multiple-value-bind (width height final-x final-y baseline) @@ -78,16 +85,26 @@ ;;; (setf (stream-cursor-position stream) (values x1 y1)) ;;; (with-text-style (stream style) ;;; (write-string str stream)) - (draw-rectangle* stream - x1 y1 - (+ x1 width) (+ y1 height) - :ink +red+ - :filled nil) - (draw-rectangle* stream - x1 y1 - (+ x1 final-x) (+ y1 final-y) - :ink +blue+ - :filled nil))))) + (ecase rectangle + ((:text-size) + (draw-rectangle* stream + x1 y1 + (+ x1 width) (+ y1 height) + :ink +red+ + :filled nil) + (draw-rectangle* stream + x1 y1 + (+ x1 final-x) (+ y1 final-y) + :ink +blue+ + :filled nil)) + ((:text-bounding-rectangle) + (multiple-value-bind (left top right bottom) + (climi::text-bounding-rectangle* (sheet-medium stream) str :text-style style) + (draw-rectangle* stream + (+ x1 left) (+ y1 baseline top) + (+ x1 right) (+ y1 baseline bottom) + :ink +purple+ + :filled nil)))))))) (define-text-size-test-command (com-quit-text-size-test :menu "Quit") () (frame-exit *application-frame*)) From afuchs at common-lisp.net Thu Apr 20 22:40:48 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 20 Apr 2006 18:40:48 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060420224048.D60A045005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19078 Modified Files: incremental-redisplay.lisp Log Message: Improve constant factors on compute-difference-set. * now does more things in only one iteration over: * is, is-table, come, stay * was, was-table. * big-O improvements left as an exercise to the reader or evaluator. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/03/10 21:58:13 1.54 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:40:48 1.55 @@ -748,75 +748,79 @@ (defmethod compute-difference-set ((record standard-updating-output-record) &optional (check-overlapping t) - offset-x offset-y - old-offset-x old-offset-y) + offset-x offset-y + old-offset-x old-offset-y) (declare (ignore offset-x offset-y old-offset-x old-offset-y)) ;; (declare (values erases moves draws erase-overlapping move-overlapping)) (let (was is + stay + come (everywhere (or +everywhere+ - (pane-viewport-region (updating-output-stream record))))) - ;; Collect what was there - (labels ((gather-was (record) - (cond ((displayed-output-record-p record) - (push record was)) - ((updating-output-record-p record) - (cond ((eq :clean (output-record-dirty record)) - (push record was)) - ((eq :moved (output-record-dirty record)) - (push (slot-value record 'old-bounds) was)) - (t - (map-over-output-records-overlapping-region #'gather-was - (old-children record) - everywhere)))) + (pane-viewport-region (updating-output-stream record)))) + (was-table (make-hash-table :test #'equalp)) + (is-table (make-hash-table :test #'equalp))) + + (labels ((collect-1-was (record) + (push record was) + (push record (gethash (output-record-hash record) was-table))) + (collect-1-is (record) + (push record is) + (push record (gethash (output-record-hash record) is-table)) + ;; come = is \ was + ;; stay = is ^ was + (cond ((updating-output-record-p record) + (if (eq :clean (output-record-dirty record)) + (push record stay) + (push record come))) (t - (map-over-output-records-overlapping-region #'gather-was record everywhere)) ))) - (gather-was record)) - ;; Collect what still is there - (labels ((gather-is (record) - (cond ((displayed-output-record-p record) - (push record is)) - ((updating-output-record-p record) - (cond ((eq :clean (output-record-dirty record)) - (push record is)) - ((eq :moved (output-record-dirty record)) - (push record is)) - (t - (map-over-output-records-overlapping-region #'gather-is - (sub-record record) - everywhere)))) - (t - (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) - (gather-is record)) + (let ((q (gethash (output-record-hash record) was-table))) + (if (some #'(lambda (x) (output-record-equal record x)) q) + (push record stay) + (push record come))))))) + ;; Collect what was there + (labels ((gather-was (record) + (cond ((displayed-output-record-p record) + (collect-1-was record)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) + (collect-1-was record)) + ((eq :moved (output-record-dirty record)) + (collect-1-was (slot-value record 'old-bounds))) + (t + (map-over-output-records-overlapping-region #'gather-was + (old-children record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-was record everywhere))))) + (gather-was record)) + ;; Collect what still is there + (labels ((gather-is (record) + (cond ((displayed-output-record-p record) + (collect-1-is record)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) + (collect-1-is record)) + ((eq :moved (output-record-dirty record)) + (collect-1-is record)) + (t + (map-over-output-records-overlapping-region #'gather-is + (sub-record record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) + (gather-is record))) ;; - (let ((was-table (make-hash-table :test #'equalp)) - (is-table (make-hash-table :test #'equalp)) - gone - stay - come) - (loop for w in was do (push w (gethash (output-record-hash w) was-table))) - (loop for i in is do (push i (gethash (output-record-hash i) is-table))) + (let (gone) ;; gone = was \ is (loop for w in was do - (cond ((updating-output-record-p w) - (unless (eq :clean (output-record-dirty w)) - (push (old-children w) gone))) - (t - (let ((q (gethash (output-record-hash w) is-table))) - (unless (some #'(lambda (x) (output-record-equal w x)) q) - (push w gone)))))) - ;; come = is \ was - ;; stay = is ^ was - (loop for i in is do - (cond ((updating-output-record-p i) - (if (eq :clean (output-record-dirty i)) - (push i stay) - (push i come))) - (t - (let ((q (gethash (output-record-hash i) was-table))) - (if (some #'(lambda (x) (output-record-equal i x)) q) - (push i stay) - (push i come)))))) + (cond ((updating-output-record-p w) + (unless (eq :clean (output-record-dirty w)) + (push (old-children w) gone))) + (t + (let ((q (gethash (output-record-hash w) is-table))) + (unless (some #'(lambda (x) (output-record-equal w x)) q) + (push w gone)))))) ;; Now we essentially want 'gone', 'stay', 'come' (let ((gone-overlap nil) (come-overlap nil)) @@ -825,14 +829,14 @@ (loop for k in gone if (some (lambda (x) (region-intersects-region-p k x)) stay) - collect k into gone-overlap* + collect k into gone-overlap* else collect k into gone* finally (return (values gone* gone-overlap*)))) (setf (values come come-overlap) (loop for k in come if (some (lambda (x) (region-intersects-region-p k x)) stay) - collect k into come-overlap* + collect k into come-overlap* else collect k into come* finally (return (values come* come-overlap*))))) ;; Hmm, we somehow miss come-overlap ... From afuchs at common-lisp.net Thu Apr 20 22:43:47 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 20 Apr 2006 18:43:47 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060420224347.8955D4707A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19230 Modified Files: incremental-redisplay.lisp Log Message: Improve constant factors on compute-difference-set further * gather-was and gather-is do the same, too. merge them. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:40:48 1.55 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:43:47 1.56 @@ -778,38 +778,24 @@ (if (some #'(lambda (x) (output-record-equal record x)) q) (push record stay) (push record come))))))) - ;; Collect what was there - (labels ((gather-was (record) + ;; Collect what was there and what's still there + (labels ((gather-was-and-is (record) (cond ((displayed-output-record-p record) (collect-1-was record)) ((updating-output-record-p record) (cond ((eq :clean (output-record-dirty record)) - (collect-1-was record)) - ((eq :moved (output-record-dirty record)) - (collect-1-was (slot-value record 'old-bounds))) - (t - (map-over-output-records-overlapping-region #'gather-was - (old-children record) - everywhere)))) - (t - (map-over-output-records-overlapping-region #'gather-was record everywhere))))) - (gather-was record)) - ;; Collect what still is there - (labels ((gather-is (record) - (cond ((displayed-output-record-p record) - (collect-1-is record)) - ((updating-output-record-p record) - (cond ((eq :clean (output-record-dirty record)) + (collect-1-was record) (collect-1-is record)) ((eq :moved (output-record-dirty record)) + (collect-1-was (slot-value record 'old-bounds)) (collect-1-is record)) (t - (map-over-output-records-overlapping-region #'gather-is - (sub-record record) + (map-over-output-records-overlapping-region #'gather-was-and-is + (old-children record) everywhere)))) (t - (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) - (gather-is record))) + (map-over-output-records-overlapping-region #'gather-was-and-is record everywhere))))) + (gather-was-and-is record))) ;; (let (gone) ;; gone = was \ is From afuchs at common-lisp.net Thu Apr 20 22:53:15 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 20 Apr 2006 18:53:15 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060420225315.B96D34D008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20802 Modified Files: incremental-redisplay.lisp Log Message: argh. revert the last constant-factors fold. gather-was and gather-is are fundamentally different. file under lessons learned. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:43:47 1.56 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:53:15 1.57 @@ -778,24 +778,38 @@ (if (some #'(lambda (x) (output-record-equal record x)) q) (push record stay) (push record come))))))) - ;; Collect what was there and what's still there - (labels ((gather-was-and-is (record) + ;; Collect what was there + (labels ((gather-was (record) (cond ((displayed-output-record-p record) (collect-1-was record)) ((updating-output-record-p record) (cond ((eq :clean (output-record-dirty record)) - (collect-1-was record) + (collect-1-was record)) + ((eq :moved (output-record-dirty record)) + (collect-1-was (slot-value record 'old-bounds))) + (t + (map-over-output-records-overlapping-region #'gather-was + (old-children record) + everywhere)))) + (t + (map-over-output-records-overlapping-region #'gather-was record everywhere))))) + (gather-was record)) + ;; Collect what still is there + (labels ((gather-is (record) + (cond ((displayed-output-record-p record) + (collect-1-is record)) + ((updating-output-record-p record) + (cond ((eq :clean (output-record-dirty record)) (collect-1-is record)) ((eq :moved (output-record-dirty record)) - (collect-1-was (slot-value record 'old-bounds)) (collect-1-is record)) (t - (map-over-output-records-overlapping-region #'gather-was-and-is - (old-children record) + (map-over-output-records-overlapping-region #'gather-is + (sub-record record) everywhere)))) (t - (map-over-output-records-overlapping-region #'gather-was-and-is record everywhere))))) - (gather-was-and-is record))) + (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) + (gather-is record))) ;; (let (gone) ;; gone = was \ is From afuchs at common-lisp.net Thu Apr 20 23:21:35 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 20 Apr 2006 19:21:35 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060420232135.41B203059@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25992 Modified Files: incremental-redisplay.lisp Log Message: Big O changes, this time. Some more constant factors, too. * Use a spatial tree for the "stay" records and query it. Note that I said "changes", not improvements. It's 1:30 in the morning, so I'll leave the benchmarking to others. (: * Also, build the list of gone-overlap, come-overlap, come and gone records "right" the first time around, so we can just return it unmodified, without having to mapcar (list x x) over them first. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 22:53:15 1.57 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 23:21:35 1.58 @@ -759,7 +759,8 @@ (everywhere (or +everywhere+ (pane-viewport-region (updating-output-stream record)))) (was-table (make-hash-table :test #'equalp)) - (is-table (make-hash-table :test #'equalp))) + (is-table (make-hash-table :test #'equalp)) + (stay-tree (%make-tree-output-record-tree))) (labels ((collect-1-was (record) (push record was) @@ -776,7 +777,8 @@ (t (let ((q (gethash (output-record-hash record) was-table))) (if (some #'(lambda (x) (output-record-equal record x)) q) - (push record stay) + (spatial-trees:insert + (make-tree-output-record-entry record 0) stay-tree) (push record come))))))) ;; Collect what was there (labels ((gather-was (record) @@ -827,29 +829,28 @@ (when check-overlapping (setf (values gone gone-overlap) (loop for k in gone - if (some (lambda (x) (region-intersects-region-p k x)) - stay) - collect k into gone-overlap* - else collect k into gone* + if (spatial-trees:search (%record-to-spatial-tree-rectangle k) + stay-tree) + collect (list k k) into gone-overlap* + else collect (list k k) into gone* finally (return (values gone* gone-overlap*)))) (setf (values come come-overlap) (loop for k in come - if (some (lambda (x) (region-intersects-region-p k x)) - stay) - collect k into come-overlap* - else collect k into come* + if (spatial-trees:search (%record-to-spatial-tree-rectangle k) + stay-tree) + collect (list k k) into come-overlap* + else collect (list k k) into come* finally (return (values come* come-overlap*))))) ;; Hmm, we somehow miss come-overlap ... (values ;; erases - (loop for k in gone collect (list k k)) + gone ;; moves nil ;; draws - (loop for k in come collect (list k k)) + come ;; erase overlapping - (append (loop for k in gone-overlap collect (list k k)) - (loop for k in come-overlap collect (list k k))) + (append gone-overlap come-overlap) ;; move overlapping nil))))) From afuchs at common-lisp.net Thu Apr 20 23:25:23 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 20 Apr 2006 19:25:23 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060420232523.70AA24006@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26160 Modified Files: incremental-redisplay.lisp Log Message: Remove the STAY list for good from c-d-set. Agh. Save your buffers before committing. Sorry for the commits spam. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 23:21:35 1.58 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 23:25:23 1.59 @@ -754,7 +754,6 @@ ;; (declare (values erases moves draws erase-overlapping move-overlapping)) (let (was is - stay come (everywhere (or +everywhere+ (pane-viewport-region (updating-output-stream record)))) @@ -772,7 +771,8 @@ ;; stay = is ^ was (cond ((updating-output-record-p record) (if (eq :clean (output-record-dirty record)) - (push record stay) + (spatial-trees:insert + (make-tree-output-record-entry record 0) stay-tree) (push record come))) (t (let ((q (gethash (output-record-hash record) was-table))) From crhodes at common-lisp.net Fri Apr 21 12:03:23 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 21 Apr 2006 08:03:23 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060421120323.6C20924002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv30320 Modified Files: commands.lisp Log Message: the command-table-error subclasses must handle :format-control and :format-arguments. Make it so, and test for it (and also test that not passing them doesn't lead to an unprintable condition. New test file input-editing, for an invariant I spotted while browsing. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/23 17:03:38 1.61 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/04/21 12:03:23 1.62 @@ -95,8 +95,9 @@ (defparameter *command-tables* (make-hash-table :test #'eq)) -(define-condition command-table-error (error) - ()) +(define-condition command-table-error (simple-error) + () + (:default-initargs :format-control "" :format-arguments nil)) (define-condition command-table-not-found (command-table-error) ()) From crhodes at common-lisp.net Fri Apr 21 12:03:23 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 21 Apr 2006 08:03:23 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Tests Message-ID: <20060421120323.A15D328078@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Tests In directory clnet:/tmp/cvs-serv30320/Tests Modified Files: commands.lisp Added Files: input-editing.lisp Log Message: the command-table-error subclasses must handle :format-control and :format-arguments. Make it so, and test for it (and also test that not passing them doesn't lead to an unprintable condition. New test file input-editing, for an invariant I spotted while browsing. --- /project/mcclim/cvsroot/mcclim/Tests/commands.lisp 2006/03/23 17:03:40 1.3 +++ /project/mcclim/cvsroot/mcclim/Tests/commands.lisp 2006/04/21 12:03:23 1.4 @@ -50,3 +50,23 @@ 'removal-test-table) (command-not-present () t) (:no-error (x) (declare (ignore x)) nil))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; command table errors (see 27.2) +(assert (subtypep 'command-table-error 'error)) +(assert (subtypep 'command-table-not-found 'command-table-error)) +(assert (subtypep 'command-table-already-exists 'command-table-error)) +(assert (subtypep 'command-not-present 'command-table-error)) +(assert (subtypep 'command-not-accessible 'command-table-error)) +(assert (subtypep 'command-already-present 'command-table-error)) + +(let ((condition (make-condition 'command-table-error + :format-control "~A" + :format-arguments '(!)))) + (assert (find #\! (format nil "~A" condition)))) +;;; not actually required to DTRT here, but we use this form (without +;;; control and arguments) internally, so make sure that we don't +;;; error out recursively when in the debugger with one of these. +(let ((condition (make-condition 'command-not-present))) + (format nil "~A" condition)) --- /project/mcclim/cvsroot/mcclim/Tests/input-editing.lisp 2006/04/21 12:03:23 NONE +++ /project/mcclim/cvsroot/mcclim/Tests/input-editing.lisp 2006/04/21 12:03:23 1.1 (defpackage :clim-tests (:use :clim-lisp :clim)) (in-package :clim-tests) (assert (null *activation-gestures*)) From afuchs at common-lisp.net Sat Apr 22 15:31:27 2006 From: afuchs at common-lisp.net (afuchs) Date: Sat, 22 Apr 2006 11:31:27 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060422153127.96200583E0@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv32675 Modified Files: incremental-redisplay.lisp Log Message: Back out the spatial-trees change to compute-difference-set. --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/20 23:25:23 1.59 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/04/22 15:31:27 1.60 @@ -754,12 +754,12 @@ ;; (declare (values erases moves draws erase-overlapping move-overlapping)) (let (was is + stay come (everywhere (or +everywhere+ (pane-viewport-region (updating-output-stream record)))) (was-table (make-hash-table :test #'equalp)) - (is-table (make-hash-table :test #'equalp)) - (stay-tree (%make-tree-output-record-tree))) + (is-table (make-hash-table :test #'equalp))) (labels ((collect-1-was (record) (push record was) @@ -771,14 +771,12 @@ ;; stay = is ^ was (cond ((updating-output-record-p record) (if (eq :clean (output-record-dirty record)) - (spatial-trees:insert - (make-tree-output-record-entry record 0) stay-tree) + (push record stay) (push record come))) (t (let ((q (gethash (output-record-hash record) was-table))) (if (some #'(lambda (x) (output-record-equal record x)) q) - (spatial-trees:insert - (make-tree-output-record-entry record 0) stay-tree) + (push record stay) (push record come))))))) ;; Collect what was there (labels ((gather-was (record) @@ -829,15 +827,15 @@ (when check-overlapping (setf (values gone gone-overlap) (loop for k in gone - if (spatial-trees:search (%record-to-spatial-tree-rectangle k) - stay-tree) + if (some (lambda (x) (region-intersects-region-p k x)) + stay) collect (list k k) into gone-overlap* else collect (list k k) into gone* finally (return (values gone* gone-overlap*)))) (setf (values come come-overlap) (loop for k in come - if (spatial-trees:search (%record-to-spatial-tree-rectangle k) - stay-tree) + if (some (lambda (x) (region-intersects-region-p k x)) + stay) collect (list k k) into come-overlap* else collect (list k k) into come* finally (return (values come* come-overlap*))))) From dlichteblau at common-lisp.net Sun Apr 23 10:18:45 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 23 Apr 2006 06:18:45 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060423101845.C22266D157@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv11052 Modified Files: NOTES clim-fix.lisp event.lisp gadgets.lisp gtk-ffi.lisp medium.lisp port.lisp Added Files: BUGS Log Message: * medium.lisp (GTKAIRO-MEDIUM, LAST-SEEN-SHEET, LAST-SEEN-REGION, INITIALIZE-INSTANCE, SHEET-CHANGED-BEHIND-OUR-BACK-P, SYNC-SHEET): Reinstate the last-seen-sheet logic, required for the pixmap trickery in drag&drop. (*ANTIALIASINGP*): Set to T again! (SYNC-TRANSFORMATION): Use the identity transformation for mediums without a sheet. (DRAW-ELLIPSE*, SYNC-TRANSFORMATION): Handle an additional transformation argument again. Fixes ellipse drawing to at least not error out. (CLIMI::TEXT-BOUNDING-RECTANGLE*): Use x_bearing+width instead of x_advance. Seems to look correct in the visual test now (try italic f). (flipping-original-cr, flipping-pixmap, invoke-with-cairo-medium, apply-flipping-ink, (sync-ink standard-flipping-ink)): Implemented flipping ink. * gtk-ffi.lisp (gdk_gc_set_function, gtk_widget_size_request): New functions. (gdkfunction): Enum. (gtkrequisition): Struct. * event.lisp (connect-signals, noop-handler): Override focus-in/out to reduce flicker. (gtk-main-iteration): Oops. If `block' is given, make it so. * clim-fix.lisp (highlight-output-record-rectangle): Adjust rectangle coordinates by half a pixel each to avoid anti-aliasing (and follow-up output artifacts). * port.lisp (port-set-mirror-region, mirror, mirror-region): Don't resize if the region hasn't actually changed. (gtk-widget-modify-bg, sheet-desired-color, realize-mirror): New wrapper function gtk-widget-modify-bg for gtk_widget_modify_bg. (native-widget-mixin, native-widget, (destroy-mirror native-widget-mixin)): New Accessor native-widget. ((realize-mirror native-widget-mixin)): Create the native widget before asking the sheet for space requirements. * gadgets.lisp ((realize-native-widget gtk-button)): Set button background color to pane-background. See BUGS. (gtk-button): Subclass the abstract gadgets, not the virtual default panes. (compose-space): Ask GTK+ for default sizes. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/NOTES 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/NOTES 2006/04/23 10:18:45 1.2 @@ -113,7 +113,11 @@ ;; by Cairo and will perhaps stop working around 2012. The fun thing is: ;; Flipping will now turn into a rather slow operation. -[ David: Das ginge auch mit Cairo, ja. ] +[ David: I have implemented this strategy now. We draw flipping ink to + a gdk pixmap, then copy that over with GDK_XOR. And indeed, Goatee + now is extremely slow over remote X because it uses flipping ink. + FIXME: Although simple cases work, sometimes flipping ink now causes + garbage output to appear. ] ;; - flipping ink ;; @@ -125,3 +129,6 @@ ;; But: A flippink can't be solved by just setting up the proper Cairo pattern ;; to a Cairo context, but drawing the shape itself must happen on our ;; temporary surface. + +[ David: see above for my implemenation of flipping ink. Not sure how the + alpha channel is meant to be handled though. ] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/04/23 10:18:45 1.2 @@ -24,3 +24,24 @@ (defmethod clim:handle-repaint :after ((s clim:sheet-with-medium-mixin) r) (medium-force-output (sheet-medium s))) + +;; cairo hack: adjust rectangle coordinates by half a pixel each to avoid +;; anti-aliasing (and follow-up output artifacts) +(defun highlight-output-record-rectangle (record stream state) + (with-identity-transformation (stream) + (multiple-value-bind (x1 y1 x2 y2) + (output-record-hit-detection-rectangle* record) + (ecase state + (:highlight + (draw-rectangle* (sheet-medium stream) + (+ (ceiling x1) 0.5d0) + (+ (ceiling y1) 0.5d0) + (+ (floor (1- x2)) 0.5d0) + (+ (floor (1- y2)) 0.5d0) + ;; XXX +FLIPPING-INK+? + :filled nil :ink +foreground-ink+)) + (:unhighlight + ;; FIXME: repaint the hit detection rectangle. It could be + ;; bigger than + ;; the bounding rectangle. + (repaint-sheet stream record)))))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/17 18:46:18 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/23 10:18:45 1.3 @@ -50,7 +50,11 @@ (connect-signal widget "key-release-event" 'key-handler) (connect-signal widget "enter-notify-event" 'enter-handler) (connect-signal widget "leave-notify-event" 'leave-handler) - (connect-signal widget "configure-event" 'configure-handler)) + (connect-signal widget "configure-event" 'configure-handler) + ;; override gtkwidget's focus handlers, which trigger an expose event, + ;; causing unnecessary redraws for mouse movement + (connect-signal widget "focus-in-event" 'noop-handler) + (connect-signal widget "focus-out-event" 'noop-handler)) (defun connect-window-signals (widget) (gtk_widget_add_events widget (logior GDK_STRUCTURE_MASK @@ -85,8 +89,10 @@ (defun gtk-main-iteration (port &optional block) (with-gtk () (let ((*port* port)) - (while (plusp (gtk_events_pending)) - (gtk_main_iteration_do (if block 1 0)))))) + (if block + (gtk_main_iteration_do 1) + (while (plusp (gtk_events_pending)) + (gtk_main_iteration_do 0)))))) (defmethod get-next-event ((port gtkairo-port) &key wait-function (timeout nil)) @@ -111,6 +117,8 @@ data (,impl widget event))))) +(define-signal noop-handler (widget event)) + (define-signal expose-handler (widget event) (enqueue (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/23 10:18:45 1.2 @@ -33,7 +33,7 @@ ;; vielleicht, von TOGGLE-BUTTON statt TOGGLE-BUTTON-PANE zu erben und ;; alles selbst zu machen. Mindestens COMPOSE-SPACE muesste man dann ;; hier implementieren. -(defclass gtk-button (native-widget-mixin push-button-pane) ()) +(defclass gtk-button (native-widget-mixin push-button) ()) (defclass gtk-check-button (native-widget-mixin toggle-button-pane) ()) (defclass gtk-radio-button (native-widget-mixin toggle-button-pane) ()) (defclass gtk-vscale (native-widget-mixin slider-pane) ()) @@ -45,7 +45,10 @@ ;;;; Constructors (defmethod realize-native-widget ((sheet gtk-button)) - (gtk_button_new_with_label (climi::gadget-label sheet))) + (let ((button (gtk_button_new_with_label (climi::gadget-label sheet)))) + (when (pane-background sheet) + (gtk-widget-modify-bg button (pane-background sheet))) + button)) (defmethod realize-native-widget ((sheet gtk-check-button)) (gtk_check_button_new_with_label (climi::gadget-label sheet))) @@ -166,3 +169,18 @@ ;; see hack in clicked-handler (gtk_toggle_button_set_active (mirror-widget mirror) (if value 1 0)))))) + +;; KLUDGE: this is getting called before the sheet has been realized. +(defmethod compose-space ((gadget native-widget-mixin) &key width height) + (declare (ignore width height)) + (let* ((widget (native-widget gadget)) + (widgetp widget)) + (unless widgetp + (setf widget (realize-native-widget gadget))) + (prog1 + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request widget r) + (cffi:with-foreign-slots ((width height) r gtkrequisition) + (make-space-requirement :width width :height height))) + (unless widgetp + (gtk_widget_destroy widget))))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/17 18:46:18 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/23 10:18:45 1.3 @@ -139,6 +139,10 @@ (gdkwindow :pointer) (parent :pointer)) +(cffi:defcstruct gtkrequisition + (width :int) + (height :int)) + (defun gtkwidget-header (widget) (cffi:foreign-slot-value widget 'gtkwidget 'header)) @@ -253,6 +257,10 @@ (max_aspect :double) (win_gravity :int)) +(cffi:defcenum gdkfunction + :copy :invert :xor :clear :and :and_reverse :and_invert :noop :or :equiv + :or_reverse :copy_invert :or_invert :nand :nor :set) + ;;; GTK functions @@ -322,6 +330,11 @@ (width :pointer) (height :pointer)) +(defcfun "gtk_widget_size_request" + :void + (widget :pointer) + (requisition :pointer)) + (defcfun "gtk_container_add" :void (parent :pointer) @@ -534,6 +547,11 @@ :void (drawable :pointer)) +(defcfun "gdk_gc_set_function" + :void + (gc :pointer) + (function gdkfunction)) + (defcfun "gdk_draw_drawable" :void (drawable :pointer) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/17 18:48:52 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/23 10:18:45 1.3 @@ -32,7 +32,16 @@ (defclass gtkairo-medium (climi::basic-medium clim:medium) ((port :initarg :port :accessor port) (cr :initform nil :initarg :cr :accessor cr) - (surface :initarg :surface :accessor surface))) + (flipping-original-cr :initform nil :accessor flipping-original-cr) + (flipping-pixmap :accessor flipping-pixmap) + (surface :initarg :surface :accessor surface) + (last-seen-sheet :accessor last-seen-sheet) + (last-seen-region :accessor last-seen-region))) + +(defmethod initialize-instance :after + ((instance gtkairo-medium) &key cr) + (unless cr + (setf (last-seen-sheet instance) nil))) (defclass metrik-medium (gtkairo-medium) ()) @@ -43,7 +52,7 @@ ;; 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* nil) +(defparameter *antialiasingp* t) (defun gtkwidget-gdkwindow (widget) (cffi:foreign-slot-value widget 'gtkwidget 'gdkwindow)) @@ -59,16 +68,28 @@ (when (or (cr medium) (climi::port-lookup-mirror (port medium) (medium-sheet medium))) (with-gtk () - (funcall fn)))) + (multiple-value-prog1 + (funcall fn) + (when (flipping-original-cr medium) + (apply-flipping-ink medium)))))) + +(defun sheet-changed-behind-our-back-p (medium) + (and (slot-boundp medium 'last-seen-sheet) + (or (not (eq (last-seen-sheet medium) (medium-sheet medium))) + (not (region-equal (last-seen-region medium) + (sheet-region (medium-sheet medium))))))) (defun sync-sheet (medium) - (unless (cr medium) + (when (or (null (cr medium)) + (sheet-changed-behind-our-back-p medium)) (with-cairo-medium (medium) (let* ((mirror (medium-mirror medium)) (drawable (mirror-drawable mirror))) (setf (cr medium) (gdk_cairo_create drawable)) (push medium (mirror-mediums mirror)) - (cairo_set_antialias (cr medium) (if *antialiasingp* 0 1)))))) + (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)))))) ;;;; ------------------------------------------------------------------------ @@ -88,16 +109,21 @@ ;;;; Drawing Options ;;;; -(defun sync-transformation (medium) +(defun sync-transformation (medium &optional extra-transformation) (with-slots (cr) medium (cffi:with-foreign-object (matrix 'cairo_matrix_t) - (multiple-value-bind (mxx mxy myx myy tx ty) - (climi::get-transformation - (sheet-native-transformation (medium-sheet medium))) - (cairo_matrix_init matrix - (df mxx) (df mxy) (df myx) (df myy) - (df tx) (df ty)) - (cairo_set_matrix cr matrix))))) + (let ((tr + (if (medium-sheet medium) + (sheet-native-transformation (medium-sheet medium)) + clim:+identity-transformation+))) + (when extra-transformation + (setf tr (compose-transformations extra-transformation tr))) + (multiple-value-bind (mxx mxy myx myy tx ty) + (climi::get-transformation tr) + (cairo_matrix_init matrix + (df mxx) (df mxy) (df myx) (df myy) + (df tx) (df ty)) + (cairo_set_matrix cr matrix)))))) (defmacro with-cairo-matrix ((matrix transformation) &body body) `(cffi:with-foreign-object (,matrix 'cairo_matrix_t) @@ -182,11 +208,39 @@ (cairo_pattern_set_matrix p matrix)) p))) +(defun apply-flipping-ink (medium) + (let ((from-surface (cairo_get_target (cr medium))) + (from-drawable (flipping-pixmap medium)) + (to-surface (cairo_get_target (flipping-original-cr medium))) + (to-drawable (medium-gdkdrawable medium))) + (cairo_surface_flush from-surface) + (cairo_surface_flush to-surface) + (let ((gc (gdk_gc_new to-drawable))) + (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_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)) + (defmethod sync-ink (medium (design climi::standard-flipping-ink)) - (with-slots ((d1 climi::design1) (d2 climi::design2)) design - (with-slots (cr) medium - (cairo_set_source_rgba cr 1.0d0 1.0d0 1.0d0 1d0) - (cairo_set_operator cr :xor)))) + (setf (flipping-original-cr medium) (cr medium)) + (let* ((mirror (medium-mirror medium)) + (drawable (mirror-drawable mirror))) + (cffi:with-foreign-slots ((allocation-width allocation-height) + (mirror-widget mirror) + gtkwidget) + (let ((pixmap + (gdk_pixmap_new drawable allocation-width allocation-height -1))) + (setf (cr medium) (gdk_cairo_create pixmap)) + (setf (flipping-pixmap medium) pixmap) + (sync-transformation medium) + (sync-ink medium +white+))))) (defmethod sync-ink (medium new-value) (warn "SYNC-INK lost ~S." new-value)) @@ -524,9 +578,7 @@ (+ cx rx2) (+ cy ry2)))) (sync-sheet medium) ;; hmm, something is wrong here. - (sync-transformation - medium - (compose-transformations tr (medium-transformation medium))) + (sync-transformation medium tr) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) @@ -809,11 +861,11 @@ ;; whether it's 100% right: ;; --DFL (cffi:with-foreign-slots - ((height x_advance y_advance x_bearing y_bearing) + ((width height x_advance y_advance x_bearing y_bearing) res cairo_text_extents) - (values (ceiling x_bearing) - (ceiling y_bearing) - (ceiling x_advance) + (values (floor x_bearing) + (floor y_bearing) + (ceiling (+ width (max 0 x_bearing))) (ceiling (+ height y_bearing)))))))) ;;;; ------------------------------------------------------------------------ --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/04/23 10:18:45 1.2 @@ -102,7 +102,8 @@ ;;;; Mirrors (defclass mirror () - ((mediums :initform '() :accessor mirror-mediums))) + ((mediums :initform '() :accessor mirror-mediums) + (region :initform nil :accessor mirror-region))) (defclass widget-mirror (mirror) ((widget :initarg :widget :accessor mirror-widget) @@ -181,24 +182,32 @@ ((port gtkairo-port) (sheet climi::unmanaged-top-level-sheet-pane)) (realize-window-mirror port sheet GTK_WINDOW_POPUP)) +(defun gtk-widget-modify-bg (widget color) + (cffi:with-foreign-object (c 'gdkcolor) + (setf (cffi:foreign-slot-value c 'gdkcolor 'pixel) 0) + (setf (values (cffi:foreign-slot-value c 'gdkcolor 'r) + (cffi:foreign-slot-value c 'gdkcolor 'g) + (cffi:foreign-slot-value c 'gdkcolor 'b)) + (multiple-value-bind (r g b) + (color-rgb color) + (values (min (truncate (* r 65536)) 65535) + (min (truncate (* g 65536)) 65535) + (min (truncate (* b 65536)) 65535)))) + (gtk_widget_modify_bg widget 0 c))) + ;; copy&paste from port.lisp|CLX: (defun sheet-desired-color (sheet) - (multiple-value-bind (r g b) - (color-rgb - (typecase sheet - (sheet-with-medium-mixin - (medium-background sheet)) - (basic-pane - ;; CHECKME [is this sensible?] seems to be - (let ((background (pane-background sheet))) - (if (typep background 'color) - background - +white+))) - (t - +white+))) - (values (min (truncate (* r 65536)) 65535) - (min (truncate (* g 65536)) 65535) - (min (truncate (* b 65536)) 65535)))) + (typecase sheet + (sheet-with-medium-mixin + (medium-background sheet)) + (basic-pane + ;; CHECKME [is this sensible?] seems to be + (let ((background (pane-background sheet))) + (if (typep background 'color) + background + +white+))) + (t + +white+))) (defmethod realize-mirror ((port gtkairo-port) (sheet mirrored-sheet-mixin)) (with-gtk () @@ -223,25 +232,21 @@ (setf y (round-coordinate y)) (gtk_fixed_put (mirror-widget parent) widget x y)) (climi::port-register-mirror (port sheet) sheet mirror) - (cffi:with-foreign-object (color 'gdkcolor) - (setf (cffi:foreign-slot-value color 'gdkcolor 'pixel) 0) - (setf (values (cffi:foreign-slot-value color 'gdkcolor 'r) - (cffi:foreign-slot-value color 'gdkcolor 'g) - (cffi:foreign-slot-value color 'gdkcolor 'b)) - (sheet-desired-color sheet)) - (gtk_widget_modify_bg widget 0 color)) + (gtk-widget-modify-bg widget (sheet-desired-color sheet)) (when (sheet-enabled-p sheet) (gtk_widget_show widget)) mirror))) -(defclass native-widget-mixin () ()) +(defclass native-widget-mixin () + ((widget :initform nil :accessor native-widget))) (defmethod realize-mirror ((port gtkairo-port) (sheet native-widget-mixin)) (with-gtk () - (let* ((parent (sheet-mirror (sheet-parent sheet))) + (setf (native-widget sheet) (realize-native-widget sheet)) + (let* ((widget (native-widget sheet)) + (parent (sheet-mirror (sheet-parent sheet))) (q (compose-space sheet)) (fixed (gtk_fixed_new)) - (widget (realize-native-widget sheet)) (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) (mirror @@ -312,6 +317,10 @@ (climi::port-unregister-mirror port sheet mirror) (setf (widget->sheet (mirror-widget mirror) port) nil)))) +(defmethod destroy-mirror :after + ((port gtkairo-port) (sheet native-widget-mixin)) + (setf (native-widget sheet) nil)) + (defmethod destroy-mirror ((port gtkairo-port) (pixmap-sheet climi::pixmap)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port pixmap-sheet))) @@ -346,12 +355,15 @@ (defmethod port-set-mirror-region ((port gtkairo-port) (mirror mirror) mirror-region) - (with-gtk () - (reset-mediums mirror) - (gtk_widget_set_size_request - (mirror-widget mirror) - (floor (bounding-rectangle-max-x mirror-region)) - (floor (bounding-rectangle-max-y mirror-region))))) + (unless (and (mirror-region mirror) + (region-equal (mirror-region mirror) mirror-region)) + (with-gtk () + (reset-mediums mirror) + (gtk_widget_set_size_request + (mirror-widget mirror) + (floor (bounding-rectangle-max-x mirror-region)) + (floor (bounding-rectangle-max-y mirror-region)))) + (setf (mirror-region mirror) mirror-region))) (defmethod port-set-mirror-region ((port gtkairo-port) (mirror native-widget-mirror) mirror-region) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/23 10:18:45 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/23 10:18:45 1.1 1. In the address book example example, the input cursor when typing and erasing characters is not getting removed properly, leaving a trace. 2. Also, the presentation highlighting rectangle leaves traces if antialiasing is enabled. 3. The text cursor does not show the correct horizontal position in climacs. 4. Menus appear but do not really work. Worth fixing, even though we would rather want native menus in the long term. 5a. Colored buttons (clim-fig) are missing. 5b. the slider is not quite right. 5c. Inheriting from the standard gadget panes is bogus anyway, we should build them from scratch. 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 moving the mouse gives an error. 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.) 8. The frontend specifies background colors (*3d-normal-color*) where the gtk theme should take precedence. 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. (Now that mouse movement doesn't trigger repaints anymore this is harder to reproduce, but sometimes it can still be triggered.) 10. Somewhere global mouse coordinates aren't turned into local coordinates correctly. (Watch the Drag&Drop test not work unless the window is in the upper left corner of the screen.) 11. The new flipping ink implementation is buggy, it produces garbage output in some cases. 12. In the address book, there are often wide grey borders instead of the narrow black ones. 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. Climacs doesn't draw itself until the window is resized. From dlichteblau at common-lisp.net Sun Apr 23 10:21:19 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 23 Apr 2006 06:21:19 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060423102119.E9A2270053@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv11222 Modified Files: BUGS Log Message: updated gtkairo bugs list --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/23 10:18:45 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/23 10:21:19 1.2 @@ -1,26 +1,26 @@ -1. +(FIXED) 1. [flipping ink is implemented now, but see 11.] In the address book example example, the input cursor when typing and erasing characters is not getting removed properly, leaving a trace. -2. +(FIXED) 2. [see clim-fix.lisp] Also, the presentation highlighting rectangle leaves traces if antialiasing is enabled. -3. +(FIXED) 3. The text cursor does not show the correct horizontal position in climacs. 4. Menus appear but do not really work. Worth fixing, even though we would rather want native menus in the long term. -5a. +(FIXED) 5a. [but see 8.] Colored buttons (clim-fig) are missing. 5b. the slider is not quite right. -5c. +(WORK IN PROGRESS) 5c. Inheriting from the standard gadget panes is bogus anyway, we should build them from scratch. @@ -30,7 +30,8 @@ 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 moving the mouse gives an error. + 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. From dlichteblau at common-lisp.net Sun Apr 23 10:42:39 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 23 Apr 2006 06:42:39 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060423104239.C01F419001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv13297 Modified Files: BUGS cairo-ffi.lisp medium.lisp Log Message: * cairo-ffi.lisp (cairo_paint): New function. * medium.lisp (sync-ink): cairo_paint the flipping ink context. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/23 10:21:19 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/23 10:42:39 1.3 @@ -58,7 +58,7 @@ coordinates correctly. (Watch the Drag&Drop test not work unless the window is in the upper left corner of the screen.) -11. +(FIXED) 11. The new flipping ink implementation is buggy, it produces garbage output in some cases. @@ -75,3 +75,6 @@ 14. Climacs doesn't draw itself until the window is resized. + +15. + The text cursor does not show the correct vertical position in climacs. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/04/23 10:42:39 1.2 @@ -807,3 +807,7 @@ :void (cr :pointer) (antialias :int)) + +(defcfun "cairo_paint" + :void + (cr :pointer)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/23 10:18:45 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/23 10:42:39 1.4 @@ -238,6 +238,7 @@ (let ((pixmap (gdk_pixmap_new drawable allocation-width allocation-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+))))) From dlichteblau at common-lisp.net Sun Apr 23 12:57:31 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 23 Apr 2006 08:57:31 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060423125731.89402550CF@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3890 Modified Files: mcclim.asd Log Message: * mcclim.asd (clim-examples): Don't conditionalize gadget-test on #+CLX. (I hope this doesn't break anything for anyone, but it _does_ work without CLX, I don't see a compilation time dependency on clim-looks either, and :clx isn't necessarily on *features* at system parse time anyway.) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/17 18:40:27 1.19 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/23 12:57:31 1.20 @@ -334,7 +334,7 @@ (:file "stream-test") (:file "presentation-test") (:file "dragndrop") - #+clx (:file "gadget-test") + (:file "gadget-test") (:file "accepting-values") (:file "method-browser") (:file "dragndrop-translator") From dlichteblau at common-lisp.net Sun Apr 23 15:42:42 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 23 Apr 2006 11:42:42 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20060423154242.F3AB32B007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv22853 Modified Files: gadget-test.lisp Log Message: * gadget-test.lisp (gadget-test): Rearranged the gadget test to not require a screen the size of a star ship bridge. --- /project/mcclim/cvsroot/mcclim/Examples/gadget-test.lisp 2005/01/02 05:29:19 1.12 +++ /project/mcclim/cvsroot/mcclim/Examples/gadget-test.lisp 2006/04/23 15:42:42 1.13 @@ -208,23 +208,28 @@ (:layouts (default (raising (:border-width 5 :background +Gray83+) - (vertically () - tf1 tf2 tf3 tf4 - slider-h - (horizontally () - (vertically () - slider-v - slider-v2) - slider-v3 - radar) - text-edit - push-btn - table - toggle-btn - scroll - radio-box - check-box - )))) + (horizontally () + (vertically () + (horizontally () + (horizontally () + (vertically () + slider-v + slider-v2) + slider-v3) + (vertically () + tf1 tf2 tf3 tf4 + slider-h)) + ;; FIXME: the radar doesn't seem to do anything except take + ;; up vast amounts of space. + #+(or) radar + text-edit) + (vertically () + push-btn + table + toggle-btn + scroll + radio-box + check-box))))) (:top-level (gadget-test-frame-top-level . nil))) (defmethod run-frame-top-level :around ((frame gadget-test) &key &allow-other-keys) From dlichteblau at common-lisp.net Sun Apr 23 17:36:28 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 23 Apr 2006 13:36:28 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060423173628.7EE23710E4@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv4775 Modified Files: BUGS cairo-ffi.lisp event.lisp frame-manager.lisp gadgets.lisp gtk-ffi.lisp medium.lisp Log Message: * medium.lisp (TEXT-STYLE-HEIGHT): McCLIM wants height = ascent + descent. Make it so. * cairo-ffi.lisp (*CAIRO-ERROR-MODE*, DEF-CAIRO-FUN): New variable and macro for cairo_status checking. (CAIRO_*): Use def-cairo-fun for (nearly) all functions taking a cairo context as an argument. * gtk-ffi.lisp (gtkscrolltype): New enum. (gtk_range_set_adjustment, gtk_adjustment_get_value, gtk_adjustment_set_value): New functions. * gadgets.lisp (GTK-CHECK-BUTTON, GTK-RADIO-BUTTON, GTK-VSCALE, GTK-HSCALE, GTK-VSCROLLBAR, GTK-HSCROLLBAR): Subclass the abstract gadgets directly. (NATIVE-SLIDER, NATIVE-SCROLLBAR): New class. (CLIMI::SHOW-VALUE-P, CLIMI::DECIMAL-PLACES, CLIMI::NUMBER-OF-QUANTA): New accessors. (HANDLE-REPAINT): Removed. (MAKE-GADGET-EVENT): Removed. (SCROLLBAR-CHANGE-VALUE-EVENT, MAGIC-GADGET-EVENT): New classes. (MAKE-SCALE): Set initial adjustment value. (MAKE-SCROLLBAR): Compute page size from thumb-size. Set step and page increments to zero. Set initial adjustment value. (CONNECT-NATIVE-SIGNALS): Replaced clicked-handler with magic-clicked-handler; collapsed identical methods. ((CONNECT-NATIVE-SIGNALS NATIVE-SCROLLBAR)): Establish change-value handler. (HANDLE-EVENT): Replaced gadget-event with magic-gadget-event; collapsed identical methods. ((HANDLE-EVENT SCROLLBAR-CHANGE-VALUE-EVENT)): New method. (UPDATE-SCROLLBAR-ADJUSTMENT): New function. ((SETF GADGET-MIN-VALUE), (SETF GADGET-MAX-VALUE), (SETF GADGET-VALUE), (SETF CLIMI::SCROLL-BAR-VALUES)): New methods on native-scrollbar. ((REALIZE-NATIVE-WIDGET GTK-CHECK-BUTTON), (REALIZE-NATIVE-WIDGET GTK-RADIO-BUTTON)): Set initial value. * event.lisp (DEFINE-SIGNAL): Let callers specify return-type and arguments. (CLICKED-HANDLER): Renamed to magic-clicked-handler. Make an instance of magic-gadget-event. (SCROLLBAR-CHANGE-VALUE-HANDLER): New function. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/23 10:42:39 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/23 17:36:28 1.4 @@ -18,13 +18,13 @@ Colored buttons (clim-fig) are missing. 5b. - the slider is not quite right. + the slider needs tick marks -(WORK IN PROGRESS) 5c. +(FIXED) 5c. Inheriting from the standard gadget panes is bogus anyway, we should build them from scratch. -5d. +(FIXED) 5d. Default gadget values aren't being used. 6. @@ -76,5 +76,10 @@ 14. Climacs doesn't draw itself until the window is resized. -15. +(FIXED) 15. The text cursor does not show the correct vertical position in climacs. + +16. + Scroll panes are now native widgets, but don't really behave. The + scroll test works a little, many other examples don't. See comment + in update-scrollbar-adjustment. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/04/23 10:42:39 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/04/23 17:36:28 1.3 @@ -25,6 +25,29 @@ (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)) + (wrapper (intern str :clim-gtkairo)) + (argnames (mapcar #'car args))) + `(progn + (cffi:defcfun (,name ,actual) + ,rtype + , at args) + (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))))))))) + + ;; user-visible structures (cffi:defcstruct cairo_text_extents @@ -125,11 +148,11 @@ :void (cr :pointer)) -(defcfun "cairo_save" +(def-cairo-fun "cairo_save" :void (cr :pointer)) -(defcfun "cairo_restore" +(def-cairo-fun "cairo_restore" :void (cr :pointer)) @@ -156,21 +179,21 @@ ;;; (height :int) ;;; (stride :int)) -(defcfun "cairo_set_operator" +(def-cairo-fun "cairo_set_operator" :void (cr :pointer) (op cairo_operator)) ;;; Colors -(defcfun "cairo_set_source_rgb" +(def-cairo-fun "cairo_set_source_rgb" :void (cr :pointer) (red :double) (green :double) (blue :double)) -(defcfun "cairo_set_source_rgba" +(def-cairo-fun "cairo_set_source_rgba" :void (cr :pointer) (red :double) @@ -178,73 +201,73 @@ (blue :double) (alpha :double)) -(defcfun "cairo_set_source" +(def-cairo-fun "cairo_set_source" :void (cr :pointer) (pattern :pointer)) -(defcfun "cairo_set_tolerance" +(def-cairo-fun "cairo_set_tolerance" :void (cr :pointer) (tolerance :double)) -(defcfun "cairo_set_fill_rule" +(def-cairo-fun "cairo_set_fill_rule" :void (cr :pointer) (fill_rule cairo_fill_rule)) -(defcfun "cairo_set_line_width" +(def-cairo-fun "cairo_set_line_width" :void (cr :pointer) (w :double)) -(defcfun "cairo_set_line_cap" +(def-cairo-fun "cairo_set_line_cap" :void (cr :pointer) (line_cap cairo_line_cap)) -(defcfun "cairo_set_line_join" +(def-cairo-fun "cairo_set_line_join" :void (cr :pointer) (line_join cairo_line_join)) -(defcfun "cairo_set_dash" +(def-cairo-fun "cairo_set_dash" :void (cr :pointer) (dashes :pointer) ;*double (ndash :int) (offset :double)) -(defcfun "cairo_set_miter_limit" +(def-cairo-fun "cairo_set_miter_limit" :int (cr :pointer) (limit :double)) ;;; Transformations -(defcfun "cairo_translate" +(def-cairo-fun "cairo_translate" :void (cr :pointer) (tx :double) (ty :double)) -(defcfun "cairo_scale" +(def-cairo-fun "cairo_scale" :void (cr :pointer) (sx :double) (sy :double)) -(defcfun "cairo_rotate" +(def-cairo-fun "cairo_rotate" :void (cr :pointer) (angle :double)) -(defcfun "cairo_set_matrix" +(def-cairo-fun "cairo_set_matrix" :void (cr :pointer) (matrix :pointer)) -(defcfun "cairo_identity_matrix" +(def-cairo-fun "cairo_identity_matrix" :void (cr :pointer)) @@ -278,23 +301,23 @@ ;;; Path creation functions -(defcfun "cairo_new_path" +(def-cairo-fun "cairo_new_path" :void (cr :pointer)) -(defcfun "cairo_move_to" +(def-cairo-fun "cairo_move_to" :void (cr :pointer) (x :double) (y :double)) -(defcfun "cairo_line_to" +(def-cairo-fun "cairo_line_to" :void (cr :pointer) (x :double) (y :double)) -(defcfun "cairo_curve_to" +(def-cairo-fun "cairo_curve_to" :void (cr :pointer) (x1 :double) @@ -304,7 +327,7 @@ (x3 :double) (y3 :double)) -(defcfun "cairo_arc" +(def-cairo-fun "cairo_arc" :void (cr :pointer) (xc :double) @@ -313,7 +336,7 @@ (angle1 :double) (angle2 :double)) -(defcfun "cairo_arc_negative" +(def-cairo-fun "cairo_arc_negative" :void (cr :pointer) (xc :double) @@ -322,19 +345,19 @@ (angle1 :double) (angle2 :double)) -(defcfun "cairo_rel_move_to" +(def-cairo-fun "cairo_rel_move_to" :void (cr :pointer) (dx :double) (dy :double)) -(defcfun "cairo_rel_line_to" +(def-cairo-fun "cairo_rel_line_to" :void (cr :pointer) (dx :double) (dy :double)) -(defcfun "cairo_rel_curve_to" +(def-cairo-fun "cairo_rel_curve_to" :void (cr :pointer) (dx1 :double) @@ -344,7 +367,7 @@ (dx3 :double) (dy3 :double)) -(defcfun "cairo_rectangle" +(def-cairo-fun "cairo_rectangle" :void (cr :pointer) (x :double) @@ -352,35 +375,35 @@ (w :double) (h :double)) -(defcfun "cairo_close_path" +(def-cairo-fun "cairo_close_path" :void (cr :pointer)) -(defcfun "cairo_stroke" +(def-cairo-fun "cairo_stroke" :void (cr :pointer)) -(defcfun "cairo_fill" +(def-cairo-fun "cairo_fill" :void (cr :pointer)) -(defcfun "cairo_copy_page" +(def-cairo-fun "cairo_copy_page" :void (cr :pointer)) -(defcfun "cairo_show_page" +(def-cairo-fun "cairo_show_page" :void (cr :pointer)) ;;; Insideness testing -(defcfun "cairo_in_stroke" +(def-cairo-fun "cairo_in_stroke" :int (cr :pointer) (x :double) (y :double)) -(defcfun "cairo_in_fill" +(def-cairo-fun "cairo_in_fill" :int (cr :pointer) (x :double) @@ -388,7 +411,7 @@ ;;; Rectangular extents -(defcfun "cairo_stroke_extents" +(def-cairo-fun "cairo_stroke_extents" :void (cr :pointer) (x1 :pointer) ;*double @@ -397,7 +420,7 @@ (y2 :pointer) ;*double ) -(defcfun "cairo_fill_extents" +(def-cairo-fun "cairo_fill_extents" :void (cr :pointer) (x1 :pointer) ;*double @@ -406,12 +429,12 @@ (y2 :pointer) ;*double ) -(defcfun "cairo_reset_clip" +(def-cairo-fun "cairo_reset_clip" :void (cr :pointer)) ;; Note: cairo_clip does not consume the current path -(defcfun "cairo_clip" +(def-cairo-fun "cairo_clip" :void (cr :pointer)) @@ -421,14 +444,14 @@ ;; This interface is for dealing with text as text, not caring about the ;; font object inside the the cairo_t. -(defcfun "cairo_select_font_face" +(def-cairo-fun "cairo_select_font_face" :void (cr :pointer) (family :string) (slant cairo_font_slant) (weight cairo_font_weight)) -(defcfun "cairo_set_font_size" +(def-cairo-fun "cairo_set_font_size" :void (cr :pointer) (size :double)) @@ -438,50 +461,50 @@ ;;; (cr :pointer) ;;; (matrix :pointer)) -(defcfun "cairo_show_text" +(def-cairo-fun "cairo_show_text" :void (cr :pointer) (string :string)) -(defcfun "cairo_show_glyphs" +(def-cairo-fun "cairo_show_glyphs" :void (cr :pointer) (glyphs :pointer) (num_glyphs :int)) -;;;(defcfun "cairo_current_font" +;;;(def-cairo-fun "cairo_current_font" ;;; :pointer ;;; (cr :pointer)) ;;; -(defcfun "cairo_font_extents" +(def-cairo-fun "cairo_font_extents" :void (cr :pointer) (extents :pointer)) -;;;(defcfun "cairo_set_font" +;;;(def-cairo-fun "cairo_set_font" ;;; :void ;;; (cr :pointer) ;;; (font :pointer)) -(defcfun "cairo_text_extents" +(def-cairo-fun "cairo_text_extents" :void (cr :pointer) (string :string) ;### utf_8 (extents :pointer)) -(defcfun "cairo_glyph_extents" +(def-cairo-fun "cairo_glyph_extents" :void (cr :pointer) (glyphs :pointer) (num_glyphs :int) (extents :pointer)) -(defcfun "cairo_text_path" +(def-cairo-fun "cairo_text_path" :void (cr :pointer) (string :string)) ;### utf_8 -(defcfun "cairo_glyph_path" +(def-cairo-fun "cairo_glyph_path" :void (cr :pointer) (glyphs :pointer) @@ -500,7 +523,7 @@ ;;; Image functions -;;;(defcfun "cairo_show_surface" +;;;(def-cairo-fun "cairo_show_surface" ;;; :void ;;; (cr :pointer) ;;; (surface :pointer) @@ -509,11 +532,11 @@ [112 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/23 10:18:45 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/23 17:36:28 1.4 @@ -106,16 +106,24 @@ (gtk-main-iteration port #-(and sbcl (not win32)) t) (dequeue port)))) -(defmacro define-signal (name (widget event) &body body) - (let ((impl (intern (concatenate 'string (symbol-name name) "-IMPL")))) - ;; jump through a trampoline so that C-M-x works without having to restart: - `(progn - (defun ,impl (,widget ,event) - , at body) - (cffi:defcallback ,name :void - ((widget :pointer) (event :pointer) (data :pointer)) - data - (,impl widget event))))) +(defmacro define-signal (name+options (widget event &rest args) &body body) + (destructuring-bind (name &key (return-type :void)) + (if (listp name+options) + name+options + (list name+options)) + (let ((impl (intern (concatenate 'string (symbol-name name) "-IMPL"))) + (args (if (symbolp event) + `((,event :pointer) , at args) + (cons event args)))) + ;; jump through a trampoline so that C-M-x works without having to + ;; restart: + `(progn + (defun ,impl (,widget ,@(mapcar #'car args)) + , at body) + (cffi:defcallback ,name ,return-type + ((widget :pointer) , at args (data :pointer)) + data + (,impl widget ,@(mapcar #'car args))))))) (define-signal noop-handler (widget event)) @@ -298,7 +306,30 @@ (make-instance 'climi::window-destroy-event :sheet (widget->sheet widget *port*)))) -(define-signal clicked-handler (widget event) +;; native widget handlers: + +(define-signal magic-clicked-handler (widget event) (declare (ignore event)) (when (boundp '*port*) ;hack alert - (enqueue (make-gadget-event (widget->sheet widget *port*))))) + (enqueue + (make-instance 'magic-gadget-event + :sheet (widget->sheet widget *port*))))) + +#-sbcl +(define-signal (scrollbar-change-value-handler :return-type :int) + (widget (scroll gtkscrolltype) (value :double)) + (enqueue (make-instance 'scrollbar-change-value-event + :scroll-type scroll + :value value + :sheet (widget->sheet widget *port*))) + 1) + +#+sbcl +;; :double in callbacks doesn't work: +(define-signal (scrollbar-change-value-handler :return-type :int) + (widget (scroll gtkscrolltype) (lo :unsigned-int) (hi :int)) + (enqueue (make-instance 'scrollbar-change-value-event + :scroll-type scroll + :value (sb-kernel:make-double-float hi lo) + :sheet (widget->sheet widget *port*))) + 1) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/04/23 17:36:28 1.2 @@ -65,9 +65,6 @@ (defmethod make-pane-2 ((type (eql 'clim:scroll-bar-pane)) &rest initargs &key orientation) - ;; doesn't really work yet - (call-next-method) - #+(or) (apply #'make-instance (if (eq orientation :vertical) 'gtk-vscrollbar --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/23 10:18:45 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/23 17:36:28 1.3 @@ -20,26 +20,37 @@ (in-package :clim-gtkairo) (defclass gadget-event (window-event) ()) +(defclass magic-gadget-event (gadget-event) ()) -(defun make-gadget-event (sheet) - (make-instance 'gadget-event :sheet sheet)) +(defclass scrollbar-change-value-event (gadget-event) + ((scroll-type :initarg :scroll-type :accessor event-scroll-type) + (value :initarg :value :accessor event-value))) ;;;; Classes -;; FIXME: Hier implementieren wir die Widgets nicht vollstaendig selbst, -;; sondern erben von den Standard-Widgets. Damit das gut geht, muessen -;; wir unten deren Redisplay-Methoden unterdruecken... Besser waere es -;; vielleicht, von TOGGLE-BUTTON statt TOGGLE-BUTTON-PANE zu erben und -;; alles selbst zu machen. Mindestens COMPOSE-SPACE muesste man dann -;; hier implementieren. (defclass gtk-button (native-widget-mixin push-button) ()) -(defclass gtk-check-button (native-widget-mixin toggle-button-pane) ()) -(defclass gtk-radio-button (native-widget-mixin toggle-button-pane) ()) -(defclass gtk-vscale (native-widget-mixin slider-pane) ()) -(defclass gtk-hscale (native-widget-mixin slider-pane) ()) -(defclass gtk-vscrollbar (native-widget-mixin scroll-bar-pane) ()) -(defclass gtk-hscrollbar (native-widget-mixin scroll-bar-pane) ()) + +(defclass gtk-check-button (native-widget-mixin toggle-button) ()) +(defclass gtk-radio-button (native-widget-mixin toggle-button) ()) + +(defclass native-slider (native-widget-mixin climi::slider-gadget) + ((climi::show-value-p :type boolean + :initform nil + :initarg :show-value-p + :accessor climi::gadget-show-value-p) + (climi::decimal-places :initform 0 + :initarg :decimal-places + :reader climi::slider-decimal-places) + (climi::number-of-quanta :initform nil + :initarg :number-of-quanta + :reader climi::slider-number-of-quanta))) +(defclass gtk-vscale (native-slider) ()) +(defclass gtk-hscale (native-slider) ()) + +(defclass native-scrollbar (native-widget-mixin scroll-bar) ()) +(defclass gtk-vscrollbar (native-scrollbar) ()) +(defclass gtk-hscrollbar (native-scrollbar) ()) ;;;; Constructors @@ -51,7 +62,9 @@ button)) (defmethod realize-native-widget ((sheet gtk-check-button)) - (gtk_check_button_new_with_label (climi::gadget-label sheet))) + (let ((widget (gtk_check_button_new_with_label (climi::gadget-label sheet)))) + (gtk_toggle_button_set_active widget (if (gadget-value sheet) 1 0)) + widget)) (defun make-scale (fn sheet) (let* ((min (df (gadget-min-value sheet))) @@ -61,6 +74,8 @@ (gtk_scale_set_digits widget (climi::slider-decimal-places sheet)) (gtk_scale_set_draw_value widget (if (climi::gadget-show-value-p sheet) 1 0)) + (gtk_adjustment_set_value (gtk_range_get_adjustment widget) + (df (gadget-value sheet))) widget)) (defmethod realize-native-widget ((sheet gtk-vscale)) @@ -72,10 +87,9 @@ (defun make-scrollbar (fn sheet) (let* ((min (df (gadget-min-value sheet))) (max (df (gadget-max-value sheet))) - (l (- max min)) - (adjustment - ;; FIXME! - (gtk_adjustment_new 0.0d0 min max (/ l 100) (/ l 10) l))) + (page-size (df (climi::scroll-bar-thumb-size sheet))) + (adjustment (gtk_adjustment_new 0.0d0 min max 0.0d0 0.0d0 page-size))) + (gtk_adjustment_set_value adjustment (df (gadget-value sheet))) (funcall fn adjustment))) (defmethod realize-native-widget ((sheet gtk-vscrollbar)) @@ -89,74 +103,108 @@ (some #'sheet-direct-mirror (sheet-children (gadget-client sheet)))) (group (if first (gtk_radio_button_get_group (mirror-widget first)) - (cffi:null-pointer)))) - (gtk_radio_button_new_with_label group (climi::gadget-label sheet)))) + (cffi:null-pointer))) + (result + (gtk_radio_button_new_with_label group (climi::gadget-label sheet)))) + (gtk_toggle_button_set_active + result + (if (eq sheet (gadget-value (gadget-client sheet))) 1 0)) + result)) ;;;; Event definition (defmethod connect-native-signals ((sheet native-widget-mixin) widget) - (connect-signal widget "clicked" 'clicked-handler)) + (connect-signal widget "clicked" 'magic-clicked-handler)) -(defmethod connect-native-signals ((sheet gtk-vscale) widget) - (connect-signal widget "value-changed" 'clicked-handler)) +(defmethod connect-native-signals ((sheet native-slider) widget) + (connect-signal widget "value-changed" 'magic-clicked-handler)) -(defmethod connect-native-signals ((sheet gtk-hscale) widget) - (connect-signal widget "value-changed" 'clicked-handler)) - -(defmethod connect-native-signals ((sheet gtk-vscrollbar) widget) - (connect-signal widget "value-changed" 'clicked-handler)) - -(defmethod connect-native-signals ((sheet gtk-hscrollbar) widget) - (connect-signal widget "value-changed" 'clicked-handler)) +(defmethod connect-native-signals ((sheet native-scrollbar) widget) + ;; (connect-signal widget "value-changed" 'magic-clicked-handler) + (connect-signal widget "change-value" 'scrollbar-change-value-handler)) ;;;; Event handling -(defmethod handle-event ((pane gtk-button) (event gadget-event)) +(defmethod handle-event ((pane gtk-button) (event magic-gadget-event)) (activate-callback pane (gadget-client pane) (gadget-id pane))) -(defmethod handle-event ((pane gtk-check-button) (event gadget-event)) +(defmethod handle-event ((pane gtk-check-button) (event magic-gadget-event)) (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane)))) -(defmethod handle-event ((pane gtk-radio-button) (event gadget-event)) +(defmethod handle-event ((pane gtk-radio-button) (event magic-gadget-event)) (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane)))) -(defmethod handle-event ((pane gtk-vscale) (event gadget-event)) - (setf (gadget-value pane :invoke-callback t) - (gtk_range_get_value (mirror-widget (sheet-direct-mirror pane))))) - -(defmethod handle-event ((pane gtk-hscale) (event gadget-event)) +(defmethod handle-event ((pane native-slider) (event magic-gadget-event)) (setf (gadget-value pane :invoke-callback t) (gtk_range_get_value (mirror-widget (sheet-direct-mirror pane))))) -(defmethod handle-event ((pane gtk-vscrollbar) (event gadget-event)) +(defmethod handle-event ((pane native-scrollbar) (event magic-gadget-event)) (setf (gadget-value pane :invoke-callback t) (gtk_range_get_value (mirror-widget (sheet-direct-mirror pane))))) -(defmethod handle-event ((pane gtk-hscrollbar) (event gadget-event)) - (setf (gadget-value pane :invoke-callback t) - (gtk_range_get_value (mirror-widget (sheet-direct-mirror pane))))) +(defun clamp (low x hi) + (min (max low x) hi)) +(defmethod handle-event + ((pane native-scrollbar) (event scrollbar-change-value-event)) + (case (event-scroll-type event) + (:jump + (let ((value + (clamp (gadget-min-value pane) + (event-value event) + (gadget-max-value pane)))) + (setf (gadget-value pane :invoke-callback nil) value) + (drag-callback pane (gadget-client pane) (gadget-id pane) value))) + (:step_backward + (scroll-up-line-callback pane (gadget-client pane) (gadget-id pane))) + (:step_forward + (scroll-down-line-callback pane (gadget-client pane) (gadget-id pane))) + (:page_backward + (scroll-up-page-callback pane (gadget-client pane) (gadget-id pane))) + (:page_forward + (scroll-down-page-callback pane (gadget-client pane) (gadget-id pane))))) -;;; Workarounds +;;; COMPOSE-SPACE -(defmethod handle-repaint ((pane native-widget-mixin) region) - (declare (ignore region)) - ;; siehe oben - ) +;; KLUDGE: this is getting called before the sheet has been realized. +(defmethod compose-space ((gadget native-widget-mixin) &key width height) + (declare (ignore width height)) + (let* ((widget (native-widget gadget)) + (widgetp widget)) + (unless widgetp + (setf widget (realize-native-widget gadget))) + (prog1 + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request widget r) + (cffi:with-foreign-slots ((width height) r gtkrequisition) + (make-space-requirement :width width :height height))) + (unless widgetp + (gtk_widget_destroy widget))))) ;;; Vermischtes (defmethod (setf gadget-value) :after + (value (gadget native-slider) &key invoke-callback) + (declare (ignore invoke-callback)) + (with-gtk () + (let ((mirror (sheet-direct-mirror gadget))) + (when mirror + ;; see hack in magic-clicked-handler + (gtk_adjustment_set_value + (gtk_range_get_adjustment (mirror-widget mirror)) + (df value)))))) + +(defmethod (setf gadget-value) :after (value (gadget gtk-radio-button) &key invoke-callback) (declare (ignore invoke-callback)) (with-gtk () (let ((mirror (sheet-direct-mirror gadget))) (when mirror - ;; see hack in clicked-handler + ;; see hack in magic-clicked-handler (gtk_toggle_button_set_active (mirror-widget mirror) (if value 1 0)))))) @@ -166,21 +214,47 @@ (with-gtk () (let ((mirror (sheet-direct-mirror gadget))) (when mirror - ;; see hack in clicked-handler + ;; see hack in magic-clicked-handler (gtk_toggle_button_set_active (mirror-widget mirror) (if value 1 0)))))) -;; KLUDGE: this is getting called before the sheet has been realized. -(defmethod compose-space ((gadget native-widget-mixin) &key width height) - (declare (ignore width height)) - (let* ((widget (native-widget gadget)) - (widgetp widget)) - (unless widgetp - (setf widget (realize-native-widget gadget))) - (prog1 - (cffi:with-foreign-object (r 'gtkrequisition) - (gtk_widget_size_request widget r) - (cffi:with-foreign-slots ((width height) r gtkrequisition) - (make-space-requirement :width width :height height))) - (unless widgetp - (gtk_widget_destroy widget))))) + +;;; Scroll bars. + +;; This is all totally broken. Why does thumb-size default to 1/4 when it's +;; not a ratio but given in value units? Why is min==max all the time? +;; And why doesn't this work! :-( +(defun update-scrollbar-adjustment (sheet) + (with-gtk () + (let* ((min (df (gadget-min-value sheet))) + (max (df (gadget-max-value sheet))) + (value (df (gadget-value sheet))) + (page-size (df (climi::scroll-bar-thumb-size sheet)))) + (gtk_range_set_adjustment + (mirror-widget (sheet-direct-mirror sheet)) + (gtk_adjustment_new value min max 0.0d0 0.0d0 page-size))))) + +(defmethod (setf gadget-min-value) :after (new-value (pane native-scrollbar)) + (declare (ignore new-value)) + (update-scrollbar-adjustment pane)) + +(defmethod (setf gadget-max-value) :after (new-value (pane native-scrollbar)) + (declare (ignore new-value)) + (update-scrollbar-adjustment pane)) + +(defmethod (setf gadget-value) + :after (new-value (pane native-scrollbar) &key invoke-callback) + (declare (ignore new-value invoke-callback)) + (update-scrollbar-adjustment pane)) + +(climi::defmethod* (setf climi::scroll-bar-values) + (min-value max-value thumb-size value (scroll-bar native-scrollbar)) + (setf (slot-value scroll-bar 'climi::min-value) min-value + (slot-value scroll-bar 'climi::max-value) max-value + (slot-value scroll-bar 'climi::thumb-size) thumb-size + (slot-value scroll-bar 'climi::value) value) + (update-scrollbar-adjustment scroll-bar)) + +(defmethod port-set-mirror-region :after + ((port gtkairo-port) (mirror native-scrollbar) mirror-region) + (update-scrollbar-adjustment (widget->sheet (mirror-widget mirror) port))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/23 10:18:45 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/23 17:36:28 1.4 @@ -261,6 +261,11 @@ :copy :invert :xor :clear :and :and_reverse :and_invert :noop :or :equiv :or_reverse :copy_invert :or_invert :nand :nor :set) +(cffi:defcenum gtkscrolltype + :none :jump :step_backward :step_forward :page_backward :page_forward + :step_up :step_down :page_up :page_down :step_left :step_right :page_left + :page_right :start :end) + ;;; GTK functions @@ -633,10 +638,20 @@ :pointer (range :pointer)) +(defcfun "gtk_range_set_adjustment" + :void + (range :pointer) + (adjustment :pointer)) + (defcfun "gtk_adjustment_get_value" :double (range :pointer)) +(defcfun "gtk_adjustment_set_value" + :void + (adjustment :pointer) + (value :double)) + (defcfun "gtk_adjustment_new" :pointer (value :double) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/23 10:42:39 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/23 17:36:28 1.5 @@ -708,22 +708,25 @@ (text-style-height text-style (metrik-medium (port medium)))) (defmethod text-style-height (text-style (medium metrik-medium)) - (with-cairo-medium (medium) - (ceiling - (with-slots (cr) medium - (sync-sheet medium) - (cairo_identity_matrix cr) - (sync-text-style medium text-style t) - (cffi:with-foreign-object (res 'cairo_font_extents) - (cairo_font_extents cr res) - ;; ### let's hope that cairo respects - ;; height = ascent + descent. - ;; - ;; No, it expressly doesn't. Cairo documentation states that - ;; height includes additional space that is meant to give more - ;; aesthetic line spacing than ascent+descent would. Is that a - ;; problem for us? --DFL - (slot res 'cairo_font_extents 'height)))))) +;;; (with-cairo-medium (medium) +;;; (ceiling +;;; (with-slots (cr) medium +;;; (sync-sheet medium) +;;; (cairo_identity_matrix cr) +;;; (sync-text-style medium text-style t) +;;; (cffi:with-foreign-object (res 'cairo_font_extents) +;;; (cairo_font_extents cr res) +;;; ;; ### let's hope that cairo respects +;;; ;; height = ascent + descent. +;;; ;; +;;; ;; No, it expressly doesn't. Cairo documentation states that +;;; ;; height includes additional space that is meant to give more +;;; ;; aesthetic line spacing than ascent+descent would. Is that a +;;; ;; problem for us? --DFL +;;; (slot res 'cairo_font_extents 'height))))) + ;; OK, so it _does_ matter (see bug 15). + (+ (text-style-ascent text-style medium) + (text-style-descent text-style medium))) ;;; TEXT-STYLE-WIDTH From crhodes at common-lisp.net Tue Apr 25 10:16:13 2006 From: crhodes at common-lisp.net (crhodes) Date: Tue, 25 Apr 2006 06:16:13 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Tests Message-ID: <20060425101613.78FB66200E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Tests In directory clnet:/tmp/cvs-serv24084/Tests Modified Files: input-editing.lisp Log Message: More trivial input editing tests --- /project/mcclim/cvsroot/mcclim/Tests/input-editing.lisp 2006/04/21 12:03:23 1.1 +++ /project/mcclim/cvsroot/mcclim/Tests/input-editing.lisp 2006/04/25 10:16:13 1.2 @@ -4,3 +4,29 @@ (in-package :clim-tests) (assert (null *activation-gestures*)) + +;;; SIMPLE-PARSE-ERROR +(assert (subtypep 'simple-parse-error 'parse-error)) + +(make-condition 'simple-parse-error + :format-control "~A" :format-arguments (list 3)) + +(handler-case + (simple-parse-error "foo: ~A" 3) + (simple-parse-error (c) + (assert (search "foo: 3" (format nil "~A" c)))) + (:no-error (&rest values) + (error "~S returned ~S" 'simple-parse-error values))) + +;;; INPUT-NOT-OF-REQUIRED-TYPE +(assert (subtypep 'input-not-of-required-type 'parse-error)) + +(let ((c (make-condition 'input-not-of-required-type + :string "not an INTEGER" :type 'integer))) + (assert (search "not an INTEGER" (format nil "~A" c)))) + +(handler-case + (input-not-of-required-type 3 'float) + (input-not-of-required-type ()) + (:no-error (&rest values) + (error "~S returned ~S" 'input-not-of-required-type values))) From tmoore at common-lisp.net Tue Apr 25 18:50:31 2006 From: tmoore at common-lisp.net (tmoore) Date: Tue, 25 Apr 2006 14:50:31 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/native-panes Message-ID: <20060425185031.E64E134041@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes In directory clnet:/tmp/cvs-serv30220 Modified Files: beagle-scroll-bar-pane.lisp Log Message: Missing parens; whoops --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-scroll-bar-pane.lisp 2006/03/30 12:07:59 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-scroll-bar-pane.lisp 2006/04/25 18:50:31 1.9 @@ -153,7 +153,7 @@ (/ size range)))) (send (toolkit-object gadget) :set-float-value (coerce position 'short-float) - :knob-proportion (coerce loz-size 'short-float)))) + :knob-proportion (coerce loz-size 'short-float))))) ;;; Called in the Cocoa App thread. From dlichteblau at common-lisp.net Sun Apr 30 09:24:41 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 30 Apr 2006 05:24:41 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060430092441.1CB71704D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv24069 Modified Files: clim-fix.lisp BUGS Log Message: "Isn't wlan great." * clim-fix.lisp ((transform-region transformation (design design))): Commented out a method to make gsharp work. Logged as bug 17. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/04/23 10:18:45 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/04/30 09:24:40 1.3 @@ -17,10 +17,12 @@ :ink ink :mask mask)) -(defmethod transform-region (transformation (design design)) - (make-instance 'transformed-design - :transformation transformation - :design design)) +;; FIXME: See bug 17. +;;;(defmethod transform-region (transformation (design design)) +;;; (make-instance 'transformed-design +;;; :transformation transformation +;;; :design design) +;;; (call-next-method)) (defmethod clim:handle-repaint :after ((s clim:sheet-with-medium-mixin) r) (medium-force-output (sheet-medium s))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/23 17:36:28 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/30 09:24:40 1.5 @@ -83,3 +83,9 @@ Scroll panes are now native widgets, but don't really behave. The scroll test works a little, many other examples don't. See comment in update-scrollbar-adjustment. + +17. + There's a commented-out method on TRANSFORM-REGION for DESIGN in + 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. From dlichteblau at common-lisp.net Sun Apr 30 10:31:15 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 30 Apr 2006 06:31:15 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20060430103115.3BB2144054@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv32082 Modified Files: BUGS gadgets.lisp Log Message: * gadgets.lisp (make-scrollbar, update-scrollbar-adjustment): Set the gtk adjustment maximum value to (+ max-value thumb-size). I don't get it, but it seems to fix scrollbars for me. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/30 09:24:40 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/04/30 10:31:15 1.6 @@ -79,7 +79,7 @@ (FIXED) 15. The text cursor does not show the correct vertical position in climacs. -16. +(FIXED?) 16. Scroll panes are now native widgets, but don't really behave. The scroll test works a little, many other examples don't. See comment in update-scrollbar-adjustment. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/23 17:36:28 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/30 10:31:15 1.4 @@ -86,8 +86,8 @@ (defun make-scrollbar (fn sheet) (let* ((min (df (gadget-min-value sheet))) - (max (df (gadget-max-value sheet))) (page-size (df (climi::scroll-bar-thumb-size sheet))) + (max (+ (df (gadget-max-value sheet)) page-size)) (adjustment (gtk_adjustment_new 0.0d0 min max 0.0d0 0.0d0 page-size))) (gtk_adjustment_set_value adjustment (df (gadget-value sheet))) (funcall fn adjustment))) @@ -227,9 +227,9 @@ (defun update-scrollbar-adjustment (sheet) (with-gtk () (let* ((min (df (gadget-min-value sheet))) - (max (df (gadget-max-value sheet))) (value (df (gadget-value sheet))) - (page-size (df (climi::scroll-bar-thumb-size sheet)))) + (page-size (df (climi::scroll-bar-thumb-size sheet))) + (max (+ (df (gadget-max-value sheet)) page-size))) (gtk_range_set_adjustment (mirror-widget (sheet-direct-mirror sheet)) (gtk_adjustment_new value min max 0.0d0 0.0d0 page-size)))))