mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim
by crhodes 10 Mar '06

10 Mar '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv2943 Modified Files: medium.lisp Log Message: Merge a hacky but functional implementation of device-font-text-styles, working on CLX, mcclim-freetype and postscript backends. No exported or documented functionality for now. --- /project/mcclim/cvsroot/mcclim/medium.lisp 2006/01/22 21:17:07 1.57 +++ /project/mcclim/cvsroot/mcclim/medium.lisp 2006/03/10 10:56:01 1.58 @@ -87,6 +87,7 @@ (defgeneric text-style-fixed-width-p (text-style medium)) (defgeneric text-style-equalp (style1 style2)) +(defmethod text-style-equalp ((style1 text-style) (style2 text-style)) nil) (defclass standard-text-style (text-style) ((family :initarg :text-family @@ -155,7 +156,7 @@ ) ; end eval-when -(defmethod print-object ((self text-style) stream) +(defmethod print-object ((self standard-text-style) stream) (print-unreadable-object (self stream :type t :identity nil) (format stream "~{~S~^ ~}" (multiple-value-list (text-style-components self))))) @@ -196,15 +197,25 @@ ;;; Device-Font-Text-Style class (defclass device-font-text-style (text-style) - ()) + ((display-device :initarg :display-device :accessor display-device) + (device-font-name :initarg :device-font-name :accessor device-font-name))) + +(defmethod print-object ((self device-font-text-style) stream) + (print-unreadable-object (self stream :type t :identity nil) + (format stream "~S on ~S" (device-font-name self) (display-device self)))) (defun device-font-text-style-p (s) (typep s 'device-font-text-style)) +(defmethod text-style-equalp ((style1 device-font-text-style) (style2 device-font-text-style)) + (eq style1 style2)) + (defmethod text-style-mapping ((port basic-port) text-style &optional character-set) (declare (ignore character-set)) - (gethash (parse-text-style text-style) (port-text-style-mappings port))) + (if (keywordp text-style) + (gethash (parse-text-style text-style) (port-text-style-mappings port)) + (gethash text-style (port-text-style-mappings port)))) (defmethod (setf text-style-mapping) (mapping (port basic-port) text-style @@ -221,11 +232,12 @@ (setf (gethash text-style (port-text-style-mappings port)) mapping)) -(defun make-device-font-text-style (port font-name) +(defgeneric make-device-font-text-style (port font-name)) + +(defmethod make-device-font-text-style (port font-name) (let ((text-style (make-instance 'device-font-text-style - :text-family font-name - :text-face nil - :text-size nil))) + :display-device port + :device-font-name font-name))) (setf (text-style-mapping port text-style) font-name) text-style))

1 0

[mcclim-cvs] CVS mcclim
by afuchs 09 Mar '06

09 Mar '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv23297 Modified Files: recording.lisp Log Message: "This is your brain on PHP". Actually remove deleted cached output records from the cache hashtable, don't just set their value to NIL. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2006/03/03 21:10:21 1.122 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2006/03/09 10:44:28 1.123 @@ -1011,6 +1011,9 @@ (defun (setf %entry-in-children-cache) (new-val record entry) (setf (gethash entry (%tree-record-children-cache record)) new-val)) +(defun %remove-entry-from-children-cache (record entry) + (remhash entry (%tree-record-children-cache record))) + (defmethod output-record-children ((record standard-tree-output-record)) (map 'list #'tree-output-record-entry-record @@ -1030,14 +1033,14 @@ (cond ((not (null entry)) (spatial-trees:delete entry (%tree-record-children record)) - (setf (%entry-in-children-cache record child) nil) + (%remove-entry-from-children-cache record child) (setf (output-record-parent child) nil)) (errorp (error "~S is not a child of ~S" child record))))) (defmethod clear-output-record ((record standard-tree-output-record)) (dolist (child (output-record-children record)) (setf (output-record-parent child) nil) - (setf (%entry-in-children-cache record child) nil)) + (%remove-entry-from-children-cache record child)) (setf (%tree-record-children record) (%make-tree-output-record-tree))) (defun map-over-tree-output-records (function record rectangle sort-order function-args)

1 0

[mcclim-cvs] CVS mcclim/Backends/PostScript
by crhodes 07 Mar '06

07 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv11247 Modified Files: sheet.lisp Log Message: Fix the postscript-test demo and table formatting NEW-PAGE must set the stream cursor position to 0 0 even if we're only recording, not drawing. (Perhaps especially so). --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/sheet.lisp 2006/03/07 14:59:29 1.12 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/sheet.lisp 2006/03/07 15:43:44 1.13 @@ -148,8 +148,8 @@ ;; output, so all pages after the first are blank. But I don't ;; know quite what the original purpose of the call was, so, ;; FIXME. -- TPD 2005-12-23 - ;; (clear-output-record (stream-output-history stream)) - (setf (stream-cursor-position stream) (values 0 0)))) + #-(and) (clear-output-record (stream-output-history stream))) + (setf (stream-cursor-position stream) (values 0 0))) ;;;; Output Protocol

1 0

[mcclim-cvs] CVS mcclim/Backends/PostScript
by crhodes 07 Mar '06

07 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv6393/Backends/PostScript Modified Files: sheet.lisp Log Message: Make our EPS files always have lower bounds of 0. --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/sheet.lisp 2005/12/30 18:02:39 1.11 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/sheet.lisp 2006/03/07 14:59:29 1.12 @@ -55,7 +55,8 @@ (let* ((port (find-port :server-path `(:ps :stream ,file-stream))) (stream (make-postscript-stream file-stream port device-type multi-page scale-to-fit - orientation header-comments))) + orientation header-comments)) + translate-x translate-y) (unwind-protect (progn (with-output-recording-options (stream :record t :draw nil) @@ -73,9 +74,12 @@ ((:eps) (let ((record (stream-output-history stream))) (multiple-value-bind (lx ly ux uy) (bounding-rectangle* record) + (setf translate-x (- (ceiling lx)) + translate-y (ceiling uy)) (format file-stream "%%BoundingBox: ~A ~A ~A ~A~%" - (floor lx) (- (ceiling uy)) - (ceiling ux) (- (floor ly)))))) + 0 0 + (+ translate-x (floor lx)) + (- translate-y (floor ly)))))) (t (multiple-value-bind (width height) (paper-size paper) @@ -93,6 +97,7 @@ (dolist (text-style (device-fonts (sheet-medium stream))) (write-font-to-postscript-stream (sheet-medium stream) text-style)) (start-page stream) + (format file-stream "~@[~A ~]~@[~A translate~%~]" translate-x translate-y) (let ((record (stream-output-history stream))) (with-output-recording-options (stream :draw t :record nil) (with-graphics-state (stream)

1 0

[mcclim-cvs] CVS mcclim/Tests
by crhodes 07 Mar '06

07 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Tests In directory clnet:/tmp/cvs-serv6393/Tests Modified Files: postscript.lisp Log Message: Make our EPS files always have lower bounds of 0. --- /project/mcclim/cvsroot/mcclim/Tests/postscript.lisp 2005/10/31 10:21:09 1.1 +++ /project/mcclim/cvsroot/mcclim/Tests/postscript.lisp 2006/03/07 14:59:29 1.2 @@ -47,6 +47,9 @@ (assert (numberp lly)) (assert (numberp urx)) (assert (numberp ury)) + ;; our EPS files have lower bounds of 0. + (assert (= 0 llx)) + (assert (= 0 lly)) (assert (>= 20 (- urx llx) 18)) (assert (>= 22 (- ury lly) 20)) (return t))))))))

1 0

[mcclim-cvs] CVS mcclim
by crhodes 06 Mar '06

06 Mar '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv2997 Modified Files: regions.lisp Log Message: Fix a couple of region bugs * the infinite loop in point/point intersection noted in the tests * isum-member was broken for more than one rectangle in the same horizontal band. Add test for this case. --- /project/mcclim/cvsroot/mcclim/regions.lisp 2005/02/11 10:05:57 1.30 +++ /project/mcclim/cvsroot/mcclim/regions.lisp 2006/03/06 16:09:12 1.31 @@ -4,7 +4,7 @@ ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> ;;; License: LGPL (See file COPYING for details). -;;; $Id: regions.lisp,v 1.30 2005/02/11 10:05:57 crhodes Exp $ +;;; $Id: regions.lisp,v 1.31 2006/03/06 16:09:12 crhodes Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet(a)emi.u-bordeaux.fr) @@ -1042,6 +1042,11 @@ (t (make-instance 'standard-region-union :regions (list a b))))) +(defmethod region-intersection ((a point) (b point)) + (cond + ((region-equal a b) a) + (t +nowhere+))) + (defmethod region-equal ((a point) (b point)) (and (coordinate= (point-x a) (point-x b)) (coordinate= (point-y a) (point-y b)))) @@ -1316,8 +1321,8 @@ (defun isum-member (elt isum) (cond ((null isum) nil) - ((<= (car isum) elt (cadr isum)) t) - ((> elt (cadr isum)) nil) + ((< elt (car isum)) nil) + ((<= elt (cadr isum)) t) (t (isum-member elt (cddr isum))))) (defun rectangle->standard-rectangle-set (rect) @@ -1563,13 +1568,13 @@ (defmethod region-intersection ((b region) (a standard-polyline)) (region-intersection a b)) -(defmethod region-intersection ((a region) (p standard-point)) +(defmethod region-intersection ((a region) (p point)) (multiple-value-bind (x y) (point-position p) (if (region-contains-position-p a x y) p +nowhere+))) -(defmethod region-intersection ((p standard-point) (a region)) +(defmethod region-intersection ((p point) (a region)) (region-intersection a p)) (defmethod region-intersection ((a standard-region-union) (b region)) @@ -1656,7 +1661,7 @@ x) res)) -(defmethod region-difference ((x standard-point) (y region)) +(defmethod region-difference ((x point) (y region)) (multiple-value-bind (px py) (point-position x) (if (region-contains-position-p y px py) +nowhere+ @@ -2186,7 +2191,7 @@ (region-union (region-difference a b) (region-difference b a))) -(defmethod region-contains-region-p ((a region) (b standard-point)) +(defmethod region-contains-region-p ((a region) (b point)) (region-contains-position-p a (point-x b) (point-y b))) ;; xxx was ist mit (region-contains-region-p x +nowhere+) ?

1 0

[mcclim-cvs] CVS mcclim/Tests
by crhodes 06 Mar '06

06 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Tests In directory clnet:/tmp/cvs-serv2997/Tests Modified Files: regions.lisp Log Message: Fix a couple of region bugs * the infinite loop in point/point intersection noted in the tests * isum-member was broken for more than one rectangle in the same horizontal band. Add test for this case. --- /project/mcclim/cvsroot/mcclim/Tests/regions.lisp 2005/09/12 21:23:56 1.4 +++ /project/mcclim/cvsroot/mcclim/Tests/regions.lisp 2006/03/06 16:09:12 1.5 @@ -83,8 +83,6 @@ (assert (member p2 regions :test #'region-equal))) ;;; intersection of two different points -;;; this test fails. It loops forever -#+(or) (let* ((p1 (make-point 10 -10)) (p2 (make-point -10 10)) (i (region-intersection p1 p2))) @@ -106,6 +104,18 @@ (assert (null (set-difference regions regions2 :test #'region-equal))) (assert (null (set-difference regions2 regions :test #'region-equal))))) +;;; standard-rectangle-set and containment calculation +(let* ((r1 (make-rectangle* 0 0 1 1)) + (r2 (make-rectangle* 2 0 3 1)) + (ru (region-union r1 r2))) + (assert (not (region-contains-position-p ru -1/2 1/2))) + (assert (region-contains-position-p ru 1/2 1/2)) + (assert (not (region-contains-position-p ru 3/2 1/2))) + (assert (region-contains-position-p ru 5/2 1/2)) + (assert (not (region-contains-position-p ru 7/2 1/2))) + (assert (not (region-contains-position-p ru 1/2 3/2))) + (assert (not (region-contains-position-p ru 5/2 -1/2)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; polyline

1 0

[mcclim-cvs] CVS mcclim
by afuchs 03 Mar '06

03 Mar '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv2565 Modified Files: recording.lisp mcclim.asd INSTALL.ASDF Log Message: Implement standard-tree-output-records using spatial trees. Also, document the updated installation process in INSTALL.ASDF. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2006/01/13 12:17:55 1.121 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2006/03/03 21:10:21 1.122 @@ -934,7 +934,6 @@ (defmethod map-over-output-records-1 (function (record standard-sequence-output-record) function-args) "Applies FUNCTION to all children in the order they were added." - (declare (ignore x-offset y-offset)) (if function-args (loop with children = (output-record-children record) for child across children @@ -972,10 +971,115 @@ when (region-intersects-region-p region child) do (apply function child function-args))) -;;; XXX bogus for now. -(defclass standard-tree-output-record (standard-sequence-output-record) - ( - )) + +;;; tree output recording + +(defclass tree-output-record-entry () + ((record :initarg :record :reader tree-output-record-entry-record) + (cached-rectangle :initform nil :accessor tree-output-record-entry-cached-rectangle) + (inserted-nr :initarg :inserted-nr :accessor tree-output-record-entry-inserted-nr))) + +(defun make-tree-output-record-entry (record inserted-nr) + (make-instance 'tree-output-record-entry :record record :inserted-nr inserted-nr)) + +(defun %record-to-spatial-tree-rectangle (r) + (rectangles:make-rectangle + :lows `(,(bounding-rectangle-min-x r) + ,(bounding-rectangle-min-y r)) + :highs `(,(bounding-rectangle-max-x r) + ,(bounding-rectangle-max-y r)))) + +(defun %output-record-entry-to-spatial-tree-rectangle (r) + (when (null (tree-output-record-entry-cached-rectangle r)) + (let* ((record (tree-output-record-entry-record r))) + (setf (tree-output-record-entry-cached-rectangle r) (%record-to-spatial-tree-rectangle record)))) + (tree-output-record-entry-cached-rectangle r)) + +(defun %make-tree-output-record-tree () + (spatial-trees:make-spatial-tree :r + :rectfun #'%output-record-entry-to-spatial-tree-rectangle)) + +(defclass standard-tree-output-record (compound-output-record) + ((children :initform (%make-tree-output-record-tree) + :accessor %tree-record-children) + (children-hash :initform (make-hash-table :test #'eql) :reader %tree-record-children-cache) + (last-insertion-nr :initform 0 :accessor last-insertion-nr))) + +(defun %entry-in-children-cache (record entry) + (gethash entry (%tree-record-children-cache record))) + +(defun (setf %entry-in-children-cache) (new-val record entry) + (setf (gethash entry (%tree-record-children-cache record)) new-val)) + +(defmethod output-record-children ((record standard-tree-output-record)) + (map 'list + #'tree-output-record-entry-record + (spatial-trees:search (%record-to-spatial-tree-rectangle record) + (%tree-record-children record)))) + +(defmethod add-output-record (child (record standard-tree-output-record)) + (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record))))) + (spatial-trees:insert entry (%tree-record-children record)) + (setf (output-record-parent child) record) + (setf (%entry-in-children-cache record child) entry))) + +(defmethod delete-output-record (child (record standard-tree-output-record) &optional (errorp t)) + (let ((entry (find child (spatial-trees:search (%entry-in-children-cache record child) + (%tree-record-children record)) + :key #'tree-output-record-entry-record))) + (cond + ((not (null entry)) + (spatial-trees:delete entry (%tree-record-children record)) + (setf (%entry-in-children-cache record child) nil) + (setf (output-record-parent child) nil)) + (errorp (error "~S is not a child of ~S" child record))))) + +(defmethod clear-output-record ((record standard-tree-output-record)) + (dolist (child (output-record-children record)) + (setf (output-record-parent child) nil) + (setf (%entry-in-children-cache record child) nil)) + (setf (%tree-record-children record) (%make-tree-output-record-tree))) + +(defun map-over-tree-output-records (function record rectangle sort-order function-args) + (dolist (child (sort (spatial-trees:search rectangle + (%tree-record-children record)) + (ecase sort-order + (:most-recent-first #'>) + (:most-recent-last #'<)) + :key #'tree-output-record-entry-inserted-nr)) + (apply function (tree-output-record-entry-record child) function-args))) + +(defmethod map-over-output-records-1 (function (record standard-tree-output-record) function-args) + (map-over-tree-output-records function record (%record-to-spatial-tree-rectangle record) :most-recent-last + function-args)) + +(defmethod map-over-output-records-containing-position (function (record standard-tree-output-record) x y &optional x-offset y-offset &rest function-args) + (declare (ignore x-offset y-offset)) + (map-over-tree-output-records function record (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) :most-recent-first + function-args)) + +(defmethod map-over-output-records-overlapping-region (function (record standard-tree-output-record) region &optional x-offset y-offset &rest function-args) + (declare (ignore x-offset y-offset)) + (typecase region + (everywhere-region (map-over-output-records-1 function record function-args)) + (nowhere-region nil) + (otherwise (map-over-tree-output-records + (lambda (child) + (if (region-intersects-region-p (multiple-value-call 'make-rectangle* (bounding-rectangle* child)) + region) + (apply function child function-args))) + record (%record-to-spatial-tree-rectangle (bounding-rectangle region)) :most-recent-last + nil)))) + +(defmethod recompute-extent-for-changed-child :around ((record standard-tree-output-record) child old-min-x old-min-y old-max-x old-max-y) + (when (eql record (output-record-parent child)) + (let ((entry (%entry-in-children-cache record child))) + (spatial-trees:delete entry (%tree-record-children record)) + (setf (tree-output-record-entry-cached-rectangle entry) nil) + (spatial-trees:insert entry (%tree-record-children record)))) + (call-next-method)) + +;;; (defmethod match-output-records ((record t) &rest args) (apply #'match-output-records-1 record args)) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2005/08/19 21:34:41 1.6 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/03 21:10:21 1.7 @@ -63,9 +63,6 @@ :class requireable-system)) -(pushnew :clim *features*) -(pushnew :mcclim *features*) - (defmacro clim-defsystem ((module &key depends-on) &rest components) `(progn (asdf:defsystem ,module @@ -96,7 +93,7 @@ (:file "package" :depends-on ("Lisp-Dep")))) (defsystem :clim-core - :depends-on (:clim-lisp) + :depends-on (:clim-lisp :spatial-trees) :components ((:file "decls") (:module "Lisp-Dep" :depends-on ("decls") @@ -392,3 +389,7 @@ ;;; package dependency lists. (defsystem :mcclim :depends-on (:clim-looks)) + +(defmethod perform :after ((op load-op) (c (eql (find-system :mcclim)))) + (pushnew :clim *features*) + (pushnew :mcclim *features*)) \ No newline at end of file --- /project/mcclim/cvsroot/mcclim/INSTALL.ASDF 2005/03/06 19:57:12 1.2 +++ /project/mcclim/cvsroot/mcclim/INSTALL.ASDF 2006/03/03 21:10:21 1.3 @@ -16,15 +16,20 @@ have to load CLX via (require :clx) or a similar mechanism yourself. - 3. On your Lisp's REPL (with ASDF loaded), type + 3. You need to install the spatial-trees library (available at + http://cliki.net/spatial-trees). The preferred method for that is + via asdf-install. see http://cliki.net/asdf-install for an + introduction to that method. + + 4. On your Lisp's REPL (with ASDF loaded), type (asdf:oos 'asdf:load-op :mcclim) ; compilation messages should zip past -After step 3, McCLIM and a suitable backend should be loaded and +After step 4, McCLIM and a suitable backend should be loaded and you are good to go. -When you restart your lisp image, you will need to perform step 3 to +When you restart your lisp image, you will need to perform step 4 to load McCLIM again. Installing mcclim.asd if you were using ASDF & system.lisp before

1 0

[mcclim-cvs] CVS mcclim/Goatee
by afuchs 01 Mar '06

01 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv10392 Modified Files: clim-area.lisp Log Message: Add a bounding-rectangle* method for screen-line that takes a visible cursor at eol into account. --- /project/mcclim/cvsroot/mcclim/Goatee/clim-area.lisp 2005/02/22 14:00:18 1.31 +++ /project/mcclim/cvsroot/mcclim/Goatee/clim-area.lisp 2006/03/01 21:51:54 1.32 @@ -196,8 +196,8 @@ &key (start 0) (end (length (current-contents line)))) (text-size (area-stream area) (current-contents line) - :start start - :end end)) + :start start + :end end)) (defmethod initialize-instance :after ((obj screen-line) &key (current-contents nil current-contents-p)) @@ -214,6 +214,18 @@ (values x1 y1 x2 (+ y1 (ascent obj) (descent obj)))) (setf (baseline obj) (+ y1 (ascent obj)))))) +(defmethod bounding-rectangle* ((record screen-line)) + (let ((cursor (cursor record))) + (multiple-value-bind (x1 y1 x2 y2) (call-next-method) + (values x1 y1 + (if cursor + (with-slots (climi::x climi::width) cursor + (max x2 (+ climi::x climi::width))) + x2) + (if cursor + (max y2 (+ y1 (climi::cursor-height cursor))) + y2))))) + (defmethod climi::map-over-output-records-1 (function (record screen-line) function-args) (declare (ignore function function-args))

1 0

[mcclim-cvs] CVS mcclim
by tmoore 23 Feb '06

23 Feb '06

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp:/tmp/cvs-serv930 Added Files: Tag: 1.17 menu-choose.lisp Log Message: Move menu-choose out of Experiemental, because it isn't

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs