From crhodes at common-lisp.net Mon Aug 1 16:50:44 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 1 Aug 2005 18:50:44 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Backends/PostScript/graphics.lisp Message-ID: <20050801165044.A0F018815C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory common-lisp.net:/tmp/cvs-serv21672 Modified Files: graphics.lisp Log Message: Fix the sense of rotations in the Postscript backend, being more careful than in my mailed patch to handle NIL angles. (When are we getting a test suite?) Date: Mon Aug 1 18:50:44 2005 Author: crhodes Index: mcclim/Backends/PostScript/graphics.lisp diff -u mcclim/Backends/PostScript/graphics.lisp:1.12 mcclim/Backends/PostScript/graphics.lisp:1.13 --- mcclim/Backends/PostScript/graphics.lisp:1.12 Fri Dec 3 12:42:43 2004 +++ mcclim/Backends/PostScript/graphics.lisp Mon Aug 1 18:50:43 2005 @@ -147,8 +147,15 @@ (cy (point-y center)) (tr (make-transformation ndx2 ndx1 ndy2 ndy1 cx cy)) (circle (untransform-region tr ellipse)) - (start-angle (or (ellipse-start-angle circle) 0)) - (end-angle (or (ellipse-end-angle circle) (* 2 pi)))) + ;; we need an extra minus sign because the rotation + ;; convention for Postscript differs in chirality from the + ;; abstract CLIM convention; we do a reflection + ;; transformation to move the coordinates to the right + ;; handedness, but then the sense of positive rotation is + ;; backwards, so we need this reflection for angles. -- + ;; CSR, 2005-08-01 + (start-angle (- (or (ellipse-end-angle circle) 0))) + (end-angle (- (or (ellipse-start-angle circle) (* -2 pi))))) (write-string (if filled "true " "false ") stream) (write-angle stream (if (< end-angle start-angle) (+ end-angle (* 2 pi)) From crhodes at common-lisp.net Mon Aug 8 17:15:09 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 8 Aug 2005 19:15:09 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/presentation-defs.lisp Message-ID: <20050808171509.9DFD888542@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv13631 Modified Files: presentation-defs.lisp Log Message: One-line patch to presentation-single-box handling, from Dave Murray (27th July 2005, mcclim-devel) Date: Mon Aug 8 19:15:08 2005 Author: crhodes Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.44 mcclim/presentation-defs.lisp:1.45 --- mcclim/presentation-defs.lisp:1.44 Wed Jun 22 11:49:15 2005 +++ mcclim/presentation-defs.lisp Mon Aug 8 19:15:07 2005 @@ -993,7 +993,7 @@ (multiple-value-bind (min-x min-y max-x max-y) (output-record-hit-detection-rectangle* record) (if (and (<= min-x x max-x) (<= min-y y max-y)) - (if (or (null single-box) (eq single-box :higlighting)) + (if (or (null single-box) (eq single-box :highlighting)) (funcall-presentation-generic-function presentation-refined-position-test (presentation-type record) record x y) From tmoore at common-lisp.net Tue Aug 9 20:30:20 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Tue, 9 Aug 2005 22:30:20 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp Message-ID: <20050809203020.56B1088540@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv27570 Modified Files: incremental-redisplay.lisp Log Message: Implement a generic output-record-hash which doesn't depend on the coordinates slot of standard-rectangle Date: Tue Aug 9 22:30:13 2005 Author: tmoore Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.48 mcclim/incremental-redisplay.lisp:1.49 --- mcclim/incremental-redisplay.lisp:1.48 Sun May 8 20:15:44 2005 +++ mcclim/incremental-redisplay.lisp Tue Aug 9 22:30:12 2005 @@ -711,9 +711,41 @@ (defvar *existing-output-records* nil) ;;; +(defgeneric output-record-hash (record) + (:documentation "Produce a value that can be used to hash the output record +in an equalp hash table")) -(defmethod output-record-hash (record) +(defmethod output-record-hash ((record basic-output-record)) (slot-value record 'coordinates)) + +(defconstant +fixnum-bits+ (integer-length most-positive-fixnum)) + +(declaim (inline hash-coords)) +(defun hash-coords (x1 y1 x2 y2) + (declare (type real x1 y1 x2 y2)) ;XXX Someday this should be float + (let ((hash-val 0)) + (declare (type fixnum hash-val)) + (labels ((rot4 (val) + (dpb (ldb (byte 4 0) val) + (byte 4 (- +fixnum-bits+ 4 1)) + (ash val -4))) + (mix-it-in (val) + (let ((xval (sxhash val))) + (declare (type fixnum xval)) + (when (minusp val) + (setq xval (rot4 xval))) + (setq hash-val (logxor (rot4 hash-val) xval))))) + (declare (inline rot4 mix-it-in)) + (mix-it-in x1) + (mix-it-in y1) + (mix-it-in x2) + (mix-it-in y2) + hash-val))) + +(defmethod output-record-hash ((record output-record)) + (with-bounding-rectangle* (x1 y1 x2 y2) + record + (hash-coords x1 y1 x2 y2))) (defmethod compute-difference-set ((record standard-updating-output-record) &optional (check-overlapping t) From rgoldman at common-lisp.net Fri Aug 12 02:18:04 2005 From: rgoldman at common-lisp.net (Robert Goldman) Date: Fri, 12 Aug 2005 04:18:04 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/graph-formatting.lisp Message-ID: <20050812021804.9E88A8853F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv20270 Modified Files: graph-formatting.lisp Log Message: Modified layout-graph-nodes so that it permits duplicate-test arguments that are not compatible with hash-tables. Added a (not very good) layout method for DAGS. Arbitrary DIGRAPHs still not supported. Date: Fri Aug 12 04:18:03 2005 Author: rgoldman Index: mcclim/graph-formatting.lisp diff -u mcclim/graph-formatting.lisp:1.15 mcclim/graph-formatting.lisp:1.16 --- mcclim/graph-formatting.lisp:1.15 Fri May 13 05:00:25 2005 +++ mcclim/graph-formatting.lisp Fri Aug 12 04:18:03 2005 @@ -3,10 +3,11 @@ ;;; Title: Graph Formatting ;;; Created: 2002-08-13 ;;; License: LGPL (See file COPYING for details). -;;; $Id: graph-formatting.lisp,v 1.15 2005/05/13 03:00:25 ahefner Exp $ +;;; $Id: graph-formatting.lisp,v 1.16 2005/08/12 02:18:03 rgoldman Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann +;;; (c) copyright 2005 by Robert P. Goldman ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -138,6 +139,15 @@ graph-type (or graph-type (if merge-duplicates :digraph :tree)) duplicate-key (or duplicate-key #'identity) duplicate-test (or duplicate-test #'eql) ) + + ;; I'm not sure what to do here. Saying you want a tree, but want + ;; duplicates merged seems wrong. OTOH, if you go out of your way + ;; to do it, at your own risk, is it our place to say "no"? + ;; [2005/08/11:rpg] +;;; (when (and (eq graph-type :tree) merge-duplicates) +;;; (cerror "Substitute NIL for merge-duplicates" +;;; "Merge duplicates specified to be true when using :tree layout.") +;;; (setf merge-duplicates nil)) ;; clean the options (remf graph-options :stream) @@ -163,8 +173,10 @@ #'cont (find-graph-type graph-type) nil - :hash-table (make-hash-table :test duplicate-test) - graph-options)))) + ;; moved to local variable... [2005/07/25:rpg] + ;; :hash-table (make-hash-table :test duplicate-test) + graph-options + )))) (setf (output-record-position graph-output-record) (values cursor-old-x cursor-old-y)) (with-output-recording-options (stream :draw t :record nil) @@ -182,35 +194,40 @@ (defclass standard-graph-output-record (graph-output-record standard-sequence-output-record) - ((orientation - :initarg :orientation - :initform :horizontal) - (center-nodes - :initarg :center-nodes - :initform nil) - (cutoff-depth - :initarg :cutoff-depth - :initform nil) - (merge-duplicates - :initarg :merge-duplicates - :initform nil) - (generation-separation - :initarg :generation-separation - :initform '(4 :character)) - (within-generation-separation - :initarg :within-generation-separation - :initform '(1/2 :line)) - (hash-table - :initarg :hash-table - :initform nil) - (root-nodes - :accessor graph-root-nodes) )) + ((orientation + :initarg :orientation + :initform :horizontal) + (center-nodes + :initarg :center-nodes + :initform nil) + (cutoff-depth + :initarg :cutoff-depth + :initform nil) + (merge-duplicates + :initarg :merge-duplicates + :initform nil) + (generation-separation + :initarg :generation-separation + :initform '(4 :character)) + (within-generation-separation + :initarg :within-generation-separation + :initform '(1/2 :line)) + ;; removed HASH-TABLE slot and stuffed it into + ;; GENERATE-GRAPH-NODES method definition [2005/07/25:rpg] + (root-nodes + :accessor graph-root-nodes) + )) (defclass tree-graph-output-record (standard-graph-output-record) - ()) + ()) + +;;;(defmethod initialize-instance :after ((obj tree-graph-output-record) &key merge-duplicates) +;;; (when merge-duplicates +;;; (warn "Cannot use a TREE layout for graphs while merging duplicates."))) (defclass dag-graph-output-record (standard-graph-output-record) - ()) + ( + )) (defclass digraph-graph-output-record (standard-graph-output-record) ()) @@ -238,45 +255,64 @@ ;;;; +;;; Modified to make this obey the spec better by using a hash-table +;;; for detecting previous nodes only when the duplicate-test argument +;;; permits it. [2005/08/10:rpg] (defmethod generate-graph-nodes ((graph-output-record standard-graph-output-record) stream root-objects object-printer inferior-producer &key duplicate-key duplicate-test) - (declare (ignore duplicate-test)) - (with-slots (cutoff-depth merge-duplicates hash-table) graph-output-record - (labels - ((traverse-objects (node objects depth) - (unless (and cutoff-depth (>= depth cutoff-depth)) - (remove nil - (map 'list - (lambda (child) - (let* ((key (funcall duplicate-key child)) - (child-node (and merge-duplicates - (gethash key hash-table)))) - (cond (child-node - (when node - (push node (graph-node-parents child-node))) - child-node) - (t - (let ((child-node - (with-output-to-output-record - (stream 'standard-graph-node-output-record new-node - :object child) - (funcall object-printer child stream)))) - (when merge-duplicates - (setf (gethash key hash-table) child-node)) - (when node - (push node (graph-node-parents child-node))) - (setf (graph-node-children child-node) - (traverse-objects child-node - (funcall inferior-producer child) - (+ depth 1))) - child-node))))) - objects))))) - ;; - (setf (graph-root-nodes graph-output-record) - (traverse-objects nil root-objects 0)) - (values)))) + (with-slots (cutoff-depth merge-duplicates) graph-output-record + (let* ((hash-table (when (and merge-duplicates (member duplicate-test (list #'eq #'eql #'equal #'equalp))) + (make-hash-table :test duplicate-test))) + node-list + (hashed hash-table)) + (labels + ((previous-node (obj) + ;; is there a previous node for obj? if so, return it. + (when merge-duplicates + (if hashed + (locally (declare (type hash-table hash-table)) + (gethash obj hash-table)) + (cdr (assoc obj node-list :test duplicate-test))))) + ((setf previous-node) (val obj) + (if hashed + (locally (declare (type hash-table hash-table)) + (setf (gethash obj hash-table) val)) + (setf node-list (push (cons obj val) node-list)))) + (traverse-objects (node objects depth) + (unless (and cutoff-depth (>= depth cutoff-depth)) + (remove nil + (map 'list + (lambda (child) + (let* ((key (funcall duplicate-key child)) + (child-node (previous-node key))) + (cond (child-node + (when node + (push node (graph-node-parents child-node))) + child-node) + (t + (let ((child-node + (with-output-to-output-record + (stream 'standard-graph-node-output-record new-node + :object child) + (funcall object-printer child stream)))) + (when merge-duplicates + (setf (previous-node key) child-node) + ;; (setf (gethash key hash-table) child-node) + ) + (when node + (push node (graph-node-parents child-node))) + (setf (graph-node-children child-node) + (traverse-objects child-node + (funcall inferior-producer child) + (+ depth 1))) + child-node))))) + objects))))) + ;; + (setf (graph-root-nodes graph-output-record) + (traverse-objects nil root-objects 0)) + (values))))) (defun traverse-graph-nodes (graph continuation) ;; continuation: node x children x cont -> some value @@ -300,6 +336,8 @@ (:horizontal :vertical) (:vertical :horizontal)))) (generation-separation (parse-space stream generation-separation orientation))) + ;; generation sizes is an adjustable array that tracks the major + ;; dimension of each of the generations [2005/07/18:rpg] (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0))) (labels ((node-major-dimension (node) (if (eq orientation :vertical) @@ -309,6 +347,9 @@ (if (eq orientation :vertical) (bounding-rectangle-width node) (bounding-rectangle-height node))) + ;; WALK returns a node minor dimension for the node, + ;; AFAICT, allowing space for that node's children + ;; along the minor dimension. [2005/07/18:rpg] (walk (node depth) (unless (graph-node-minor-size node) (when (>= depth (length generation-sizes)) @@ -367,6 +408,121 @@ (unless (null rest) (incf v within-generation-separation))) (graph-root-nodes graph-output-record))))))))))) + + +(defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record) + stream arc-drawer arc-drawing-options) + "This is a first shot at a DAG layout. First does a TOPO sort that associates +each node with a depth, then lays out by depth. Tries to reuse a maximum of the +tree graph layout code. +PRECONDITION: This code assumes that we have generated only nodes up to the +cutoff-depth. GENERATE-GRAPH-NODES seems to obey this precondition." + (declare (ignore arc-drawer arc-drawing-options)) + (with-slots (orientation center-nodes generation-separation within-generation-separation root-nodes + merge-duplicates) graph-output-record + ;; this code is snarly enough, handling merge-duplicates. If + ;; you're not merging duplicates, you're out of luck, at least for + ;; now... [2005/07/18:rpg] + (unless merge-duplicates + (cerror "Set to T and continue?" "DAG graph-layout type only supports merge-duplicates to be T") + (setf merge-duplicates t)) + + (check-type orientation (member :horizontal :vertical)) ;xxx move to init.-inst. + + ;; here major dimension is the dimension in which we grow the + ;; tree. + (let ((within-generation-separation (parse-space stream within-generation-separation + (case orientation + (:horizontal :vertical) + (:vertical :horizontal)))) + (generation-separation (parse-space stream generation-separation orientation))) + ;; generation sizes is an adjustable array that tracks the major + ;; dimension of each of the generations [2005/07/18:rpg] + (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0)) + (visited (make-hash-table :test #'eq)) + (parent-hash (make-hash-table :test #'eq))) + (labels ((node-major-dimension (node) + (if (eq orientation :vertical) + (bounding-rectangle-height node) + (bounding-rectangle-width node))) + (node-minor-dimension (node) + (if (eq orientation :vertical) + (bounding-rectangle-width node) + (bounding-rectangle-height node))) + ;; WALK returns a node minor dimension for the node, + ;; AFAICT, allowing space for that node's children + ;; along the minor dimension. [2005/07/18:rpg] + (walk (node depth &optional parent) + (unless (gethash node visited) + (setf (gethash node visited) depth) + (when parent + (setf (gethash node parent-hash) parent)) + (unless (graph-node-minor-size node) + (when (>= depth (length generation-sizes)) + (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2)) + :initial-element 0))) + (setf (aref generation-sizes depth) + (max (aref generation-sizes depth) (node-major-dimension node))) + (setf (graph-node-minor-size node) 0) + (max (node-minor-dimension node) + (setf (graph-node-minor-size node) + (let ((sum 0) (n 0)) + (map nil (lambda (child) + (let ((x (walk child (+ depth 1) node))) + (when x + (incf sum x) + (incf n)))) + (graph-node-children node)) + (+ sum + (* (max 0 (- n 1)) within-generation-separation))))))))) + (map nil #'(lambda (x) (walk x 0)) root-nodes) + (let ((hash (make-hash-table :test #'eq))) + (labels ((foo (node majors u0 v0) + (cond ((gethash node hash) + v0) + (t + (setf (gethash node hash) t) + (let ((d (- (node-minor-dimension node) + (graph-node-minor-size node)))) + (let ((v (+ v0 (/ (min 0 d) -2)))) + (setf (output-record-position node) + (if (eq orientation :vertical) + (transform-position (medium-transformation stream) v u0) + (transform-position (medium-transformation stream) u0 v))) + (add-output-record node graph-output-record)) + ;; + (let ((u (+ u0 (car majors))) + (v (+ v0 (max 0 (/ d 2)))) + (firstp t)) + (map nil (lambda (q) + (unless (gethash q hash) + (if firstp + (setf firstp nil) + (incf v within-generation-separation)) + (setf v (foo q (cdr majors) + u v)))) + ;; when computing the sizes, to + ;; make the tree-style layout + ;; work, we have to have each + ;; node have a unique + ;; parent. [2005/07/18:rpg] + (remove-if-not #'(lambda (x) (eq (gethash x parent-hash) node)) + (graph-node-children node)))) + ;; + (+ v0 (max (node-minor-dimension node) + (graph-node-minor-size node)))))))) + ;; + (let ((majors (mapcar (lambda (x) (+ x generation-separation)) + (coerce generation-sizes 'list)))) + (let ((u (+ 0 (car majors))) + (v 0)) + (maplist (lambda (rest) + (setf v (foo (car rest) majors u v)) + (unless (null rest) + (incf v within-generation-separation))) + (graph-root-nodes graph-output-record))))))))))) + + #+ignore (defmethod layout-graph-edges ((graph-output-record standard-graph-output-record) From rgoldman at common-lisp.net Fri Aug 12 02:26:01 2005 From: rgoldman at common-lisp.net (Robert Goldman) Date: Fri, 12 Aug 2005 04:26:01 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/package.lisp Message-ID: <20050812022601.C10608853F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv20358 Modified Files: package.lisp Log Message: FORMAT-GRAPH-FROM-ROOT was not exported from CLIM package. Date: Fri Aug 12 04:26:00 2005 Author: rgoldman Index: mcclim/package.lisp diff -u mcclim/package.lisp:1.49 mcclim/package.lisp:1.50 --- mcclim/package.lisp:1.49 Tue Mar 22 13:31:18 2005 +++ mcclim/package.lisp Fri Aug 12 04:26:00 2005 @@ -709,6 +709,7 @@ #:float ;presentation type #:form ;presentation type #:format-graph-from-roots ;function + #:format-graph-from-root ;function #:format-items ;function #:format-textual-list ;function #:formatting-cell ;macro From crhodes at common-lisp.net Sat Aug 13 14:28:24 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Sat, 13 Aug 2005 16:28:24 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/recording.lisp mcclim/stream-output.lisp Message-ID: <20050813142824.3151988545@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv4334 Modified Files: recording.lisp stream-output.lisp Log Message: Commit working version of text-bounding-rectangle* stuff, as trailed on mcclim-devel 2005-08-12. Basically, this is needed because the drawn area for left-to-right text need not lie between (x,y-ascent) and (x+width,y+descent). (No doubt other text drawing directions suffer from the same problem, but they're not yet implemented in McCLIM). New per-medium function TEXT-BOUNDING-RECTANGLE* which actually returns the bounding-rectangle* of what is drawn (cf. TEXT-WIDTH, which doesn't do anything of the sort). Use it in DEF-GRECORDING DRAW-TEXT, and in add-{string,character}-to-output-record, to properly adjust the output record coordinates. While we're at it, fix the bounding box for :y-align :center DRAW-TEXT. Implement this per-medium function for the CLX backend, for the experimental freetype text handling, and for postscript (tested using Climacs, Tabcode and clim-demo::postscript-text). This patch was mostly motivated by the observation that incremental redisplay in climacs windows using the freetype backend caused graphical artifacts to appear over time, thanks to glyphs drawing outside the output record bounding rectangles. Breaks: * CLX backend with #+unicode (clisp?) * Beagle backend * OpenGL backend (please fix!) Date: Sat Aug 13 16:28:21 2005 Author: crhodes Index: mcclim/recording.lisp diff -u mcclim/recording.lisp:1.118 mcclim/recording.lisp:1.119 --- mcclim/recording.lisp:1.118 Tue Feb 15 12:28:11 2005 +++ mcclim/recording.lisp Sat Aug 13 16:28:19 2005 @@ -1644,7 +1644,7 @@ (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end align-x align-y toward-x toward-y transform-glyphs) () ;; FIXME!!! Text direction. - ;; Multiple lines? + ;; FIXME: Multiple lines. (let* ((text-style (graphics-state-text-style graphic)) (width (if (characterp string) (stream-character-width stream string :text-style text-style) @@ -1654,27 +1654,26 @@ (ascent (text-style-ascent text-style (sheet-medium stream))) (descent (text-style-descent text-style (sheet-medium stream))) (height (+ ascent descent)) - (transform (medium-transformation medium)) - left top right bottom) + (transform (medium-transformation medium))) (setf (values point-x point-y) (transform-position transform point-x point-y)) - (ecase align-x - (:left (setq left point-x - right (+ point-x width))) - (:right (setq left (- point-x width) - right point-x)) - (:center (setq left (- point-x (round width 2)) - right (+ point-x (round width 2))))) - (ecase align-y - (:baseline (setq top (- point-y ascent) - bottom (+ point-y descent))) - (:top (setq top point-y - bottom (+ point-y height))) - (:bottom (setq top (- point-y height) - bottom point-y)) - (:center (setq top (- point-y (floor height 2)) - bottom (+ point-y (ceiling height 2))))) - (values left top right bottom))) + (multiple-value-bind (left top right bottom) + (text-bounding-rectangle* medium string + :start start :end end :text-style text-style) + (ecase align-x + (:left (incf left point-x) (incf right point-x)) + (:right (incf left (- point-x width)) (incf right (- point-x width))) + (:center (incf left (- point-x (round width 2))) + (incf right (- point-x (round width 2))))) + (ecase align-y + (:baseline (incf top point-y) (incf bottom point-y)) + (:top (incf top (+ point-y ascent)) + (incf bottom (+ point-y ascent))) + (:bottom (incf top (- point-y descent)) + (incf bottom (- point-y descent))) + (:center (incf top (+ point-y (ceiling (- ascent descent) 2))) + (incf bottom (+ point-y (ceiling (- ascent descent) 2))))) + (values left top right bottom)))) (defmethod* (setf output-record-position) :around (nx ny (record draw-text-output-record)) @@ -1736,6 +1735,15 @@ (baseline :initform 0) (width :initform 0) (max-height :initform 0) + ;; FIXME (or rework this comment): CLIM does not separate the + ;; notions of the text width and the bounding box; however, we need + ;; to, because some fonts will render outside the logical + ;; coordinates defined by the start position and the width. LEFT + ;; and RIGHT here (and below) deal with this in a manner completely + ;; hidden from the user. (should we export + ;; TEXT-BOUNDING-RECTANGLE*?) + (left :initarg :start-x) + (right :initarg :start-x) (start-x :initarg :start-x) (start-y :initarg :start-y) (end-x :initarg :start-x) @@ -1757,12 +1765,14 @@ ((record standard-text-displayed-output-record) (record2 standard-text-displayed-output-record)) (with-slots - (initial-x1 initial-y1 start-x start-y end-x end-y wrapped strings) + (initial-x1 initial-y1 start-x start-y left right end-x end-y wrapped strings) record2 (and (coordinate= (slot-value record 'initial-x1) initial-x1) (coordinate= (slot-value record 'initial-y1) initial-y1) (coordinate= (slot-value record 'start-x) start-x) (coordinate= (slot-value record 'start-y) start-y) + (coordinate= (slot-value record 'left) left) + (coordinate= (slot-value record 'right) right) (coordinate= (slot-value record 'end-x) end-x) (coordinate= (slot-value record 'end-y) end-y) (eq (slot-value record 'wrapped) wrapped) @@ -1835,20 +1845,21 @@ (defmethod tree-recompute-extent ((text-record standard-text-displayed-output-record)) - (with-standard-rectangle* (:x1 x1 :y1 y1) + (with-standard-rectangle* (:y1 y1) text-record - (with-slots (width max-height) + (with-slots (max-height left right) text-record (setf (rectangle-edges* text-record) - (values x1 y1 - (coordinate (+ x1 width)) - (coordinate (+ y1 max-height)))))) + (values (coordinate left) + y1 + (coordinate right) + (coordinate (+ y1 max-height)))))) text-record) (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-... ((text-record standard-text-displayed-output-record) character text-style char-width height new-baseline) - (with-slots (strings baseline width max-height start-y end-x end-y medium) + (with-slots (strings baseline width max-height left right start-y end-x end-y medium) text-record (if (and strings (let ((string (last1 strings))) @@ -1868,11 +1879,18 @@ :element-type 'character :adjustable t :fill-pointer t))))) - (setq baseline (max baseline new-baseline) - end-x (+ end-x char-width) - max-height (max max-height height) - end-y (max end-y (+ start-y max-height)) - width (+ width char-width))) + (multiple-value-bind (minx miny maxx maxy) + (text-bounding-rectangle* medium character :text-style text-style) + (declare (ignore miny maxy)) + (setq baseline (max baseline new-baseline) + ;; KLUDGE: note END-X here is really START-X of the new + ;; string + left (min left (+ end-x minx)) + end-x (+ end-x char-width) + right (+ end-x (max 0 (- maxx char-width))) + max-height (max max-height height) + end-y (max end-y (+ start-y max-height)) + width (+ width char-width)))) (tree-recompute-extent text-record)) (defmethod add-string-output-to-text-record @@ -1886,7 +1904,7 @@ (aref string start) text-style string-width height new-baseline)) - (t (with-slots (strings baseline width max-height start-y end-x end-y + (t (with-slots (strings baseline width max-height left right start-y end-x end-y medium) text-record (let ((styled-string (make-instance @@ -1901,12 +1919,21 @@ (nconcf strings (list styled-string)) (replace (styled-string-string styled-string) string :start2 start :end2 end)) - (setq baseline (max baseline new-baseline) - end-x (+ end-x string-width) - max-height (max max-height height) - end-y (max end-y (+ start-y max-height)) - width (+ width string-width))) - (tree-recompute-extent text-record))))) + (multiple-value-bind (minx miny maxx maxy) + (text-bounding-rectangle* medium string + :text-style text-style + :start start :end end) + (declare (ignore miny maxy)) + (setq baseline (max baseline new-baseline) + ;; KLUDGE: note that END-X here really means + ;; START-X of the new string. + left (min left (+ end-x minx)) + end-x (+ end-x string-width) + right (+ end-x (max 0 (- maxx string-width))) + max-height (max max-height height) + end-y (max end-y (+ start-y max-height)) + width (+ width string-width)))) + (tree-recompute-extent text-record))))) (defmethod text-displayed-output-record-string ((record standard-text-displayed-output-record)) Index: mcclim/stream-output.lisp diff -u mcclim/stream-output.lisp:1.55 mcclim/stream-output.lisp:1.56 --- mcclim/stream-output.lisp:1.55 Thu Apr 21 04:43:19 2005 +++ mcclim/stream-output.lisp Sat Aug 13 16:28:20 2005 @@ -358,9 +358,7 @@ (unless (= start split) (stream-write-output stream string - (if (eql end split) - width - nil) + nil start split) (setq cx (+ cx width)) (with-slots (x y) (stream-text-cursor stream) From crhodes at common-lisp.net Sat Aug 13 14:28:59 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Sat, 13 Aug 2005 16:28:59 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-fonts.lisp Message-ID: <20050813142859.5686B88545@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv4334/Experimental/freetype Modified Files: freetype-fonts.lisp Log Message: Commit working version of text-bounding-rectangle* stuff, as trailed on mcclim-devel 2005-08-12. Basically, this is needed because the drawn area for left-to-right text need not lie between (x,y-ascent) and (x+width,y+descent). (No doubt other text drawing directions suffer from the same problem, but they're not yet implemented in McCLIM). New per-medium function TEXT-BOUNDING-RECTANGLE* which actually returns the bounding-rectangle* of what is drawn (cf. TEXT-WIDTH, which doesn't do anything of the sort). Use it in DEF-GRECORDING DRAW-TEXT, and in add-{string,character}-to-output-record, to properly adjust the output record coordinates. While we're at it, fix the bounding box for :y-align :center DRAW-TEXT. Implement this per-medium function for the CLX backend, for the experimental freetype text handling, and for postscript (tested using Climacs, Tabcode and clim-demo::postscript-text). This patch was mostly motivated by the observation that incremental redisplay in climacs windows using the freetype backend caused graphical artifacts to appear over time, thanks to glyphs drawing outside the output record bounding rectangles. Breaks: * CLX backend with #+unicode (clisp?) * Beagle backend * OpenGL backend (please fix!) Date: Sat Aug 13 16:28:34 2005 Author: crhodes Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.10 mcclim/Experimental/freetype/freetype-fonts.lisp:1.11 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.10 Fri Jul 29 08:50:20 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Sat Aug 13 16:28:33 2005 @@ -160,7 +160,8 @@ :y-origin top :x-advance dx :y-advance dy) - (list glyph-id dx dy)))) + (let ((right (+ left (array-dimension arr 1)))) + (list glyph-id dx dy left right top))))) ;;;;;;; mcclim interface @@ -182,22 +183,32 @@ (defmethod clim-clx::font-glyph-width ((font freetype-face) char) (with-slots (display font matrix) font (nth 1 (display-get-glyph display font matrix char)))) +(defmethod clim-clx::font-glyph-left ((font freetype-face) char) + (with-slots (display font matrix) font + (nth 3 (display-get-glyph display font matrix char)))) +(defmethod clim-clx::font-glyph-right ((font freetype-face) char) + (with-slots (display font matrix) font + (nth 4 (display-get-glyph display font matrix char)))) +;;; this is a hacky copy of XLIB:TEXT-EXTENTS (defmethod clim-clx::font-text-extents ((font freetype-face) string &key (start 0) (end (length string)) translate) ;; -> (width ascent descent left right ;; font-ascent font-descent direction ;; first-not-done) translate - (values - (loop for i from start below end - sum (clim-clx::font-glyph-width font (char-code (aref string i)))) - (clim-clx::font-ascent font) - (clim-clx::font-descent font) - 0 0 - (clim-clx::font-ascent font) - (clim-clx::font-descent font) - 0 end)) + (let ((width (loop for i from start below end + sum (clim-clx::font-glyph-width font (char-code (aref string i)))))) + (values + width + (clim-clx::font-ascent font) + (clim-clx::font-descent font) + (clim-clx::font-glyph-left font (char-code (char string start))) + (- width (- (clim-clx::font-glyph-width font (char-code (char string (1- end)))) + (clim-clx::font-glyph-right font (char-code (char string (1- end)))))) + (clim-clx::font-ascent font) + (clim-clx::font-descent font) + 0 end))) (defun drawable-picture (drawable) (or (getf (xlib:drawable-plist drawable) 'picture) @@ -373,6 +384,47 @@ font-ascent font-descent direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) + +(defmethod climi::text-bounding-rectangle* + ((medium clx-medium) string &key text-style (start 0) end) + (when (characterp string) + (setf string (make-string 1 :initial-element string))) + (unless end (setf end (length string))) + (unless text-style (setf text-style (medium-text-style medium))) + (let ((xfont (text-style-to-X-font (port medium) text-style))) + (cond ((= start end) + (values 0 0 0 0)) + (t + (let ((position-newline (position #\newline string :start start))) + (cond ((not (null position-newline)) + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (font-text-extents xfont string + :start start :end position-newline + :translate #'translate) + (declare (ignorable left right + font-ascent font-descent + direction first-not-done)) + (multiple-value-bind (minx miny maxx maxy) + (climi::text-bounding-rectangle* + medium string :text-style text-style + :start (1+ position-newline) :end end) + (values (min minx left) (- ascent) + (max maxx right) (+ descent maxy))))) + (t + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (font-text-extents xfont string + :start start :end end + :translate #'translate) + (declare (ignore width direction first-not-done)) + ;; FIXME: Potential style points: + ;; * (min 0 left), (max width right) + ;; * font-ascent / ascent + (values left (- font-ascent) right font-descent))))))))) + (defmethod make-medium-gcontext* (medium foreground background line-style text-style (ink color) clipping-region) (let* ((drawable (sheet-mirror (medium-sheet medium))) From rstrandh at common-lisp.net Sun Aug 14 04:01:28 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 14 Aug 2005 06:01:28 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Doc/manual.tex mcclim/Doc/ex2.lisp Message-ID: <20050814040128.6D275884CB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv23985 Modified Files: manual.tex ex2.lisp Log Message: Added :display-time nil to example 2 so that it will run correctly. Added a paragraph to the manual explaining what that means. Date: Sun Aug 14 06:01:23 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.27 mcclim/Doc/manual.tex:1.28 --- mcclim/Doc/manual.tex:1.27 Thu Apr 7 09:54:59 2005 +++ mcclim/Doc/manual.tex Sun Aug 14 06:01:19 2005 @@ -1,6 +1,7 @@ % -*- coding: latin-1; -*- \documentclass{book} +\usepackage[T1]{fontenc} \usepackage[latin1]{inputenc} \usepackage{color} \usepackage{epsfig} @@ -350,6 +351,22 @@ such as \texttt{format} and \texttt{read} and to CLIM-specific functions such as \texttt{draw-line}. +In this example we have such an application pane, the name of which is +\texttt{app}. As you can see, we have defined it with an option +\texttt{:display-time nil}. The default value for this option for an +application pane is \texttt{:command-loop}, which means that the pane +is cleared after each iteration in the command loop, and then +redisplayed using a client-supplied \emph{display function}. The +default display function does nothing, and we have not supplied any, +so if we had omitted the \texttt{:display-time nil} option, the +\texttt{parity} command would have written to the pane. Then, at the +end of the command loop, the pane would have been cleared, and nothing +else would have been displayed. The net result is that we would have +seen no visible output. With the option \texttt{:display-time nil}, +the pane is never cleared, and output is accumulated every time we +execute the \texttt{parity} command. + + For this example, let us also add a few \emph{commands}. Such commands are defined by the use of a macro called \texttt{define-}\textit{name}\texttt{-command}, where \textit{name} is @@ -648,9 +665,8 @@ c. Mirrors are outlined with dotted rectangles. \begin{figure} - \begin{center} - \input native.pstex_t -%\inputfig{native.pstex_t} +\begin{center} +\inputfig{native.pstex_t} \end{center} \caption{\label{fignative} A sheet with a nontrivial transformation} \end{figure} Index: mcclim/Doc/ex2.lisp diff -u mcclim/Doc/ex2.lisp:1.2 mcclim/Doc/ex2.lisp:1.3 --- mcclim/Doc/ex2.lisp:1.2 Thu Jul 22 14:04:55 2004 +++ mcclim/Doc/ex2.lisp Sun Aug 14 06:01:21 2005 @@ -10,7 +10,7 @@ () (:pointer-documentation t) (:panes - (app :application :height 600 :width 600) + (app :application :display-time nil :height 400 :width 600) (int :interactor :height 200 :width 600)) (:layouts (default (vertically () app int)))) From rstrandh at common-lisp.net Sun Aug 14 04:32:39 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 14 Aug 2005 06:32:39 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Doc/ex2b.lisp mcclim/Doc/manual.tex Message-ID: <20050814043239.6553C884CB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv26982 Modified Files: manual.tex Added Files: ex2b.lisp Log Message: Another simple example with explanations. Date: Sun Aug 14 06:32:39 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.28 mcclim/Doc/manual.tex:1.29 --- mcclim/Doc/manual.tex:1.28 Sun Aug 14 06:01:19 2005 +++ mcclim/Doc/manual.tex Sun Aug 14 06:32:38 2005 @@ -403,6 +403,52 @@ must have an option of \texttt{:name t}. The reason is that some commands will be available only from menus or by some other mechanism. +\section{An application displaying a data structure} + +Many applications use a central data structure that is to be on +display at all times, and that is modified by the commands of the +application. CLIM allows for a very easy way to write such an +application. The main idea is to store the data structure in slots of +the application frame, and to use a \emph{display function} that after +each iteration of the command loop displays the entire data structure +to the application pane. + +Here is a variation of the previous application that shows this +possibility: + +\verbatimtabinput{ex2b.lisp} + +Here, we have added a slot that is called \texttt{current-number} to +the application frame. It is initialized to \texttt{NIL} and it has +an accessor function that allow us to query and to modify the value. + +Observe that in this example, we no longer have the option +\texttt{:display-time nil} set in the application pane. By default, +then, the \texttt{:display-time} is \texttt{:command-loop} which means +that the pane is erased after each iteration of the command loop. +Also observe the option \texttt{:display-function} which takes a +symbol that names a function to be called to display the pane after it +has been cleared. In this case, the name is \texttt{display-app}, the +name of the function defined immediately after the application frame. + +Instead of immediately displaying information about its argument, the +command \texttt{com-parity} instead modifies the new slot of the +application frame. Think of this function as being more general, for +instance a command to add a new object to a set of graphical objects +in a figure drawing program, or as a command to add a new name to an +address book. Notice how this function accesses the current +application frame by means of the special variable +\texttt{*application-frame*}. + +A display function is called with the frame and the pane as +arguments. It is good style to use the pane as the stream in calls to +functions that will result in output. This makes it possible for the +same function to be used by several different frames, should that be +called for. In our simple example, the display function only displays +the value of a single number (or \texttt{NIL}), but you could think of +this as displaying all the objects that have been drawn in some figure +drawing program or displaying all the entries in an address book. + \chapter{Using presentation types} \section{What is a presentation type} From rstrandh at common-lisp.net Sun Aug 14 06:20:13 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 14 Aug 2005 08:20:13 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Doc/ex2c.lisp mcclim/Doc/manual.tex Message-ID: <20050814062013.202DC884CB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv1335 Modified Files: manual.tex Added Files: ex2c.lisp Log Message: Added example using incremental redisplay. Date: Sun Aug 14 08:20:13 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.29 mcclim/Doc/manual.tex:1.30 --- mcclim/Doc/manual.tex:1.29 Sun Aug 14 06:32:38 2005 +++ mcclim/Doc/manual.tex Sun Aug 14 08:20:12 2005 @@ -403,6 +403,25 @@ must have an option of \texttt{:name t}. The reason is that some commands will be available only from menus or by some other mechanism. +You may notice that if the output of the application is hidden (say by +the window of some other application) and then re-exposed, the output +reappears normally, without any intervention necessary on the part of +the programmer. This effect is accomplished by a CLIM mechanism +called \emph{output recording}. Essentially, every piece of output is +not only displayed in the pane, but also captured in an \emph{output + record} associated with the pane. When a pane is re-exposed, its +output records are consulted and if any of them overlap the +re-exposed region, they are redisplayed. In fact, some others may be +redisplayed as well, because CLIM guarantees that the effect will be +the same as when the initial output was created. It does that by +making sure that the order between (partially) overlapping output +records is respected. + +Not all panes support output recording, but certainly application +panes do, so it is good to use some subclass of +\texttt{application-pane} to display application-specific object, +because output recording is then automatic. + \section{An application displaying a data structure} Many applications use a central data structure that is to be on @@ -448,6 +467,73 @@ the value of a single number (or \texttt{NIL}), but you could think of this as displaying all the objects that have been drawn in some figure drawing program or displaying all the entries in an address book. + +\section{Incremental redisplay} + +While the example in the previous section is a very simple way of +structuring an application (let commands arbitrarily modify the data +structure, and simply erase the pane and redisplay the structure after +each iteration of the command loop), the visual result is not so great +when many objects are to be displayed. There is most often a +noticeable flicker between the moment when the pane is cleared and the +objects are drawn. Sometimes this is inevitable (as when nearly all +objects change), but most of the time, only an incremental +modification has been made, and most of the objects are still in the +same place as before. + +In simple toolkits, the application programmer would have to figure +out what has changed since the previous display, and only display the +differences. CLIM offers a mechanism called \emph{incremental + redisplay} that automates a large part of this task. As we +mentioned earlier, CLIM captures output in the form of \emph{output + records}. The same mechanism is used to obtain incremental +redisplay. + +To use incremental redisplay, Client code remains structured in the +simple way that was mention above: after each iteration of the command +loop, the display function output the entire data structure as usual, +except that it helps the incremental redisplay mechanism by telling +CLIM which piece of output corresponds to which piece of output during +the previous iteration of the command loop. It does this by giving +some kind of \emph{unique identity} to some piece of output, and some +means of indicating whether the contents of this output is \emph{the + same} as it was last time. With this information, the CLIM +incremental redisplay mechanism can figure out whether some output is +new, has disappeared, or has been moved, compared to the previous +iteration of the command loop. As with re-exposure, CLIM guarantees +that the result is identical to that which would have been obtained, +had all the output records been output in order to a blank pane. + +The next example illustrates this idea. It is a simple application +that displays a fixed number (here 20) of lines, each line being a +number. Here is the code: + +\verbatimtabinput{ex2c.lisp} + +We store the numbers in a slot called \texttt{numbers} of the +application frame. However, we store each number in its own list. +This is a simple way to provide a unique identity for each number. We +could not use the number itself, because two numbers could be the same +and the identities would not be unique. Instead, we use the cons cell +that store the number as the unique identity. By using +\texttt{:id-test \#'eq} we inform CLIM that it can figure out whether +an output record is the same as one that was issued previous time by +using the function \texttt{eq} to compare them. But there is a second +test that has to be verified, namely whether an output record that was +issued last time has to be redisplayed or not. That is the purpose of +the cache-value. Here we use the number itself as the cache value and +\texttt{eql} as the test to determine whether the output is going to +be the same as last time. + +For convenience, we display a \texttt{*} at the beginning of the +current line, and we provide two commands \texttt{next} and +\texttt{previous} to navigate between the lines. + +Notice that in the declaration of the pane in the application frame, +we have given the option \texttt{:incremental-redisplay t}. This +informs CLIM not to clear the pane after each command-loop iteration, +but to keep the output records around and compare them to the new ones +that are produced during the new iteration. \chapter{Using presentation types} From crhodes at common-lisp.net Sun Aug 14 12:47:42 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Sun, 14 Aug 2005 14:47:42 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp Message-ID: <20050814124742.044E488545@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv27374/Backends/CLX Modified Files: medium.lisp Log Message: Whoops. Forgot to commit this one. (Thanks to Peter Mechlenborg) Date: Sun Aug 14 14:47:42 2005 Author: crhodes Index: mcclim/Backends/CLX/medium.lisp diff -u mcclim/Backends/CLX/medium.lisp:1.66 mcclim/Backends/CLX/medium.lisp:1.67 --- mcclim/Backends/CLX/medium.lisp:1.66 Thu Feb 17 22:23:29 2005 +++ mcclim/Backends/CLX/medium.lisp Sun Aug 14 14:47:42 2005 @@ -827,6 +827,47 @@ direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) +#-unicode +(defmethod climi::text-bounding-rectangle* + ((medium clx-medium) string &key text-style (start 0) end) + (when (characterp string) + (setf string (make-string 1 :initial-element string))) + (unless end (setf end (length string))) + (unless text-style (setf text-style (medium-text-style medium))) + (let ((xfont (text-style-to-X-font (port medium) text-style))) + (cond ((= start end) + (values 0 0 0 0)) + (t + (let ((position-newline (position #\newline string :start start))) + (cond ((not (null position-newline)) + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (xlib:text-extents xfont string + :start start :end position-newline + :translate #'translate) + (declare (ignorable left right + font-ascent font-descent + direction first-not-done)) + (multiple-value-bind (minx miny maxx maxy) + (text-bounding-rectangle* + medium string :text-style text-style + :start (1+ position-newline) :end end) + (values (min minx left) (- ascent) + (max maxx right) (+ descent maxy))))) + (t + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (xlib:text-extents xfont string + :start start :end end + :translate #'translate) + (declare (ignore width direction first-not-done)) + ;; FIXME: Potential style points: + ;; * (min 0 left), (max width right) + ;; * font-ascent / ascent + (values left (- font-ascent) right font-descent))))))))) + #+unicode (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end) (when (characterp string) From tmoore at common-lisp.net Mon Aug 15 00:41:41 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Mon, 15 Aug 2005 02:41:41 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp Message-ID: <20050815004141.BAFDD88547@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv9635 Modified Files: incremental-redisplay.lisp Log Message: Change specialized output-record-hash method to specialize on standard-bounding-rectangle, as noted by Taylor Campbell Date: Mon Aug 15 02:41:38 2005 Author: tmoore Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.49 mcclim/incremental-redisplay.lisp:1.50 --- mcclim/incremental-redisplay.lisp:1.49 Tue Aug 9 22:30:12 2005 +++ mcclim/incremental-redisplay.lisp Mon Aug 15 02:41:38 2005 @@ -715,7 +715,7 @@ (:documentation "Produce a value that can be used to hash the output record in an equalp hash table")) -(defmethod output-record-hash ((record basic-output-record)) +(defmethod output-record-hash ((record standard-bounding-rectangle)) (slot-value record 'coordinates)) (defconstant +fixnum-bits+ (integer-length most-positive-fixnum)) From rstrandh at common-lisp.net Tue Aug 16 04:30:38 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Tue, 16 Aug 2005 06:30:38 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp Message-ID: <20050816043038.64A7088544@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26736 Modified Files: incremental-redisplay.lisp Log Message: Fixed a bug in function-matches-p. It should use symbol-function and not symbol-value. Date: Tue Aug 16 06:30:37 2005 Author: rstrandh Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.50 mcclim/incremental-redisplay.lisp:1.51 --- mcclim/incremental-redisplay.lisp:1.50 Mon Aug 15 02:41:38 2005 +++ mcclim/incremental-redisplay.lisp Tue Aug 16 06:30:37 2005 @@ -124,9 +124,9 @@ ((and (symbolp map-test-func) (symbolp func)) ; not eq nil) ((and (symbolp map-test-func) (fboundp map-test-func)) - (eq (symbol-value map-test-func) func)) + (eq (symbol-function map-test-func) func)) ((and (symbolp func) (fboundp func)) - (eq map-test-func (symbol-value func))) + (eq map-test-func (symbol-function func))) (t nil)))) (defun ensure-test (map test) From rstrandh at common-lisp.net Thu Aug 18 03:17:23 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 18 Aug 2005 05:17:23 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/frames.lisp mcclim/incremental-redisplay.lisp Message-ID: <20050818031723.BB0448815C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv24177 Modified Files: frames.lisp incremental-redisplay.lisp Log Message: Initial cleanups to incremental redisplay. Date: Thu Aug 18 05:17:22 2005 Author: rstrandh Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.107 mcclim/frames.lisp:1.108 --- mcclim/frames.lisp:1.107 Sun Apr 17 20:46:26 2005 +++ mcclim/frames.lisp Thu Aug 18 05:17:21 2005 @@ -484,25 +484,6 @@ (:disowned (disown-frame fm frame))))))) -;;; Defined in incremental-redisplay.lisp -(defvar *enable-updating-output*) - -#+nil -(defun redisplay-changed-panes (frame) - (map-over-sheets #'(lambda (pane) - (multiple-value-bind (redisplayp clearp) - (pane-needs-redisplay pane) - (when redisplayp - (when (and clearp - (or (not (pane-incremental-redisplay - pane)) - (not *enable-updating-output*))) - (window-clear pane)) - (redisplay-frame-pane frame pane) - (unless (eq redisplayp :command-loop) - (setf (pane-needs-redisplay pane) nil))))) - (frame-top-level-sheet frame))) - (defparameter +default-prompt-style+ (make-text-style :fix :italic :normal)) (defmethod default-frame-top-level Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.51 mcclim/incremental-redisplay.lisp:1.52 --- mcclim/incremental-redisplay.lisp:1.51 Tue Aug 16 06:30:37 2005 +++ mcclim/incremental-redisplay.lisp Thu Aug 18 05:17:21 2005 @@ -245,8 +245,7 @@ (defmethod pane-needs-redisplay :around ((pane updating-output-stream-mixin)) (let ((redisplayp (call-next-method))) (values redisplayp (and (not (eq redisplayp :no-clear)) - (or (not (pane-incremental-redisplay pane)) - (not *enable-updating-output*)))))) + (not (pane-incremental-redisplay pane)))))) (defmethod window-clear :after ((pane updating-output-stream-mixin)) "Get rid of any updating output records stored in the stream; they're gone @@ -850,9 +849,6 @@ ;; move overlapping nil))))) -(defparameter *enable-updating-output* t - "Switch to turn on incremental redisplay") - (defvar *trace-updating-output* nil) (defvar *no-unique-id* (cons nil nil)) @@ -874,8 +870,6 @@ unique-id id-test cache-value cache-test &key (fixed-position nil) (all-new nil) (parent-cache nil)) - (unless *enable-updating-output* - (return-from invoke-updating-output (funcall continuation stream))) (finish-output stream) (let ((parent-cache (or parent-cache *current-updating-output* stream))) (when (eq unique-id *no-unique-id*) @@ -991,16 +985,6 @@ (defvar *dump-updating-output* nil) -;;; Protocol for notifying that records have been added or deleted, -;;; for real, during redisplay. - -(defgeneric redisplay-add-output-record (record stream) - (:documentation "Process an output record that has been added (i.e., - was not in the output history of the stream) during redisplay. The - record has not been displayed yet.")) - -(defgeneric redisplay-delete-output-record (record bounding-rectangle stream)) - (defgeneric redisplay-output-record (record stream &optional check-overlapping)) @@ -1032,30 +1016,6 @@ (delete-stale-updating-output record)) (set-medium-graphics-state current-graphics-state stream))))) -(defmethod redisplay-add-output-record (record - (stream updating-output-stream-mixin)) - (with-bounding-rectangle* (x1 y1 x2 y2) - record - (draw-rectangle* stream x1 y1 x2 y2 - :ink +background-ink+))) - -(defmethod redisplay-add-output-record :after - (record (stream updating-output-stream-mixin)) - (note-output-record-got-sheet record stream)) - -(defmethod redisplay-delete-output-record - (record bounding-rectangle (stream updating-output-stream-mixin)) - (declare (ignore record)) - (with-bounding-rectangle* (x1 y1 x2 y2) - bounding-rectangle - (draw-rectangle* stream x1 y1 x2 y2 - :ink +background-ink+))) - -(defmethod redisplay-delete-output-record :after - (record bounding-rectangle (stream updating-output-stream-mixin)) - (declare (ignore bounding-rectangle)) - (note-output-record-lost-sheet record stream)) - (defun erase-rectangle (stream bounding) (with-bounding-rectangle* (x1 y1 x2 y2) bounding @@ -1244,7 +1204,7 @@ ((frame application-frame) (pane updating-output-stream-mixin) &key force-p) (setf (id-counter pane) 0) (let ((incremental-redisplay (pane-incremental-redisplay pane))) - (cond ((or (not incremental-redisplay) (not *enable-updating-output*)) + (cond ((not incremental-redisplay) (call-next-method)) ((or (null (updating-record pane)) force-p) From rstrandh at common-lisp.net Thu Aug 18 03:25:31 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 18 Aug 2005 05:25:31 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Examples/town-example.lisp Message-ID: <20050818032531.C03B38815C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv24274 Added Files: town-example.lisp Log Message: Another example of the use of CLIM. (thanks to Max-Gerd Retzlaff) It tries to demonstrate the following topics: custom view classes, different present presentation methods for different views, completion for accept presentation methods, accepting-values dialogues, presentation to command translators, partial commands in menus, automatically generated menus, and keystroke gestures for commands. Date: Thu Aug 18 05:25:31 2005 Author: rstrandh From rstrandh at common-lisp.net Thu Aug 18 04:30:12 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 18 Aug 2005 06:30:12 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/commands.lisp Message-ID: <20050818043012.D4BFA8815C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv28655 Modified Files: commands.lisp Log Message: Patch from Max-Gerd Retzlaff Date: Thu Aug 18 06:30:11 2005 Author: rstrandh Index: mcclim/commands.lisp diff -u mcclim/commands.lisp:1.53 mcclim/commands.lisp:1.54 --- mcclim/commands.lisp:1.53 Wed Jun 22 13:41:35 2005 +++ mcclim/commands.lisp Thu Aug 18 06:30:09 2005 @@ -746,30 +746,36 @@ ;; We don't need fresh gensyms of these variables for each accept form. (with-gensyms (value ptype changedp) `(defun ,name (,command-table ,stream ,partial-command) - (destructuring-bind (,command-name , at original-args) - ,partial-command - (let ((,command-line-name (command-line-name-for-command - ,command-name - ,command-table - :errorp nil)) - ,@(mapcar #'list required-arg-names original-args)) - (accepting-values (,stream) - (format ,stream - "You are being prompted for arguments to ~S~%" - ,command-line-name) - ,@(loop - for var in required-arg-names - for original-var in original-args - for parameter in required-args - append `((multiple-value-bind (,value ,ptype ,changedp) - ,(accept-form-for-argument-partial - stream parameter var original-var) - (declare (ignore ,ptype)) - (terpri ,stream) - (when ,changedp - (setq ,var ,value)))))) - (list ,command-name , at required-arg-names)))))))) - + (do ((still-missing nil t)) + (nil) + (destructuring-bind (,command-name , at original-args) + ,partial-command + (let ((,command-line-name (command-line-name-for-command + ,command-name + ,command-table + :errorp nil)) + ,@(mapcar #'list required-arg-names original-args)) + (accepting-values (,stream) + (format ,stream + "You are being prompted for arguments to ~S~%~%" + ,command-line-name) + ,@(loop + for var in required-arg-names + for original-var in original-args + for parameter in required-args + append `((multiple-value-bind (,value ,ptype ,changedp) + ,(accept-form-for-argument-partial + stream parameter var original-var) + (declare (ignore ,ptype)) + (terpri ,stream) + (when ,changedp + (setq ,var ,value))))) + (when still-missing + (format ,stream + "~&Please supply all arguments."))) + (setf ,partial-command (list ,command-name , at required-arg-names)) + (unless (partial-command-p ,partial-command) + (return ,partial-command)))))))))) ;;; XXX What do to about :acceptably? Probably need to wait for Goatee "buffer ;;; streams" so we can insert an accept-result-extent in the buffer for @@ -1079,7 +1085,6 @@ stream (view textual-view) &key) - (declare (ignore acceptably for-context-type)) (let ((command-line-name (command-line-name-for-command object command-table :errorp nil))) (if command-line-name From rstrandh at common-lisp.net Thu Aug 18 19:58:19 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 18 Aug 2005 21:58:19 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/design.lisp mcclim/ports.lisp Message-ID: <20050818195819.9B1D28852B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26220 Modified Files: design.lisp ports.lisp Log Message: Removed a few compiler warnings. Date: Thu Aug 18 21:58:18 2005 Author: rstrandh Index: mcclim/design.lisp diff -u mcclim/design.lisp:1.23 mcclim/design.lisp:1.24 --- mcclim/design.lisp:1.23 Wed Oct 6 07:12:12 2004 +++ mcclim/design.lisp Thu Aug 18 21:58:18 2005 @@ -89,6 +89,8 @@ (define-protocol-class color (design uniform-design)) +(defgeneric color-rgb (color)) + (defmethod print-object ((color color) stream) (print-unreadable-object (color stream :identity nil :type t) (multiple-value-call #'format stream "~,4F ~,4F ~,4F" (color-rgb color)))) @@ -239,6 +241,8 @@ (saturation (atan f2 f1))) (values intensity hue saturation))))) +(defgeneric color-ihs (color)) + (defmethod color-ihs ((color color)) (multiple-value-call #'rgb-to-ihs (color-rgb color))) @@ -354,6 +358,8 @@ (print-unreadable-object (flipper stream :identity nil :type t) (format stream "~S ~S" design1 design2)))) +(defgeneric make-flipping-ink (design1 design2)) + (defmethod make-flipping-ink ((design1 design) (design2 design)) (make-instance 'standard-flipping-ink :design1 design1 :design2 design2)) @@ -396,9 +402,13 @@ (defun make-pattern (array designs) (make-instance 'indexed-pattern :array array :designs designs)) +(defgeneric pattern-width (pattern)) + (defmethod pattern-width ((pattern indexed-pattern)) (with-slots (array) pattern (array-dimension array 1))) + +(defgeneric pattern-height (pattern)) (defmethod pattern-height ((pattern indexed-pattern)) (with-slots (array) pattern Index: mcclim/ports.lisp diff -u mcclim/ports.lisp:1.48 mcclim/ports.lisp:1.49 --- mcclim/ports.lisp:1.48 Tue Feb 22 04:14:26 2005 +++ mcclim/ports.lisp Thu Aug 18 21:58:18 2005 @@ -92,6 +92,9 @@ ;; A method on (SETF KEYBOARD-INPUT-FOCUS) brings them together, ;; calling %SET-PORT-KEYBOARD-FOCUS. +(defgeneric port-keyboard-input-focus (port)) +(defgeneric (setf port-keyboard-input-focus) (focus port)) + (defmethod port-keyboard-input-focus (port) (declare (ignore port)) (when *application-frame* @@ -107,7 +110,7 @@ ;; now calls (setf keyboard-input-focus), we need something concrete the ;; backend can implement to set the focus. (defmethod %set-port-keyboard-focus (port focus &key timestamp) - (declare (ignore focus)) + (declare (ignore focus timestamp)) (warn "%SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port)) From rstrandh at common-lisp.net Fri Aug 19 00:48:26 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 19 Aug 2005 02:48:26 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/dialog.lisp Message-ID: <20050819004826.BA1348852B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14088 Modified Files: dialog.lisp Log Message: Patches to dialog.lisp from Max-Gerd Retzlaff. Date: Fri Aug 19 02:48:26 2005 Author: rstrandh Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.19 mcclim/dialog.lisp:1.20 --- mcclim/dialog.lisp:1.19 Fri Feb 25 15:15:17 2005 +++ mcclim/dialog.lisp Fri Aug 19 02:48:25 2005 @@ -136,6 +136,19 @@ (defvar *accepting-values-stream* nil) +(defmacro with-stream-in-own-window ((&optional (stream '*query-io*) + &rest further-streams) + &rest body) + `(let* ((,stream (open-window-stream)) + ,@(mapcar (lambda (a-stream) + (list a-stream stream)) + further-streams)) + (sleep 0.1) ;; hackhack.. some delay to "ensure" that the window-stream ist opened + (unwind-protect + (progn + , at body) + (close ,stream)))) + (defmacro accepting-values ((&optional (stream t) &rest args @@ -144,17 +157,22 @@ align-prompts label scroll-bars x-position y-position width height command-table frame-class) &body body) - (declare (ignorable own-window exit-boxes initially-select-query-identifier + (declare (ignorable exit-boxes initially-select-query-identifier modify-initial-query resynchronize-every-pass resize-frame align-prompts label scroll-bars x-position y-position width height command-table frame-class)) (setq stream (stream-designator-symbol stream '*standard-input*)) (with-gensyms (accepting-values-continuation) - `(flet ((,accepting-values-continuation (,stream) - , at body)) - (invoke-accepting-values ,stream - #',accepting-values-continuation - , at args)))) + (let ((return-form + `(flet ((,accepting-values-continuation (,stream) + , at body)) + (invoke-accepting-values ,stream + #',accepting-values-continuation + , at args)) + )) + (if own-window + `(with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) + return-form)))) (defun invoke-accepting-values (stream body @@ -167,7 +185,10 @@ (frame-class 'accept-values)) (declare (ignore own-window exit-boxes modify-initial-query resize-frame label scroll-bars x-position y-position - width height frame-class)) + width height frame-class)) + (when (and align-prompts ;; t means the same as :right + (not (eq align-prompts :left))) + (setf align-prompts :right)) (multiple-value-bind (cx cy) (stream-cursor-position stream) (let* ((*accepting-values-stream* (make-instance 'accepting-values-stream @@ -224,11 +245,11 @@ (fresh-line stream) (with-output-as-presentation (stream nil 'exit-button) - (format stream "Exit")) + (format stream "OK")) (write-char #\space stream) (with-output-as-presentation (stream nil 'abort-button) - (format stream "Abort")) + (format stream "Cancel")) (terpri stream))) (defmethod stream-accept ((stream accepting-values-stream) type From rstrandh at common-lisp.net Fri Aug 19 02:20:36 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 19 Aug 2005 04:20:36 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp Message-ID: <20050819022036.977D88852B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv19958 Modified Files: panes.lisp Log Message: Patch to panes.lisp from Max-Gerd Retzlaff. Date: Fri Aug 19 04:20:35 2005 Author: rstrandh Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.153 mcclim/panes.lisp:1.154 --- mcclim/panes.lisp:1.153 Wed Jun 22 11:49:15 2005 +++ mcclim/panes.lisp Fri Aug 19 04:20:35 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.153 2005/06/22 09:49:15 tmoore Exp $ +;;; $Id: panes.lisp,v 1.154 2005/08/19 02:20:35 rstrandh Exp $ (in-package :clim-internals) @@ -2591,6 +2591,7 @@ #+clim-mp (unless input-buffer (clim-sys:make-process (lambda () (let ((*application-frame* frame)) + (redisplay-frame-panes frame :force-p t) (standalone-event-loop))))) (slot-value frame 'stream))) From crhodes at common-lisp.net Fri Aug 19 21:34:44 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Fri, 19 Aug 2005 23:34:44 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Lisp-Dep/fix-sbcl.lisp Message-ID: <20050819213444.7FC0E8853E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory common-lisp.net:/tmp/cvs-serv32041/Lisp-Dep Modified Files: fix-sbcl.lisp Log Message: SBCL / OpenMCL(?) build fixes Fix the perennially annoying duplicate component error in the Scigraph defsystem (name the components by the full namestring, which should be unique) While I'm at it, fix the annoyance over static / dynamic packages: for sbcl, clim-lisp-patch and clim-mop are dynamic packages, so they shouldn't be created by DEFPACKAGE (because reevaluating the defpackage subsequently, say by recompiling stuff, then invokes undefined behaviour) Date: Fri Aug 19 23:34:43 2005 Author: crhodes Index: mcclim/Lisp-Dep/fix-sbcl.lisp diff -u mcclim/Lisp-Dep/fix-sbcl.lisp:1.8 mcclim/Lisp-Dep/fix-sbcl.lisp:1.9 --- mcclim/Lisp-Dep/fix-sbcl.lisp:1.8 Mon Feb 23 11:48:28 2004 +++ mcclim/Lisp-Dep/fix-sbcl.lisp Fri Aug 19 23:34:43 2005 @@ -2,10 +2,11 @@ (when (find-package "SB-MOP") (pushnew :sb-mop *features*))) -(defpackage #:clim-mop - (:use #+sb-mop #:sb-mop #-sb-mop #:sb-pcl) - #-sb-mop - (:shadowing-import-from #:sb-pcl #:eql-specializer-object)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package '#:clim-mop) + (make-package '#:clim-mop :use '(#+sb-mop #:sb-mop + #-sb-mop #:sb-pcl)) + (shadowing-import 'sb-pcl::eql-specializer-object '#:clim-mop))) (eval-when (:compile-toplevel :load-toplevel :execute) (loop for sym being the symbols of :clim-mop From crhodes at common-lisp.net Fri Aug 19 21:34:43 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Fri, 19 Aug 2005 23:34:43 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/mcclim.asd mcclim/patch.lisp Message-ID: <20050819213443.1CD0988032@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv32041 Modified Files: mcclim.asd patch.lisp Log Message: SBCL / OpenMCL(?) build fixes Fix the perennially annoying duplicate component error in the Scigraph defsystem (name the components by the full namestring, which should be unique) While I'm at it, fix the annoyance over static / dynamic packages: for sbcl, clim-lisp-patch and clim-mop are dynamic packages, so they shouldn't be created by DEFPACKAGE (because reevaluating the defpackage subsequently, say by recompiling stuff, then invokes undefined behaviour) Date: Fri Aug 19 23:34:42 2005 Author: crhodes Index: mcclim/mcclim.asd diff -u mcclim/mcclim.asd:1.5 mcclim/mcclim.asd:1.6 --- mcclim/mcclim.asd:1.5 Wed Apr 20 00:35:42 2005 +++ mcclim/mcclim.asd Fri Aug 19 23:34:41 2005 @@ -78,7 +78,7 @@ (parse-namestring c) (make-pathname :type "lisp" :defaults *clim-directory*)) - collect `(:file ,(pathname-name p) :pathname ,p)))))) + collect `(:file ,(namestring p) :pathname ,p)))))) (defsystem :clim-lisp :components Index: mcclim/patch.lisp diff -u mcclim/patch.lisp:1.4 mcclim/patch.lisp:1.5 --- mcclim/patch.lisp:1.4 Mon Nov 15 05:47:41 2004 +++ mcclim/patch.lisp Fri Aug 19 23:34:41 2005 @@ -1,6 +1,10 @@ (in-package :cl-user) -(defpackage :clim-lisp-patch - (:use) - (:export #:describe #:describe-object #:interactive-stream-p)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package :clim-lisp-patch) + (make-package :clim-lisp-patch :use nil))) +(export '(clim-lisp-patch::describe + clim-lisp-patch::describe-object + clim-lisp-patch::interactive-stream-p) + :clim-lisp-patch) From rstrandh at common-lisp.net Mon Aug 22 02:49:09 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 22 Aug 2005 04:49:09 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Doc/manual.tex Message-ID: <20050822024909.43594884C2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv18523 Modified Files: manual.tex Log Message: Fixed the figure of the example application according to a mail from Dan Barlow in July of 2003. Date: Mon Aug 22 04:49:06 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.30 mcclim/Doc/manual.tex:1.31 --- mcclim/Doc/manual.tex:1.30 Sun Aug 14 08:20:12 2005 +++ mcclim/Doc/manual.tex Mon Aug 22 04:49:05 2005 @@ -394,7 +394,8 @@ \begin{figure} \begin{center} -\includegraphics{ex2} +\epsfxsize=5in +\epsffile{ex2.eps} \end{center} \caption{\label{figex2} View of the improved example} \end{figure} From crhodes at common-lisp.net Mon Aug 22 09:28:35 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 22 Aug 2005 11:28:35 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-ffi.lisp Message-ID: <20050822092835.026A3880DD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv12313 Modified Files: freetype-ffi.lisp Log Message: Make the Freetype FFI 32/64 agnostic. Untested on CMUCL, but I don't think the previous version worked on CMUCL either. Date: Mon Aug 22 11:28:35 2005 Author: crhodes Index: mcclim/Experimental/freetype/freetype-ffi.lisp diff -u mcclim/Experimental/freetype/freetype-ffi.lisp:1.2 mcclim/Experimental/freetype/freetype-ffi.lisp:1.3 --- mcclim/Experimental/freetype/freetype-ffi.lisp:1.2 Sun Jun 5 22:50:29 2005 +++ mcclim/Experimental/freetype/freetype-ffi.lisp Mon Aug 22 11:28:34 2005 @@ -1,6 +1,9 @@ ;;; automatically generated, hand tweaked, do not regenerate. -(DEFPACKAGE :FREETYPE (:USE :cl #+sbcl :sb-alien #+cmucl :alien) +(DEFPACKAGE :FREETYPE + (:USE :cl + #+sbcl :sb-alien + #+cmucl :alien #+cmucl :c-call) (:EXPORT "MEMORY-BASE" "DESCENDER" "LINEAR-VERT-ADVANCE" "YX" "XX" "FREE" "AVAILABLE-SIZES" "COVERAGE" "METRICS" "RASTER-FLAG" "GLYPH" "GET-CHAR-INDEX" "LIMIT" "STRING" "SHIFT" "LEN" "UNDERLINE-POSITION" "RASTER-NEW-FUNC" "POINTS" "TAG" "SIZE-INTERNAL" "NUM-SUBGLYPHS" "UNITS-PER-EM" "LIBRARY" "ALLOC" "OPEN-FACE" "ATTACH-FILE" @@ -37,8 +40,6 @@ "BITMAP-" "FILE_BASE" "KERN_MODE" "CHAR_CODE" "RENDERER-REC-" "RASTER-REC-" "VECTOR-" "SIZE-METRICS-" "CHAR_WIDTH" "GENERIC-" "ENCODING-" "FACE_INDEX" "SLOT" "GLYPH-FORMAT-" "OPEN-ARGS-" "BBOX-" "SIZE_S")) -;;(declaim (sb-ext:muffle-conditions sb-int:deprecation-warning)) - (in-package :freetype) #+cmucl @@ -75,6 +76,52 @@ (define-alien-type freetype:ufast (unsigned 32)) +(define-alien-type freetype:ptrdiff-t (signed 32)) + +(define-alien-type freetype:size-t (unsigned 32)) + +(define-alien-type freetype:wchar-t (signed 32)) + +(define-alien-type freetype:wint-t (unsigned 32)) + +(define-alien-type freetype:bool (unsigned 8)) + +(define-alien-type freetype:fword (signed 16)) + +(define-alien-type freetype:ufword (unsigned 16)) + +(define-alien-type freetype:char (signed 8)) + +(define-alien-type freetype:byte (unsigned 8)) + +(define-alien-type freetype:string (signed 8)) + +(define-alien-type freetype:short (signed 16)) + +(define-alien-type freetype:ushort (unsigned 16)) + +(define-alien-type freetype:int (signed 32)) + +(define-alien-type freetype:uint (unsigned 32)) + +(define-alien-type freetype:long long) + +(define-alien-type freetype:ulong unsigned-long) + +(define-alien-type freetype:f2dot14 (signed 16)) + +(define-alien-type freetype:f26dot6 long) + +(define-alien-type freetype:fixed long) + +(define-alien-type freetype:error (signed 32)) + +(define-alien-type freetype:pointer (* t)) + +(define-alien-type freetype:offset freetype:size-t) + +(define-alien-type freetype:ptr-dist freetype:size-t) + (define-alien-type nil (enum nil (:mod-err-base #.#x000) (:mod-err-autohint #.#x100) (:mod-err-cache #.#x200) (:mod-err-cff #.#x300) (:mod-err-cid #.#x400) (:mod-err-pcf #.#x500) (:mod-err-psaux #.#x600) (:mod-err-psnames #.#x700) (:mod-err-raster #.#x800) @@ -118,7 +165,10 @@ (struct freetype::memory-rec- (freetype:user (* t)) (freetype:alloc freetype:alloc-func) (freetype:free freetype:free-func) (freetype:realloc freetype:realloc-func))) -(define-alien-type freetype:stream-desc (union freetype::stream-desc- (freetype:value (signed 32)) (freetype:pointer (* t)))) +(define-alien-type freetype:stream-desc + (union freetype::stream-desc- + (freetype:value long) + (freetype:pointer (* t)))) (define-alien-type freetype:stream-io (* t)) @@ -127,8 +177,8 @@ (define-alien-type nil (struct freetype::stream-rec- (freetype:base (* (unsigned 8))) - (freetype:size (unsigned 32)) - (freetype:pos (unsigned 32)) + (freetype:size freetype:ulong) + (freetype:pos freetype:ulong) (freetype:descriptor freetype:stream-desc) (freetype:pathname freetype:stream-desc) (freetype:read freetype:stream-io) @@ -137,7 +187,7 @@ (freetype:cursor (* (unsigned 8))) (freetype:limit (* (unsigned 8))))) -(define-alien-type freetype:pos (signed 32)) +(define-alien-type freetype:pos long) (define-alien-type freetype:vector (struct freetype::vector- (freetype:x freetype:pos) (freetype:y freetype:pos))) @@ -229,52 +279,6 @@ (freetype:raster-reset freetype:raster-reset-func) (freetype:raster-set-mode freetype:raster-set-mode-func) (freetype:raster-render freetype:raster-render-func) (freetype:raster-done freetype:raster-done-func))) -(define-alien-type freetype:ptrdiff-t (signed 32)) - -(define-alien-type freetype:size-t (unsigned 32)) - -(define-alien-type freetype:wchar-t (signed 32)) - -(define-alien-type freetype:wint-t (unsigned 32)) - -(define-alien-type freetype:bool (unsigned 8)) - -(define-alien-type freetype:fword (signed 16)) - -(define-alien-type freetype:ufword (unsigned 16)) - -(define-alien-type freetype:char (signed 8)) - -(define-alien-type freetype:byte (unsigned 8)) - -(define-alien-type freetype:string (signed 8)) - -(define-alien-type freetype:short (signed 16)) - -(define-alien-type freetype:ushort (unsigned 16)) - -(define-alien-type freetype:int (signed 32)) - -(define-alien-type freetype:uint (unsigned 32)) - -(define-alien-type freetype:long (signed 32)) - -(define-alien-type freetype:ulong (unsigned 32)) - -(define-alien-type freetype:f2dot14 (signed 16)) - -(define-alien-type freetype:f26dot6 (signed 32)) - -(define-alien-type freetype:fixed (signed 32)) - -(define-alien-type freetype:error (signed 32)) - -(define-alien-type freetype:pointer (* t)) - -(define-alien-type freetype:offset freetype:size-t) - -(define-alien-type freetype:ptr-dist freetype:size-t) - (define-alien-type freetype:unit-vector (struct freetype::unit-vector- (freetype:x freetype:f2dot14) (freetype:y freetype:f2dot14))) @@ -310,7 +314,7 @@ (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) - (freetype:control-data (* t)) (freetype:control-len (signed 32)) (freetype:other (* t)) + (freetype:control-data (* t)) (freetype:control-len long) (freetype:other (* t)) (freetype:internal freetype:slot-internal))) (define-alien-type freetype:size-metrics @@ -347,7 +351,7 @@ (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) - (freetype:control-data (* t)) (freetype:control-len (signed 32)) (freetype:other (* t)) + (freetype:control-data (* t)) (freetype:control-len long) (freetype:other (* t)) (freetype:internal freetype:slot-internal))) (define-alien-type freetype:glyph-slot (* freetype:glyph-slot-rec)) From mretzlaff at common-lisp.net Thu Aug 25 20:24:13 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Thu, 25 Aug 2005 22:24:13 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/presentation-defs.lisp Message-ID: <20050825202413.81879880DA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv23472 Modified Files: presentation-defs.lisp Log Message: This patch HANDLER-BINDs the ABORT-GESTURE condition to #'abort for the function ACCEPT in presentation-defs.lisp. ABORT-GESTURE is the condition that is signaled when any of the gestures in *ABORT-GESTURES* is read (in STREAM-READ-GESTURE). Right now *ABORT-GESTURES* contains only :abort on mcclim, which is a the keyboard gesture (#\c :control) (on Genera it contains #\Abort, the ABORT-key). I do not find explicitly in the clim specification that an ACCEPT should be aborted on an ABORT-GESTURE, but it seems to be the right thing (and I have to admit that I haven't been looking very hard). I did short tests with ACCEPTING-VALUES and it seems to behave correctly with this patch, i.e. the whole dialog will be aborted. But perhaps it would be nicer if, as long as a gadget of the dialog is selected, only the edit of that gadget were aborted. Date: Thu Aug 25 22:24:12 2005 Author: mretzlaff Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.45 mcclim/presentation-defs.lisp:1.46 --- mcclim/presentation-defs.lisp:1.45 Mon Aug 8 19:15:07 2005 +++ mcclim/presentation-defs.lisp Thu Aug 25 22:24:10 2005 @@ -664,71 +664,72 @@ display-default query-identifier activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures)) - (let* ((real-type (expand-presentation-type-abbreviation type)) - (real-default-type (cond (default-type-p - (expand-presentation-type-abbreviation - default-type)) - ((or defaultp provide-default) - real-type) - (t nil))) - (real-history-type (cond ((null historyp) real-type) - ((null history) nil) - (t (expand-presentation-type-abbreviation - history)))) - (*recursive-accept-p* *recursive-accept-1-p*) - (*recursive-accept-1-p* t)) - (with-keywords-removed (rest-args (:stream)) - (when (or default-type-p defaultp) - (setf rest-args - (list* :default-type real-default-type rest-args))) - (when historyp - (setf rest-args (list* :history real-history-type rest-args))) - (cond ((and viewp (symbolp view)) - (setf rest-args - (list* :view (funcall #'make-instance view) rest-args))) - ((consp view) - (setf rest-args - (list* :view (apply #'make-instance view) rest-args)))) - ;; Presentation type history interaction. According to the spec, - ;; if provide-default is true, we take the default from the - ;; presentation history. In addition, we'll implement the Genera - ;; behavior of temporarily putting the default on the history - ;; stack so the user can conveniently suck it in. - (flet ((do-accept (args) - (apply #'stream-accept stream real-type args)) - (get-history () - (when real-history-type - (funcall-presentation-generic-function - presentation-type-history-for-stream - real-history-type stream)))) - (let* ((default-from-history (and (not defaultp) provide-default)) - (history (get-history)) - (results - (multiple-value-list - (if history - (let ((*active-history-type* real-history-type)) - (cond (defaultp - (with-object-on-history - (history default real-default-type) - (do-accept rest-args))) - (default-from-history - (multiple-value-bind - (history-default history-type) - (presentation-history-head history - real-default-type) - (do-accept (if history-type - (list* :default history-default - :default-type history-type - rest-args) - rest-args)))) - (t (do-accept rest-args)))) - (do-accept rest-args)))) - (results-history (get-history))) - (when results-history - (presentation-history-add results-history - (car results) - (cadr results))) - (values-list results)))))) + (handler-bind ((abort-gesture #'abort)) + (let* ((real-type (expand-presentation-type-abbreviation type)) + (real-default-type (cond (default-type-p + (expand-presentation-type-abbreviation + default-type)) + ((or defaultp provide-default) + real-type) + (t nil))) + (real-history-type (cond ((null historyp) real-type) + ((null history) nil) + (t (expand-presentation-type-abbreviation + history)))) + (*recursive-accept-p* *recursive-accept-1-p*) + (*recursive-accept-1-p* t)) + (with-keywords-removed (rest-args (:stream)) + (when (or default-type-p defaultp) + (setf rest-args + (list* :default-type real-default-type rest-args))) + (when historyp + (setf rest-args (list* :history real-history-type rest-args))) + (cond ((and viewp (symbolp view)) + (setf rest-args + (list* :view (funcall #'make-instance view) rest-args))) + ((consp view) + (setf rest-args + (list* :view (apply #'make-instance view) rest-args)))) + ;; Presentation type history interaction. According to the spec, + ;; if provide-default is true, we take the default from the + ;; presentation history. In addition, we'll implement the Genera + ;; behavior of temporarily putting the default on the history + ;; stack so the user can conveniently suck it in. + (flet ((do-accept (args) + (apply #'stream-accept stream real-type args)) + (get-history () + (when real-history-type + (funcall-presentation-generic-function + presentation-type-history-for-stream + real-history-type stream)))) + (let* ((default-from-history (and (not defaultp) provide-default)) + (history (get-history)) + (results + (multiple-value-list + (if history + (let ((*active-history-type* real-history-type)) + (cond (defaultp + (with-object-on-history + (history default real-default-type) + (do-accept rest-args))) + (default-from-history + (multiple-value-bind + (history-default history-type) + (presentation-history-head history + real-default-type) + (do-accept (if history-type + (list* :default history-default + :default-type history-type + rest-args) + rest-args)))) + (t (do-accept rest-args)))) + (do-accept rest-args)))) + (results-history (get-history))) + (when results-history + (presentation-history-add results-history + (car results) + (cadr results))) + (values-list results))))))) (defgeneric stream-accept (stream type &key From mretzlaff at common-lisp.net Thu Aug 25 20:48:46 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Thu, 25 Aug 2005 22:48:46 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/dialog.lisp Message-ID: <20050825204846.5C821880DA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26547 Modified Files: dialog.lisp Log Message: A patch against the first bug a patch by me introduced to mcclim. Sorry, that shouldn't have happened.. At least it was only a bug in a feature that the patch introduced (displaying an ACCEPTING-VALUES dialog in its :OWN-WINDOW), and it affected only code that thoughtlessly relied of this new and still broken feature. (Broken because OPEN-WINDOW-STREAM doesn't really work yet. I think there has to be a (redisplay-frame-panes frame) or something like that in its event-loop (that is the function STANDALONE-EVENT-LOOP).) Date: Thu Aug 25 22:48:41 2005 Author: mretzlaff Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.20 mcclim/dialog.lisp:1.21 --- mcclim/dialog.lisp:1.20 Fri Aug 19 02:48:25 2005 +++ mcclim/dialog.lisp Thu Aug 25 22:48:40 2005 @@ -170,9 +170,9 @@ #',accepting-values-continuation , at args)) )) - (if own-window - `(with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) - return-form)))) + `(if ,own-window + (with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) + ,return-form)))) (defun invoke-accepting-values (stream body From mretzlaff at common-lisp.net Fri Aug 26 00:32:58 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Fri, 26 Aug 2005 02:32:58 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/dialog.lisp Message-ID: <20050826003258.9D6348855C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv12901 Modified Files: dialog.lisp Log Message: (climi::frame-event-queue *application-frame*) as argument :INPUT-BUFFER to the call of OPEN-WINDOW-STREAM in WITH-STREAM-IN-OWN-WINDOW (was not specified previously). The ugly delay could be dropped, because no new process is created anymore. See http://common-lisp.net/pipermail/mcclim-devel/2005-August/004239.html for more information. (Thanks go to Christophe.) The parameter :LABEL to ACCEPTING-VALUES will now actually be used to label the newly created window if :OWN-WINDOW is true. Date: Fri Aug 26 02:32:56 2005 Author: mretzlaff Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.21 mcclim/dialog.lisp:1.22 --- mcclim/dialog.lisp:1.21 Thu Aug 25 22:48:40 2005 +++ mcclim/dialog.lisp Fri Aug 26 02:32:56 2005 @@ -138,12 +138,13 @@ (defmacro with-stream-in-own-window ((&optional (stream '*query-io*) &rest further-streams) + (&optional label) &rest body) - `(let* ((,stream (open-window-stream)) + `(let* ((,stream (open-window-stream :label ,label + :input-buffer (climi::frame-event-queue *application-frame*))) ,@(mapcar (lambda (a-stream) (list a-stream stream)) further-streams)) - (sleep 0.1) ;; hackhack.. some delay to "ensure" that the window-stream ist opened (unwind-protect (progn , at body) @@ -159,7 +160,7 @@ &body body) (declare (ignorable exit-boxes initially-select-query-identifier modify-initial-query resynchronize-every-pass resize-frame - align-prompts label scroll-bars + align-prompts scroll-bars x-position y-position width height command-table frame-class)) (setq stream (stream-designator-symbol stream '*standard-input*)) (with-gensyms (accepting-values-continuation) @@ -171,7 +172,9 @@ , at args)) )) `(if ,own-window - (with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) + (with-stream-in-own-window (,stream *standard-input* *standard-output*) + (,label) + ,return-form) ,return-form)))) (defun invoke-accepting-values From amoroso at mclink.it Fri Aug 26 10:58:13 2005 From: amoroso at mclink.it (Paolo Amoroso) Date: Fri, 26 Aug 2005 12:58:13 +0200 Subject: [mcclim-cvs] CVS update: mcclim/dialog.lisp In-Reply-To: <20050826003258.9D6348855C@common-lisp.net> (Max-Gerd Retzlaff's message of "Fri, 26 Aug 2005 02:32:58 +0200 (CEST)") References: <20050826003258.9D6348855C@common-lisp.net> Message-ID: <87hddd55iy.fsf@plato.moon.paoloamoroso.it> mretzlaff at common-lisp.net (Max-Gerd Retzlaff) writes: > specified previously). The ugly delay could be dropped, because no new > process is created anymore. See > http://common-lisp.net/pipermail/mcclim-devel/2005-August/004239.html You might want to post links to the mcclim-devel archive at Gmane... Paolo -- Lisp Propulsion Laboratory log - http://www.paoloamoroso.it/log From amoroso at mclink.it Fri Aug 26 11:50:21 2005 From: amoroso at mclink.it (Paolo Amoroso) Date: Fri, 26 Aug 2005 13:50:21 +0200 Subject: [mcclim-cvs] CVS update: mcclim/dialog.lisp References: <20050826003258.9D6348855C@common-lisp.net> Message-ID: <8764ts5342.fsf@plato.moon.paoloamoroso.it> mretzlaff at common-lisp.net (Max-Gerd Retzlaff) writes: > Modified Files: > dialog.lisp > Log Message: > (climi::frame-event-queue *application-frame*) as argument :INPUT-BUFFER > to the call of OPEN-WINDOW-STREAM in WITH-STREAM-IN-OWN-WINDOW (was not > specified previously). The ugly delay could be dropped, because no new > process is created anymore. See > http://common-lisp.net/pipermail/mcclim-devel/2005-August/004239.html > for more information. (Thanks go to Christophe.) > > The parameter :LABEL to ACCEPTING-VALUES will now actually be used to > label the newly created window if :OWN-WINDOW is true. I still don't get separate windows in dialogs of town-example.lisp that have :own-window t. The accepting-values dialogs still appear in the interactor. I use the latest McCLIM CVS sources. Paolo -- Lisp Propulsion Laboratory log - http://www.paoloamoroso.it/log From rstrandh at common-lisp.net Fri Aug 26 19:56:59 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 26 Aug 2005 21:56:59 +0200 (CEST) Subject: [mcclim-cvs] CVS update: Directory change: mcclim/Tests Message-ID: <20050826195659.761B38853F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv30107/Tests Log Message: Directory /project/mcclim/cvsroot/mcclim/Tests added to the repository Date: Fri Aug 26 21:56:59 2005 Author: rstrandh New directory mcclim/Tests added From rstrandh at common-lisp.net Fri Aug 26 19:58:38 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 26 Aug 2005 21:58:38 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Tests/regions.lisp Message-ID: <20050826195838.91A778853F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv30153/Tests Added Files: regions.lisp Log Message: Hopefully the beginning of a testing framework for McCLIM. Date: Fri Aug 26 21:58:38 2005 Author: rstrandh From mretzlaff at common-lisp.net Mon Aug 29 22:39:32 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Tue, 30 Aug 2005 00:39:32 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp Message-ID: <20050829223932.3C97D88542@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15426 Modified Files: panes.lisp Log Message: Added a method PANE-BORDER that works just like PANE-VIEWPORT and PANE-SCROLLER, only for BORDER-PANEs. It is not in the spec, but so is the BORDER-PANE as a whole. (And, yes, I needed it.) In addition to this it changes the IFs in PANE-VIEWPORT and PANE-SCROLLER to WHENs (both had no else-forms). (Minor change: Five changes in the comments: The section titles of the different panes are made consistent. (Most of them were of the pattern "FOO PANE", only five of them "FOO-PANE"; as I liked the former pattern more, they are now all of that pattern.)) Date: Tue Aug 30 00:39:31 2005 Author: mretzlaff Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.154 mcclim/panes.lisp:1.155 --- mcclim/panes.lisp:1.154 Fri Aug 19 04:20:35 2005 +++ mcclim/panes.lisp Tue Aug 30 00:39:31 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.154 2005/08/19 02:20:35 rstrandh Exp $ +;;; $Id: panes.lisp,v 1.155 2005/08/29 22:39:31 mretzlaff Exp $ (in-package :clim-internals) @@ -795,7 +795,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; BASIC-PANE +;;; BASIC PANE (defclass basic-pane (;; layout-protocol-mixin standard-space-requirement-options-mixin @@ -957,7 +957,7 @@ (event window-manager-delete-event)) (frame-exit (pane-frame (event-sheet event)))) -;;;; UNMANAGED-TOP-LEVEL-SHEET-PANE +;;;; UNMANAGED-TOP-LEVEL-SHEET PANE (defclass unmanaged-top-level-sheet-pane (top-level-sheet-pane) () @@ -1643,7 +1643,7 @@ (- width border-width border-width) (- height border-width border-width))))) -;;; OUTLINED-PANE +;;; OUTLINED PANE ;; same as SPACING-PANE but a different default background. @@ -1654,7 +1654,7 @@ (defmacro outlining ((&rest options) &body contents) `(make-pane 'outlined-pane , at options :contents (list , at contents))) -;;; BORDER-PANE +;;; BORDER PANE ;; same as outlined-pane, but thickness is now called border-width. @@ -1667,6 +1667,11 @@ (defmacro bordering ((&rest options) &body contents) `(make-pane 'border-pane , at options :contents (list , at contents))) +(defmethod pane-border ((pane basic-pane)) + (let ((parent (sheet-parent pane))) + (when (and parent (typep parent 'border-pane)) + parent))) + ;;; RAISED PANE (defclass raised-pane (border-pane permanent-medium-sheet-output-mixin) @@ -1751,7 +1756,7 @@ (note-input-focus-changed (sheet-child pane) state)) ;;;; -;;;; SCROLLER-PANE +;;;; SCROLLER PANE ;;;; ;;; How scrolling is done @@ -2033,9 +2038,8 @@ (defmethod pane-viewport ((pane basic-pane)) (let ((parent (sheet-parent pane))) - (if (and parent (typep parent 'viewport-pane)) - parent - nil))) + (when (and parent (typep parent 'viewport-pane)) + parent))) ;;; Default for streams that aren't even panes. @@ -2051,7 +2055,7 @@ (defmethod pane-scroller ((pane basic-pane)) (let ((viewport (pane-viewport pane))) - (if viewport + (when viewport (sheet-parent viewport)))) (defmethod scroll-extent ((pane basic-pane) x y) From mretzlaff at common-lisp.net Wed Aug 31 05:50:41 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Wed, 31 Aug 2005 07:50:41 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Listener/dev-commands.lisp mcclim/Apps/Listener/file-types.lisp mcclim/Apps/Listener/util.lisp Message-ID: <20050831055041.D1A12880DA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv17279/Apps/Listener Modified Files: dev-commands.lisp file-types.lisp util.lisp Log Message: This patch affects the CLIM-Listener. It adds : - sort-by for filenames to COM-SHOW-DIRECTORY, - an icon and a cond-clause in ICON-OF for wild pathnames, - a wrapper for LIST-DIRECTORY (that NCONCs the direct subdirectories of the directory to the output of LIST-DIRECTORY if it is called with a wild pathname), - and does some minor changes to COM-SHOW-DIRECTORY. Also it removes the SB-POSIX LIST-DIRECTORY for SBCL as that one completely ignores the pathname-name and -type, which renders it quite useless for :wild searches (pune or play on words intended). There was a short discussion about this patch in #lisp some hourse ago. As a result the wrapper for LIST-DIRECTORY is now called LIST-DIRECTORY-WITH-ALL-DIRECT-SUBDIRECTORIES. And it will only used by COM-SHOW-DIRECTORY if its new keyword parameter :list-all-direct-subdirectories is specified as t (the default being nil). The discussion (included because of the removed posix code in the former SBCL version of LIST-DIRECTORY): 01:18 < mgr> hefner: Did you have a look at my listener patch? 01:19 < hefner> I did, it looked good 01:19 < mgr> hefner: You are not angry because it removes the posix stuff? :) 01:20 < hefner> mgr: did it? :) The posix stuff was horrible, terrible. 01:20 < mgr> hefner: So, you don't object if I commit it to the mcclim repository? 01:20 < hefner> mgr: no, go ahead 01:22 < mgr> hefner: Perhaps there should be a option to COM-SHOW-DIRECTORY to switch between using LIST-DIRECTORY and LIST-DIRECTORY-WITH-ALL-SUBDIRECTORIES? Perhaps the latter is not always desired.. 01:22 < hefner> mgr: :recursive t ? 01:23 < mgr> hefner: No, it's different. if you list "/tmp/*.list" all direct subdirectories of "/tmp/" will be listed as well, altough they do not match "*.lisp". 01:24 < hefner> ah.. 01:27 < hefner> mgr: hold on, you're just calling cl:directory? Isn't that going to explode on broken symlinks? 01:33 < mgr> hefner: Uhm, explode? not really, no. Why? Symlinks are just "resolved" on sbcl. That is if you select "/foo/bar" that is a symlink to "/baz/quux", you'll always get the latter even if you select the former one. 01:34 < gilberth> mgr: not so fast. I have major hassle with CMUCL and XEmacs silly lock symlinks. 01:34 < hefner> mgr: what if /baz/quux doesn't exist? I didn't write the aweful posix code for my health. 01:35 < gilberth> They point to silly stuff like "gilbert at morganit.local.6092" 01:36 < mgr> gilberth: Well, the listener did always do only #'directory for cmucl.. So, don't worry this does not affect you. :) 01:36 < gilberth> great. 01:37 < hefner> not only #'directory, but (directory pathname :truenamep nil) 01:39 < gilberth> mgr: It must use the right keyword options to #'directory in CMUCL or something, since it works with borken symlinks. 01:39 < gilberth> it even shows a particular icon for the broken symlink. 01:39 < hefner> does it? that's a nice touch. 01:40 < gilberth> hefner: I thought you would know? 01:40 < hefner> I guess I forgot. 01:45 < mgr> hefner: there ist no problem with them. they will not be resolved, that is #p"/foo/bar" will be returned. it will be displayed as an invalid pathname because probe-file returns nil. 01:46 < hefner> mgr: I guess the behaviour changed. SBCL of 1.5 years ago didn't do that. Carry on. :) 01:47 < mgr> hefner: Also the posix version completely ignores the pathname-name and -type, and that's really not nice. 01:47 < hefner> well, pathname-name and pathname-type aren't nice either 01:47 < hefner> pathnames aren't nice 01:47 < mgr> hefner: Well, that's a different problem. 01:48 < mgr> hefner: I'll include this short discussion into the commit message, okay? :) 01:48 < hefner> okay Date: Wed Aug 31 07:50:38 2005 Author: mretzlaff Index: mcclim/Apps/Listener/dev-commands.lisp diff -u mcclim/Apps/Listener/dev-commands.lisp:1.29 mcclim/Apps/Listener/dev-commands.lisp:1.30 --- mcclim/Apps/Listener/dev-commands.lisp:1.29 Thu Apr 21 05:41:24 2005 +++ mcclim/Apps/Listener/dev-commands.lisp Wed Aug 31 07:50:37 2005 @@ -1028,7 +1028,9 @@ (terpri stream)) (defun sort-pathnames (list sort-by) - list) ; <--- FIXME + (case sort-by ; <--- FIXME + ('name (sort list #'string-lessp :key #'file-namestring)) + (t list))) (defun split-sort-pathnames (list group-dirs sort-by) (mapcar (lambda (x) (sort-pathnames x sort-by)) @@ -1064,31 +1066,37 @@ :provide-output-destination-keyword t) ((pathname 'pathname #+nil(or 'string 'pathname) :prompt "pathname") &key - #+NIL (sort-by '(member name size modify none) :default 'name) + (sort-by '(member name size modify none) :default 'name) (show-hidden 'boolean :default nil :prompt "show hidden") (hide-garbage 'boolean :default T :prompt "hide garbage") (show-all 'boolean :default nil :prompt "show all") (style '(member items list) :default 'items :prompt "listing style") (group-directories 'boolean :default T :prompt "group directories?") - (full-names 'boolean :default nil :prompt "show full name?")) + (full-names 'boolean :default nil :prompt "show full name?") + (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?")) (let* ((pathname (if (wild-pathname-p pathname) ; Forgot why I did this.. (merge-pathnames pathname) pathname)) - (dir (list-directory (gen-wild-pathname pathname)))) + (wild-pathname (gen-wild-pathname pathname)) + (dir (if list-all-direct-subdirectories + (list-directory-with-all-direct-subdirectories wild-pathname) + (list-directory wild-pathname)))) (with-text-family (T :sans-serif) (invoke-as-heading (lambda () (format T "Directory contents of ") - (present pathname))) + (present (directory-namestring pathname) 'pathname) + (when (pathname-type pathname) + (format T " (only files of type ~a)" (pathname-type pathname))))) (when (parent-directory pathname) - (with-output-as-presentation (T (parent-directory pathname) 'clim:pathname) + (with-output-as-presentation (T (strip-filespec (parent-directory pathname)) 'clim:pathname) (draw-icon T (standard-icon "up-folder.xpm") :extra-spacing 3) (format T "Parent Directory~%"))) - (dolist (group (split-sort-pathnames dir group-directories :none #+NIL sort-by)) + (dolist (group (split-sort-pathnames dir group-directories sort-by)) (unless show-all (setf group (filter-garbage-pathnames group show-hidden hide-garbage))) (ecase style @@ -1105,7 +1113,8 @@ (goatee::reposition-stream-cursor *standard-output*) (vertical-gap T)) (list (dolist (ent group) - (let ((ent (merge-pathnames ent pathname))) ; This is for CMUCL, see above. (fixme!) + (let ((ent (merge-pathnames ent pathname))) ;; This is for CMUCL, see above. (fixme!) + ;; And breaks some things for SBCL.. (mgr) (pretty-pretty-pathname ent *standard-output* :long-name full-names))))))))) #+nil ; OBSOLETE Index: mcclim/Apps/Listener/file-types.lisp diff -u mcclim/Apps/Listener/file-types.lisp:1.7 mcclim/Apps/Listener/file-types.lisp:1.8 --- mcclim/Apps/Listener/file-types.lisp:1.7 Sun Nov 9 22:12:05 2003 +++ mcclim/Apps/Listener/file-types.lisp Wed Aug 31 07:50:37 2005 @@ -133,7 +133,8 @@ ;; ICON-OF is measurably slow here in CMUCL. Interesting.. (defmethod icon-of ((pathname pathname)) - (cond ((not (probe-file pathname)) (standard-icon "invalid.xpm")) + (cond ((wild-pathname-p pathname) (standard-icon "wild.xpm")) + ((not (probe-file pathname)) (standard-icon "invalid.xpm")) ((directoryp pathname) *folder-icon*) ;; FIXME: use inode mime types (T (let ((mime-class (find-class (pathname-mime-type pathname) nil))) (if mime-class Index: mcclim/Apps/Listener/util.lisp diff -u mcclim/Apps/Listener/util.lisp:1.17 mcclim/Apps/Listener/util.lisp:1.18 --- mcclim/Apps/Listener/util.lisp:1.17 Tue Feb 22 04:10:27 2005 +++ mcclim/Apps/Listener/util.lisp Wed Aug 31 07:50:37 2005 @@ -118,6 +118,8 @@ #+SBCL (defun list-directory (pathname) + (directory pathname) + #+nil ;; ugh. is too ughy. (mgr) (let* ((pathname (strip-filespec pathname)) ;; ugh. (dir (sb-posix:opendir pathname)) (list nil)) @@ -141,6 +143,19 @@ (defun list-directory (pathname) (directory pathname)) +;;; Calls LIST-DIRECTORY and appends the subdirectories of the directory +;;; PATHNAME to the output of LIST-DIRECTORY if PATHNAME is a wild pathname. + +(defun list-directory-with-all-direct-subdirectories (pathname) + (let ((file-list (list-directory pathname))) + (if (wild-pathname-p pathname) + (nconc file-list + (delete-if (lambda (directory) + (member directory file-list :test #'equal)) + (delete-if-not #'directoryp + (list-directory (gen-wild-pathname + (strip-filespec pathname)))))) + file-list))) ;;; A farce of a "portable" run-program, which grows as I need options from ;;; the CMUCL run-program. From mretzlaff at common-lisp.net Wed Aug 31 05:50:42 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Wed, 31 Aug 2005 07:50:42 +0200 (CEST) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Listener/icons/wild.xpm Message-ID: <20050831055042.C1783880DA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener/icons In directory common-lisp.net:/tmp/cvs-serv17279/Apps/Listener/icons Added Files: wild.xpm Log Message: This patch affects the CLIM-Listener. It adds : - sort-by for filenames to COM-SHOW-DIRECTORY, - an icon and a cond-clause in ICON-OF for wild pathnames, - a wrapper for LIST-DIRECTORY (that NCONCs the direct subdirectories of the directory to the output of LIST-DIRECTORY if it is called with a wild pathname), - and does some minor changes to COM-SHOW-DIRECTORY. Also it removes the SB-POSIX LIST-DIRECTORY for SBCL as that one completely ignores the pathname-name and -type, which renders it quite useless for :wild searches (pune or play on words intended). There was a short discussion about this patch in #lisp some hourse ago. As a result the wrapper for LIST-DIRECTORY is now called LIST-DIRECTORY-WITH-ALL-DIRECT-SUBDIRECTORIES. And it will only used by COM-SHOW-DIRECTORY if its new keyword parameter :list-all-direct-subdirectories is specified as t (the default being nil). The discussion (included because of the removed posix code in the former SBCL version of LIST-DIRECTORY): 01:18 < mgr> hefner: Did you have a look at my listener patch? 01:19 < hefner> I did, it looked good 01:19 < mgr> hefner: You are not angry because it removes the posix stuff? :) 01:20 < hefner> mgr: did it? :) The posix stuff was horrible, terrible. 01:20 < mgr> hefner: So, you don't object if I commit it to the mcclim repository? 01:20 < hefner> mgr: no, go ahead 01:22 < mgr> hefner: Perhaps there should be a option to COM-SHOW-DIRECTORY to switch between using LIST-DIRECTORY and LIST-DIRECTORY-WITH-ALL-SUBDIRECTORIES? Perhaps the latter is not always desired.. 01:22 < hefner> mgr: :recursive t ? 01:23 < mgr> hefner: No, it's different. if you list "/tmp/*.list" all direct subdirectories of "/tmp/" will be listed as well, altough they do not match "*.lisp". 01:24 < hefner> ah.. 01:27 < hefner> mgr: hold on, you're just calling cl:directory? Isn't that going to explode on broken symlinks? 01:33 < mgr> hefner: Uhm, explode? not really, no. Why? Symlinks are just "resolved" on sbcl. That is if you select "/foo/bar" that is a symlink to "/baz/quux", you'll always get the latter even if you select the former one. 01:34 < gilberth> mgr: not so fast. I have major hassle with CMUCL and XEmacs silly lock symlinks. 01:34 < hefner> mgr: what if /baz/quux doesn't exist? I didn't write the aweful posix code for my health. 01:35 < gilberth> They point to silly stuff like "gilbert at morganit.local.6092" 01:36 < mgr> gilberth: Well, the listener did always do only #'directory for cmucl.. So, don't worry this does not affect you. :) 01:36 < gilberth> great. 01:37 < hefner> not only #'directory, but (directory pathname :truenamep nil) 01:39 < gilberth> mgr: It must use the right keyword options to #'directory in CMUCL or something, since it works with borken symlinks. 01:39 < gilberth> it even shows a particular icon for the broken symlink. 01:39 < hefner> does it? that's a nice touch. 01:40 < gilberth> hefner: I thought you would know? 01:40 < hefner> I guess I forgot. 01:45 < mgr> hefner: there ist no problem with them. they will not be resolved, that is #p"/foo/bar" will be returned. it will be displayed as an invalid pathname because probe-file returns nil. 01:46 < hefner> mgr: I guess the behaviour changed. SBCL of 1.5 years ago didn't do that. Carry on. :) 01:47 < mgr> hefner: Also the posix version completely ignores the pathname-name and -type, and that's really not nice. 01:47 < hefner> well, pathname-name and pathname-type aren't nice either 01:47 < hefner> pathnames aren't nice 01:47 < mgr> hefner: Well, that's a different problem. 01:48 < mgr> hefner: I'll include this short discussion into the commit message, okay? :) 01:48 < hefner> okay Date: Wed Aug 31 07:50:41 2005 Author: mretzlaff