- mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS update: mcclim/recording.lisp mcclim/stream-output.lisp
by crhodes＠common-lisp.net 13 Aug '05

13 Aug '05

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)

1 0

[mcclim-cvs] CVS update: mcclim/package.lisp
by rgoldman＠common-lisp.net 12 Aug '05

12 Aug '05

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

1 0

[mcclim-cvs] CVS update: mcclim/graph-formatting.lisp
by rgoldman＠common-lisp.net 12 Aug '05

12 Aug '05

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)

1 0

[mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp
by tmoore＠common-lisp.net 09 Aug '05

09 Aug '05

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)

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp
by crhodes＠common-lisp.net 08 Aug '05

08 Aug '05

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)

1 0

[mcclim-cvs] CVS update: mcclim/Backends/PostScript/graphics.lisp
by crhodes＠common-lisp.net 01 Aug '05

01 Aug '05

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))

1 0

[mcclim-cvs] CVS update: mcclim/Webpage/downloads/index.html
by afuchs＠common-lisp.net 30 Jul '05

30 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory common-lisp.net:/tmp/cvs-serv29447/downloads Modified Files: index.html Log Message: Fix link in downloads/index.html. Date: Sat Jul 30 19:11:36 2005 Author: afuchs Index: mcclim/Webpage/downloads/index.html diff -u mcclim/Webpage/downloads/index.html:1.11 mcclim/Webpage/downloads/index.html:1.12 --- mcclim/Webpage/downloads/index.html:1.11 Sat Jul 30 19:10:48 2005 +++ mcclim/Webpage/downloads/index.html Sat Jul 30 19:11:36 2005 @@ -46,13 +46,13 @@ A compressed tar file of the <a href="http://common-lisp.net/cvs_tarballs/mcclim.tar.gz">sources</a> is made nightly. </p> <h2>Releases</h2> - The most recent release of McCLIM is 0.9.1, in March 2005, available here: <a href="downloads/mcclim-0.9.1.tar.gz">mcclim-0.9.1.tar.gz</a>. It is also available via <a href="http://cliki.net/asdf-install">ASDF-INSTALL</a>. + The most recent release of McCLIM is 0.9.1, in March 2005, available here: <a href="mcclim-0.9.1.tar.gz">mcclim-0.9.1.tar.gz</a>. It is also available via <a href="http://cliki.net/asdf-install">ASDF-INSTALL</a>. </td> </tr> </table> <br> <hr> -$Date: 2005/07/30 17:10:48 $ +$Date: 2005/07/30 17:11:36 $

1 0

[mcclim-cvs] CVS update: mcclim/Webpage/downloads/index.html
by afuchs＠common-lisp.net 30 Jul '05

30 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory common-lisp.net:/tmp/cvs-serv29397/downloads Modified Files: index.html Log Message: Change website to reflect the 0.9.1 release. Date: Sat Jul 30 19:10:48 2005 Author: afuchs Index: mcclim/Webpage/downloads/index.html diff -u mcclim/Webpage/downloads/index.html:1.10 mcclim/Webpage/downloads/index.html:1.11 --- mcclim/Webpage/downloads/index.html:1.10 Sat Dec 11 21:52:02 2004 +++ mcclim/Webpage/downloads/index.html Sat Jul 30 19:10:48 2005 @@ -46,14 +46,13 @@ A compressed tar file of the <a href="http://common-lisp.net/cvs_tarballs/mcclim.tar.gz">sources</a> is made nightly. </p> <h2>Releases</h2> - The most recent release of McCLIM was 0.9, in November - 2003. It's probably a better idea to use the CVS version instead + The most recent release of McCLIM is 0.9.1, in March 2005, available here: <a href="downloads/mcclim-0.9.1.tar.gz">mcclim-0.9.1.tar.gz</a>. It is also available via <a href="http://cliki.net/asdf-install">ASDF-INSTALL</a>. </td> </tr> </table> <br> <hr> -$Date: 2004/12/11 20:52:02 $ +$Date: 2005/07/30 17:10:48 $

1 0

[mcclim-cvs] CVS update: mcclim/Webpage/index.html
by afuchs＠common-lisp.net 30 Jul '05

30 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Webpage In directory common-lisp.net:/tmp/cvs-serv29397 Modified Files: index.html Log Message: Change website to reflect the 0.9.1 release. Date: Sat Jul 30 19:10:47 2005 Author: afuchs Index: mcclim/Webpage/index.html diff -u mcclim/Webpage/index.html:1.10 mcclim/Webpage/index.html:1.11 --- mcclim/Webpage/index.html:1.10 Mon Dec 13 16:53:02 2004 +++ mcclim/Webpage/index.html Sat Jul 30 19:10:47 2005 @@ -55,8 +55,7 @@ <h2><a name="downloads">Releases</a></h2> A compressed tar file of the <a href="http://common-lisp.net/cvs_tarballs/mcclim.tar.gz">sources</a> is made nightly. <p> - The most recent release of McCLIM was 0.9, in November - 2003. It's probably a better idea to use the CVS version instead, as there have been many bug fixes and performance improvements since then. + The most recent release of McCLIM is 0.9.1, in March 2005, available here: <a href="downloads/mcclim-0.9.1.tar.gz">mcclim-0.9.1.tar.gz</a>. It is also available via <a href="http://cliki.net/asdf-install">ASDF-INSTALL</a>. </p> <h2>Recent News</h2> <p> @@ -92,7 +91,7 @@ </div> <br> <hr> -$Date: 2004/12/13 15:53:02 $ +$Date: 2005/07/30 17:10:47 $

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-fonts.lisp mcclim/Experimental/freetype/mcclim-freetype.asd
by afuchs＠common-lisp.net 29 Jul '05

29 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv25410/Experimental/freetype Modified Files: freetype-fonts.lisp mcclim-freetype.asd Log Message: Add Bitstream Vera detection routines to mcclim-freetype's system definition. This depends on the fontconfig utilties, namely fc-match. If they're not found, it defaults to the old (warning) behavior. Date: Fri Jul 29 08:50:20 2005 Author: afuchs Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.9 mcclim/Experimental/freetype/freetype-fonts.lisp:1.10 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.9 Thu Jul 14 14:09:24 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Fri Jul 29 08:50:20 2005 @@ -487,10 +487,3 @@ (clim:with-drawing-options (m :clipping-region r) (clim:draw-design m r :ink clim:+background-ink+) (call-next-method s r))))) - -(format t -"~%~%NOTE:~%~ -* Remember to set mcclim-freetype:*freetype-font-path* to the - location of the Bitstream Vera family of fonts on disk. If you - don't have them, get them from http://www.gnome.org/fonts/~%~%~%") -(finish-output t) Index: mcclim/Experimental/freetype/mcclim-freetype.asd diff -u mcclim/Experimental/freetype/mcclim-freetype.asd:1.2 mcclim/Experimental/freetype/mcclim-freetype.asd:1.3 --- mcclim/Experimental/freetype/mcclim-freetype.asd:1.2 Sat Jun 18 03:56:43 2005 +++ mcclim/Experimental/freetype/mcclim-freetype.asd Fri Jul 29 08:50:20 2005 @@ -1,5 +1,14 @@ ;;;; -*- Lisp -*- +#| +To autoload mcclim-freetype after mcclim, link this file to a +directory in your asdf:*central-registry* and add the following to +your lisp's init file: + + (defmethod asdf:perform :after ((o asdf:load-op) (s (eql (asdf:find-system :clim-clx)))) + (asdf:oos 'asdf:load-op :mcclim-freetype)) +|# + (defpackage :mcclim-freetype-system (:use :cl :asdf)) (in-package :mcclim-freetype-system) @@ -12,9 +21,51 @@ (list (component-pathname c))) (defsystem :mcclim-freetype - :depends-on (:clim :clx) + :depends-on (:clim-clx) :serial t :components ((:file "freetype-package") (:uncompiled-cl-source-file "freetype-ffi") (:file "freetype-fonts"))) + + +;;; Freetype autodetection + +(defun parse-fontconfig-output (s) + (let* ((match-string (concatenate 'string (string #\Tab) "file:")) + (matching-line + (loop for l = (read-line s nil nil) + while l + if (= (mismatch l match-string) (length match-string)) + do (return l))) + (filename (when matching-line + (probe-file + (subseq matching-line + (1+ (position #\" matching-line :from-end nil :test #'char=)) + (position #\" matching-line :from-end t :test #'char=)))))) + (when filename + (make-pathname :directory (pathname-directory filename))))) + +(defun warn-about-unset-font-path () + (warn "~%~%NOTE:~%~ +* Remember to set mcclim-freetype:*freetype-font-path* to the + location of the Bitstream Vera family of fonts on disk. If you + don't have them, get them from http://www.gnome.org/fonts/~%~%~%")) + +#+sbcl +(defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) + (let ((fc-match (sb-ext:find-executable-in-search-path "fc-match"))) + (if (null fc-match) + (warn-about-unset-font-path) + (let* ((process (sb-ext:run-program fc-match `("-v" "Bitstream Vera") + :output :stream + :input nil)) + (font-path (parse-fontconfig-output (sb-ext:process-output process)))) + (if (null font-path) + (warn-about-unset-font-path) + (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) + font-path)))))) + +#-sbcl +(defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) + (warn-about-unset-font-path)) \ No newline at end of file

1 0