From afuchs at common-lisp.net Wed Mar 1 21:51:54 2006 From: afuchs at common-lisp.net (afuchs) Date: Wed, 1 Mar 2006 16:51:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20060301215154.632237087@common-lisp.net> 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)) From afuchs at common-lisp.net Fri Mar 3 21:10:21 2006 From: afuchs at common-lisp.net (afuchs) Date: Fri, 3 Mar 2006 16:10:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060303211021.54726900B@common-lisp.net> 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 From crhodes at common-lisp.net Mon Mar 6 16:09:12 2006 From: crhodes at common-lisp.net (crhodes) Date: Mon, 6 Mar 2006 11:09:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Tests Message-ID: <20060306160912.7A0366713E@common-lisp.net> 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 From crhodes at common-lisp.net Mon Mar 6 16:09:12 2006 From: crhodes at common-lisp.net (crhodes) Date: Mon, 6 Mar 2006 11:09:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060306160912.4B4C6650A1@common-lisp.net> 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 ;;; 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 at 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+) ? From crhodes at common-lisp.net Tue Mar 7 14:59:29 2006 From: crhodes at common-lisp.net (crhodes) Date: Tue, 7 Mar 2006 09:59:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Tests Message-ID: <20060307145929.94AE273230@common-lisp.net> 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)))))))) From crhodes at common-lisp.net Tue Mar 7 14:59:30 2006 From: crhodes at common-lisp.net (crhodes) Date: Tue, 7 Mar 2006 09:59:30 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/PostScript Message-ID: <20060307145930.06A4B73230@common-lisp.net> 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) From crhodes at common-lisp.net Tue Mar 7 15:43:44 2006 From: crhodes at common-lisp.net (crhodes) Date: Tue, 7 Mar 2006 10:43:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/PostScript Message-ID: <20060307154344.32B8816001@common-lisp.net> 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 From afuchs at common-lisp.net Thu Mar 9 10:44:28 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 9 Mar 2006 05:44:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060309104428.D411715001@common-lisp.net> 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) From crhodes at common-lisp.net Fri Mar 10 10:56:01 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 10 Mar 2006 05:56:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060310105601.5D1C960011@common-lisp.net> 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)) From crhodes at common-lisp.net Fri Mar 10 10:56:01 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 10 Mar 2006 05:56:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/PostScript Message-ID: <20060310105601.99DE56102C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv2943/Backends/PostScript Modified Files: font.lisp graphics.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/Backends/PostScript/font.lisp 2005/08/13 14:28:23 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/font.lisp 2006/03/10 10:56:01 1.9 @@ -42,16 +42,40 @@ (xmin :initarg :xmin :reader char-xmin) (xmax :initarg :xmax :reader char-xmax))) -;;; (defvar *font-metrics* (make-hash-table :test 'equal)) -(defun define-font-metrics (name ascent descent angle char-infos) +(defstruct postscript-device-font-name + (font-file (error "missing argument")) + (metrics-file (error "missing argument")) + (size (error "missing argument"))) + +(defun %font-name-size (font-name) + (etypecase font-name + (postscript-device-font-name (postscript-device-font-name-size font-name)) + (cons (cdr font-name)))) +(defun %font-name-metrics-key (font-name) + (etypecase font-name + (postscript-device-font-name font-name) + (cons (car font-name)))) +(defun %font-name-postscript-name (font-name) + (etypecase font-name + (postscript-device-font-name + (let ((font-info (gethash font-name *font-metrics*))) + (unless font-info + (error "Unknown font: ~S" font-info)) + (font-info-name font-info))) + (cons (concatenate 'string (car font-name) "-iso")))) + + + + +(defun define-font-metrics (name ascent descent angle char-infos &optional (font-name nil)) (let ((font-info (make-instance 'font-info :name name :ascent ascent :descent descent :italic-angle angle))) - (setf (gethash name *font-metrics*) font-info) + (setf (gethash (or font-name name) *font-metrics*) font-info) (loop for (code name width ascent descent xmin xmax) in char-infos do (when (>= code 0) (setf (aref (font-info-char-names font-info) code) @@ -137,30 +161,44 @@ (mapping (port postscript-port) (text-style text-style) &optional character-set) (declare (ignore character-set)) - (unless (and (consp mapping) - (stringp (car mapping)) - (numberp (cdr mapping))) - (error "Mapping a text style to a style specification is not~ - implemented.")) - (when (not (gethash (car mapping) *font-metrics*)) - (cerror "Ignore." "Mapping text style ~S to an unknown font ~S." - text-style (car mapping))) - (setf (gethash text-style (port-text-style-mappings port)) - mapping)) + (cond + ((and (consp mapping) + (stringp (car mapping)) + (numberp (cdr mapping))) + (when (not (gethash (car mapping) *font-metrics*)) + (cerror "Ignore." "Mapping text style ~S to an unknown font ~S." + text-style (car mapping))) + (setf (gethash text-style (port-text-style-mappings port)) + mapping)) + (t + (when (not (gethash mapping *font-metrics*)) + (cerror "Ignore." "Mapping text style ~S to an unknown font ~S." + text-style mapping)) + (setf (gethash text-style (port-text-style-mappings port)) + mapping)))) ;; The following four functions should be rewritten: AFM contains all ;; needed information (defmethod text-style-ascent (text-style (medium postscript-medium)) - (multiple-value-bind (width height final-x final-y baseline) - (text-size medium "I" :text-style text-style) - (declare (ignore width height final-x final-y)) - baseline)) + (let* ((font-name (text-style-mapping (port medium) + (merge-text-styles text-style + (medium-merged-text-style medium)))) + (font-info (or (gethash (%font-name-metrics-key font-name) + *font-metrics*) + (error "Unknown font ~S." font-name))) + (size (%font-name-size font-name))) + (* (/ size 1000) (font-info-ascent font-info)))) + (defmethod text-style-descent (text-style (medium postscript-medium)) - (multiple-value-bind (width height final-x final-y baseline) - (text-size medium "q" :text-style text-style) - (declare (ignore width final-x final-y)) - (- height baseline))) + (let* ((font-name (text-style-mapping (port medium) + (merge-text-styles text-style + (medium-merged-text-style medium)))) + (font-info (or (gethash (%font-name-metrics-key font-name) + *font-metrics*) + (error "Unknown font ~S." font-name))) + (size (%font-name-size font-name))) + (* (/ size 1000) (font-info-descent font-info)))) (defmethod text-style-height (text-style (medium postscript-medium)) (multiple-value-bind (width height final-x final-y baseline) @@ -181,10 +219,13 @@ (setf string (make-string 1 :initial-element string))) (unless end (setf end (length string))) (unless text-style (setf text-style (medium-text-style medium))) - (destructuring-bind (psfont . size) - (text-style-mapping (port medium) - (merge-text-styles text-style - (medium-merged-text-style medium))) + (let* ((font-name + (text-style-mapping (port medium) + (merge-text-styles + text-style + (medium-merged-text-style medium)))) + (metrics-key (%font-name-metrics-key font-name)) + (size (%font-name-size font-name))) (let ((scale (/ size 1000))) (cond ((= start end) (values 0 0 0 0)) @@ -194,7 +235,7 @@ (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) - (psfont-text-extents psfont string + (psfont-text-extents metrics-key string :start start :end position-newline) (multiple-value-bind (minx miny maxx maxy) (climi::text-bounding-rectangle* @@ -208,24 +249,30 @@ (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) - (psfont-text-extents psfont string + (psfont-text-extents metrics-key string :start start :end end) (values (* scale left) - (* scale (- font-ascent)) + (* scale (- ascent)) (* scale right) - (* scale font-descent))))))))))) + (* scale descent))))))))))) -(defun psfont-text-extents (font string &key (start 0) (end (length string))) - (let* ((font-info (or (gethash font *font-metrics*) - (error "Unknown font ~S." font))) +(defun psfont-text-extents (metrics-key string &key (start 0) (end (length string))) + (let* ((font-info (or (gethash metrics-key *font-metrics*) + (error "Unknown font ~S." metrics-key))) (char-metrics (font-info-char-infos font-info)) (width (loop for i from start below end sum (char-width (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string i))) - char-metrics))))) + char-metrics)))) + (ascent (loop for i from start below end + maximize (char-ascent (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string i))) + char-metrics)))) + (descent (loop for i from start below end + maximize (char-descent (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string i))) + char-metrics))))) (values width - (font-info-ascent font-info) - (font-info-descent font-info) + ascent + descent (char-xmin (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string start))) char-metrics)) (- width (- (char-width (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string (1- end)))) @@ -243,9 +290,41 @@ &key text-style (start 0) end) (when (characterp string) (setq string (string string))) (unless end (setq end (length string))) - (destructuring-bind (font . size) - (text-style-mapping (port medium) - (merge-text-styles text-style - (medium-merged-text-style medium))) - (text-size-in-font font size + (let* ((font-name (text-style-mapping (port medium) + (merge-text-styles text-style + (medium-merged-text-style medium)))) + (size (%font-name-size font-name)) + (metrics-key (%font-name-metrics-key font-name))) + (text-size-in-font metrics-key size string start (or end (length string))))) + +(defmethod invoke-with-text-style :around + ((medium postscript-medium) + continuation + (text-style clim-internals::device-font-text-style)) + (unless (member text-style (device-fonts medium)) + (push text-style (device-fonts medium))) + (call-next-method)) + +(defun write-font-to-postscript-stream (stream text-style) + (with-open-file (font-stream + (postscript-device-font-name-font-file (clim-internals::device-font-name text-style)) + :direction :input + :external-format :latin-1) + (let ((font (make-string (file-length font-stream)))) + (read-sequence font font-stream) + (write-string font (postscript-medium-file-stream stream))))) + +(defmethod make-device-font-text-style ((port postscript-port) font-name) + (check-type font-name postscript-device-font-name) + (let ((text-style (make-instance 'clim-internals::device-font-text-style + :display-device port + :device-font-name font-name))) + (multiple-value-bind (dict-name ascent descent angle char-infos) + (with-open-file (stream (postscript-device-font-name-metrics-file font-name) + :direction :input + :external-format :latin-1) + (clim-postscript::read-afm-stream stream)) + (clim-postscript::define-font-metrics dict-name ascent descent angle char-infos font-name)) + (setf (text-style-mapping port text-style) font-name) + text-style)) --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2005/12/30 18:02:39 1.15 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2006/03/10 10:56:01 1.16 @@ -462,11 +462,14 @@ (defmethod postscript-set-graphics-state (stream medium (kind (eql :text-style))) - (destructuring-bind (font . size) - (medium-font medium) + (let* ((font-name (medium-font medium)) + (font (%font-name-postscript-name font-name)) + (size (%font-name-size font-name))) (pushnew font (slot-value (medium-sheet medium) 'document-fonts) :test #'string=) - (format stream "/~A-iso findfont ~D scalefont setfont~%" font size))) ;### evil hack. + (format stream "/~A findfont ~D scalefont setfont~%" + font + size))) ;### evil hack. (defun postscript-escape-char (char) (case char @@ -522,7 +525,9 @@ (format-postscript-number ty)))) (multiple-value-bind (total-width total-height final-x final-y baseline) - (destructuring-bind (font . size) (medium-font medium) + (let* ((font-name (medium-font medium)) + (font (%font-name-metrics-key font-name)) + (size (%font-name-size font-name))) (text-size-in-font font size string 0 nil)) (declare (ignore final-x final-y)) ;; Only one line? From crhodes at common-lisp.net Fri Mar 10 10:56:01 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 10 Mar 2006 05:56:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20060310105601.CF48563020@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv2943/Experimental/freetype Modified Files: freetype-fonts.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/Experimental/freetype/freetype-fonts.lisp 2005/08/13 14:28:33 1.11 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2006/03/10 10:56:01 1.12 @@ -301,9 +301,32 @@ (fmakunbound 'clim-clx::text-style-to-x-font) +(defstruct freetype-device-font-name + (font-file (error "missing argument")) + (size (error "missing argument"))) + +(defmethod clim-clx::text-style-to-X-font :around + ((port clim-clx::clx-port) (text-style climi::device-font-text-style)) + (let ((display (slot-value port 'clim-clx::display)) + (font-name (climi::device-font-name text-style))) + (make-free-type-face display + (freetype-device-font-name-font-file font-name) + (freetype-device-font-name-size font-name)))) + +(defmethod text-style-mapping :around + ((port clim-clx::clx-port) (text-style climi::device-font-text-style) + &optional character-set) + (values (gethash text-style (clim-clx::port-text-style-mappings port)))) +(defmethod (setf text-style-mapping) :around + (value + (port clim-clx::clx-port) + (text-style climi::device-font-text-style) + &optional character-set) + (setf (gethash text-style (clim-clx::port-text-style-mappings port)) value)) + (defparameter *free-type-face-hash* (make-hash-table :test #'equal)) -(defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) text-style) +(defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) (text-style standard-text-style)) (multiple-value-bind (family face size) (clim:text-style-components text-style) (let ((display (clim-clx::clx-port-display port))) From afuchs at common-lisp.net Sat Mar 11 11:25:03 2006 From: afuchs at common-lisp.net (afuchs) Date: Sat, 11 Mar 2006 06:25:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20060311112503.E04872806B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv22853 Modified Files: goatee-command.lisp Log Message: Add transpose-chars, bind it to C-t; add control-modified commands bindings: * C-left, C-right * C-backspace, C-delete --- /project/mcclim/cvsroot/mcclim/Goatee/goatee-command.lisp 2005/12/05 22:40:01 1.20 +++ /project/mcclim/cvsroot/mcclim/Goatee/goatee-command.lisp 2006/03/11 11:25:03 1.21 @@ -216,6 +216,29 @@ (error "Last operation was not a yank!")) (yank-prev *kill-ring* *buffer* *insert-extent*)) +;; Transposing (taken from climacs) + +(defun at-beginning-of-buffer-p (buffer) + (and (first-line-p (line (point buffer))) + (zerop (pos (point buffer))))) + +(defun at-end-of-line-p (buffer) + (multiple-value-bind (line pos) (location* (point buffer)) + (declare (ignore line)) + (multiple-value-bind (eoline eolpos) (end-of-line* buffer) + (declare (ignore eoline)) + (= eolpos pos)))) + +(defun cmd-transpose-chars (&key &allow-other-keys) + (unless (at-beginning-of-buffer-p *buffer*) + (with-point (*buffer*) + (when (at-end-of-line-p *buffer*) + (backward-character)) + (let ((object (char-ref *buffer* (point *buffer*)))) + (delete-char *buffer*) + (backward-character) + (insert *buffer* object))))) + ;; Line motion (defun up-line (&key &allow-other-keys) @@ -284,6 +307,9 @@ (add-gesture-command-to-table '(:right :meta) 'forward-word *simple-area-gesture-table*) +(add-gesture-command-to-table '(:right :control) + 'forward-word + *simple-area-gesture-table*) (add-gesture-command-to-table '(#\b :meta) 'backward-word @@ -291,15 +317,24 @@ (add-gesture-command-to-table '(:left :meta) 'backward-word *simple-area-gesture-table*) +(add-gesture-command-to-table '(:left :control) + 'backward-word + *simple-area-gesture-table*) (add-gesture-command-to-table '(#\backspace :meta) 'backwards-delete-word *simple-area-gesture-table*) +(add-gesture-command-to-table '(#\backspace :control) + 'backwards-delete-word + *simple-area-gesture-table*) +(add-gesture-command-to-table '(#\d :meta) + 'delete-word + *simple-area-gesture-table*) (add-gesture-command-to-table '(#\delete :meta) 'delete-word *simple-area-gesture-table*) -(add-gesture-command-to-table '(#\d :meta) +(add-gesture-command-to-table '(#\delete :control) 'delete-word *simple-area-gesture-table*) @@ -343,6 +378,10 @@ 'cmd-yank *simple-area-gesture-table*) +(add-gesture-command-to-table '(#\t :control) + 'cmd-transpose-chars + *simple-area-gesture-table*) + #+nil (add-gesture-command-to-table '(#\y :meta) 'cmd-yank-next From tmoore at common-lisp.net Sun Mar 12 23:09:27 2006 From: tmoore at common-lisp.net (tmoore) Date: Sun, 12 Mar 2006 18:09:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060312230927.CE90461038@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8927 Modified Files: frames.lisp presentation-defs.lisp presentations.lisp Log Message: drag-and-drop, not quite working yet --- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/10 21:58:12 1.114 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/12 23:09:27 1.115 @@ -1566,46 +1566,162 @@ (buffer-rectangle)) (stream-replay stream buffer-rectangle)))))))) -(defgeneric frame-drag-and-drop-highlighting (frame to-presentation state)) +(defgeneric frame-drag-and-drop-highlighting + (frame to-presentation stream state)) (defmethod frame-drag-and-drop-highlighting - ((frame standard-application-frame) to-presentation state) - ) + ((frame standard-application-frame) to-presentation stream state) + (highlight-presentation-1 to-presentation stream state)) -(defun frame-drag-and-drop (translator-name command-table object presentation - context-type frame event window x y) - (let* ((translators (mapcan (lambda (trans) +(defun frame-drag-and-drop (translator-name command-table + from-presentation context-type frame event window + x y) + (declare (ignore command-table)) + (let* ((*dragged-presentation* from-presentation) + (*dragged-object* (presentation-object from-presentation)) + (translators (mapcan (lambda (trans) (and (typep trans 'drag-n-drop-translator) - (test-presentation-translator - trans presentation context-type frame - window x y :event event))) + (funcall (tester trans) + (presentation-object + from-presentation) + :presentation from-presentation + :context-type context-type + :frame frame + :window window + :x x + :y y + :event event))) (find-presentation-translators - (presentation-type presentation) + (presentation-type from-presentation) context-type (frame-command-table frame)))) + ;; Try to run the feedback and highlight functions of the translator + ;; that got us here. (translator (or (find translator-name translators :key #'name) (car translators))) - (tester (tester translator)) - (drag-type (from-type translator)) - (feedback-fn (feedback translator)) - (hilite-fn (highlighting translator)) - (drag-context (make-fake-input-context drag-c-type)) - (*dragged-object* object) - (destination-object nil)) - (multiple-value-bind (x0 y0) - (stream-pointer-position window) - (funcall feedback-fn *application-frame* object window - x0 y0 x0 y0 :highlight) - (tracking-pointer (window :context-type `(or ,(mapcar #'from-type - translators)) - :highlight nil) - (:presentation (&key presentation event x y) - ) - (:pointer-motion (&key event x y) - (multiple-value-bind (presentation translator) - (find-innermost-presentation-match drag-context window - x y :event event))) - (:presentation-button-press (&key presentation x y)) - (:presentation-button-release (&key presentation x y)) - (:button-press (&key x y)) - (:button-release (&key x y)))))) + (initial-feedback-fn (feedback translator)) + (initial-hilite-fn (highlighting translator)) + (destination-presentation nil) + (initial-x x) + (initial-y y) + (last-presentation nil) + (feedback-activated nil) + (feedback-fn initial-feedback-fn) + (hilite-fn initial-hilite-fn) + (last-event nil)) + ;; We shouldn't need to use find-innermost-presentation-match + ;; This repeats what tracking-pointer has already done, but what are you + ;; gonna do? + (flet ((find-dest-translator (presentation window x y) + (loop for translator in translators + when (and (presentation-subtypep + (presentation-type presentation) + (destination-ptype translator)) + (test-presentation-translator translator + presentation + context-type frame + window x y)) + do (return-from find-dest-translator translator)) + nil) + (do-feedback (window x y state do-it) + (when do-it + (funcall feedback-fn frame from-presentation window + initial-x initial-y x y state))) + (do-hilite (presentation window state) + (when presentation + (funcall hilite-fn frame presentation window state))) + (last-window () + (event-sheet last-event)) + (last-x () + (pointer-event-x last-event)) + (last-y () + (pointer-event-y last-event))) + ;; :highlight nil will cause the presentation that is the source of the + ;; dragged object to be unhighlighted initially. + (block do-tracking + (tracking-pointer (window :context-type `(or ,(mapcar #'from-type + translators)) + :highlight nil + :multiple-window t) + (:presentation (&key presentation window event x y) + (let ((dest-translator (find-dest-translator presentation window + x y))) + (do-feedback (last-window) (last-x) (last-y) + :unhighlight feedback-activated) + (setq feedback-activated t + last-event event) + (do-hilite last-presentation (last-window) :unhighlight) + (setq last-presentation presentation + feedback-fn (feedback dest-translator) + hilite-fn (highlighting dest-translator)) + (do-hilite presentation window :highlight) + (do-feedback window x y :highlight t) + (document-drag-n-drop dest-translator presentation + context-type frame event window + x y))) + (:pointer-motion (&key event window x y) + (do-feedback (last-window) (last-x) (last-y) + :unhighlight feedback-activated) + (setq feedback-activated t + last-event event) + (do-hilite last-presentation (last-window) :unhighlight) + (setq last-presentation nil) + (do-feedback window x y :highlight t) + (document-drag-n-drop translator nil + context-type frame event window + x y)) + ;; XXX only support finish-on-release for now. + #-(and)(:presentation-button-press ()) + (:presentation-button-release (&key presentation event) + (setq destination-presentation presentation + last-event event) + (return-from do-tracking nil)) + #-(and)(:button-press ()) + (:button-release (&key event) + (setq last-event event) + (return-from do-tracking nil)))) + ;; + ;; XXX Assumes x y from :button-release are the same as for the preceding + ;; button-motion; is that correct? + (do-feedback (last-window) (last-x) (last-y) + :unhighlight feedback-activated) + (do-hilite last-presentation (last-window) :unhighlight) + (if destination-presentation + (let ((final-translator (find-dest-translator destination-presentation + (last-window) + (last-x) + (last-y)))) + (if final-translator + (funcall (destination-translator final-translator) + *dragged-object* + :presentation *dragged-presentation* + :destination-object (presentation-object + destination-presentation) + :destination-presentation destination-presentation + :context-type context-type + :frame frame + :event event + :window window + :x x + :y y) + (values nil nil))) + (values nil nil))))) + +(defun document-drag-n-drop + (translator presentation context-type frame event window x y) + (when *pointer-documentation-output* + (let ((s *pointer-documentation-output*)) + (window-clear s) + (with-end-of-page-action (s :allow) + (with-end-of-line-action (s :allow) + (document-presentation-translator translator + presentation + context-type + frame + event + window + x y + :stream s + :documentation-type :pointer)))))) + + --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/10 21:58:13 1.51 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/12 23:09:27 1.52 @@ -2002,30 +2002,44 @@ (destination-translator :reader destination-translator :initarg :destination-translator))) + +(defvar *dragged-presentation* nil + "Bound to the presentation dragged in a drag-and-drop context") (defvar *dragged-object* nil "Bound to the object dragged in a drag-and-drop context") +() ;;; According to the Franz User's guide, the destination object is ;;; available in the tester, documentation, and translator function ;;; as destination-object. Therefore OBJECT is the dragged object. In ;;; our scheme the tester function, translator function etc. is ;;; really called on the destination object. So, we do a little -;;; shuffling of arguments here. +;;; shuffling of arguments here. We don't do that for the destination +;;; translator because we can call that ourselves in frame-drag-and-drop. +;;; +;;; Also, in Classic CLIM the destination presentation is passed as a +;;; destination-presentation keyword argument; hence the presentation argument +;;; is the dragged presentation. (defmethod initialize-instance :after ((obj drag-n-drop-translator) - &key tester documentation + &key documentation pointer-documentation - translator-function) + destination-translator) + ;; This is starting to smell... (flet ((make-adapter (func) - (lambda (object &rest args) - (apply func *dragged-object* :destination-object object args)))) - (setf (slot-value obj 'tester) (make-adapter tester)) + (lambda (object &rest args &key presentation &allow-other-keys) + (if *dragged-presentation* + (apply func + *dragged-object* + :presentation *dragged-presentation* + :destination-object object + :destination-presentation presentation + args) + (apply func object args))))) (setf (slot-value obj 'documentation) (make-adapter documentation)) (when pointer-documentation (setf (slot-value obj 'pointer-documentation) - (make-adapter pointer-documentation))) - (setf (slot-value obj 'translator-function) - (make-adapter translator-function)))) + (make-adapter pointer-documentation))))) (defmacro define-drag-and-drop-translator (name (from-type to-type destination-type command-table @@ -2048,17 +2062,14 @@ (with-keywords-removed (args (:feedback :highlighting)) `(progn (define-presentation-translator ,name - (,from-type ,to-type + (,from-type ,to-type ,command-table , at args :feedback #',feedback :highlighting #',highlighting :destination-ptype ',real-dest-type :destination-translator #',(make-translator-fun arglist body) :translator-class drag-n-drop-translator) - (object presentation context-type frame event window x y) - (frame-drag-and-drop ',name ',command-table object + (presentation context-type frame event window x y) + (frame-drag-and-drop ',name ',command-table presentation context-type frame event window x y)))))) - - - --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/10 21:58:13 1.72 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/12 23:09:27 1.73 @@ -1497,17 +1497,20 @@ (defmethod call-presentation-translator ((translator presentation-translator) presentation context-type frame event window x y) - (multiple-value-bind (object ptype options) - (funcall (translator-function translator) - (presentation-object presentation) - :presentation presentation - :context-type context-type - :frame frame - :event event - :window window - :x x - :y y) - (values object (or ptype context-type) options))) + ;; Let the translator return an explict ptype of nil to, in effect, abort the + ;; presentation throw. + (multiple-value-call + #'(lambda (object &optional (ptype context-type) options) + (values object ptype options)) + (funcall (translator-function translator) + (presentation-object presentation) + :presentation presentation + :context-type context-type + :frame frame + :event event + :window window + :x x + :y y))) (defmethod call-presentation-translator ((translator presentation-action) presentation context-type From tmoore at common-lisp.net Mon Mar 13 06:08:13 2006 From: tmoore at common-lisp.net (tmoore) Date: Mon, 13 Mar 2006 01:08:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060313060813.441965E0D0@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv28040 Modified Files: frames.lisp Log Message: drag-and-drop mostly working except for highlighting of destination presentations --- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/12 23:09:27 1.115 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/13 06:08:12 1.116 @@ -1562,7 +1562,7 @@ :filled nil :line-dashes #(4 4)))) (:unhighlight (with-double-buffering - ((stream hilite-x1 hilite-y1 hilite-x2 hilite-y2) + ((stream hilite-x1 hilite-y1 (1+ hilite-x2) (1+ hilite-y2)) (buffer-rectangle)) (stream-replay stream buffer-rectangle)))))))) @@ -1590,7 +1590,8 @@ :window window :x x :y y - :event event))) + :event event) + (list trans))) (find-presentation-translators (presentation-type from-presentation) context-type @@ -1623,13 +1624,11 @@ window x y)) do (return-from find-dest-translator translator)) nil) - (do-feedback (window x y state do-it) - (when do-it - (funcall feedback-fn frame from-presentation window - initial-x initial-y x y state))) + (do-feedback (window x y state) + (funcall feedback-fn frame from-presentation window + initial-x initial-y x y state)) (do-hilite (presentation window state) - (when presentation - (funcall hilite-fn frame presentation window state))) + (funcall hilite-fn frame presentation window state)) (last-window () (event-sheet last-event)) (last-x () @@ -1646,27 +1645,29 @@ (:presentation (&key presentation window event x y) (let ((dest-translator (find-dest-translator presentation window x y))) - (do-feedback (last-window) (last-x) (last-y) - :unhighlight feedback-activated) + (when feedback-activated + (do-feedback (last-window) (last-x) (last-y) :unhighlight)) (setq feedback-activated t last-event event) - (do-hilite last-presentation (last-window) :unhighlight) + (when last-presentation + (do-hilite last-presentation (last-window) :unhighlight)) (setq last-presentation presentation feedback-fn (feedback dest-translator) hilite-fn (highlighting dest-translator)) (do-hilite presentation window :highlight) - (do-feedback window x y :highlight t) + (do-feedback window x y :highlight) (document-drag-n-drop dest-translator presentation context-type frame event window x y))) (:pointer-motion (&key event window x y) - (do-feedback (last-window) (last-x) (last-y) - :unhighlight feedback-activated) + (when feedback-activated + (do-feedback (last-window) (last-x) (last-y) :unhighlight)) (setq feedback-activated t last-event event) - (do-hilite last-presentation (last-window) :unhighlight) + (when last-presentation + (do-hilite last-presentation (last-window) :unhighlight)) (setq last-presentation nil) - (do-feedback window x y :highlight t) + (do-feedback window x y :highlight) (document-drag-n-drop translator nil context-type frame event window x y)) @@ -1683,9 +1684,10 @@ ;; ;; XXX Assumes x y from :button-release are the same as for the preceding ;; button-motion; is that correct? - (do-feedback (last-window) (last-x) (last-y) - :unhighlight feedback-activated) - (do-hilite last-presentation (last-window) :unhighlight) + (when feedback-activated + (do-feedback (last-window) (last-x) (last-y) :unhighlight)) + (when last-presentation + (do-hilite last-presentation (last-window) :unhighlight)) (if destination-presentation (let ((final-translator (find-dest-translator destination-presentation (last-window) @@ -1714,14 +1716,19 @@ (window-clear s) (with-end-of-page-action (s :allow) (with-end-of-line-action (s :allow) - (document-presentation-translator translator - presentation - context-type - frame - event - window - x y - :stream s - :documentation-type :pointer)))))) + (funcall (pointer-documentation translator) + *dragged-object* + :presentation *dragged-presentation* + :destination-object (and presentation + (presentation-object presentation)) + :destination-presentation presentation + :context-type context-type + :frame frame + :event event + :window window + :x x + :y y + :stream s)))))) + From tmoore at common-lisp.net Mon Mar 13 06:13:05 2006 From: tmoore at common-lisp.net (tmoore) Date: Mon, 13 Mar 2006 01:13:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20060313061305.926366001A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv28215 Added Files: dragndrop-translator.lisp Log Message: Test program for drag-and-drop translators --- /project/mcclim/cvsroot/mcclim/Examples/dragndrop-translator.lisp 2006/03/13 06:13:05 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/dragndrop-translator.lisp 2006/03/13 06:13:05 1.1 ;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2006 by ;;; Tim Moore (moore at bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defparameter *colors* (list +black+ +white+ +red+ +green+ +blue+ +magenta+ +cyan+ +yellow+)) (defparameter *color-alist* `(("black" . ,+black+) ("white" . ,+white+) ("red" . ,+red+) ("green" . ,+green+) ("blue" . ,+blue+) ("magenta" . ,+magenta+) ("cyan" . ,+cyan+) ("yellow" . ,+yellow+))) (define-presentation-type named-color () :inherit-from `(completion ,*color-alist* :value-key cdr)) (defclass rect () ((x :accessor x :initarg :x) (y :accessor y :initarg :y) (width :accessor width :initarg :width) (height :accessor height :initarg :height) (color :accessor color :initarg :color)) (:default-initargs :x 0 :y 0 :width 50 :height 50 :color +black+)) (defgeneric draw (stream thing)) (defmethod draw (stream (thing rect)) (with-output-as-presentation (stream thing 'rect) (let ((x (x thing)) (y (y thing))) (draw-rectangle* stream x y (+ x (width thing)) (+ y (height thing)) :ink (color thing))))) (define-application-frame drag-test () ((shape1 :accessor shape1 :initform (make-instance 'rect :x 10 :y 10)) (shape2 :accessor shape2 :initform (make-instance 'rect :x 100 :y 10))) (:pointer-documentation t) (:panes (interactor :interactor) (scribble :application :width 200 :display-function 'display-shapes)) (:layouts (default (vertically () scribble interactor)))) (defun display-shapes (frame stream) (draw stream (shape1 frame)) (draw stream (shape2 frame))) (define-drag-test-command (com-set-color :name t) ((shape 'rect) &key (color 'named-color :default +cyan+ )) (setf (color shape) color)) (define-drag-test-command (com-set-random-color :name t) ((shape 'rect)) (let ((elt (random (length *color-alist*)))) (setf (color shape) (cdr (nth elt *color-alist*))))) (define-drag-and-drop-translator com-drop-color (rect command rect drag-test) (object destination-object) (if (eq object destination-object) `(com-set-random-color ,object) `(com-set-color ,destination-object :color ,(color object)))) #-(and) (define-gesture-name :drag-and-drop :pointer-button (:control :left) :unique t) From tmoore at common-lisp.net Mon Mar 13 11:24:01 2006 From: tmoore at common-lisp.net (tmoore) Date: Mon, 13 Mar 2006 06:24:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20060313112401.512754100F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv32650 Modified Files: dragndrop-translator.lisp Log Message: Missing eval-when --- /project/mcclim/cvsroot/mcclim/Examples/dragndrop-translator.lisp 2006/03/13 06:13:05 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/dragndrop-translator.lisp 2006/03/13 11:24:01 1.2 @@ -23,14 +23,15 @@ (defparameter *colors* (list +black+ +white+ +red+ +green+ +blue+ +magenta+ +cyan+ +yellow+)) -(defparameter *color-alist* `(("black" . ,+black+) - ("white" . ,+white+) - ("red" . ,+red+) - ("green" . ,+green+) - ("blue" . ,+blue+) - ("magenta" . ,+magenta+) - ("cyan" . ,+cyan+) - ("yellow" . ,+yellow+))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *color-alist* `(("black" . ,+black+) + ("white" . ,+white+) + ("red" . ,+red+) + ("green" . ,+green+) + ("blue" . ,+blue+) + ("magenta" . ,+magenta+) + ("cyan" . ,+cyan+) + ("yellow" . ,+yellow+)))) (define-presentation-type named-color () :inherit-from `(completion ,*color-alist* :value-key cdr)) @@ -79,7 +80,12 @@ (setf (color shape) (cdr (nth elt *color-alist*))))) (define-drag-and-drop-translator com-drop-color - (rect command rect drag-test) + (rect command rect drag-test + :tester ((destination-object event) + (when destination-object + (break)) + event + t)) (object destination-object) (if (eq object destination-object) `(com-set-random-color ,object) From tmoore at common-lisp.net Mon Mar 13 17:06:08 2006 From: tmoore at common-lisp.net (tmoore) Date: Mon, 13 Mar 2006 12:06:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20060313170608.112B372080@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv11856 Modified Files: dragndrop-translator.lisp Log Message: Remove some debugging code that breaks everything --- /project/mcclim/cvsroot/mcclim/Examples/dragndrop-translator.lisp 2006/03/13 11:24:01 1.2 +++ /project/mcclim/cvsroot/mcclim/Examples/dragndrop-translator.lisp 2006/03/13 17:06:08 1.3 @@ -80,12 +80,7 @@ (setf (color shape) (cdr (nth elt *color-alist*))))) (define-drag-and-drop-translator com-drop-color - (rect command rect drag-test - :tester ((destination-object event) - (when destination-object - (break)) - event - t)) + (rect command rect drag-test) (object destination-object) (if (eq object destination-object) `(com-set-random-color ,object) From crhodes at common-lisp.net Tue Mar 14 12:27:24 2006 From: crhodes at common-lisp.net (crhodes) Date: Tue, 14 Mar 2006 07:27:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20060314122724.DCE5521002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv4322/Goatee Modified Files: goatee-command.lisp Log Message: Latin1 commands for Goatee. Requires, in the case of the CLX backend, SBCL and a post-0.7.2 CLX. --- /project/mcclim/cvsroot/mcclim/Goatee/goatee-command.lisp 2006/03/11 11:25:03 1.21 +++ /project/mcclim/cvsroot/mcclim/Goatee/goatee-command.lisp 2006/03/14 12:27:24 1.22 @@ -261,6 +261,11 @@ do (add-gesture-command-to-table (code-char i) 'insert-character *simple-area-gesture-table*)) +;;; people who use dead keys get to implement code for that in Goatee. +(loop for i from 160 to 255 + do (add-gesture-command-to-table (code-char i) + 'insert-character + *simple-area-gesture-table*)) (add-gesture-command-to-table #\tab 'insert-character From crhodes at common-lisp.net Wed Mar 15 09:31:31 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 15 Mar 2006 04:31:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20060315093131.A8D572F000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv4599/Experimental/freetype Modified Files: mcclim-freetype.asd Log Message: Fix for uncompiled-cl-source-file in the presence of the (advertised) asdf protocol with output-files :around. No output files! --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2006/02/06 13:42:09 1.4 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2006/03/15 09:31:31 1.5 @@ -12,13 +12,20 @@ (defpackage :mcclim-freetype-system (:use :cl :asdf)) (in-package :mcclim-freetype-system) -(defclass uncompiled-cl-source-file (cl-source-file) ()) +(defclass uncompiled-cl-source-file (source-file) ()) (defmethod perform ((o compile-op) (f uncompiled-cl-source-file)) t) - +(defmethod perform ((o load-op) (f uncompiled-cl-source-file)) + (mapcar #'load (input-files o f))) (defmethod output-files ((operation compile-op) (c uncompiled-cl-source-file)) + nil) +(defmethod input-files ((operation load-op) (c uncompiled-cl-source-file)) (list (component-pathname c))) +(defmethod operation-done-p ((operation compile-op) (c uncompiled-cl-source-file)) + t) +(defmethod source-file-type ((c uncompiled-cl-source-file) (s module)) + "lisp") (defsystem :mcclim-freetype :depends-on (:clim-clx) From tmoore at common-lisp.net Wed Mar 15 15:38:39 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 15 Mar 2006 10:38:39 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060315153839.6B40646116@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv18917 Modified Files: builtin-commands.lisp commands.lisp decls.lisp frames.lisp mcclim.asd presentation-defs.lisp presentations.lisp stream-input.lisp system.lisp utils.lisp Log Message: Fixed destination highlighting for drag-and-drop translators. Added documentation for dnd translators. Corrected the default value for modifier-state in find-innermost-applicable-presentation and friends. This isn't as big as it looks :) --- /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2005/06/22 11:41:34 1.20 +++ /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2006/03/15 15:38:38 1.21 @@ -136,7 +136,9 @@ :for-menu t)) ;;; Action for possibilities menu of complete-input - +;;; +;;; XXX The context type needs to change to COMPLETER or something so that this +;;; isn't applicable all over the place. (define-presentation-action possibilities-menu (blank-area nil global-command-table :documentation "Possibilities menu for completion" --- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/10 21:58:12 1.58 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/15 15:38:39 1.59 @@ -178,19 +178,6 @@ :menu ',menu :errorp nil)))) -(defun command-name-from-symbol (symbol) - (let ((name (symbol-name symbol))) - (string-capitalize - (substitute - #\Space #\- - (subseq name (if (string= "COM-" name :end2 (min (length name) 4)) - 4 - 0)))))) - -(defun keyword-arg-name-from-symbol (symbol) - (let ((name (symbol-name symbol))) - (string-capitalize (substitute #\Space #\- name)))) - (defun remove-command-from-command-table (command-name command-table &key (errorp t)) --- /project/mcclim/cvsroot/mcclim/decls.lisp 2006/03/10 21:58:12 1.36 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2006/03/15 15:38:39 1.37 @@ -502,6 +502,10 @@ (defgeneric port-disable-sheet (port sheet)) (defgeneric port-pointer (port)) +(defgeneric pointer-update-state (pointer event) + (:documentation "Called by port event dispatching code to update the modifier +and button states of the pointer.")) + ;;; ;; Used in stream-input.lisp, defined in frames.lisp --- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/13 06:08:12 1.116 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/15 15:38:39 1.117 @@ -1460,17 +1460,19 @@ ;;; Classic CLIM seems to agree. -- moore (defun highlight-for-tracking-pointer (frame stream event input-context highlight) - (let ((context-ptype (input-context-type (car input-context))) - (presentation nil) + (let ((presentation nil) (current-hilited (frame-hilited-presentation frame))) (when (output-recording-stream-p stream) - (setq presentation (find-innermost-applicable-presentation - input-context - stream - (device-event-x event) - (device-event-y event) - :frame frame - :event event))) + ;; XXX Massive hack to prevent the presentation action for completions + ;; from being applicable. After the .9.2.2 release that action will have + ;; a more restrictive context type. + (let ((*completion-possibilities-continuation* nil)) + (setq presentation (find-innermost-applicable-presentation + input-context + stream + (device-event-x event) + (device-event-y event) + :frame frame)))) (when (and current-hilited (not (eq (car current-hilited) presentation))) (highlight-presentation-1 (car current-hilited) (cdr current-hilited) @@ -1641,7 +1643,7 @@ (tracking-pointer (window :context-type `(or ,(mapcar #'from-type translators)) :highlight nil - :multiple-window t) + :multiple-window nil) ;XXX (:presentation (&key presentation window event x y) (let ((dest-translator (find-dest-translator presentation window x y))) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/10 21:58:13 1.8 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/15 15:38:39 1.9 @@ -321,7 +321,8 @@ (:file "presentation-test") #+clx (:file "gadget-test") (:file "accepting-values") - (:file "method-browser"))))) + (:file "method-browser") + (:file "dragndrop-translator"))))) ;;; This won't load in SBCL, either. I have really crappy code to ;;; extract dependency information from :serial t ASDF systems, but --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/12 23:09:27 1.52 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/15 15:38:39 1.53 @@ -2047,7 +2047,7 @@ (gesture :select) (tester 'default-translator-tester) documentation - pointer-documentation + (pointer-documentation nil pointer-doc-p) (menu t) (priority 0) (feedback 'frame-drag-and-drop-feedback) @@ -2056,14 +2056,25 @@ &body body) (declare (ignore tester gesture documentation pointer-documentation menu priority)) - (let ((real-dest-type (expand-presentation-type-abbreviation - destination-type))) - - (with-keywords-removed (args (:feedback :highlighting)) + (let* ((real-dest-type (expand-presentation-type-abbreviation + destination-type)) + (name-string (command-name-from-symbol name)) + (drag-string (format nil "Drag to ~A" name-string)) + (pointer-doc (if pointer-doc-p + nil + `(:pointer-documentation + ((object destination-object stream) + (declare (ignore object)) + (write-string (if destination-object + ,name-string + ,drag-string) + stream)))))) + (with-keywords-removed (args (:feedback :highlighting)) `(progn (define-presentation-translator ,name (,from-type ,to-type ,command-table , at args + , at pointer-doc :feedback #',feedback :highlighting #',highlighting :destination-ptype ',real-dest-type :destination-translator #',(make-translator-fun arglist body) --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/12 23:09:27 1.73 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/15 15:38:39 1.74 @@ -1598,8 +1598,6 @@ x y) context-type)) (return-from test-presentation-translator nil)))) - - t) ;;; presentation-contains-position moved to presentation-defs.lisp @@ -1661,9 +1659,14 @@ presentation x y))))) +(defun window-modifier-state (window) + "Provides default modifier state for presentation translator functions." + (let ((pointer (port-pointer (port window)))) + (pointer-modifier-state pointer))) + (defun find-applicable-translators (presentation input-context frame window x y - &key event (modifier-state 0) for-menu fastp) + &key event (modifier-state (window-modifier-state window)) for-menu fastp) (let ((results nil)) (flet ((fast-func (translator presentation context) (declare (ignore translator presentation context)) @@ -1751,7 +1754,9 @@ (defun find-innermost-applicable-presentation (input-context window x y - &key (frame *application-frame*) modifier-state event) + &key (frame *application-frame*) + (modifier-state (window-modifier-state window)) + event) (values (find-innermost-presentation-match input-context (stream-output-history window) frame @@ -1761,12 +1766,13 @@ modifier-state nil))) -(defun find-innermost-presentation-context (input-context window x y - &key - (top-record - (stream-output-history window)) - (frame *application-frame*) - event modifier-state button) +(defun find-innermost-presentation-context + (input-context window x y + &key (top-record (stream-output-history window)) + (frame *application-frame*) + event + (modifier-state (window-modifier-state window)) + button) (find-innermost-presentation-match input-context top-record frame --- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/03/10 21:58:13 1.44 +++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/03/15 15:38:39 1.45 @@ -644,7 +644,10 @@ ;;; backends. (defclass standard-pointer (pointer) - ((port :reader port :initarg :port))) + ((port :reader port :initarg :port) + (state-lock :reader state-lock :initform (make-lock "pointer lock")) + (button-state :initform 0 ) + (modifier-state :initform 0))) (defgeneric pointer-sheet (pointer)) @@ -680,8 +683,37 @@ (with-accessors ((port-pointer-sheet port-pointer-sheet)) (port sheet) (when (eq port-pointer-sheet sheet) + (setq port-pointer-sheet nil)))) +(defmethod pointer-button-state ((pointer standard-pointer)) + (with-lock-held ((state-lock pointer)) + (slot-value pointer 'button-state))) + +(defmethod pointer-modifier-state ((pointer standard-pointer)) + (with-lock-held ((state-lock pointer)) + (slot-value pointer 'modifier-state))) + +(defmethod pointer-update-state + ((pointer standard-pointer) (event keyboard-event)) + (with-lock-held ((state-lock pointer)) + (setf (slot-value pointer 'modifier-state) (event-modifier-state event)))) + +(defmethod pointer-update-state + ((pointer standard-pointer) (event pointer-button-press-event)) + (with-lock-held ((state-lock pointer)) + (setf (slot-value pointer 'button-state) + (logior (slot-value pointer 'button-state) + (pointer-event-button event))))) + +(defmethod pointer-update-state + ((pointer standard-pointer) (event pointer-button-release-event)) + (with-lock-held ((state-lock pointer)) + (setf (slot-value pointer 'button-state) + (logandc2 (slot-value pointer 'button-state) + (pointer-event-button event))))) + +(defmethod pointer-butt) (defgeneric stream-pointer-position (stream &key pointer)) (defmethod stream-pointer-position ((stream standard-extended-input-stream) --- /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/10 21:58:13 1.113 +++ /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/15 15:38:39 1.114 @@ -89,6 +89,7 @@ (clim-defsystem (:clim-core :depends-on (:clim-lisp)) "decls" + "protocol-classes" #.(or #+(and :cmu :mp (not :pthread)) "Lisp-Dep/mp-cmu" @@ -213,6 +214,7 @@ "Examples/dragndrop" "Examples/gadget-test" "Examples/method-browser" + "Examples/dragndrop-translator" "Goatee/goatee-test" "Examples/accepting-values") --- /project/mcclim/cvsroot/mcclim/utils.lisp 2006/03/10 21:58:13 1.43 +++ /project/mcclim/cvsroot/mcclim/utils.lisp 2006/03/15 15:38:39 1.44 @@ -574,3 +574,18 @@ (intern (symbol-name obj) :keyword)) (string (intern (string-upcase obj) :keyword)))) + +;;; Command name utilities that are useful elsewhere. + +(defun command-name-from-symbol (symbol) + (let ((name (symbol-name symbol))) + (string-capitalize + (substitute + #\Space #\- + (subseq name (if (string= '#:com- name :end2 (min (length name) 4)) + 4 + 0)))))) + +(defun keyword-arg-name-from-symbol (symbol) + (let ((name (symbol-name symbol))) + (string-capitalize (substitute #\Space #\- name)))) From tmoore at common-lisp.net Wed Mar 15 22:56:54 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 15 Mar 2006 17:56:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060315225654.BDFC530006@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7770 Modified Files: README mcclim.asd package.lisp presentations.lisp stream-input.lisp system.lisp utils.lisp Log Message: Patches from dtc for Scieneer Common Lisp, and a few other fixes too. --- /project/mcclim/cvsroot/mcclim/README 2004/12/20 15:47:32 1.2 +++ /project/mcclim/cvsroot/mcclim/README 2006/03/15 22:56:54 1.3 @@ -2,7 +2,9 @@ This is McCLIM, an implementation of the "Common Lisp Interface Manager CLIM II Specification." It currently works on X Windows using -CLX. It works with CMUCL, SBCL, CLISP, OpenMCL, Allegro CL and LispWorks. +CLX. It works with CMUCL, SBCL, CLISP, OpenMCL, Allegro CL, LispWorks, +and the Scieneer CL. + The INSTALL files in this directory give instructions for each Lisp implementation. Release notes for each release of McCLIM are in the ReleaseNotes directory. @@ -22,7 +24,7 @@ address-book - the canonical CLIM application clim-fig - a drawing program -postscript-test - shows of the CLIM PostScript stream +postscript-test - shows off the CLIM PostScript stream gadget-test - fun with CLIM gadgets calculator - a gadget-based calculator goatee-test - Hacks with Goatee, the Emacs-like editor used in McCLIM --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/15 15:38:39 1.9 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/15 22:56:54 1.10 @@ -85,6 +85,7 @@ :depends-on ("patch") :components ((:file #+cmu "fix-cmu" + #+scl "fix-scl" #+excl "fix-acl" #+sbcl "fix-sbcl" #+openmcl "fix-openmcl" @@ -101,6 +102,7 @@ :components ((:file #.(or #+(and :cmu :mp (not :pthread)) "mp-cmu" + #+scl "mp-scl" #+sb-thread "mp-sbcl" #+excl "mp-acl" #+openmcl "mp-openmcl" @@ -289,7 +291,7 @@ :depends-on (:clim ;; If we're on an implementation that ships CLX, use ;; it. Same if the user has loaded CLX already. - #+(or sbcl openmcl ecl clx allegro) :clim-clx + #+(or sbcl scl openmcl ecl clx allegro) :clim-clx #+gl :clim-opengl ;; OpenMCL and MCL support the beagle backend (native ;; OS X look&feel on OS X). --- /project/mcclim/cvsroot/mcclim/package.lisp 2006/01/28 00:38:04 1.52 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2006/03/15 22:56:54 1.53 @@ -219,6 +219,7 @@ (gray-packages `(#+clisp ,@'(:gray) #+cmu ,@'(:ext) + #+scl ,@'(:ext) #+mcl ,@'(:ccl) #+allegro ,@'(:common-lisp :excl :stream) #+harlequin-common-lisp ,@'(:stream) --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/15 15:38:39 1.74 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/15 22:56:54 1.75 @@ -910,6 +910,7 @@ (defvar *standard-object-class* (find-class 'standard-object)) +#-scl (defmethod clim-mop:compute-applicable-methods-using-classes :around ((gf presentation-generic-function) classes) (multiple-value-bind (methods success) @@ -924,7 +925,24 @@ *standard-object-class*)) methods) t))))) - + +#+scl +(defmethod clim-mop:compute-applicable-methods-using-classes :around + ((gf presentation-generic-function) classes) + (multiple-value-bind (methods success non-class-positions) + (call-next-method) + (let ((ptype-class (car classes))) + (if (or (null success) + (not (typep ptype-class 'presentation-type-class))) + (values methods non-class-positions non-class-positions) + (values (remove-if #'(lambda (method) + (eq (car (clim-mop:method-specializers + method)) + *standard-object-class*)) + methods) + t + non-class-positions))))) + (defun method-applicable (method arguments) (loop for arg in arguments for specializer in (clim-mop:method-specializers method) --- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/03/15 15:38:39 1.45 +++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/03/15 22:56:54 1.46 @@ -117,6 +117,15 @@ else do (handle-event (event-sheet event) event)))) +(defmethod stream-clear-input ((pane standard-input-stream)) + (setf (stream-unread-chars pane) nil) + (loop for event = (event-read-no-hang pane) + if (null event) + return nil + else + do (handle-event (event-sheet event) event)) + nil) + ;;; XXX The should be moved to protocol-classes.lisp and the ;;; standard-sheet-input-mixin superclass should be removed. (define-protocol-class extended-input-stream (fundamental-character-input-stream ;Gray stream @@ -384,6 +393,18 @@ do (stream-read-gesture estream) ; consume pointer gesture finally (return (characterp char))))) +(defmethod stream-clear-input ((stream standard-extended-input-stream)) + (with-encapsulating-stream (estream stream) + (loop + with char and reason + do (setf (values char reason) (stream-read-gesture estream + :timeout 0 + :peek-p t)) + until (or (eq reason :eof) (eq reason :timeout)) + do (stream-read-gesture estream) ; consume pointer gesture + )) + nil) + ;;; stream-read-line returns a second value of t if terminated by eof. (defmethod stream-read-line ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) --- /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/15 15:38:39 1.114 +++ /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/15 22:56:54 1.115 @@ -80,6 +80,7 @@ ;; First possible patches "patch" #+cmu "Lisp-Dep/fix-cmu" + #+scl "Lisp-Dep/fix-scl" #+excl "Lisp-Dep/fix-acl" #+sbcl "Lisp-Dep/fix-sbcl" #+openmcl "Lisp-Dep/fix-openmcl" @@ -101,6 +102,7 @@ #+excl "Lisp-Dep/mp-acl" #+openmcl "Lisp-Dep/mp-openmcl" #+lispworks "Lisp-Dep/mp-lw" + #+scl "Lisp-Dep/mp-scl" #| fall back |# "Lisp-Dep/mp-nil") "utils" "defresource" --- /project/mcclim/cvsroot/mcclim/utils.lisp 2006/03/15 15:38:39 1.44 +++ /project/mcclim/cvsroot/mcclim/utils.lisp 2006/03/15 22:56:54 1.45 @@ -21,12 +21,12 @@ (defun get-environment-variable (string) #+excl (sys:getenv string) - #+cmu (cdr (assoc string ext:*environment-list* :test #'string=)) + #+(or cmu scl) (cdr (assoc string ext:*environment-list* :test #'string=)) #+clisp (ext:getenv (string string)) #+sbcl (sb-ext::posix-getenv string) #+openmcl (ccl::getenv string) #+lispworks (lw:environment-variable string) - #-(or excl cmu clisp sbcl openmcl lispworks) + #-(or excl cmu scl clisp sbcl openmcl lispworks) (error "GET-ENVIRONMENT-VARIABLE not implemented")) ;;; It would be nice to define this macro in terms of letf, but that From tmoore at common-lisp.net Wed Mar 15 22:56:55 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 15 Mar 2006 17:56:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20060315225655.37B3B3000E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv7770/Apps/Listener Modified Files: dev-commands.lisp file-types.lisp listener.lisp util.lisp Log Message: Patches from dtc for Scieneer Common Lisp, and a few other fixes too. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2005/12/06 16:21:58 1.32 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/03/15 22:56:54 1.33 @@ -672,7 +672,8 @@ #+clisp (clos:specializer-direct-generic-functions specializer) #+openmcl-partial-mop (openmcl-mop:specializer-direct-generic-functions specializer) - #-(or PCL SBCL clisp openmcl-partial-mop) + #+scl (clos:specializer-direct-generic-functions specializer) + #-(or PCL SBCL scl clisp openmcl-partial-mop) (error "Sorry, not supported in your CL implementation. See the function X-SPECIALIZER-DIRECT-GENERIC-FUNCTION if you are interested in fixing this.")) (defun class-funcs (class) @@ -941,10 +942,10 @@ "Return the number of internal symbols in PACKAGE." ;; We take only the first value, the symbol count, and discard the second, the ;; hash table capacity - #+cmu (values (lisp::internal-symbol-count package)) + #+(or cmu scl) (values (lisp::internal-symbol-count package)) #+sbcl (values (sb-int:package-internal-symbol-count package)) #+clisp (svref (sys::%record-ref *package* 1) 2) - #-(or cmu sbcl clisp) (portable-internal-symbol-count package)) + #-(or cmu scl sbcl clisp) (portable-internal-symbol-count package)) (defun portable-external-symbol-count (package) (let ((n 0)) @@ -955,10 +956,10 @@ (defun count-external-symbols (package) "Return the number of external symbols in PACKAGE." - #+cmu (values (lisp::external-symbol-count package)) + #+(or cmu scl) (values (lisp::external-symbol-count package)) #+sbcl (values (sb-int:package-external-symbol-count package)) #+clisp (svref (sys::%record-ref *package* 0) 2) - #-(or cmu sbcl clisp) (portable-external-symbol-count package)) + #-(or cmu scl sbcl clisp) (portable-external-symbol-count package)) (defun package-grapher (stream package inferior-fun) "Draw package hierarchy graphs for `Show Package Users' and `Show Used Packages'." --- /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2005/08/31 05:50:37 1.8 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2006/03/15 22:56:54 1.9 @@ -181,7 +181,8 @@ (:icon (standard-icon "design.xpm"))) (define-mime-type (application x-lisp-fasl) - (:extensions "x86f" "fasl" "ibin" "dfsl" "ufsl") ; MORE! + (:extensions "x86f" "amd64f" "sparcf" "sparc64f" "hpf" "hp64f" "lbytef" + "fasl" "ibin" "dfsl" "ufsl") ; MORE! (:icon (standard-icon "object.xpm"))) (define-mime-type (text x-shellscript) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2005/12/06 16:21:11 1.22 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/03/15 22:56:54 1.23 @@ -72,16 +72,18 @@ (declare (ignore frame)) (let* ((*standard-output* pane) (username (or #+cmu (cdr (assoc :user ext:*environment-list*)) + #+scl (cdr (assoc "USER" ext:*environment-list* + :test 'string=)) #+allegro (sys:getenv "USER") - #-(or allegro cmu) (getenv "USER") + #-(or allegro cmu scl) (getenv "USER") "luser")) ; sorry.. (sitename (machine-instance)) - (memusage #+cmu (lisp::dynamic-usage) + (memusage #+(or cmu scl) (lisp::dynamic-space-usage) #+sbcl (sb-kernel:dynamic-usage) #+lispworks (getf (system:room-values) :total-allocated) #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) #+clisp (values (sys::%room)) - #-(or cmu sbcl lispworks openmcl clisp) 0)) + #-(or cmu scl sbcl lispworks openmcl clisp) 0)) (with-text-family (T :serif) (formatting-table (T :x-spacing '(3 :character)) (formatting-row (T) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2005/10/13 14:32:13 1.19 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2006/03/15 22:56:54 1.20 @@ -63,6 +63,7 @@ (defun getenv (var) (or #+cmu (cdr (assoc var ext:*environment-list*)) + #+scl (cdr (assoc var ext:*environment-list* :test #'string=)) #+sbcl (sb-ext:posix-getenv var) #+lispworks (lw:environment-variable var) #+openmcl (ccl::getenv var) @@ -73,6 +74,7 @@ (defun change-directory (pathname) "Ensure that the current directory seen by RUN-PROGRAM has changed, and update *default-pathname-defaults*" #+CMU (unix:unix-chdir (namestring pathname)) + #+scl (unix:unix-chdir (ext:unix-namestring pathname)) #+clisp (ext:cd pathname) ; SBCL FIXME? (setf *default-pathname-defaults* pathname)) @@ -85,7 +87,7 @@ ;;; LIST-DIRECTORY is a wrapper for the CL DIRECTORY function, which really doesn't ;;; do what I'd like (resolves symbolic links, tends to be horribly buggy, etc.) -#+CMU +#+(or CMU scl) (defun list-directory (pathname) (directory pathname :truenamep nil)) @@ -143,7 +145,7 @@ (directory pathname :directories-are-files nil)) ;; Fallback to ANSI CL -#-(OR CMU SBCL OPENMCL ALLEGRO) +#-(OR CMU scl SBCL OPENMCL ALLEGRO) (defun list-directory (pathname) (directory pathname)) @@ -167,8 +169,8 @@ ;;; (see above) (defun run-program (program args &key (wait T) (output *standard-output*) (input *standard-input*)) - #+CMU (ext:run-program program args :input input - :output output :wait wait) + #+(or CMU scl) (ext:run-program program args :input input + :output output :wait wait) #+SBCL (sb-ext:run-program program args :input input :search T :output output :wait wait) @@ -179,7 +181,7 @@ :wait wait) #+clisp (ext:run-program program :arguments args :wait wait) - #-(or CMU SBCL lispworks clisp) + #-(or CMU scl SBCL lispworks clisp) (format T "~&Sorry, don't know how to run programs in your CL.~%")) ;;;; CLIM/UI utilities @@ -256,25 +258,23 @@ (defun gen-wild-pathname (pathname) "Build a pathname with appropriate :wild components for the directory listing." - (make-pathname :host (pathname-host pathname) - :device (pathname-device pathname) - :directory (pathname-directory pathname) - :name (or (pathname-name pathname) :wild) + (make-pathname :name (or (pathname-name pathname) :wild) :type (or (pathname-type pathname) :wild) :version (or #+allegro :unspecific :wild ;#-SBCL (pathname-version pathname) ;#+SBCL :newest - ))) + ) + #+scl :query #+scl nil + :defaults pathname)) (defun strip-filespec (pathname) "Removes name, type, and version components from a pathname." - (make-pathname :host (pathname-host pathname) - :device (pathname-device pathname) - :directory (pathname-directory pathname) - :name nil + (make-pathname :name nil :type nil - :version nil)) + :version nil + #+scl :query #+scl nil + :defaults pathname)) ;; Oops, should I be doing something with relative pathnames here? (defun parent-directory (pathname) @@ -282,12 +282,8 @@ (let ((dir (pathname-directory (truename (strip-filespec pathname))))) (when (and (eq (first dir) :absolute) (not (zerop (length (rest dir))))) - (make-pathname :host (pathname-host pathname) - :device (pathname-device pathname) - :directory `(:absolute ,@(nreverse (rest (reverse (rest dir))))) - :name (pathname-name pathname) - :type (pathname-type pathname) - :version (pathname-version pathname))))) + (make-pathname :directory `(:absolute ,@(nreverse (rest (reverse (rest dir))))) + :defaults pathname)))) ;;;; Abbreviating item formatter From tmoore at common-lisp.net Wed Mar 15 22:56:55 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 15 Mar 2006 17:56:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20060315225655.6B7F932013@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv7770/Backends/CLX Modified Files: port.lisp Log Message: Patches from dtc for Scieneer Common Lisp, and a few other fixes too. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/02/06 08:51:02 1.120 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/03/15 22:56:55 1.121 @@ -210,9 +210,11 @@ (defmethod print-object ((object clx-port) stream) (print-unreadable-object (object stream :identity t :type t) (when (slot-boundp object 'display) - (format stream "~S ~S ~S ~S" - :host (xlib:display-host (slot-value object 'display)) - :display-id (xlib:display-display (slot-value object 'display)))))) + (let ((display (slot-value object 'display))) + (when display + (format stream "~S ~S ~S ~S" + :host (xlib:display-host display) + :display-id (xlib:display-display display))))))) (defun clx-error-handler (display error-name &rest args &key major &allow-other-keys) (unless (and (eql major 42) ; 42 is SetInputFocus, we ignore match-errors from that From tmoore at common-lisp.net Wed Mar 15 22:56:55 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 15 Mar 2006 17:56:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20060315225655.A835933016@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv7770/Experimental/freetype Modified Files: freetype-ffi.lisp Log Message: Patches from dtc for Scieneer Common Lisp, and a few other fixes too. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-ffi.lisp 2005/08/22 09:28:34 1.3 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-ffi.lisp 2006/03/15 22:56:55 1.4 @@ -3,7 +3,7 @@ (DEFPACKAGE :FREETYPE (:USE :cl #+sbcl :sb-alien - #+cmucl :alien #+cmucl :c-call) + #+(or cmu scl) :alien #+(or cmu scl) :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" @@ -42,9 +42,20 @@ (in-package :freetype) -#+cmucl +#+cmu (alien:load-foreign "/usr/lib/libfreetype.so.6") +#+scl +(alien:load-dynamic-object #+64bit "/usr/lib64/libfreetype.so.6" + #-64bit "/usr/lib/libfreetype.so.6") + +#+(or scl cmu) +(defmacro define-alien-type (&rest rest) + `(def-alien-type , at rest)) +#+(or scl cmu) +(defmacro define-alien-routine (&rest rest) + `(def-alien-routine , at rest)) + #+sbcl (load-shared-object #+darwin "/usr/X11R6/lib/libfreetype.dylib" #-darwin "libfreetype.so") @@ -373,7 +384,7 @@ (freetype:driver freetype:module) (freetype:num-params freetype:int) (freetype:params (* freetype:parameter)))) (define-alien-routine ("FT_New_Face" freetype:new-face) freetype:error (freetype:library freetype:library) - (freetype::filepathname #+cmucl c-call:c-string #+sbcl c-string) (freetype::face_index freetype:long) (freetype::aface (* (* freetype:face-rec)))) + (freetype::filepathname #+(or cmu scl) c-call:c-string #+sbcl c-string) (freetype::face_index freetype:long) (freetype::aface (* (* freetype:face-rec)))) (define-alien-routine ("FT_New_Memory_Face" freetype:new-memory-face) freetype:error (freetype:library freetype:library) (freetype::file_base (* freetype:byte)) (freetype::file_size freetype:long) (freetype::face_index freetype:long) @@ -403,7 +414,7 @@ (define-alien-routine ("FT_Load_Char" freetype:load-char) freetype:error (freetype:face freetype:face) (freetype::char_code freetype:ulong) (freetype::load_flags freetype:int)) -(define-alien-routine ("FT_Set_Transform" freetype:set-transform) #+cmucl c-call:void #+sbcl void (freetype:face freetype:face) +(define-alien-routine ("FT_Set_Transform" freetype:set-transform) #+(or cmu scl) c-call:void #+sbcl void (freetype:face freetype:face) (freetype:matrix (* freetype:matrix)) (freetype:delta (* freetype:vector))) (define-alien-type freetype:render-mode (enum freetype::render-mode- (:ft-render-mode-normal #.#o0) (:ft-render-mode-mono #.1))) @@ -437,7 +448,7 @@ (define-alien-routine ("FT_FloorFix" freetype:floor-fix) freetype:fixed (freetype::a freetype:fixed)) -(define-alien-routine ("FT_Vector_Transform" freetype:vector-transform) #+cmucl c-call:void #+sbcl void (freetype::vec (* freetype:vector)) +(define-alien-routine ("FT_Vector_Transform" freetype:vector-transform) #+(or cmu scl) c-call:void #+sbcl void (freetype::vec (* freetype:vector)) (freetype:matrix (* freetype:matrix))) (define-alien-type freetype:encoding From tmoore at common-lisp.net Wed Mar 15 22:56:55 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 15 Mar 2006 17:56:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Lisp-Dep Message-ID: <20060315225655.DBE0C38009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv7770/Lisp-Dep Added Files: fix-scl.lisp mp-scl.lisp Log Message: Patches from dtc for Scieneer Common Lisp, and a few other fixes too. --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/fix-scl.lisp 2006/03/15 22:56:55 NONE +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/fix-scl.lisp 2006/03/15 22:56:55 1.1 ;;;; Support for the Scieneer Common Lisp. ;;;; Gray streams can be defined as subclass of the native stream classes. (in-package :ext) (export '(fundamental-stream fundamental-input-stream fundamental-output-stream fundamental-character-stream fundamental-binary-stream fundamental-character-input-stream fundamental-character-output-stream fundamental-binary-input-stream fundamental-binary-output-stream stream-read-line stream-start-line-p stream-write-string stream-terpri stream-fresh-line stream-advance-to-column ) :ext) (defclass fundamental-stream (stream) () (:documentation "Base class for all CLOS streams")) ;;; Define the stream classes. (defclass fundamental-input-stream (fundamental-stream ext:input-stream) ()) (defclass fundamental-output-stream (fundamental-stream ext:output-stream) ()) (defclass fundamental-character-stream (fundamental-stream ext:character-stream) ()) (defclass fundamental-binary-stream (fundamental-stream ext:binary-stream) ()) (defclass fundamental-character-input-stream (fundamental-input-stream fundamental-character-stream ext:character-input-stream) ()) (defclass fundamental-character-output-stream (fundamental-output-stream fundamental-character-stream ext:character-output-stream) ()) (defclass fundamental-binary-input-stream (fundamental-input-stream fundamental-binary-stream ext:binary-input-stream) ()) (defclass fundamental-binary-output-stream (fundamental-output-stream fundamental-binary-stream ext:binary-output-stream) ()) (defgeneric stream-read-line (stream) (:documentation "Used by 'read-line. A string is returned as the first value. The second value is true if the string was terminated by end-of-file instead of the end of a line. The default method uses repeated calls to 'stream-read-char.")) (defmethod stream-read-line ((stream fundamental-character-input-stream)) (let ((res (make-string 80)) (len 80) (index 0)) (loop (let ((ch (stream-read-char stream))) (cond ((eq ch :eof) (return (values (cl::shrink-vector res index) t))) (t (when (char= ch #\newline) (return (values (cl::shrink-vector res index) nil))) (when (= index len) (setq len (* len 2)) (let ((new (make-string len))) (replace new res) (setq res new))) (setf (schar res index) ch) (incf index))))))) (defgeneric stream-start-line-p (stream)) (defmethod stream-start-line-p ((stream fundamental-character-output-stream)) (eql (stream-line-column stream) 0)) (defgeneric stream-terpri (stream) (:documentation "Writes an end of line, as for TERPRI. Returns NIL. The default method does (STREAM-WRITE-CHAR stream #\NEWLINE).")) (defmethod stream-terpri ((stream fundamental-character-output-stream)) (stream-write-char stream #\Newline)) (defgeneric stream-fresh-line (stream) (:documentation "Outputs a new line to the Stream if it is not positioned at the begining of a line. Returns 't if it output a new line, nil otherwise. Used by 'fresh-line. The default method uses 'stream-start-line-p and 'stream-terpri.")) (defmethod stream-fresh-line ((stream fundamental-character-output-stream)) (unless (stream-start-line-p stream) (stream-terpri stream) t)) (defgeneric stream-advance-to-column (stream column) (:documentation "Writes enough blank space so that the next character will be written at the specified column. Returns true if the operation is successful, or NIL if it is not supported for this stream. This is intended for use by by PPRINT and FORMAT ~T. The default method uses STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL.")) (defmethod stream-advance-to-column ((stream fundamental-character-output-stream) column) (let ((current-column (stream-line-column stream))) (when current-column (let ((fill (- column current-column))) (dotimes (i fill) (stream-write-char stream #\Space))) t))) (defpackage :clim-mop (:use :common-lisp :clos)) (eval-when (:compile-toplevel :load-toplevel :execute) (loop for sym being the symbols of :clim-mop do (export sym :clim-mop))) (in-package :clim-mop) (eval-when (:compile-toplevel :load-toplevel :execute) (export '(clim-lisp-patch::defconstant clim-lisp-patch::defclass) :clim-lisp-patch)) (defmacro clim-lisp-patch:defconstant (symbol value &optional docu) `(defvar ,symbol ,value ,@(and docu (list docu)))) (defvar clim-lisp-patch::*compile-time-clos-names* (make-hash-table)) (defun clim-lisp-patch::compile-time-clos-class-p (name) (gethash name clim-lisp-patch::*compile-time-clos-names* nil)) (defmacro clim-lisp-patch:defclass (name &rest args) `(progn (eval-when (:compile-toplevel) (setf (gethash ',name clim-lisp-patch::*compile-time-clos-names*) t)) (eval-when (:compile-toplevel :load-toplevel :execute) (cl:defclass ,name , at args)))) --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-scl.lisp 2006/03/15 22:56:55 NONE +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-scl.lisp 2006/03/15 22:56:55 1.1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: clim-internals; -*- ;;; --------------------------------------------------------------------------- ;;; Title: CLIM-2, Chapter 32.2 Multi-processing ;;; for the Scieneer Common Lisp ;;; Created: 2006-03-12 ;;; Author: Scieneer Pty Ltd ;;; Based on mp-acl, created 2001-05-22 by Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2006 by Scieneer Pty Ltd ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defconstant *multiprocessing-p* t) (eval-when (:load-toplevel :compile-toplevel :execute) (pushnew :clim-mp *features*)) (defun make-process (function &key name) (mp:make-process function :name name)) (defun restart-process (process) (mp:restart-process process)) (defun destroy-process (process) (mp:destroy-process process)) (defun current-process () (mp:current-process)) (defun all-processes () (mp:all-processes)) (defun processp (object) (mp:processp object)) (defun process-name (process) (mp:process-name process)) (defun process-state (process) (mp:process-state process)) (defun process-whostate (process) (mp:process-whostate process)) (defun process-wait (reason predicate) (mp:process-wait reason predicate)) (defun process-wait-with-timeout (reason timeout predicate) (mp:process-wait-with-timeout reason timeout predicate)) (defun process-yield () (mp:process-yield)) (defun process-interrupt (process function) (mp:process-interrupt process function)) (defun disable-process (process) (mp:disable-process process)) (defun enable-process (process) (mp:enable-process process)) (defmacro without-scheduling (&body body) `(mp:without-scheduling , at body)) (defmacro atomic-incf (place) `(mp:atomic-incf ,place)) (defmacro atomic-decf (place) `(mp:atomic-decf ,place)) ;;; 32.3 Locks (defun make-lock (&optional name) (mp:make-lock name :type :error-check)) (defmacro with-lock-held ((place &optional state) &body body) `(mp:with-lock-held (,place (or ,state "Lock Wait")) , at body)) (defun make-recursive-lock (&optional name) (mp:make-lock name :type :recursive)) (defmacro with-recursive-lock-held ((place &optional state) &body body) `(mp:with-lock-held (,place (or ,state "Lock Wait")) , at body)) (defun make-condition-variable () (thread:make-cond-var)) (defun condition-wait (condition-variable lock &optional timeout) (cond (timeout (thread:cond-var-timedwait condition-variable lock timeout)) (t (thread:cond-var-wait condition-variable lock) t))) (defun condition-notify (condition-variable) (thread:cond-var-broadcast condition-variable)) From rgoldman at common-lisp.net Thu Mar 16 15:49:33 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Thu, 16 Mar 2006 10:49:33 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc/Guided-Tour Message-ID: <20060316154933.E275A52002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour In directory clnet:/tmp/cvs-serv5466 Modified Files: guided-tour.bib Log Message: Fixes to the BibTeX database entries for citations referenced. --- /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/guided-tour.bib 2006/01/30 16:14:01 1.1 +++ /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/guided-tour.bib 2006/03/16 15:49:33 1.2 @@ -13,15 +13,22 @@ } @misc { composing-uis, - author = "M. Linton, J. Vlissides, P. Calder", + author = "M. Linton and J. Vlissides and P. Calder", title = "Composing user interfaces with interviews", publisher = "IEEE Computer, 22(2):8-22, Feb 1989" } - at misc { presentation-manager, - author = "Scott McKay, William York, Michael McMahon", - title = "A presentation manager based on application semantics", - published = "In Proceedings of the ACM SIG-GRAPH Symposium on User Interface Software and Technology, pages 141-148. ACM Press, Nov 1989" } + at InProceedings{presentation-manager, + author = {Scott McKay and William York and Michael McMahon}, + title = {A presentation manager based on application + semantics}, + booktitle = {Proceedings of the ACM SIG-GRAPH Symposium on User + Interface Software and Technology}, + pages = {141--148}, + year = 1989, + month = nov, + publisher = {ACM Press} +} @misc { ms-sdk, author = "Microsoft Corporation, Redmond, WA", @@ -38,7 +45,7 @@ @misc { clos-window-system, author = "Rob Pettengill", -title = "The deli window system, A portable, clos based network window system interface", +title = "The deli window system, A portable, {CLOS} based network window system interface", published = "In Proceedings of the First CLOS Users and Implementors Workshop, pages 121??? 124, Oct 1988" } @@ -58,14 +65,14 @@ @comment { 10^^^ 11\/ } @misc { clim-spec, - author = "Scott McKay, Wiliam York", + author = "Scott McKay and Wiliam York", year = 2005, title = "Common lisp interface manager specification", published = "In Preparation" } @misc { x-window-system, -author = "R.W. Scheifler, J. Gettys", +author = "R.W. Scheifler and J. Gettys", title = "The x window system. ACM Transactions on Graphics, 5(2)", year = 1986 } @@ -85,19 +92,21 @@ } @comment { 15^^^ 16\/ } - at misc { prog-ref-manual, -author = "Symbolics, Inc", -title = "Programmer's Reference Manual Vol 7: Programming the User Interface." + + at Manual{prog-ref-manual, + title = {Programmer's Reference Manual Vol 7: Programming the + User Interface}, + organization = {Symbolics, Inc.} } @book { oop-in-cl, - title = "Object-Oriented Programmin in Common Lisp", - author = "Sonja E. Kenne", + title = "Object-Oriented Programming in Common Lisp", + author = "Sonja E. Keene", year = "1988", isbn = "0-201-17589-4" } @misc { mcclim, author = "McCLIM", - title = "A free CLIM implementation", + title = "A free {CLIM} implementation", url = "http://common-lisp.net/project/mcclim/" } From rgoldman at common-lisp.net Thu Mar 16 15:50:20 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Thu, 16 Mar 2006 10:50:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc/Guided-Tour Message-ID: <20060316155020.552F0550D2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour In directory clnet:/tmp/cvs-serv5590 Modified Files: guided-tour.tex Log Message: Minor grammar patches and some suggestions (in comments only). --- /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/guided-tour.tex 2006/02/09 13:20:38 1.2 +++ /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/guided-tour.tex 2006/03/16 15:50:20 1.3 @@ -89,10 +89,10 @@ The Common Lisp Interface Manager addresses this problem by specifying an interface to a broad range of services necessary or useful for developing graphical user interfaces. These services include low level -facilities like geometry, graphics, event-oriented input, and -windowing; intermediate level facilities like support for Common Lisp +facilities such as geometry, graphics, event-oriented input, and +windowing; intermediate level facilities such as support for Common Lisp stream operations, output recording, and advanced output formatting; -and high level facilities like context sensitive input, an adaptive +and high level facilities such as context sensitive input, an adaptive toolkit, and an application building framework. \CLIM{} implementations will eventually support a large number of window environments @@ -101,10 +101,10 @@ to the degree that it makes sense. For example, \CLIM{} top level windows are typically mapped onto host windows, and input and output operations are ultimately performed by host window system -code. Another example is that \CLIM{} supports the incorporation of +code. \CLIM{} supports the incorporation of toolkits written in other languages. A uniform interface provided by \CLIM{} allows Lisp application programmers to deal only with Lisp -objects and functions regardless of their operating platform. +objects and functions regardless of the operating platform. An important goal that has guided the design of \CLIM{} was to layer the specification into a number of distinct @@ -127,10 +127,10 @@ For example, \CLIM{}'s application framework and adaptive toolkit allow programmers to develop applications that automatically adopt the look -and feel of the host's environment. (We often call this +and feel of the host's environment. We often call this ``adaptiveness,'' ``look and feel independence,'' or occasionally more -picturesquely, ``chameleon look and feel''.) However, many users may -need or want to define a particular look and feel that stays constant +picturesquely, ``chameleon look and feel''. However, many users may +need or want to define a particular look and feel that is constant across all host environments (we call this ``portable look and feel''). Such users can circumvent the look and feel adaptiveness provided by \CLIM{}, while still using most of the application @@ -168,7 +168,7 @@ \caption{An Overview of \CLIM{} facilities}\label{clim-facilities} \end{figure*} -\paragraph*{Graphic substrate} \CLIM{} provides a portable interface +\paragraph*{Graphics substrate} \CLIM{} provides a portable interface to a broad set of graphics functions for drawing complex geometric shapes. @@ -177,7 +177,9 @@ \paragraph*{Extended Streams} \CLIM{} integrates the Common Lisp Stream I/O functionality with the \CLIM{} graphics, windowing, and -panes facilities. Next to ordinary text, the programmer can send a +panes facilities. +% I believe that this was what was intended [2006/03/14:rpg] +In addition to ordinary text, the programmer can send a button, a picture or any other arbitrary widget to a \CLIM{} output stream and \CLIM{} will display the widget in the sheet associated with the output stream. @@ -189,14 +191,19 @@ \paragraph*{Formatted Output} \CLIM{} provides a set of high-level macros that enable programs to produce neatly formatted tabular and graphical displays easily.\footnote{This also includes Graph - Formatting.} + Formatting. Graph formatting is only partly implemented in McCLIM + at this date (March 2006).} \paragraph*{Presentations} \CLIM{} provides the ability to associate semantics with output, such that Lisp objects may be retrieved later via user gestures (e.g.{} mouse clicks) on their displayed representation. This context sensitive input is modularly layered on top of the output recording facility and is integrated with the Common -Lisp type system. A mechanism for type coercion is also included, +Lisp type system. +% I understand this, but I suspect it's not going to be obvious to the +% ordinary reader why type coercion provides the basis for a user +% interface... [2006/03/14:rpg] +A mechanism for type coercion is also included, providing the basis for powerful user interfaces. \paragraph*{Panes} \CLIM{} provides \concept{panes} that are analogous @@ -212,9 +219,9 @@ independence by specifying a set of abstract gadget pane protocols. These protocols define a gadget in terms of its function and not in terms of the details of its appearance or -operation. Application that use these gadget types and related +operation. Applications that use these gadget types and related facilities will automatically adapt to use whatever toolkit is -available and appropriate for the host environment. In addition, +available on and appropriate for the host environment. In addition, portable Lisp-based implementations of the abstract gadget pane protocols are provided.\footnote{\mcclim{} does not support look and feel adaptiveness at the moment except for the experimental beagle backend for Mac @@ -234,7 +241,9 @@ presentation. Commands can also be invoked explicitly by the programmer. -\paragraph*{Dialogs and Incremental Update} Incremental Redisplay goes +% added ``Redisplay'' below so that the paragraph header harmonizes +% with the jargon used in the paragraph. +\paragraph*{Dialogs and Incremental Update/Redisplay} Incremental Redisplay goes a bit further than Output Recording. With Incremental Redisplay, an output record can not only reproduce content that was written to a stream, the \CLIM{} programmer can also attach the code that generated @@ -253,10 +262,10 @@ \section{Our first application} -We will spend a few lines of code for the trivial Hello World example +We will start with a few lines of code for the trivial Hello World example to give the reader a test case to verify his \CLIM{} setup. It also serves as a point of reference from where the reader can start his -explorations for more challenging \CLIM{} facilities. We do not try to +explorations of more challenging \CLIM{} facilities. We do not try to elaborate the \CLIM{} concepts in detail here, but simply use them with a brief discussion. The confused reader may hope for a more in-depth explanation in the following section. Please regard @@ -264,27 +273,27 @@ \concept{sheet hierarchy}, \concept{graft} and \concept{top-level loop} as terms we will discuss later. -Also, we conduct excessive \CLIM{} specification referencing in +We provide extensive \CLIM{} specification references in footnotes. The motivation for this is to show that all the relevant information can be found in the \CLIM{} 2 specification\cite{clim-spec}. Before a good \CLIM{} programmer can master any \CLIM{} concept, he has to get used to the style of writing -of the specification first as this is the most relevant work for -\CLIM{}. The best we can do in this context is to provide pointers and +of the specification, as this is the most relevant work for +\CLIM{}. The best we can do in this short paper is provide pointers and references and hope that the interested reader starts to explore the surrounding text sections on his own. After loading a \CLIM{} implementation, the package \keyword{:clim-user} is available to absorb user code. This package is -a good start for experimentations and first steps. When proper +a good start for experimentation and first steps. When proper packaging is required, simply include the packages \keyword{:clim} and -\keyword{:clim-lisp} in your \keyword{:use} list. +\keyword{:clim-lisp} in your new package's \keyword{:use} list. The central element of \CLIM{} application programming is the \concept{application-frame}. An application frame is defined via \code{define-application-frame}.\footnote{See Section 28.2 ``Defining - and Creating Application Frames'' in \cite{clim-spec}.} Here comes -the application frame for Hello World: + and Creating Application Frames'' in \cite{clim-spec}.} Here is +the application frame definition for Hello World: \lstset{style=inlinestyle} \lstinputlisting{hello-world-def-app} @@ -293,17 +302,18 @@ \lstinputlisting{hello-world-handle-repaint} \caption{\method{handle-repaint} for \class{hello-world-pane}}\label{hello-world-repaint} \end{figure*} -Its basic syntax is similar to \code{defclass} because +\code{define-application-frame}'s basic syntax is similar to \code{defclass} because \code{define-application-frame} also generates classes. In this case, it creates a frame class \class{hello-world} that has no superclass -except \class{frame} which is added automatically. +except \class{frame} (which is added automatically). With \code{:pane}, we define a \concept{top-level-pane} that becomes -the content of the fresh window that belongs to an application -frame. But sometimes, an application frame is swallowed by another -application and only space in an other existing window is +the content of a fresh window that belongs to an application +frame. Although the usual case is for an application frame to +correspond to a top level window, sometimes an application frame is swallowed by another +application and only space in another existing window is reserved. For instance, a web site management tool might swallow a -text editor, so the user has the option to edit web sites without +text editor, so that the user has the option to edit web sites without switching to another application. % \footnote{The graft is the root of a sheet hierarchy and on most @@ -320,20 +330,20 @@ created. We use \method{make-pane} to construct a pane as the top-level-pane for frame instances. \method{make-pane} is a constructor for panes.\footnote{See Section 29.2 ``Basic Pane - Construction'' in \cite{clim-spec}.} We can treat it as + Construction'' in \cite{clim-spec}.} We can treat it as an analog to \code{make-instance} especially made for pane classes. Let us have a look at the definition of \class{hello-world-pane}. \lstset{style=inlinestyle} \lstinputlisting{hello-world-defclass} The one and only superclass of \class{hello-world-pane} is -\class{clim-stream-pane}\footnote{See Section 29.4 ``CLIM Stream - Panes'' in \cite{clim-spec}.}. As there are no additional slots, an -experienced \CLOS{} user might guess that we will use +\class{clim-stream-pane}.\footnote{See Section 29.4 ``CLIM Stream + Panes'' in \cite{clim-spec}.} As there are no additional slots, an +experienced \CLOS{} programmer might guess that we will use \class{hello-world-pane} solely for method specialization. Before doing so, let us have a look what we have actually -inherited from \class{clim-stream-pane}\footnote{Internal classes - removed from listing.}: +inherited from \class{clim-stream-pane}:\footnote{Internal classes + removed from listing.} \lstset{style=inlinestyle} \begin{lstlisting} @@ -349,6 +359,10 @@ BASIC-PANE \end{lstlisting} +% would it be appropriate to define the phrase ``protocol class'' +% here? I'm not sufficiently confident in my CLIM fu to provide a +% definition myself. [2006/03/14:rpg] + \class{basic-pane} is the foundation of all pane classes. It provides reasonable defaults for all protocol methods and inherits from the protocol class \class{pane}. In turn, \class{pane} inherits from @@ -399,6 +413,13 @@ \subsection{Geometry} +% The footnote describing ``protocol'' below seems to give a critical +% insight into the style and functioning of CLIM. It should certainly +% be promoted out of footnote and into body text. I'm inclined to +% think it should be promoted to the introduction. The notion of +% Protocol is alluded to there, but not clearly described. +% [2006/03/14:rpg] + To \CLIM{}, geometry means \concept{regions}. A region is either bound or unbound and has a dimensionality of either zero, one or two. That corresponds to a point, a path or an area respectively. Regions can be @@ -421,10 +442,15 @@ transformation is affine when every straight line remains straight after transformation. Transformations can be composed arbitrarily. The programmer can attach transformations to mediums and panes. In layout -panes, \CLIM{} uses transformation to map the coordinates of children -panes to the coordinate system of its parents. All drawing settings -can be changed permanently, or in the context of a -\macro{with-drawing-options} macro temporarily. +panes, \CLIM{} uses transformations to map the coordinates of child +panes to the coordinate system of their parents. + +% This was attached to the previous paragraph, but doesn't seem to +% have anything to do with its topic. I'm inclined to think that this +% could use some further expansions (have we adequately explained what +% a drawing setting is?) [2006/03/14:rpg] +All drawing settings can be changed either permanently, or temporarily +in the context of the \macro{with-drawing-options} macro. \subsection{The Windowing Substrate} @@ -519,7 +545,7 @@ specialization, so the application developer can implement special policies for selected events. For instance, when a sheet notices through a \code{window-configuration-event} that the sheet's size -changed, it might redo its layout for its children panes. +has changed, it might redo its layout for its children. % There are two mixins that specialize on the % \code{window-repaint-event} class as event argument to @@ -561,6 +587,12 @@ % the sheet's medium. According to the \mcclim{} authors, this is done % for optimization.} +% in the topic sentence here, should it read ``of sheets'' or ``of +% mediums'' (media?). I'm not sure, but if ``sheets'' is meant, we +% should probably have some transition wording here to explain how we +% got from discussing mediums above to discussing sheets here. +% [2006/03/14:rpg] + The graphic output capabilities of sheets range from simple line style and text style customization over rendering various geometrical shapes, a color model capable of doing alpha blending, composable @@ -569,9 +601,9 @@ specified briefly in Section 8.3 ``Output Protocol''and more precisely in Chapters 10-14 of \cite{clim-spec}. -\CLIM{} lives in idealized world in terms of graphics operations. A +\CLIM{} lives in an idealized world in terms of graphics operations. A \CLIM{} programmer can use an infinitely long and wide drawing pane -with an arbitrarily precise resolution and continuously variable +with arbitrarily precise resolution and continuously variable opacity. As rendering devices with these properties are rare, we need to render the idealized graphic description to a device with finite size and a fixed drawing precision. The rendering rules @@ -602,7 +634,7 @@ system window hierarchy) when the frame is adopted. To build a user interface, an application programmer defines one or -more frames classes. These frame classes define a number of frame +more frame classes. These frame classes define a number of frame properties including application specific state and a hierarchy of panes (i.e.{} user interface gadgets and regions, for interacting with the users). Frame classes also provide hooks for customizing @@ -615,7 +647,7 @@ up is usually quite different from the code that is used to generate the content of application frames. This is unusual for a windowing toolkit as most of them unify the generation of dialog content and -content of other windows types. +content of other window types. \CLIM{} generates a dialog with the appropriate input gadget as consequence of a series of input requests. Thanks to the stream @@ -624,11 +656,19 @@ asynchronously handling confirmation or cancel button clicks. For instance, the programmer requests a string from the user and the user is presented with a prompt, an editable text field, and two buttons -for confirmation and canceling. Only after the user hits the -confirmation button, the string requesting function returns; the +for confirmation and canceling. +The string requesting function returns only after the user hits the +confirmation button. The programmer can directly use the function's return value which is the -string provided by the user. Clicking the cancel button is dealt with by throwing to an -\code{abort} tag. +string provided by the user. +% Is the following rewrite correct? Seems like in the actual code an +% abort-gesture is signaled, but it is handled by invoking an abort, +% if no abort-gesture handler is found. [2006/03/14:rpg] +% OLD: +% Clicking the cancel button is dealt with by throwing to an +% \code{abort} tag. +Clicking the cancel button is dealt with by signaling an abort-gesture +condition. From the caller's perspective, an attempt to separate application frames and dialogs could be: a dialog window itself is side-effect @@ -719,9 +759,11 @@ Panes and sheets as defined by the windowing substrate have in common that they are associated with a region on screen, a parent, and optional children. They differ in their usage of the input and output -capabilities. A sheet is passive and intended for others to be used, -while a pane already contains this active part. This relationship -leads that panes are implemented as subclasses of \class{basic-sheet} +capabilities. A sheet is passive and intended to be used by other, +active components, +while a pane already contains this active part. +For this reason, +panes are implemented as subclasses of \class{basic-sheet} augmenting the class with an active part. For instance, a button-pane actively draws its own button representation on its allotted screen area and a click on the correct button area triggers a callback for @@ -745,15 +787,16 @@ in the case where the programmer needs a lot of buttons with related behavior, creating a subclass for changing a single specific callback is not economical. Hence upon gadget creation, the programmer can -specify an alternative callback method for all callbacks available. By +specify an alternative callback method for any callback available. For +example, by providing the \keyword{:activate-callback} initarg, the programmer can change the callback to any regular or generic function. By convention, -all callbacks can be changed by providing an initarg keyword equal to +any callback can be changed by providing an initarg keyword equal to the callback's name. See Chapter 30 in \cite{clim-spec} for a listing and description of available callbacks. \CLIM{} also provides composite and layout panes. These pane types are -used for aggregating several children panes into a bigger single pane +used for aggregating several child panes into a bigger single pane that has a layout according to the requested directives. For example, \CLIM{} provides two pane classes, \class{hbox-pane} and \class{vbox-pane}, that lay out their children in horizontal rows or @@ -764,11 +807,11 @@ management via the windowing protocol. He is provided with a set of convenience macros that allows elegant interfaces composed simply by wrapping the respective pane construction code into the convenience -macros. +macros. % could we name the convenience macros here? [2006/03/14:rpg] Application pane classes can be used for subclassing. They can be used to present application specific data -- for instance by specializing -\method{handle-repaint} -- and manage user interactions -- for +\method{handle-repaint} -- and to manage user interactions -- for instance by specializing \method{handle-event}. \subsection{Commands} @@ -784,7 +827,7 @@ choose to export as an explicit user entry point. A command is defined to have a name and a set of zero or more operands, or arguments. These commands can then be invoked using a variety of interaction -techniques. For example, commands can be invoked from menu, keyboard +techniques. For example, commands can be invoked from menus, keyboard accelerators, direct typein, mouse clicks on application data, or gadgets. From cfruhwirth at common-lisp.net Fri Mar 17 07:12:53 2006 From: cfruhwirth at common-lisp.net (cfruhwirth) Date: Fri, 17 Mar 2006 02:12:53 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Scigraph/scigraph Message-ID: <20060317071253.18B5C5E0CA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph In directory clnet:/tmp/cvs-serv2101 Modified Files: axis.lisp basic-graph.lisp draw.lisp graph-data.lisp mouse.lisp package.lisp present.lisp random.lisp scigraph-system.lisp Log Message: Build fixes for scigraph and sbcl/cmucl. Consisting mostly of: * Replacing (ignore x) with (declare (ignore x)). * Hide custom declarations in defmethod from sbcl/cmu that both choke on these. * Change defconstant on cons into a defvar, for recompilation sake. * Unwrap defpackage from eval-when. * Change the memoize macro to use load-time-value to generate a hash-table. --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/axis.lisp 2003/10/31 11:35:37 1.1 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/axis.lisp 2006/03/17 07:12:52 1.2 @@ -158,8 +158,8 @@ (macrolet ((push-digits (number length string) `(dotimes (.i. ,length) - (ignore .i.) - (vector-push-extend (digit-char (values (floor ,number))) ,string extension) + (declare (ignore .i.)) + (vector-push-extend (digit-char (values (floor ,number))) ,string extension) (setf ,number (mod (* 10.0 ,number) 10.0))))) (push-digits number ilength string) ; Integer part. (setq flength (- max-digits ilength)) ; Fractional part. --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/basic-graph.lisp 2004/08/06 13:19:40 1.2 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/basic-graph.lisp 2006/03/17 07:12:52 1.3 @@ -557,6 +557,7 @@ (defmethod graph-with-clipping ((self basic-graph) STREAM inside-p continuation) ;; Internal to WITH-CLIPPING-TO-GRAPH macro. + #-(or sbcl cmu) (declare (downward-funarg continuation)) (multiple-value-bind (le re be te) (if inside-p (screen-inside self STREAM) (screen-outside self STREAM)) --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/draw.lisp 2004/08/06 13:19:40 1.2 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/draw.lisp 2006/03/17 07:12:52 1.3 @@ -320,7 +320,7 @@ (defconstant *DASH-PATTERN-SIZE* 64 "Length of dashed pattern in pixels.") (defconstant *DASH-STEP-SIZE* (/ *dash-pattern-size* 8)) -(defconstant *DASH-PATTERNS* +(defvar *DASH-PATTERNS* #2A((8 7 6 5 4 3 2 1) (7 6 5 4 3 2 1 -1) (5 4 3 2 1 -1 1 -1) @@ -331,7 +331,7 @@ (1 -1 1 -1 1 -1 1 -1)) "Dashed line patterns. -1 -> lift pen.") -(defconstant *dash-pattern-alist* +(defvar *dash-pattern-alist* '(("----------------" :value 0) ("------- ------- " :value 1) ("----- - ----- - " :value 2) --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/graph-data.lisp 2003/10/31 11:35:38 1.1 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/graph-data.lisp 2006/03/17 07:12:52 1.2 @@ -94,11 +94,13 @@ (defmethod map-data ((dataset t) function (data sequence)) "Map FUNCTION over each datum." + #-(or sbcl cmu) (declare (downward-funarg function)) (map nil function data)) (defmethod map-data-xy ((dataset ESSENTIAL-GRAPH-DATA-MAP-MIXIN) function data) "Map function over each x y pair." + #-(or sbcl cmu) (declare (downward-funarg function)) (declare (compiled-function function)) (map-data dataset @@ -649,7 +651,7 @@ (last-in nil) (last-u NIL) (last-v NIL)) - (declare (fixnum last-u last-v thickness)) + (declare (fixnum thickness)) (if (< bottom top) (psetq top bottom bottom top)) (if (zerop line-style) (let ((displayer (compute-line-displayer self))) @@ -1115,7 +1117,7 @@ (unless *repainting-dataset* (with-new-output-record (stream 'dataset-record-element record :dataset dataset :graph graph) - (ignore record) + (declare (ignore record)) :done))) (defclass presentable-mixin --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/mouse.lisp 2005/01/11 12:45:35 1.6 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/mouse.lisp 2006/03/17 07:12:52 1.7 @@ -90,8 +90,7 @@ ;; In 0.9, we can take advantage of one of the BBN clim extensions. (notify-user frame string))) (:clim-1.0 - (progn - (ignore stream) + (locally (declare (ignore stream)) (let ((stream clim::*pointer-documentation-output*) #+genera (documentation-window (clim::mouse-documentation-window stream))) #+genera @@ -102,16 +101,14 @@ (window-clear stream) (format stream string))))) ((and :clim-2 (not :mcclim)) - (progn - (ignore stream) + (locally (declare (ignore stream)) (clim:frame-manager-display-pointer-documentation-string (frame-manager *application-frame*) *application-frame* clim:*pointer-documentation-output* string))) (:mcclim - (progn - (ignore stream) + (locally (declare (ignore stream)) (clim-extensions:frame-display-pointer-documentation-string *application-frame* clim:*pointer-documentation-output* string))) ((not :clim) nil))) --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/package.lisp 2004/12/28 11:45:30 1.3 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/package.lisp 2006/03/17 07:12:52 1.4 @@ -27,22 +27,25 @@ (in-package #-ansi-cl :user #+ansi-cl :common-lisp-user) -(eval-when (compile load eval) - (defpackage TOOL - #+MCL (:shadow copy) - (:use dwim-lisp))) - -(eval-when (compile load eval) - (defpackage STATISTICS - (:nicknames stat st) - (:use dwim-lisp))) - -(eval-when (compile load eval) - (defpackage GRAPH - #-allegro (:nicknames gr) ; "GR" names something already. - (:shadow variable) ; shouldn't be inherited but is - #+MCL (:shadow copy) - (:use dwim-lisp tool statistics))) +(defpackage TOOL + #+MCL (:shadow copy) + (:use dwim-lisp)) + +(defpackage STATISTICS + (:nicknames stat st) + (:use dwim-lisp)) + +(defpackage GRAPH + #-allegro (:nicknames gr) ; "GR" names something already. + (:shadow variable) ; shouldn't be inherited but is + #+MCL (:shadow copy) + (:use dwim-lisp tool statistics)) + +(in-package :graph) + +(declaim (declaration downward-funarg + downward-function + array-register)) -(dwim:make-command-table :graph) +(dwim:make-command-table :graph) --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/present.lisp 2003/10/31 11:35:38 1.1 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/present.lisp 2006/03/17 07:12:52 1.2 @@ -178,7 +178,7 @@ (dotimes (column columns) (let ((g nil)) (dotimes (row rows) - (ignore row) + (declare (ignore row)) (let ((temp (pop graphs))) (and temp (push temp g)))) (stream-set-cursor-position* --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/random.lisp 2003/10/31 11:35:38 1.1 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/random.lisp 2006/03/17 07:12:52 1.2 @@ -289,7 +289,7 @@ (setq .entry. (multiple-value-list , at body))) (values-list .entry.)))))) - `(let ((.table. ,(make-hash-table :test #'equal))) + `(let ((.table. (load-time-value (make-hash-table :test #'equal)))) ,(if (cdr args) `(with-stack-list (.args. , at args) ,body) `(let ((.args. ,(first args))) ,body))))) --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/scigraph-system.lisp 2003/10/31 11:35:38 1.1 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/scigraph-system.lisp 2006/03/17 07:12:52 1.2 @@ -86,6 +86,3 @@ ("frame" :load-before-compile ("duplicate-methods")) ("export" :load-before-compile ("frame")) ("demo-frame" :load-before-compile ("export"))) - - - From rgoldman at common-lisp.net Sun Mar 19 15:34:25 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Sun, 19 Mar 2006 10:34:25 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc/Guided-Tour Message-ID: <20060319153425.2E4BA200A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour In directory clnet:/tmp/cvs-serv22609 Modified Files: simple-draw.lisp Log Message: define-application-frame was misspelled. --- /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/simple-draw.lisp 2006/01/30 16:14:01 1.1 +++ /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/simple-draw.lisp 2006/03/19 15:34:24 1.2 @@ -1,4 +1,4 @@ -(define-application-frarae hello-frame () () +(define-application-frame hello-frame () () (:pane (make-instance 'hello-data-pane :hs 200 :hs+ +fill+ :vs 200 :vs+ +fill+)) (:settings :title "Hello from Lisp")) From tmoore at common-lisp.net Mon Mar 20 07:46:17 2006 From: tmoore at common-lisp.net (tmoore) Date: Mon, 20 Mar 2006 02:46:17 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Functional-Geometry Message-ID: <20060320074617.A5D641C002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Functional-Geometry In directory clnet:/tmp/cvs-serv11508/Functional-Geometry Log Message: Directory /project/mcclim/cvsroot/mcclim/Apps/Functional-Geometry added to the repository From tmoore at common-lisp.net Mon Mar 20 08:15:27 2006 From: tmoore at common-lisp.net (tmoore) Date: Mon, 20 Mar 2006 03:15:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060320081527.5B0C223003@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14553 Modified Files: builtin-commands.lisp commands.lisp mcclim.asd presentation-defs.lisp presentations.lisp system.lisp Log Message: Made the command-table-inherit-from slot of command tables setf-able, as per the Franz manual. Changed the default documentation of presentation translators from the presentation object to the name of the translator. If this is too controversial I will back it out. Force the tester of drag-and-drop translators to be definitive; otherwise serious weirdness ensues. Added the functional geometry explorer of Frank Buss and Rainer Joswig, who graciously agreed to it being included, as an application. --- /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2006/03/15 15:38:38 1.21 +++ /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2006/03/20 08:15:26 1.22 @@ -301,6 +301,12 @@ ;; We don't want activation gestures like :return causing an eof ;; while reading a form. Also, we don't want spaces within forms or ;; strings causing a premature return either! + ;; XXX This loses when rescanning (possibly in other contexts too) an + ;; activated input buffer (e.g., reading an expression from the accept + ;; method for OR where the previous readers have already given + ;; up). We should call *sys-read-preserving-whitespace* and handle the + ;; munching of whitespace ourselves according to the + ;; PRESERVE-WHITESPACE parameter. Fix after .9.2.2. (with-delimiter-gestures (nil :override t) (with-activation-gestures (nil :override t) (setq object (funcall (if preserve-whitespace --- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/15 15:38:39 1.59 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/20 08:15:26 1.60 @@ -84,7 +84,15 @@ (defmethod print-object ((table standard-command-table) stream) (print-unreadable-object (table stream :identity t :type t) (format stream "~S" (command-table-name table)))) - + +;;; Franz user manual says that this slot is setf-able +(defgeneric (setf command-table-inherit-from) (inherit-from table)) + +(defmethod (setf command-table-inherit-from) + (inherit (table standard-command-table)) + (invalidate-translator-caches) + (setf (slot-value table 'inherit-from) inherit)) + (defparameter *command-tables* (make-hash-table :test #'eq)) (define-condition command-table-error (error) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/15 22:56:54 1.10 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/20 08:15:26 1.11 @@ -56,7 +56,7 @@ (defclass requireable-system (asdf:system) ()) (defmethod asdf:perform ((op asdf:load-op) (system requireable-system)) - (require (intern (slot-value system 'asdf::name) "KEYWORD"))) + (require (intern (slot-value system 'asdf::name) :keyword))) (defmethod asdf::traverse ((op asdf:load-op) (system requireable-system)) (list (cons op system))) (defsystem :clx --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/15 15:38:39 1.53 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/20 08:15:26 1.54 @@ -2073,6 +2073,7 @@ `(progn (define-presentation-translator ,name (,from-type ,to-type ,command-table + :tester-definitive t , at args , at pointer-doc :feedback #',feedback :highlighting #',highlighting --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/15 22:56:54 1.75 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/20 08:15:26 1.76 @@ -1228,6 +1228,9 @@ :writer (setf presentation-translators-cache) :initform (make-hash-table :test #'equal)))) +(defun invalidate-translator-caches () + (incf *current-translator-cache-generation*)) + (defmethod presentation-translators-cache ((table translator-table)) (with-slots ((cache presentation-translators-cache) (generation translator-cache-generation)) @@ -1269,10 +1272,11 @@ (remove old (gethash (presentation-type-name (from-type old)) simple-type-translators)))) - (incf *current-translator-cache-generation*) + (invalidate-translator-caches) (setf (gethash (name translator) translators) translator) (push translator - (gethash (from-type translator) simple-type-translators))))) + (gethash (from-type translator) simple-type-translators)) + translator))) (defun make-translator-fun (args body) (multiple-value-bind (ll ignore) @@ -1301,7 +1305,7 @@ (gesture :select) (tester 'default-translator-tester testerp) (tester-definitive (if testerp nil t)) - (documentation nil) + (documentation nil documentationp) (pointer-documentation nil pointer-documentation-p) (menu t) (priority 0) @@ -1335,7 +1339,10 @@ (cdr tester))) :tester-definitive ',tester-definitive :documentation #',(make-documentation-fun - documentation) + (if documentationp + documentation + (command-name-from-symbol + name))) ,@(when pointer-documentation-p `(:pointer-documentation #',(make-documentation-fun @@ -1350,7 +1357,7 @@ (name (from-type to-type command-table &key (gesture :select) (tester 'default-translator-tester) - (documentation nil) + (documentation nil documentationp) (pointer-documentation nil pointer-documentation-p) (menu t) (priority 0)) @@ -1373,7 +1380,10 @@ `#',(make-translator-fun (car tester) (cdr tester))) :tester-definitive t - :documentation #',(make-documentation-fun documentation) + :documentation #',(make-documentation-fun (if documentationp + documentation + (command-name-from-symbol + name))) ,@(when pointer-documentation-p `(:pointer-documentation #',(make-documentation-fun pointer-documentation))) --- /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/15 22:56:54 1.115 +++ /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/20 08:15:26 1.116 @@ -267,7 +267,6 @@ (clim-defsystem (:clim-listener :depends-on (:clim #+clx :clim-looks #+sbcl :sb-posix)) "Experimental/xpm" "Apps/Listener/package" - "Apps/Listener/hotfixes" "Apps/Listener/util" "Apps/Listener/icons.lisp" "Apps/Listener/file-types" From tmoore at common-lisp.net Mon Mar 20 08:15:27 2006 From: tmoore at common-lisp.net (tmoore) Date: Mon, 20 Mar 2006 03:15:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Functional-Geometry Message-ID: <20060320081527.AB80626080@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Functional-Geometry In directory clnet:/tmp/cvs-serv14553/Apps/Functional-Geometry Added Files: functional-geometry.asd geometry.lisp package.lisp Log Message: Made the command-table-inherit-from slot of command tables setf-able, as per the Franz manual. Changed the default documentation of presentation translators from the presentation object to the name of the translator. If this is too controversial I will back it out. Force the tester of drag-and-drop translators to be definitive; otherwise serious weirdness ensues. Added the functional geometry explorer of Frank Buss and Rainer Joswig, who graciously agreed to it being included, as an application. --- /project/mcclim/cvsroot/mcclim/Apps/Functional-Geometry/functional-geometry.asd 2006/03/20 08:15:27 NONE +++ /project/mcclim/cvsroot/mcclim/Apps/Functional-Geometry/functional-geometry.asd 2006/03/20 08:15:27 1.1 ;;; -*- Mode: Lisp -*- ;;; ;;; (c) copyright 2006 by Timothy Moore (moore at bricoworks.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (defpackage :mcclim.functional-geometry.system (:use :asdf :cl)) (in-package :mcclim.functional-geometry.system) (defsystem #:functional-geometry :name #:functional-geometry :depends-on (:clim-listener) :components ((:file "package") (:file "geometry" :depends-on ("package")))) --- /project/mcclim/cvsroot/mcclim/Apps/Functional-Geometry/geometry.lisp 2006/03/20 08:15:27 NONE +++ /project/mcclim/cvsroot/mcclim/Apps/Functional-Geometry/geometry.lisp 2006/03/20 08:15:27 1.1 ;;; -*- Mode: Lisp -*- ;;; ;;; Copyright (c) 2005 by Frank Buss (fb at frank-buss.de) ;;; Clim interface by Rainer Joswig is in the public domain ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a ;;; copy of this software and associated documentation files (the "Software"), ;;; to deal in the Software without restriction, including without limitation ;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;;; and/or sell copies of the Software, and to permit persons to whom the ;;; Software is furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; Functional Geometry ;;; ;;; Original idea by Peter Henderson, see ;;; http://www.ecs.soton.ac.uk/~ph/funcgeo.pdf ;;; and http://www.ecs.soton.ac.uk/~ph/papers/funcgeo2.pdf ;;; ;;; Implemented in Lisp by Frank Buss ;;; ;;; CLIM Listener interface by Rainer Joswig ;;; ;;; call it with (clim-plot *fishes*) from a Listener. ;;; ;;; the framework ;;; (in-package #:functional-geometry) (defun p* (vector m) "vector scalar multiplication" (destructuring-bind (vx vy) vector (list (* vx m) (* vy m)))) (defun p/ (vector d) "vector scalar division" (destructuring-bind (vx vy) vector (list (/ vx d) (/ vy d)))) (defun p+ (&rest vectors) "#'+ for vectors" (case (length vectors) (0 '(0 0)) (1 (car vectors)) (otherwise (flet ((p+p (v1 v2) (destructuring-bind (vx0 vy0) v1 (destructuring-bind (vx1 vy1) v2 (list (+ vx0 vx1) (+ vy0 vy1)))))) (reduce #'p+p vectors))))) (defun p- (&rest vectors) "#'- for vectors" (case (length vectors) (0 '(0 0)) (1 (p* (car vectors) -1)) (otherwise (flet ((p-p (v1 v2) (destructuring-bind (vx0 vy0) v1 (destructuring-bind (vx1 vy1) v2 (list (- vx0 vx1) (- vy0 vy1)))))) (reduce #'p-p vectors))))) (defun grid (m n s) "defines a picture from lines in a grid" (lambda (a b c) (loop for line in s collect (destructuring-bind ((x0 y0) (x1 y1)) line (list (p+ (p/ (p* b x0) m) a (p/ (p* c y0) n)) (p+ (p/ (p* b x1) m) a (p/ (p* c y1) n))))))) (defun polygon (points) "converts the points, which specifies a polygon, in a list of lines" (let ((start (car (last points)))) (loop for point in points collect (list start point) do (setf start point)))) (defun blank () "a blank picture" (lambda (a b c) (declare (ignore a b c)) '())) (defun beside (p q) "returns picture p besides picture q" (lambda (a b c) (let ((b-half (p/ b 2))) (union (funcall p a b-half c) (funcall q (p+ a b-half) b-half c))))) (defun above (p q) "returns picture q above picture p" (lambda (a b c) (let ((c-half (p/ c 2))) (union (funcall p (p+ a c-half) b c-half) (funcall q a b c-half))))) (defun rot (p) "returns picture p rotated by 90 degree" (lambda (a b c) (funcall p (p+ a b) c (p- b)))) (defun quartet (p1 p2 p3 p4) "returns the pictures p1-p4, layouted in a square" (above (beside p1 p2) (beside p3 p4))) (defun cycle (p) "returns four times the p, layouted in a square and rotated" (quartet p (rot (rot (rot p))) (rot p) (rot (rot p)))) #-(and) (defun plot (p) " saves a picture as postscript and shows it" (with-open-file (s "c:/tmp/test.ps" :direction :output :if-exists :supersede) (format s "500 500 scale~%") (format s ".1 .1 translate~%") (format s "0 setlinewidth~%") (format s "0 0 moveto 1 0 lineto 1 1 lineto 0 1 lineto 0 0 lineto~%") (dolist (line (funcall p '(0 0) '(1 0) '(0 1))) (destructuring-bind ((x0 y0) (x1 y1)) line (format s "~D ~D moveto ~D ~D lineto~%" (float x0) (float y0) (float x1) (float y1)))) (format s "stroke~%") (format s "showpage~%")) (sys:call-system "c:/gs/gs7.05/bin/gswin32.exe -g800x800 c:/tmp/test.ps")) ;;; ;;; a simple test ;;; ;; defines a man (defparameter *man* (grid 14 20 (polygon '((6 10) (0 10) (0 12) (6 12) (6 14) (4 16) (4 18) (6 20) (8 20) (10 18) (10 16) (8 14) (8 12) (10 12) (10 14) (12 14) (12 10) (8 10) (8 8) (10 0) (8 0) (7 4) (6 0) (4 0) (6 8))))) ;; demonstrates beside (defparameter *man-beside-man* (beside *man* *man*)) ;; demonstrates above (defparameter *man-above-man* (above *man* *man*)) ;; demonstrates rot (defparameter *man-rotated* (rot *man*)) ;; demonstrates quartet (defparameter *man-quartet* (quartet *man* *man* *man* *man*)) ;; demonstrates cycle (defparameter *man-cycle* (cycle *man*)) ;;; ;;; the fish ;;; ;; defines part p of the fish (defparameter *p* (grid 16 16 '(((4 4) (6 0)) ((0 3)(3 4)) ((3 4)(0 8)) ((0 8)(0 3)) ((4 5)(7 6)) ((7 6)(4 10)) ((4 10)(4 5)) ((11 0)(10 4)) ((10 4)(8 8)) ((8 8)(4 13)) ((4 13)(0 16)) ((11 0)(14 2)) ((14 2)(16 2)) ((10 4)(13 5)) ((13 5)(16 4)) ((9 6)(12 7)) ((12 7)(16 6)) ((8 8)(12 9)) ((12 9)(16 8)) ((8 12)(16 10)) ((0 16)(6 15)) ((6 15)(8 16)) ((8 16)(12 12)) ((12 12)(16 12)) ((10 16)(12 14)) ((12 14)(16 13)) ((12 16)(13 15)) ((13 15)(16 14)) ((14 16)(16 15))))) ;; defines part q of the fish (defparameter *q* (grid 16 16 '(((2 0)(4 5)) ((4 5)(4 7)) ((4 0)(6 5)) ((6 5)(6 7)) ((6 0)(8 5)) ((8 5)(8 8)) ((8 0)(10 6)) ((10 6)(10 9)) ((10 0)(14 11)) ((12 0)(13 4)) ((13 4)(16 8)) ((16 8)(15 10)) ((15 10)(16 16)) ((16 16)(12 10)) ((12 10)(6 7)) ((6 7)(4 7)) ((4 7)(0 8)) ((13 0)(16 6)) ((14 0)(16 4)) ((15 0)(16 2)) ((0 10)(7 11)) ((9 12)(10 10)) ((10 10)(12 12)) ((12 12)(9 12)) ((8 15)(9 13)) ((9 13)(11 15)) ((11 15)(8 15)) ((0 12)(3 13)) ((3 13)(7 15)) ((7 15)(8 16)) ((2 16)(3 13)) ((4 16)(5 14)) ((6 16)(7 15))))) ;; defines part r of the fish (defparameter *r* (grid 16 16 '(((0 12)(1 14)) ((0 8)(2 12)) ((0 4)(5 10)) ((0 0)(8 8)) ((1 1)(4 0)) ((2 2)(8 0)) ((3 3)(8 2)) ((8 2)(12 0)) ((5 5)(12 3)) ((12 3)(16 0)) ((0 16)(2 12)) ((2 12)(8 8)) ((8 8)(14 6)) ((14 6)(16 4)) ((6 16)(11 10)) ((11 10)(16 6)) ((11 16)(12 12)) ((12 12)(16 8)) ((12 12)(16 16)) ((13 13)(16 10)) ((14 14)(16 12)) ((15 15)(16 14))))) ;; defines part s of the fish (defparameter *s* (grid 16 16 '(((0 0)(4 2)) ((4 2)(8 2)) ((8 2)(16 0)) ((0 4)(2 1)) ((0 6)(7 4)) ((0 8)(8 6)) ((0 10)(7 8)) ((0 12)(7 10)) ((0 14)(7 13)) ((8 16)(7 13)) ((7 13)(7 8)) ((7 8)(8 6)) ((8 6)(10 4)) ((10 4)(16 0)) ((10 16)(11 10)) ((10 6)(12 4)) ((12 4)(12 7)) ((12 7)(10 6)) ((13 7)(15 5)) ((15 5)(15 8)) ((15 8)(13 7)) ((12 16)(13 13)) ((13 13)(15 9)) ((15 9)(16 8)) ((13 13)(16 14)) ((14 11)(16 12)) ((15 9)(16 10))))) ;; builds the fishes drawing (defparameter *t* (quartet *p* *q* *r* *s*)) (defparameter *u* (cycle (rot *q*))) (defparameter *side1* (quartet (blank) (blank) (rot *t*) *t*)) (defparameter *side2* (quartet *side1* *side1* (rot *t*) *t*)) (defparameter *corner1* (quartet (blank) (blank) (blank) *u*)) (defparameter *corner2* (quartet *corner1* *side1* (rot *side1*) *u*)) (defparameter *pseudocorner* (quartet *corner2* *side2* (rot *side2*) (rot *t*))) (defparameter *fishes* (cycle *pseudocorner*)) (define-presentation-type picture ()) (define-presentation-method presentation-typep (object (type picture)) (typep object 'function)) ;;; Plotting (define-command-table functional-geometry) (defmacro define-functional-geometry-command ((name &rest options) &body body) `(define-command (,name :command-table functional-geometry , at options) , at body)) (defun clim-plot (p &optional (stream *standard-output*)) (fresh-line stream) (with-output-as-presentation (stream p 'picture :single-box t) (with-room-for-graphics (stream) (with-scaling (stream 200 200) (with-translation (stream 0.1 0.1) (loop for (x0 y0 x1 y1) in '((0 0 1 0) (1 0 1 1) (1 1 0 1) (0 1 0 0)) do (draw-line* stream x0 y0 x1 y1)) (dolist (line (funcall p (list 0 0) (list 1 0) (list 0 1))) (destructuring-bind ((x0 y0) (x1 y1)) line (draw-line* stream x0 y0 x1 y1)))))))) (defun clim-plot-in-window (p &optional (stream *standard-output*)) (clim-plot p stream)) (defun clim-plot-to-postscript (p &optional (pathname "/Users/joswig/Desktop/test-clim.ps")) (with-open-file (file-stream pathname :direction :output :if-exists :supersede :if-does-not-exist :create) (with-output-to-postscript-stream (stream file-stream) (clim-plot p stream)))) ;;; XXX The use of EXPRESSION in the OR presentation type exposes a bug in the ;;; accept method for expression when rescanning; you have to hit ENTER three ;;; times when entering an expression (e.g., a variable name) as a picture ;;; value. This will be fixed after .9.2.2. -- moore (define-functional-geometry-command (plot :name t) ((picture '(or picture expression) :provide-default nil :prompt "picture")) (unless (presentation-typep picture 'picture) (setq picture (eval picture)) (clim-plot-in-window picture) picture)) (define-functional-geometry-command(save-picture-as-postscript :name t) ((picture 'picture :provide-default nil :prompt "picture") (file 'pathname :provide-default nil :prompt "file")) (clim-plot-to-postscript picture file) (values file picture)) (define-functional-geometry-command (com-beside :name t) ((picture0 'picture :provide-default nil :prompt "picture 0") (picture1 'picture :provide-default nil :prompt "picture 1")) (let ((new-picture (beside picture0 picture1))) (clim-plot new-picture) new-picture)) (define-functional-geometry-command (com-above :name t) ((picture0 'picture :provide-default nil :prompt "picture 0") (picture1 'picture :provide-default nil :prompt "picture 1")) (let ((new-picture (above picture0 picture1))) (clim-plot new-picture) new-picture)) (define-functional-geometry-command (com-rot :name t) ((picture 'picture :provide-default nil :prompt "picture")) (let ((new-picture (rot picture))) (clim-plot new-picture) new-picture)) (define-functional-geometry-command (com-cycle :name t) ((picture 'picture :provide-default nil :prompt "picture")) (let ((new-picture (cycle picture))) (clim-plot new-picture) new-picture)) (define-functional-geometry-command (com-quartet :name t) ((picture0 'picture :provide-default nil :prompt "picture 0") (picture1 'picture :provide-default nil :prompt "picture 1") (picture2 'picture :provide-default nil :prompt "picture 2") (picture3 'picture :provide-default nil :prompt "picture 3")) (let ((new-picture (quartet picture0 picture1 picture2 picture3))) (clim-plot new-picture) new-picture)) (define-presentation-to-command-translator rot (picture com-rot functional-geometry :menu t :gesture nil) (object) (list object)) (define-presentation-to-command-translator cycle (picture com-cycle functional-geometry :menu t :gesture nil) (object) (list object)) (define-drag-and-drop-translator besides (picture command picture functional-geometry :tester ((object destination-object) (not (eq object destination-object)))) (object destination-object) `(com-beside ,object ,destination-object)) (pushnew 'functional-geometry (command-table-inherit-from (find-command-table 'clim-listener::listener))) (defun run-functional-geometry (&rest args) "Run a Lisp Listener augmented with functional geometry commands." (let ((*package* (find-package '#:functional-geometry))) (apply #'run-listener (append args '(:process-name "Functional Geometry" :height 800))))) --- /project/mcclim/cvsroot/mcclim/Apps/Functional-Geometry/package.lisp 2006/03/20 08:15:27 NONE +++ /project/mcclim/cvsroot/mcclim/Apps/Functional-Geometry/package.lisp 2006/03/20 08:15:27 1.1 ;;; ;;; (c) copyright 2006 by Timothy Moore (moore at bricoworks.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public [17 lines skipped] From afuchs at common-lisp.net Mon Mar 20 11:01:54 2006 From: afuchs at common-lisp.net (afuchs) Date: Mon, 20 Mar 2006 06:01:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060320110154.E17CC7700A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv6192 Modified Files: mcclim.asd Log Message: Change build order to work around CMUCL method definition bug. * instead of system clim, system clim-looks now depends on clim-postscript --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/20 08:15:26 1.11 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/20 11:01:54 1.12 @@ -189,7 +189,7 @@ (:file "standard-metrics" :depends-on ("font" "package")))))) (defsystem :clim - :depends-on (:clim-core :goatee-core :clim-postscript) + :depends-on (:clim-core :goatee-core) :components ((:file "text-formatting") (:file "input-editing") @@ -288,7 +288,7 @@ ;;; A system that loads the appropriate backend for the current ;;; platform. (defsystem :clim-looks - :depends-on (:clim + :depends-on (:clim :clim-postscript ;; If we're on an implementation that ships CLX, use ;; it. Same if the user has loaded CLX already. #+(or sbcl scl openmcl ecl clx allegro) :clim-clx From crhodes at common-lisp.net Mon Mar 20 11:21:03 2006 From: crhodes at common-lisp.net (crhodes) Date: Mon, 20 Mar 2006 06:21:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20060320112103.0CB35A0E5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv8331 Removed Files: xrender.asd xrender.lisp xrender.system Log Message: Remove xrender files; bug your CLX vendor for xrender instead. (Available at least at anyway) From rgoldman at common-lisp.net Tue Mar 21 15:00:25 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Tue, 21 Mar 2006 10:00:25 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc/Guided-Tour Message-ID: <20060321150025.786D9690E5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour In directory clnet:/tmp/cvs-serv23388 Modified Files: guided-tour.tex Log Message: Minor wording changes and typo fixes to the middle of the document. --- /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/guided-tour.tex 2006/03/16 15:50:20 1.3 +++ /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/guided-tour.tex 2006/03/21 15:00:24 1.4 @@ -991,7 +991,7 @@ \subsection{A simple drawing application} -We move on to a simple drawing application that draws +We move on to a simple application that draws lines and inserts text interactively. Our simple drawing program defines commands for various drawing operations and binds specific input events to these commands. @@ -1005,6 +1005,11 @@ multiple layouts with this option. We define two simple layouts, \code{default-layout} and \code{alternative}. +% I was confused by the discussion of layouts here. Looking at Figure +% 4, I do not see an alternative layout, and the default-default in +% the listing looks odd to me. Is this the remainder of a discussion +% that was deleted or an extension yet to be written? [2006/03/19:rpg] + \begin{figure*}[t] \lstset{style=framestyle} \lstinputlisting{draw-frame-commands} @@ -1048,8 +1053,18 @@ static user interfaces use this mixin. Note that \mcclim{} is sensitive to the order of the superclasses.\footnote{All stream classes like \class{standard-extended-input-stream} must be listed before -\class{basic-pane}. Otherwise, there are no stream handling facilities -available.} +\class{basic-pane}. Otherwise, no stream handling facilities +will be available.} + +% The above footnote refers to what looks like a very big potential +% ``gotcha'' for the beginning McCLIM programmer. Suggestion: promote +% this out of the footnote into body text as a main body paragraph +% here. That paragraph should explain (1) why is it that putting +% basic-pane before standard-extended-input-stream will cause stream +% handling facilities to be crushed and (2) what exactly are the +% implications of not having stream handling facilities. The phrase +% ``stream handling'' hasn't been defined, and it's not obvious what +% these facilities are. [2006/03/19:rpg] For \class{draw-pane}, the \method{handle-repaint} method shown in \figurename~\ref{fig-draw-handlerepaint} is straightforward. It @@ -1085,41 +1100,61 @@ conveniently. The interactor pane can be used to invoke one of three commands, either by typing the complete command including all its parameters or by typing only the command name, then a dialog queries -the user for the missing command argument. Clicking on the menu bar -entries is also possible. Also in this case, the user is queried for -the missing arguments. +the user for the missing command argument(s). Clicking on the menu bar +entries is another way to invoke commands. When commands are invoked +through the menu bar, the user will be queried for the missing +argument(s) in the same way as if a command had been typed into the +interactor pane. +% also possible. Also in this case, the user is queried for +% the missing arguments. But drawing by typing coordinates is not convenient. Therefore, we attach these commands to other user interactions. Figure -\ref{fig-draw-interfacing} defines input methods for pointer button -presses as well as key presses on the draw pane. Both handlers invoke -the respective tracking function that uses \macro{tracking-pointer} to +\ref{fig-draw-interfacing} defines input methods (methods for +\code{handle-event}) for pointer button +presses as well as key presses on the draw pane. +Each handler invokes a tracking function (\code{track-line-drawing} and +\code{track-text-drawing}) that uses \macro{tracking-pointer} to bypass the regular input distribution channels and to dispatch events to user defined handlers. - -For \class{pointer-button-press-event}, the input loop manages a -``rubber-banding'' line. The \keyword{:pointer-motion} is invoked +% old text: [2006/03/19:rpg] +% Both handlers invoke +% the respective tracking function that uses \macro{tracking-pointer} to +% bypass the regular input distribution channels and to dispatch events +% to user defined handlers. + +For \class{pointer-button-press-event}, which is used to draw lines, +the input loop manages a +``rubber-banding'' line. % +% what is pointer-motion here? Is it an event? And it's not really +% the event that's invoked, to be absolutely clear. The event is +% signaled, and the tracking-pointer macro provides a handler for that +% event. So it is the code associated with :pointer-motion that is +% invoked... I wasn't confident enough in my understanding of the +% precise organization of the (Mc)CLIM architecture to venture a +% rewrite, but there should be a clarification here. [2006/03/19:rpg] +The \keyword{:pointer-motion} is invoked whenever the mouse pointer is moved by the user. The code attached to -\keyword{:pointer-motion} clears line already drawn and draws a new +\keyword{:pointer-motion} clears the previously-drawn line and draws a new line with the new pointer position. It can easily undraw the old line by the using the special ink \constant{+flipping-ink+}. When the user confirms the line by releasing the pointer button, a command to the application is synthesized via \method{execute-frame-command} supplying all required parameters. -Similarly, we provide such an input facility for text input. Whenever +We provide a similar input facility for text input. Whenever the user hits a key in the draw-pane, the respective \method{handle-event} calls \method{track-text-drawing} which attaches -the character entered to the mouse pointer. Similarly to the -rubber-banding line, the user can move the around this character while +the character entered to the mouse pointer. As with the +rubber-banding line, the user can move the displayed string around while he is free to append additional string characters by additional key presses. He can confirm the text position with a mouse click causing a -command to be dispatched to the application frame adding the text to +command to be dispatched to the application frame that will add the text to the application frame permanently. As each of these methods invoke \code{execute-frame-command} passing -in a special command invocation form, this naturally leads to code -separation of how a command is invoked (menu-bar click, click on +in a special command invocation form, this naturally leads to a +separation between the code that specifies how a command is invoked (menu-bar click, click on draw-pane or typing in the interactor pane) and the code for command execution (code bodies of \method{define-command}). From afuchs at common-lisp.net Wed Mar 22 09:14:31 2006 From: afuchs at common-lisp.net (afuchs) Date: Wed, 22 Mar 2006 04:14:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20060322091431.29FE34505B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv31467/Apps/Listener Modified Files: listener.lisp Log Message: Apply Douglas Crosher's patch fixing the listener for CMUCL: * Revert function 'dynamic-space-usage to 'dynamic-usage. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/03/15 22:56:54 1.23 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/03/22 09:14:30 1.24 @@ -78,7 +78,7 @@ #-(or allegro cmu scl) (getenv "USER") "luser")) ; sorry.. (sitename (machine-instance)) - (memusage #+(or cmu scl) (lisp::dynamic-space-usage) + (memusage #+(or cmu scl) (lisp::dynamic-usage) #+sbcl (sb-kernel:dynamic-usage) #+lispworks (getf (system:room-values) :total-allocated) #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) From cfruhwirth at common-lisp.net Wed Mar 22 13:47:13 2006 From: cfruhwirth at common-lisp.net (cfruhwirth) Date: Wed, 22 Mar 2006 08:47:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc/Guided-Tour Message-ID: <20060322134713.C68284C00C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour In directory clnet:/tmp/cvs-serv6799 Added Files: COPYING Log Message: Add file to document that we got permission to use the original authors work. --- /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/COPYING 2006/03/22 13:47:13 NONE +++ /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/COPYING 2006/03/22 13:47:13 1.1 This file contains the logs of the mail conversations between various copyright holders in "A guided tour of CLIM" published in ACM Lisp Pointers 1991. It purpose is to document that we got permission for reusing the original authors' work. ======================================================================== From: Clemens Fruhwirth To: rao at inxight.com Subject: CLIM a guided tour X-Mailer: MH-E 7.84; nmh 1.1; XEmacs 21.5 (beta22) Date: Sun, 27 Nov 2005 18:27:28 +0100 Hello! I hope I got the correct "Ramona Rao", that is, the one that has co-authored "A Guided Tour of CLIM". McCLIM is an effort to provide a free CLIM environment for recent CL implementations like SBCL, CMUCL, et al. The community hasn't come up with a useful and short documentation like your tour to introduce users to CLIM. Unfortunately, CLIM has changed and the examples included in the article don't run anymore. I would like to update this article to produce a tutorial for the McCLIM community. Given the age of the article I presume that the interest in commercial exploitation has also faded. Therefore, I would like to ask, if it's possible to obtain any TeX source for this article. If the source got lost, I could also extract the text and reformat it. Of course, I would need your permission for these actions. Also, I'm not sure if that's ok for ACM. Is any of that possible? Thanks in advance! P.S.: I found your article here http://lemonodor.com/archives/000765.html -- Fruhwirth Clemens - http://clemens.endorphin.org for robots: sp4mtrap at endorphin.org From: Clemens Fruhwirth To: dennis.doughty at pantero.com Subject: A guided tour of CLIM - permission for 2005 update X-Mailer: MH-E 7.84; nmh 1.1; XEmacs 21.5 (beta22) Date: Thu, 08 Dec 2005 11:03:07 +0100 Hello Mr. Doughty, Together with Ramana Rao and Bill York, you have authored the article "A guided tour of CLIM" for ACM in 1991. CLIM has changed much since 1991, especially with the release of the CLIM 2 specification. The CLIM community lacks a good and short introduction to CLIM like your article was. I would like to update the examples in your article and also rewrite parts of the article that doesn't apply to the new CLIM. Assuming your permission for this action, I intend to publish this update on my webpage to aid the CLIM community. Ramano Rao as well as Bill York give me permission for this update. ACM also acknowledged this step. Now, I would like to ask, if this is ok with you. Thank you, Clemens P.S. Here are the mails from Ramana Rao, ACM and Bill York: Subject: RE: CLIM a guided tour Date: Mon, 28 Nov 2005 12:47:05 -0800 From: "Ramana Rao" To: "Clemens Fruhwirth" Cc: "Bill York" Clemens, Unfortunately, I don't seem to be able to get my hands on the original tex source for that article. I happily give you permission to adapt the text as supports the CLIM community. I've really been out of touch and would be curious to hear any highlights of what's happening there. Meanwhile, Bill York may be able to put his hands on the tex source. Thanks, Ramana Subject: RE: CLIM a guided tour Date: Thu, 1 Dec 2005 14:31:21 -0600 From: "Bill York" To: "Clemens Fruhwirth" Cc: "Ramana Rao" I don't seem to have the source file. Good luck in your efforts. From: Deborah Cotton To: 'Clemens Fruhwirth' Cc: permissions at acm.org Subject: RE: Update to http://portal.acm.org/citation.cfm?id=121996 Date: Wed, 7 Dec 2005 14:56:15 -0500 X-Mailer: Internet Mail Service (5.5.2657.72) Dear Mr. Fruhwirth, Thank you for your inquiry, and interest in ACM publications. Because the article in question appeared in a SIG newsletter, rather than a journal or conference proceedings, the authors retained copyright. In this case, ACM only requires acknowledgment of the original publication. You have received permission from two of the three authors, but you should also pursue the third author's permission, especially since you have revised the original work. Let me know if you have any further questions. Best regards, Deborah Cotton Copyright & Permissions ACM Publications 212.869.7440 ext. 652 212.869.0481 fax permissions at acm.org -- Fruhwirth Clemens - http://clemens.endorphin.org for robots: sp4mtrap at endorphin.org From: Robert Strandh Message-ID: <17326.56044.483289.241972 at serveur5.labri.fr> Date: Sun, 25 Dec 2005 18:46:20 +0100 To: clemens at endorphin.org Subject: forwarded message from Dennis Doughty --U9PbTyCujO Content-Type: text/plain; charset=us-ascii Content-Description: message body text Content-Transfer-Encoding: 7bit We got the permission! --U9PbTyCujO Content-Type: message/rfc822 Content-Description: forwarded message Content-Transfer-Encoding: 7bit Return-Path: Received: from iona.labri.fr ([unix socket]) by iona.labri.fr (Cyrus v2.2.12) with LMTPA; Sun, 25 Dec 2005 13:06:08 +0100 X-Sieve: CMU Sieve 2.2 Received: from localhost (guismo.drimm.u-bordeaux1.fr [147.210.36.243]) by iona.labri.fr (Postfix) with ESMTP id 59080101767 for ; Sun, 25 Dec 2005 13:06:08 +0100 (CET) Received: from iona.labri.fr ([147.210.8.143]) by localhost (guismo.drimm.u-bordeaux1.fr [147.210.36.243]) (amavisd-new, port 10024) with LMTP id 30892-06-2 for ; Sun, 25 Dec 2005 13:06:08 +0100 (CET) X-policyd-weight: using cached result; rate: -3.41 X-Greylist: delayed 903 seconds by postgrey-1.23 at iona.labri.fr; Sun, 25 Dec 2005 13:06:07 CET Received: from s-utl01-dcpop.stsn.net (s-utl01-dcpop.stsn.net [72.255.0.201]) by iona.labri.fr (Postfix) with SMTP id DC7BC101765 for ; Sun, 25 Dec 2005 13:06:07 +0100 (CET) Received: from s-utl01-dcpop.stsn.net ([127.0.0.1]) by s-utl01-dcpop.stsn.net (SMSSMTP 4.1.2.20) with SMTP id M2005122506505622450 for ; Sun, 25 Dec 2005 06:50:56 -0500 Received: from [10.57.103.119] ([10.57.103.119]) by s-utl01-dcpop.stsn.net for strandh at labri.fr; Sun, 25 Dec 2005 06:50:55 -0500 Message-ID: <43AE87A9.8050908 at alum.mit.edu> User-Agent: Mozilla Thunderbird 1.0.2 (Windows/20050317) X-Accept-Language: en-us, en MIME-Version: 1.0 References: In-Reply-To: Content-Type: text/plain; charset=ISO-8859-1; format=flowed X-Virus-Scanned: amavisd-new at u-bordeaux1.fr From: Dennis Doughty To: strandh at labri.fr Subject: Re: permission to update your CLIM article Date: Sun, 25 Dec 2005 06:51:05 -0500 Hi Robert, Sorry for the delay in getting back to you. I'm no longer at Pantero and it's only a coincidence that I ended up seeing this email. Absolutely you may have my permission to update the article. Dennis Doughty > From: *Robert Strandh* > > Date: Dec 17, 2005 4:37 PM > Subject: permission to update your CLIM article > To: dennis.doughty at pantero.com > > Dear Dennis Doughty, > > I am one of the original authors of McCLIM, the free implementation of > CLIM that we started writing in 2000 and which is now quite usable. > One of the things we lack at the moment to spread the use of CLIM is a > collection of simple examples on typical usage. Your CLIM article has > some very good ones, but it was apparently written for CLIM 1, and the > examples do not necessarily run unmodified on a CLIM 2 > implementation. > > Clemens Fruhwirth has suggested updating the examples of your article, > but for that, he needs the permission of all the authors. He has > already obtained the permission from your co-authors, so we need a > permission from you as well in order to go ahead. Clemens would > naturally accept a refusal on your part, and is willing to write a > similar article from scratch, updated for CLIM 2, but that would be > unnecessary work, should you agree to let him update yours. > > We therefore kindly ask for your permission to update the article, or > at least a clear message indicating that you do not give us such a > permission. I am sure you are very busy like the rest of us, but I > would very much appreciate this effort on your part. > > Thanks in advance, > -- > Robert Strandh > > --------------------------------------------------------------------- > Greenspun's Tenth Rule of Programming: any sufficiently complicated C > or Fortran program contains an ad hoc informally-specified bug-ridden > slow implementation of half of Common Lisp. > --------------------------------------------------------------------- > --U9PbTyCujO Content-Type: text/plain; charset=us-ascii Content-Description: .signature Content-Transfer-Encoding: 7bit -- Robert Strandh --------------------------------------------------------------------- Greenspun's Tenth Rule of Programming: any sufficiently complicated C or Fortran program contains an ad hoc informally-specified bug-ridden slow implementation of half of Common Lisp. --------------------------------------------------------------------- --U9PbTyCujO-- \ From tmoore at common-lisp.net Thu Mar 23 08:45:26 2006 From: tmoore at common-lisp.net (tmoore) Date: Thu, 23 Mar 2006 03:45:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20060323084526.DAC60431B6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv25483 Modified Files: image.lisp port.lisp Log Message: Fix (temporary hack) to use file sockets in CLX on ACL --- /project/mcclim/cvsroot/mcclim/Backends/CLX/image.lisp 2005/02/21 13:32:49 1.20 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/image.lisp 2006/03/23 08:45:26 1.21 @@ -18,7 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -(defpackage "IMAGE" +(defpackage :image ; (:use #:clim-lisp) (:use :clim-clx :common-lisp) (:export --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/03/15 22:56:55 1.121 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/03/23 08:45:26 1.122 @@ -1412,3 +1412,24 @@ Sending property NIL to target.~%" target) (send-event :target target :property nil)))) (xlib:display-force-output (xlib:window-display requestor)))) + +;;; XXX CLX in ACL doesn't use local sockets, so here's a fix. This is gross +;;; and should obviously be included in Franz' clx and portable clx, but I +;;; believe that enough users will find that their X servers don't listen for +;;; TCP connections that it is worthwhile to include this code here +;;; temporarily. + +#+allegro +(defun xlib::open-x-stream (host display protocol) + (declare (ignore protocol)) ;; Derive from host + (let ((stream (if (or (string= host "") (string= host "unix")) + (socket:make-socket + :address-family :file + :remote-filename (format nil "/tmp/.X11-unix/X~D" display) + :format :binary) + (socket:make-socket :remote-host (string host) + :remote-port (+ *x-tcp-port* display) + :format :binary)))) + (if (streamp stream) + stream + (error "Cannot connect to server: ~A:~D" host display)))) From crhodes at common-lisp.net Thu Mar 23 10:09:50 2006 From: crhodes at common-lisp.net (crhodes) Date: Thu, 23 Mar 2006 05:09:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Scigraph/dwim Message-ID: <20060323100950.7B28C1B005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim In directory clnet:/tmp/cvs-serv1310/Apps/Scigraph/dwim Modified Files: extensions.lisp package.lisp present.lisp tv.lisp wholine.lisp Log Message: Make Scigraph/dwim compile without error under SBCL. The code is still a horrible mess of reader conditionals, feature case, and other similar stuff; it really deserves to die a horrible death. For now, though, put it on a life support machine. --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/extensions.lisp 2004/08/06 13:19:40 1.5 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/extensions.lisp 2006/03/23 10:09:50 1.6 @@ -31,6 +31,7 @@ ;;; Lisp Extensions ;;;***************** +#-(and) (unless (fboundp 'ignore) ;; Define IGNORE to be like our old friend from Genera. ;; This practice is frowned upon because IGNORE is in the --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/package.lisp 2004/08/06 13:19:40 1.4 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/package.lisp 2006/03/23 10:09:50 1.5 @@ -87,6 +87,7 @@ ;; March 1989, X3J13 votes to subsume downward-funarg & downward-function ;; by dynamic-extent. Get rid of the next two eventually. jpm. dwim::downward-funarg dwim::downward-function + #-ansi-cl dwim::dynamic-extent dwim::array-register))) --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/present.lisp 2004/08/06 13:19:40 1.3 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/present.lisp 2006/03/23 10:09:50 1.4 @@ -527,9 +527,10 @@ #+clim-0.9 nil #+clim-1.0 clim:*activation-characters*)) (declare (ignore bchars)) + (declare (ignorable achars)) #FEATURE-CASE ((:clim-0.9 (clim::activation-character-p char)) - (:clim-2 (ignore achars) (clim:activation-gesture-p char)) + (:clim-2 (clim:activation-gesture-p char)) ((or :clim-1.0 :clim-2 (not :clim)) (and (if (consp char) (setq char (second char)) t) @@ -548,9 +549,10 @@ (defun accept-blip-p (char &optional (chars #-clim dw::*accept-blip-chars* #+clim-1.0 clim:*blip-characters* #+clim-0.9 nil)) + (declare (ignorable chars)) #FEATURE-CASE ((:clim-0.9 (clim::blip-character-p char)) - (:clim-2 (ignore chars) (clim:delimiter-gesture-p char)) + (:clim-2 (clim:delimiter-gesture-p char)) ((or :clim-1.0 :clim-2 (not :clim)) (loop for l in chars thereis (and (characterp char) (member char l :test #'char-equal)))))) @@ -662,7 +664,7 @@ #-clim (dw:accept 'tv:sheet :stream stream :prompt nil)) :printer ((window stream) (let ((*print-readably* nil)) - (declare (special *print-readably*)) + #-ansi-cl (declare (special *print-readably*)) #+clim (format stream "~A" window) #-clim (present window 'tv:sheet :stream stream))) :description "a window") @@ -690,12 +692,13 @@ (otherwise (present-to-string element)))) (defun make-accept-values-choices (&key query-identifier sequence select-action) + (declare (ignorable sequence)) #FEATURE-CASE - ((:clim-2 (ignore sequence) + ((:clim-2 (clim-internals::make-accept-values-multiple-choices :query-identifier query-identifier :select-action select-action)) - (:clim-1.0 (ignore sequence) + (:clim-1.0 (clim::make-accept-values-multiple-choices :query-identifier query-identifier :select-action select-action)) @@ -710,12 +713,13 @@ (defun make-accept-values-choice (&key choices choice value documentation) #+clim (declare (ignore documentation)) + (declare (ignorable choice)) #FEATURE-CASE - ((:clim-2 (ignore choice) + ((:clim-2 (clim-internals::make-accept-values-multiple-choice :choices choices :value value)) - (:clim-1.0 (ignore choice) + (:clim-1.0 (clim::make-accept-values-multiple-choice :choices choices :value value)) @@ -871,7 +875,7 @@ (accept 'string :stream stream :prompt nil :default nil))) (:clim-1.0 (let ((clim::*disable-input-editor-echo* t)) - (ignore clim::*disable-input-editor-echo*) + (declare (ignorable clim::*disable-input-editor-echo*)) ;; This variable is defined in a patch file (echo-patch.lisp) ;; that came from Scott MacKay and has not been made a part of DWIM. ;; You must load it separately. @@ -907,5 +911,5 @@ :parser ((stream) (values (readline-no-echo stream) 'invisible-object)) :printer ((object stream) - (ignore object) + (declare (ignore object)) (write-string "*" stream))) --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/tv.lisp 2004/08/06 13:19:40 1.7 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/tv.lisp 2006/03/23 10:09:50 1.8 @@ -363,7 +363,7 @@ ((not :clim) (scl:send frame :superior)))) (defun find-frame-manager (&key (if-exists :reuse)) - (ignore if-exists) + (declare (ignorable if-exists)) #FEATURE-CASE ((:clim-2 (clim:find-frame-manager)) (:clim-1.0 @@ -384,10 +384,10 @@ (tv:console-default-superior)))))) (defun get-reusable-frame (manager type) + (declare (ignorable manager)) #FEATURE-CASE (((not :clim) (let ((choices *deactivated-frames*)) - (ignore manager) (dolist (item choices) (when (and (eq (frame-manager item) manager) (typep (scl:send item :program) type)) @@ -401,7 +401,6 @@ (:clim-1.0 #-MCL (let ((choices *deactivated-frames*)) - (ignore manager) (dolist (item choices) (when (typep item type) (setq *deactivated-frames* (delete item *deactivated-frames*)) @@ -582,7 +581,6 @@ :left left :top top :right (+ left width) :bottom (+ top height))) (:clim-2 ;; what parent does this get? - #-mcclim (ignore parent) (let ((frame (clim:make-application-frame type :pretty-name title --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/wholine.lisp 2003/10/31 11:35:37 1.1 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/wholine.lisp 2006/03/23 10:09:50 1.2 @@ -490,12 +490,12 @@ #+(or clim-1.0 clim-2) (defmethod clim:read-frame-command :around ((frame t) &key stream) - (ignore stream) + (declare (ignore stream)) (with-process-state (input-string) (call-next-method))) #+(or clim-1.0 clim-2) (defmethod clim:execute-frame-command :around ((frame t) command) - (ignore command) + (declare (ignore command)) (with-process-state (run-string) (call-next-method))) #-clim From crhodes at common-lisp.net Thu Mar 23 11:59:00 2006 From: crhodes at common-lisp.net (crhodes) Date: Thu, 23 Mar 2006 06:59:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20060323115900.B45334C000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv27080/Backends/CLX Modified Files: medium.lisp Log Message: Fix for ellipse drawing (from Troels Henriksen) --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/02/17 14:16:39 1.72 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/03/23 11:59:00 1.73 @@ -564,7 +564,7 @@ (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) center-x center-y) (let* ((arc-angle (- end-angle start-angle)) - (arc-angle (if (< end-angle 0) + (arc-angle (if (< arc-angle 0) (+ (* pi 2) arc-angle) arc-angle))) (with-clx-graphics (medium) @@ -588,7 +588,7 @@ medium)) center-x center-y) (let* ((arc-angle (- end-angle start-angle)) - (arc-angle (if (< end-angle 0) + (arc-angle (if (< arc-angle 0) (+ (* pi 2) arc-angle) arc-angle)) (min-x (round-coordinate (- center-x radius))) From tmoore at common-lisp.net Thu Mar 23 15:27:24 2006 From: tmoore at common-lisp.net (tmoore) Date: Thu, 23 Mar 2006 10:27:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060323152724.130C64C000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22888 Modified Files: mcclim.asd Log Message: Changes to get Beagle running with current sources. Various demos 'run' (tested address-book, clim-listener, functional-geometry) but many things aren't working (scroll bars). --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/20 11:01:54 1.12 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/23 15:27:23 1.13 @@ -256,35 +256,6 @@ "Backends/OpenGL/opengl-medium" "Backends/OpenGL/opengl-x-graft") -;;; TODO/asf: I don't have the required macintosh to get :clim-beagle to load. - -(defsystem :clim-objc-support) -(defmethod perform ((op load-op) (c (eql (find-system :clim-objc-support)))) - (require "OBJC-SUPPORT")) - -(clim-defsystem (:clim-beagle :depends-on (:clim :clim-objc-support)) - "Backends/beagle/package" - "Backends/beagle/lisp-window" - "Backends/beagle/lisp-window-delegate" - "Backends/beagle/lisp-view" - "Backends/beagle/lisp-view-additional" - "Backends/beagle/lisp-image" - "Backends/beagle/lisp-unmanaged-view" - "Backends/beagle/cocoa-util" - "Backends/beagle/port" - "Backends/beagle/frame-manager" - "Backends/beagle/medium" - "Backends/beagle/mirror" - "Backends/beagle/events" - "Backends/beagle/graft" - "Backends/beagle/fonts" - "Backends/beagle/image" - "Backends/beagle/keysymdef") - -;;; legacy system that loads :clim-beagle -(defsystem :beagle - :depends-on (:clim-beagle)) - ;;; A system that loads the appropriate backend for the current ;;; platform. (defsystem :clim-looks From tmoore at common-lisp.net Thu Mar 23 15:27:24 2006 From: tmoore at common-lisp.net (tmoore) Date: Thu, 23 Mar 2006 10:27:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/input Message-ID: <20060323152724.497574C000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input In directory clnet:/tmp/cvs-serv22888/Backends/beagle/input Modified Files: events.lisp Log Message: Changes to get Beagle running with current sources. Various demos 'run' (tested address-book, clim-listener, functional-geometry) but many things aren't working (scroll bars). --- /project/mcclim/cvsroot/mcclim/Backends/beagle/input/events.lisp 2005/06/16 09:27:50 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/input/events.lisp 2006/03/23 15:27:24 1.10 @@ -28,7 +28,7 @@ #|| -$Id: events.lisp,v 1.9 2005/06/16 09:27:50 crhodes Exp $ +$Id: events.lisp,v 1.10 2006/03/23 15:27:24 tmoore Exp $ Events in Cocoa --------------- @@ -747,14 +747,6 @@ ;; Need to make use of the Cocoa method for getting modifier state - this is independent of events ;; pretty much (i.e. pointer documentation pane changes depending what modifier keys are pressed ;; prior to a mouse click etc.) ::FIXME:: -(defmethod pointer-modifier-state ((pointer beagle-pointer)) - ;; (multiple-value-bind (x y same-screen-p child mask) - ;; (xlib:query-pointer (clx-port-window (port pointer))) - ;; (declare (ignore x y same-screen-p child)) - ;; (x-event-state-modifiers (port pointer) mask))) - (warn "pointer-modifier-state: implement me") - nil) - ;; Again, make use of Cocoa methods for querying the pointer position. See above ::FIXME:: (defmethod pointer-position ((pointer beagle-pointer)) @@ -763,12 +755,6 @@ (warn "pointer-position: implement me") nil) - -;; Ditto previous two methods... -(defmethod pointer-button-state ((pointer beagle-pointer)) - (warn "pointer-button-state: implement me") - nil) - ;;; Is PORT-POINTER-SHEET also needed? See STREAM-POINTER-POSITION in ;;; STREAM-INPUT.LISP From tmoore at common-lisp.net Thu Mar 23 15:27:24 2006 From: tmoore at common-lisp.net (tmoore) Date: Thu, 23 Mar 2006 10:27:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/output Message-ID: <20060323152724.7A9DE4C000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory clnet:/tmp/cvs-serv22888/Backends/beagle/output Modified Files: fonts.lisp Log Message: Changes to get Beagle running with current sources. Various demos 'run' (tested address-book, clim-listener, functional-geometry) but many things aren't working (scroll bars). --- /project/mcclim/cvsroot/mcclim/Backends/beagle/output/fonts.lisp 2005/05/18 20:21:57 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/output/fonts.lisp 2006/03/23 15:27:24 1.3 @@ -200,71 +200,104 @@ ;;; All mediums and output sheets must implement a method for this generic function. -(defmethod text-size ((medium beagle-medium) string &key text-style (start 0) end) - (declare (special *default-text-style*)) - - ;; Method can be passed either a string or a char; make sure for the latter - ;; that we see only strings. - (when (characterp string) - (setf string (string string))) - - ;; Make sure there's an 'end' specified - (unless end - (setf end (length string))) - - ;; Make sure there's a text-style - (unless text-style - (setf text-style (medium-text-style medium))) +;;; Helper that doesn't handle newline +;;; XXX text-size and text-bounding-rectangle* are both broken because the +;;; Cocoa NSString function :size-with-attributes is quite buggy. Text +;;; rendering should be rewritten to use glyphs or ATSUI (a pleasant task I'm +;;; sure). -- moore + +(defun text-size-aux (medium string font start end) + ;; See if there's a better way to do this; is this stack allocation? + (let ((objc-str (%make-nsstring (subseq string start end)))) + (slet ((bsize (send objc-str :size-with-attributes + (reuse-attribute-dictionary medium font)))) + (let* ((descender (abs (send font 'descender))) + (fragment-width (pref bsize :ize.width)) + (fragment-height (pref bsize :ize.height)) + (fragment-baseline (- fragment-height descender))) + (send objc-str 'release) + (values fragment-width fragment-height descender fragment-baseline))))) + +(defmethod text-size ((medium beagle-medium) (s character) + &key (text-style (medium-text-style medium)) + (start 0) + (end 1)) + (text-size medium (string s) :text-style text-style :start start :end end)) + +(defmethod text-size ((medium beagle-medium) (string string) + &key (text-style (medium-text-style medium)) + (start 0) + ( end (length string))) + (declare (special *default-text-style*)) ;; Check for 'empty string' case - (if (>= start end) - (values 0 0 0 0 0) - (let ((position-newline (position #\newline string :start start)) - ;; See if there's a better way to do this; is this stack - ;; allocation? - (objc-str (%make-nsstring (subseq string start end))) - (font (%text-style->beagle-font (or text-style - *default-text-style*)))) - (slet ((bsize (send objc-str :size-with-attributes - (reuse-attribute-dictionary medium font)))) - ;; Don't use 'text-style-descent' in the following, since that - ;; method is defined in terms of this one :-) - (let* ((descender (abs (send font 'descender))) - (fragment-width (pref bsize :ize.width)) - (fragment-height (pref bsize :ize.height)) - (fragment-x (pref bsize :ize.width)) - ;; subtract line height from this later... - (fragment-y (pref bsize :ize.height)) - ;; baseline = height - descender - (fragment-baseline (- fragment-height descender))) - (send objc-str 'release) - (if (null position-newline) - (values fragment-width - fragment-height - fragment-x - (- fragment-y fragment-height) - fragment-baseline) - (progn - (multiple-value-bind (w h x y b) - (text-size medium string :text-style text-style - :start position-newline - :end end) - ;; Current width, or width of sub-fragment, whichever - ;; is larger - (let ((largest-width (max fragment-width w)) - ;; current height + height of sub-fragment - (current+fragment-height (+ fragment-height h)) - ;; new y position; one line height smaller than the - ;; total height - (y-position (- (+ fragment-y y) fragment-height)) - ;; baseline of string; total height - baseline size, where - ;; baseline 'size' is (line-height - baseline). - (baseline (- (+ fragment-height h) (- h b)))) - (values largest-width - current+fragment-height - x ; always use last x calculated... - y-position - baseline)))))))))) + (when (>= start end) + ;; XXX is 0 value for the baseline correct? + (return-from text-size (values 0 0 0 0 0))) + (let ((position-newline (position #\newline string :start start :end end)) + (font (%text-style->beagle-font (or text-style *default-text-style*)))) + (multiple-value-bind + (fragment-width fragment-height descender fragment-baseline) + (text-size-aux medium string font start (or position-newline end)) + (declare (ignore descender)) + (unless position-newline + (return-from text-size + (values fragment-width fragment-height fragment-width 0 + fragment-baseline))) + (multiple-value-bind (w h x y b) + (text-size medium string :text-style text-style + :start (1+ position-newline) + :end end) + ;; Current width, or width of sub-fragment, whichever is larger + (let ((largest-width (max fragment-width w)) + ;; current height + height of sub-fragment + (current+fragment-height (+ fragment-height h)) + ;; new y position; one line height smaller than the total height + (y-position y) + ;; baseline of string; total height - baseline size, where + ;; baseline 'size' is (line-height - baseline). + (Baseline (- (+ fragment-height h) (- h b)))) + (values largest-width + current+fragment-height + x ; always use last x calculated... + y-position + baseline)))))) + +(defmethod climi::text-bounding-rectangle* + ((medium beagle-medium) (s character) + &key (text-style (medium-text-style medium)) + (start 0) + (end 1)) + (climi::text-bounding-rectangle* medium (string s) + :text-style text-style :start start :end end)) + +(defmethod climi::text-bounding-rectangle* + ((medium beagle-medium) (s string) + &key (text-style (medium-text-style medium)) + (start 0) + (end 1)) + (declare (special *default-text-style*)) + ;; Check for 'empty string' case + (when (>= start end) + (return-from climi::text-bounding-rectangle* (values 0 0 0 0))) + (let ((font (%text-style->beagle-font (or text-style *default-text-style*))) + (height 0) + (width 0) + (baseline nil)) + (loop + for line-start = start then (1+ line-end) + for line-end = (position #\newline s :start line-start :end end) + do (multiple-value-bind + (fragment-width fragment-height descender fragment-baseline) + (text-size-aux medium s font line-start (or line-end end)) + (declare (ignore descender)) + (incf height fragment-height) + (setq width (max width fragment-width)) + (unless baseline + (setq baseline fragment-baseline))) + while line-end) + (values 0 (- baseline) width (- height baseline)))) + ;;; Note: we DO NOT want to draw the fonts in the medium-foreground colour - we want From tmoore at common-lisp.net Thu Mar 23 16:37:54 2006 From: tmoore at common-lisp.net (tmoore) Date: Thu, 23 Mar 2006 11:37:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060323163754.5FF315D08E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv30838 Modified Files: INSTALL Removed Files: INSTALL.ASDF INSTALL.CLISP INSTALL.CMU INSTALL.OPENMCL INSTALL.SBCL Log Message: Updated instructions to refer only to asdf method --- /project/mcclim/cvsroot/mcclim/INSTALL 2003/11/19 13:51:17 1.6 +++ /project/mcclim/cvsroot/mcclim/INSTALL 2006/03/23 16:37:54 1.7 @@ -1,64 +1,148 @@ -Install instructions for Franz Allegro Common Lisp --------------------------------------------------- +Prerequisites: +============== -1. Start Lisp +ASDF - The ASDF system definition facility. Many implementations come +with it and (require :asdf) is all that is needed. If yours doesn't, +see http://www.cliki.net/asdf. -2. Load the system definition file: - (load "system") -3. Compile and load the system: +Installing McCLIM using mcclim.asd +================================== - (compile-system :clim) - (compile-system :clim-clx) - (compile-system :clim-examples) +To tell ASDF about the wherabouts of McCLIM and to compile it for the +first time, perform these steps: -4. Load the compiled system: + 1. Symlink mcclim.asd to a directory in your + asdf:*central-registry* list. E.g., for SBCL, that would be: - (load-system :clim) - (load-system :clim-clx) - (load-system :clim-examples) + $ ln -sf /path/to/mcclim.asd ~/.sbcl/systems/ + + 2. If you are using a Lisp implementation that requires a separate + CLX to be installed, do this now and symlink the clx's .asd file + to your asdf:*central-registry*, as above. If your + implementation's CLX doesn't come with a clx.asd file, you will + have to load CLX via (require :clx) or a similar mechanism + yourself. + + 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 4, McCLIM and the CLX backend should be loaded and +you are good to go. + +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 +================================================================= + +Make sure to remove all symlinks in your asdf:*central-registry* to +system.lisp and replace them with symlinks to mcclim.asd. Keeping the +old links around will break loading the McCLIM system in subtle ways. + +After replacing the symlinks, follow the "Installing McCLIM..." +section above, beginning at step 1 - the symlink mcclim.asd itself is +required, too. + +Writing a system that depends on McCLIM +======================================= + +In an ASDF system that depends on a loaded CLIM, use the following +code to declare a dependency on McCLIM: + +(defsystem :your-clim-using-system + :depends-on (:mcclim #| other dependencies |#) + :components (#| components |#) + ) + +The dependency on the McCLIM system will also load a suitable display +backend on implementations where it can determine one. Running the demos ------------------ +================= + +McCLIM comes with some interesting demo programs and applications: + + address-book - The classic CLIM demo: + + (asdf:oos 'asdf:load :clim-examples) + (in-package :clim-demo) + (run-frame-top-level (make-application-frame 'address-book) + + The Examples directory includes other demo programs that might be + of interest. Many of these are quite old and were written before + large parts of the CLIM specification were implemented; for good + examples of CLIM style it is best to look elsewhere. + + + clim-listener - a Lisp 'listener' or top-level loop with many + goodies for examining directories, CLOS classes, etc. Printed + results are mouse-sensitive and in supported implementations + (currently OpenMCL) can be used directly as arguments in Lisp expressions: + + (asdf:oos 'asdf:load :clim-listener) + (clim-listener:run-listener) + + + functional-geometry - Frank Buss' and Rainer Joswig's functional + geometry explorer, implmented on top of clim-listener: + + (load "Apps/Functional-Geometry/functional-geometry.asd") + (asdf:oos 'asdf:load :functional-geometry) + (functional-geometry::run-functional-geometry) + + +Installation Notes for Implementations +====================================== + +Notes about bugs or gotchas in specific Common Lisp implementations +appear in the release notes found in the ReleaseNotes directory. + +Franz Allegro Common Lisp +========================= + +McCLIM has been tested with the ANSI Common Lisp image alisp. It +doesn't currently work in with "modern Lisp" but support is on the way. + -1. Run the calculator demo +OpenMCL +======= - (clim-demo::calculator) +McCLIM has been tested with openmcl-1.0. It is recommended that you +download CLX from ftp://clozure.com/pub/CLX. - This demo is self-explanatory. - - when you get tired of it, hit ^C in the Lisp listener. +An experimental Cocoa backend for McCLIM, called Beagle, is included +in Backends/beagle. -2. Run the menu demo - (menutest::menutest) +CLISP +===== - This demo is self-explanatory. - - when you get tired of it, hit ^C in the Lisp listener. +1. Get clisp-20041218 or newer. Build it with option --with-module=clx/mit-clx. -3. Run the slider demo +2. Get a copy of the ASDF package. Compile it: + $ clisp -c $ASDF/asdf.lisp - (clim-demo::colorslider) +3. Start + $ clisp -K full -i $ASDF/asdf.fas - You should see three sliders on the left and a color area on the right. - Use the three sliders to adjust RGB values to obtain a color. +and continue as above. - when you get tired of it, hit ^C in the Lisp listener. -4. A some of the demos should be run using the function clim-demo::run-test: - (clim-demo::run-test 'clim-demo::address-book) - (clim-demo::run-test 'goatee::goatee-test) - [N.B.: This advice is mostly obsolete. The usual way to start a - CLIM application is with e.g., - (run-frame-top-level (make-application-frame 'clim-demo::address-book) - Any problems that result should be reported as bugs.] +CMUCL +===== -Note: +McCLIM has been tested with version 19.c. - Before running any McCLIM application, it may be necessary for you - to enable host based access to the X server. This can be - accomplished by executing the following command at a shell prompt: +SBCL +==== - xhost localhost +McCLIM has been tested with version 0.9.8 and later. From tmoore at common-lisp.net Thu Mar 23 16:44:58 2006 From: tmoore at common-lisp.net (tmoore) Date: Thu, 23 Mar 2006 11:44:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060323164458.53CF960010@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv31048 Modified Files: INSTALL Log Message: Typo --- /project/mcclim/cvsroot/mcclim/INSTALL 2006/03/23 16:37:54 1.7 +++ /project/mcclim/cvsroot/mcclim/INSTALL 2006/03/23 16:44:58 1.8 @@ -93,7 +93,7 @@ functional-geometry - Frank Buss' and Rainer Joswig's functional - geometry explorer, implmented on top of clim-listener: + geometry explorer, implemented on top of clim-listener: (load "Apps/Functional-Geometry/functional-geometry.asd") (asdf:oos 'asdf:load :functional-geometry) From tmoore at common-lisp.net Thu Mar 23 16:59:18 2006 From: tmoore at common-lisp.net (tmoore) Date: Thu, 23 Mar 2006 11:59:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060323165918.C637A650A1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv32705 Modified Files: TODO Log Message: update --- /project/mcclim/cvsroot/mcclim/TODO 2004/07/23 12:36:44 1.11 +++ /project/mcclim/cvsroot/mcclim/TODO 2006/03/23 16:59:18 1.12 @@ -14,19 +14,12 @@ General designs need more work, particularly the support of compositing. - A compound output recording record structure based on R trees or - another spatial data structure is needed. - make-design-from-output-record (setf* pointer-position) - drag-output-record, dragging-output - More spiffy presentation accept and present methods - define-drag-and-drop-translator - with-input-editor-typeout read-only extents in Goatee @@ -39,12 +32,10 @@ display-command-table-menu, menu-choose-command-from-table - raise-frame, bury-frame, notify-user + notify-user :accept-values panes - frame-drag-and-drop-feedback, frame-drag-and-drop-highlighting - display-command-menu restraining-pane @@ -70,6 +61,19 @@ each pane to decide when it wants the input focus. ====================== Resolved issues ====================== +TBM:20060323:175700 + A compound output recording record structure based on R trees or + another spatial data structure is needed. [Implemented by + Christophe Rhodes and Andreas Fuchs]. + + drag-output-record, dragging-output + + define-drag-and-drop-translator + + raise-frame, bury-frame + + frame-drag-and-drop-feedback, frame-drag-and-drop-highlighting + TBM:20040524:100000 command-enable From varkesteijn at common-lisp.net Thu Mar 23 16:59:47 2006 From: varkesteijn at common-lisp.net (varkesteijn) Date: Thu, 23 Mar 2006 11:59:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060323165947.3B46868122@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv32694 Modified Files: mcclim.asd Log Message: * mcclim.asd (defsystem :clim-system): include a few more of the examples. (patch by Douglas Crosher, mcclim-devel, 'Patch: clim-example system definition', 16 March 2006) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/23 15:27:23 1.13 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/23 16:59:47 1.14 @@ -286,16 +286,24 @@ :components ((:file "calculator") (:file "colorslider") + (:file "menutest") ; extra (:file "address-book") (:file "traffic-lights") (:file "clim-fig") (:file "postscript-test") + (:file "puzzle") + (:file "transformations-test") + (:file "demodemo") (:file "stream-test") (:file "presentation-test") + (:file "dragndrop") #+clx (:file "gadget-test") (:file "accepting-values") (:file "method-browser") - (:file "dragndrop-translator"))))) + (:file "dragndrop-translator"))) + (:module "Goatee" + :components + ((:file "goatee-test"))))) ;;; This won't load in SBCL, either. I have really crappy code to ;;; extract dependency information from :serial t ASDF systems, but From varkesteijn at common-lisp.net Thu Mar 23 17:03:40 2006 From: varkesteijn at common-lisp.net (varkesteijn) Date: Thu, 23 Mar 2006 12:03:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060323170340.3EF087A001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv2336 Modified Files: commands.lisp Log Message: * fix remove-command-from-command-table * add relevant test --- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/20 08:15:26 1.60 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/23 17:03:38 1.61 @@ -198,11 +198,11 @@ (when (typep item 'menu-item) (remove-menu-item-from-command-table table (command-menu-item-name item) - :errorp nil) - - (when (command-item-name item) - (remhash (command-item-name item) (command-line-names table))) - (remhash command-name (commands table))))))) + :errorp nil)) + + (when (command-item-name item) + (remhash (command-item-name item) (command-line-names table))) + (remhash command-name (commands table)))))) (defun add-command-to-command-table (command-name command-table From varkesteijn at common-lisp.net Thu Mar 23 17:03:40 2006 From: varkesteijn at common-lisp.net (varkesteijn) Date: Thu, 23 Mar 2006 12:03:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Tests Message-ID: <20060323170340.5637E7A000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Tests In directory clnet:/tmp/cvs-serv2336/Tests Modified Files: commands.lisp Log Message: * fix remove-command-from-command-table * add relevant test --- /project/mcclim/cvsroot/mcclim/Tests/commands.lisp 2005/09/30 16:02:33 1.2 +++ /project/mcclim/cvsroot/mcclim/Tests/commands.lisp 2006/03/23 17:03:40 1.3 @@ -41,3 +41,12 @@ (lookup-keystroke-command-item gesture 'menu-test-table))))) 'menu-test-table) (assert (= count 1))) + +(define-command-table removal-test-table) +(add-command-to-command-table 'com-test-command 'removal-test-table) +(remove-command-from-command-table 'com-test-command 'removal-test-table) +(assert (handler-case + (remove-command-from-command-table 'com-test-command + 'removal-test-table) + (command-not-present () t) + (:no-error (x) (declare (ignore x)) nil))) From tmoore at common-lisp.net Fri Mar 24 11:18:26 2006 From: tmoore at common-lisp.net (tmoore) Date: Fri, 24 Mar 2006 06:18:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle Message-ID: <20060324111826.F1A5214005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory clnet:/tmp/cvs-serv7141/Backends/beagle Modified Files: README.txt Log Message: Ripped out the CLIM event process in the Beagle back end. Events are delivered to the principal Cocoa thread which can deliver them directly to the CLIM application processes. --- /project/mcclim/cvsroot/mcclim/Backends/beagle/README.txt 2005/09/22 11:40:30 1.19 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/README.txt 2006/03/24 11:18:26 1.20 @@ -32,16 +32,22 @@ -Duncan duncan at robotcat.demon.co.uk +I've taken a look at the Beagle backend for the .9.2 release of McCLIM +and added some of my own notes and edits to this file. + +-Tim +moore at bricoworks.com + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% INSTALLATION -The code has been written using OpenMCL Version (Beta: Darwin) 0.14.3 and -up-to-date McCLIM sources (since both are available within the same CVS -module, it should be safe to assume the back end will work with whatever -McCLIM sources were checked out at the same time). Hopefully newer versions -of OpenMCL will be ok; unfortunately older versions will not work due to -changes in the OpenMCL Cocoa Bridge. +The code has been tested using OpenMCL Version 1.0 and up-to-date +McCLIM sources (since both are available within the same CVS module, +it should be safe to assume the back end will work with whatever +McCLIM sources were checked out at the same time). Hopefully newer +versions of OpenMCL will be ok; unfortunately older versions will not +work due to changes in the OpenMCL Cocoa Bridge. Compiling and running the back end currently is a straight-forward (if rather limiting [see note #2]) task: @@ -57,8 +63,14 @@ 5. Evaluate '(asdf:oos 'asdf:load-op :mcclim)' [See note #3] The McCLIM Listener should now be able to be started from the OpenMCL -Listener by evaluating '(clim-listener:run-listener)'. See the McCLIM -installation notes for other things you might want to do. [See note #1] +Listener by evaluating '(clim-listener:run-listener)' after loading it +with '(asdf:oos 'asdf:load-op :clim-listener)'. See the McCLIM +installation notes for other things you might want to do. [See note +#1]. If you load the clim-examples system, you cause the CLX backend +to be loaded too; after this you currently need to set a default +backend with '(setf climi:*default-server-path* :beagle)' to avoid +problems. + Note #1: Some of the examples provided with McCLIM do not execute when using the Beagle back end, either because of unimplemented features in From tmoore at common-lisp.net Fri Mar 24 11:18:27 2006 From: tmoore at common-lisp.net (tmoore) Date: Fri, 24 Mar 2006 06:18:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/input Message-ID: <20060324111827.439B816006@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input In directory clnet:/tmp/cvs-serv7141/Backends/beagle/input Modified Files: events.lisp Log Message: Ripped out the CLIM event process in the Beagle back end. Events are delivered to the principal Cocoa thread which can deliver them directly to the CLIM application processes. --- /project/mcclim/cvsroot/mcclim/Backends/beagle/input/events.lisp 2006/03/23 15:27:24 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/input/events.lisp 2006/03/24 11:18:27 1.11 @@ -28,7 +28,7 @@ #|| -$Id: events.lisp,v 1.10 2006/03/23 15:27:24 tmoore Exp $ +$Id: events.lisp,v 1.11 2006/03/24 11:18:27 tmoore Exp $ Events in Cocoa --------------- @@ -119,52 +119,48 @@ ;;; us (apart from the menus use grabbing I think) -(defparameter *mcclim-event-queue* nil) - - ;;; TODO: roll the next two methods into a single code-block; only the ;;; beagle-event|notification-to-clim-event method differs ;;; between them. (defmethod add-event-to-queue (mirror event) - "Adds an event to the dynamically scoped *mcclim-event-queue* queue, after + "Adds an event to the event queue associated with the mirror's sheet, after conversion from a Cocoa event MACPTR to a CLIM event. This method signals the port event semaphore when an event is added to the queue. Cocoa events that map onto a NIL CLIM event (i.e. those that are not handled) are not added to the queue." - (declare (special *beagle-port - *mcclim-event-queue*)) (let ((clim-event (beagle-event-to-clim-event mirror event))) (unless (not clim-event) ;; This provides way too much information... - #+nil + #-(and) (unless (or (typep event 'pointer-enter-event) (typep event 'pointer-exit-event)) (format *trace-output* "Adding event to queue: ") (describe-object clim-event *trace-output*) (terpri *trace-output*)) - (setf *mcclim-event-queue* (nconc *mcclim-event-queue* (list clim-event))) - (ccl:signal-semaphore (beagle-port-event-semaphore *beagle-port*))))) + (distribute-event *beagle-port* clim-event)))) (defmethod add-notification-to-queue (window notification &optional origin-x origin-y width height) - "Adds an event to the dynamically scoped *mcclim-event-queue* queue, after + "Adds an event to the queue, after queue associated with the mirror's sheet after conversion from a Cocoa notification MACPTR to a CLIM event. This method signals the port event semaphore when a notification is added to the queue." - (declare (special *beagle-port* - *mcclim-event-queue*)) (let ((clim-event (beagle-notification-to-clim-event window notification origin-x origin-y width height))) (unless (not clim-event) - (setf *mcclim-event-queue* (nconc *mcclim-event-queue* (list clim-event))) - (ccl:signal-semaphore (beagle-port-event-semaphore *beagle-port*))))) + (distribute-event *beagle-port* clim-event)))) ;;; timeout = timeout delay in seconds -;;; If no timeout is specified (nil timeout), this method hangs around until an event arrives. +;;; If no timeout is specified (nil timeout), this method hangs around until an +;;; event arrives. +;;; +;;; get-next-event is not defined because it is not used in the Beagle backend +;;; (there is no event process calling process-next-event). +#-(and) (defmethod get-next-event ((port beagle-port) &key wait-function (timeout nil)) (declare (special *mcclim-event-queue* *beagle-port*) (ignore wait-function)) From tmoore at common-lisp.net Fri Mar 24 11:18:27 2006 From: tmoore at common-lisp.net (tmoore) Date: Fri, 24 Mar 2006 06:18:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/native Message-ID: <20060324111827.7AEF61800A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native In directory clnet:/tmp/cvs-serv7141/Backends/beagle/native Modified Files: lisp-view.lisp Log Message: Ripped out the CLIM event process in the Beagle back end. Events are delivered to the principal Cocoa thread which can deliver them directly to the CLIM application processes. --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-view.lisp 2005/05/16 22:13:17 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-view.lisp 2006/03/24 11:18:27 1.2 @@ -236,78 +236,32 @@ ;;; Event handling methods. -;;; Add the event they're invoked with to the "event queue" we define -;;; in the events.lisp file. +;;; Add the event they're invoked with to the event queue of the associated +;;;sheet. ;;; ;;; Cocoa docs say if you don't want to handle the event, you should ;;; pass it on to your superclass. So that's what we do. ;;; ---------------------------------------------------------------------------- -(define-objc-method ((:void :mouse-moved event) lisp-view) - (when (> (logand (view-event-mask self) #$NSMouseMovedMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received MOUSE MOVED event: ~S" (description event))) - (add-event-to-queue self event))) - -(define-objc-method ((:void :mouse-down event) lisp-view) - (when (> (logand (view-event-mask self) #$NSLeftMouseDownMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received MOUSE DOWN event: ~S" (description event))) - (add-event-to-queue self event))) - -(define-objc-method ((:void :mouse-dragged event) lisp-view) - (when (> (logand (view-event-mask self) #$NSLeftMouseDraggedMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received MOUSE DRAGGED event: ~S" (description event))) - (add-event-to-queue self event))) - -(define-objc-method ((:void :mouse-up event) lisp-view) - (when (> (logand (view-event-mask self) #$NSLeftMouseUpMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received MOUSE UP event: ~S" (description event))) - (add-event-to-queue self event))) - -(define-objc-method ((:void :mouse-entered event) lisp-view) - (when (> (logand (view-event-mask self) #$NSMouseEnteredMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received MOUSE ENTERED event: ~S" (description event))) - (add-event-to-queue self event))) - -(define-objc-method ((:void :mouse-exited event) lisp-view) - (when (> (logand (view-event-mask self) #$NSMouseExitedMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received MOUSE EXITED event: ~S" (description event))) - (add-event-to-queue self event))) - -(define-objc-method ((:void :right-mouse-down event) lisp-view) - (when (> (logand (view-event-mask self) #$NSRightMouseDownMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received RIGHT MOUSE DOWN event: ~S" (description event))) - (add-event-to-queue self event))) - -(define-objc-method ((:void :right-mouse-dragged event) lisp-view) - (when (> (logand (view-event-mask self) #$NSRightMouseDraggedMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received RIGHT MOUSE DRAGGED event: ~S" (description event))) - (add-event-to-queue self event))) - -(define-objc-method ((:void :right-mouse-up event) lisp-view) - (when (> (logand (view-event-mask self) #$NSRightMouseUpMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received RIGHT MOUSE UP event: ~S" (description event))) - (add-event-to-queue self event))) - -(define-objc-method ((:void :other-mouse-down event) lisp-view) - (when (> (logand (view-event-mask self) #$NSOtherMouseDownMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received OTHER MOUSE DOWN event: ~S" (description event))) - (add-event-to-queue self event))) - -(define-objc-method ((:void :other-mouse-dragged event) lisp-view) - (when (> (logand (view-event-mask self) #$NSOtherMouseDraggedMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received OTHER MOUSE DRAGGED event: ~S" (description event))) - (add-event-to-queue self event))) - -(define-objc-method ((:void :other-mouse-up event) lisp-view) - (when (> (logand (view-event-mask self) #$NSOtherMouseUpMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received OTHER MOUSE UP event: ~S" (description event))) - (add-event-to-queue self event))) - -(define-objc-method ((:void :scroll-wheel event) lisp-view) - (when (> (logand (view-event-mask self) #$NSScrollWheelMask) 0) -;;; (nslog (format nil "LISP-VIEW: Received SCROLL WHEEL event: ~S" (description event))) - (add-event-to-queue self event))) +(macrolet ((frob (selector mask) + `(define-objc-method ((:void ,selector event) lisp-view) + (unless (zerop (logand (view-event-mask self) ,mask)) + ;; (nslog (format nil "LISP-VIEW: Received ~S event: ~S" ',selector (description event))) + (add-event-to-queue self event))))) + (frob :mouse-moved #$NSMouseMovedMask) + (frob :mouse-down #$NSLeftMouseDownMask) + (frob :mouse-dragged #$NSLeftMouseDraggedMask) + (frob :mouse-up #$NSLeftMouseUpMask) + (frob :mouse-entered #$NSMouseEnteredMask) + (frob :mouse-exited #$NSMouseExitedMask) + (frob :right-mouse-down #$NSRightMouseDownMask) + (frob :right-mouse-dragged #$NSRightMouseDraggedMask) + (frob :right-mouse-up #$NSRightMouseUpMask) + (frob :other-mouse-down #$NSOtherMouseDownMask) + (frob :other-mouse-dragged #$NSOtherMouseDraggedMask) + (frob :other-mouse-up #$NSOtherMouseUpMask) + (frob :scroll-wheel #$NSScrollWheelMask)) ;;; ---------------------------------------------------------------------------- From tmoore at common-lisp.net Fri Mar 24 11:18:27 2006 From: tmoore at common-lisp.net (tmoore) Date: Fri, 24 Mar 2006 06:18:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/windowing Message-ID: <20060324111827.B2F031C001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory clnet:/tmp/cvs-serv7141/Backends/beagle/windowing Modified Files: port.lisp Log Message: Ripped out the CLIM event process in the Beagle back end. Events are delivered to the principal Cocoa thread which can deliver them directly to the CLIM application processes. --- /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/port.lisp 2005/06/16 09:27:51 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/port.lisp 2006/03/24 11:18:27 1.6 @@ -26,8 +26,14 @@ (in-package :beagle) +;;; The beagle backend of McCLIM runs inside a Cocoa application. There is one +;;; port, associated with that application. There is no separate event process; +;;; the main thread of the Cocoa app is notified of events and puts them on the +;;; proper event queues using the mapping in the port object between NSViews +;;; and sheets. (defparameter *beagle-port* nil) + (defparameter *default-beagle-frame-manager* 'beagle:beagle-aqua-frame-manager "Specifies the frame manager that should be used by default when the port creates its frame manager. Permissable values are 'beagle::beagle-standard-frame-manager and @@ -53,6 +59,10 @@ ;;; in the long-term. (NB. this duplicates behaviour in McCLIM "PORT" type but that uses ;;; 'eq tests in the hashtables, and MACPTRs (which is what a mirror boils down to being in ;;; the end) are only ever 'eql.) +;;; +;;; I'm not sure what Duncan was getting at with that comment; +;;; mirror/sheet/NSView seems like a fine correspondence to me, unless you want +;;; to only use one mirror per window. -- moore (defclass beagle-port (basic-port) ((screen :initform nil :accessor beagle-port-screen) @@ -63,9 +73,7 @@ ;; holds sheet that should receive key events. ::FIXME:: need to tell McCLIM which sheet ;; is taking keyboard events; look into how all that bit hangs together, it's changed ;; since this was written. - (key-focus-sheet :initform nil :accessor beagle-port-key-focus) - (event-semaphore :initform nil :accessor beagle-port-event-semaphore))) - + (key-focus-sheet :initform nil :accessor beagle-port-key-focus))) (defmethod destroy-port :before ((port beagle-port)) ;; clear out color-table, view-table, cached images etc. ::TODO:: check this logic is correct... @@ -133,8 +141,10 @@ ;;; the port-server-path? Not sure...) to permit the user to make use of screens other ;;; than the main screen. (defmethod initialize-beagle ((port beagle-port)) - - (ccl::create-autorelease-pool) + ;; If we were not already running inside a Cocoa application (OpenMCL's + ;; COCOA), we would obviously have to invoke the magic here to start up a + ;; Cocoa main thread. + (ccl::create-autorelease-pool) ;XXX Is this necessary? -- moore ;; CLX port gets some options here and uses those to set stuff up. We should probably do ;; this too, in the future ::FIXME:: @@ -150,24 +160,7 @@ ;;; :WITH-OBJECT nil)) (make-cursor-table port) - (make-graft port) - - (setf (beagle-port-event-semaphore port) (ccl:make-semaphore)) - - (setf (port-event-process port) - (clim-sys:make-process - (lambda () - (ccl::create-autorelease-pool) - (loop - (with-simple-restart - (restart-event-loop "Restart CLIM's event loop.") -;;; (with-autorelease-pool - (loop - ;; process-next-event is defined in ports.lisp. It invokes - ;; get-next-event in the backend to actually get the next - ;; event in the queue - (process-next-event port))))) - :name (format nil "~S's event process." port))));) + (make-graft port)) ;;; From CLX/port.lisp From crhodes at common-lisp.net Fri Mar 24 11:41:16 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 24 Mar 2006 06:41:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Null Message-ID: <20060324114116.BCCE323003@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Null In directory clnet:/tmp/cvs-serv9552/Null Log Message: Directory /project/mcclim/cvsroot/mcclim/Backends/Null added to the repository From crhodes at common-lisp.net Fri Mar 24 11:45:03 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 24 Mar 2006 06:45:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060324114503.93B7530000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv9598 Modified Files: mcclim.asd Log Message: Add highly experimental Null backend. The idea is that the null backend implements all the mcclim machinery for a backend, but doesn't side-effect the rest of the world; this should make it possible to write test cases for mcclim-internal invariants, and potentially also mcclim applications, by running them under this backend. This utopia is quite a way off, however; what actually works at present is not much more than: (setf clim:*default-server-path* :null) (let ((stream (clim:open-window-stream) (clim:draw-rectangle* stream 10 10 100 200) (clim:stream-output-history stream)) but it's a start. (Additionally, the Null backend could be used as a starting point for implementing other backends.) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/23 16:59:47 1.14 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/24 11:45:03 1.15 @@ -246,6 +246,18 @@ (:file "graft" :depends-on ("port" "package")) (:file "frame-manager" :depends-on ("medium" "port" "package")))))) +(defsystem :clim-null + :depends-on (:clim) + :components + ((:module "Backends/Null" + :pathname #.(make-pathname :directory '(:relative "Backends" "Null")) + :components + ((:file "package") + (:file "port" :depends-on ("package")) + (:file "medium" :depends-on ("port" "package")) + (:file "graft" :depends-on ("port" "package")) + (:file "frame-manager" :depends-on ("medium" "port" "package")))))) + ;;; TODO/asf: I don't have the required libs to get :clim-opengl to load. tough. (clim-defsystem (:clim-opengl :depends-on (:clim)) "Backends/OpenGL/opengl-x-frame-manager" @@ -270,6 +282,9 @@ ;; But until it's ready, it's no use forcing users to ;; cope with possible bugs. ;; #+(or openmcl mcl) :clim-beagle + + ;; null backend + :clim-null ) :components ((:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp")))) From crhodes at common-lisp.net Fri Mar 24 11:45:03 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 24 Mar 2006 06:45:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Null Message-ID: <20060324114503.D106F32005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Null In directory clnet:/tmp/cvs-serv9598/Backends/Null Added Files: frame-manager.lisp graft.lisp medium.lisp package.lisp port.lisp Log Message: Add highly experimental Null backend. The idea is that the null backend implements all the mcclim machinery for a backend, but doesn't side-effect the rest of the world; this should make it possible to write test cases for mcclim-internal invariants, and potentially also mcclim applications, by running them under this backend. This utopia is quite a way off, however; what actually works at present is not much more than: (setf clim:*default-server-path* :null) (let ((stream (clim:open-window-stream) (clim:draw-rectangle* stream 10 10 100 200) (clim:stream-output-history stream)) but it's a start. (Additionally, the Null backend could be used as a starting point for implementing other backends.) --- /project/mcclim/cvsroot/mcclim/Backends/Null/frame-manager.lisp 2006/03/24 11:45:03 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Null/frame-manager.lisp 2006/03/24 11:45:03 1.1 ;;; -*- Mode: Lisp; Package: CLIM-NULL -*- ;;; (c) 2005 Christophe Rhodes (c.rhodes at gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-null) (defclass null-frame-manager (frame-manager) ()) (defmethod make-pane-1 ((fm null-frame-manager) (frame application-frame) type &rest initargs) (apply #'make-instance type :frame frame :manager fm :port (port frame) initargs)) (defmethod adopt-frame :after ((fm null-frame-manager) (frame application-frame)) ()) (defmethod note-space-requirements-changed :after ((graft null-graft) pane) ()) --- /project/mcclim/cvsroot/mcclim/Backends/Null/graft.lisp 2006/03/24 11:45:03 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Null/graft.lisp 2006/03/24 11:45:03 1.1 ;;; -*- Mode: Lisp; Package: CLIM-CLX -*- ;;; (c) copyright 2005 Christophe Rhodes (c.rhodes at gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-null) (defclass null-graft (graft) ()) (defmethod graft-width ((graft null-graft) &key (units :device)) ()) (defmethod graft-height ((graft null-graft) &key (units :device)) ()) --- /project/mcclim/cvsroot/mcclim/Backends/Null/medium.lisp 2006/03/24 11:45:03 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Null/medium.lisp 2006/03/24 11:45:03 1.1 ;;; -*- Mode: Lisp; Package: CLIM-NULL -*- ;;; (c) 2005 Christophe Rhodes (c.rhodes at gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-null) (defclass null-medium (basic-medium) ((buffering-output-p :accessor medium-buffering-output-p))) (defmethod (setf medium-text-style) :before (text-style (medium null-medium)) ()) (defmethod (setf medium-line-style) :before (line-style (medium null-medium)) ()) (defmethod (setf medium-clipping-region) :after (region (medium null-medium)) ()) (defmethod medium-copy-area ((from-drawable null-medium) from-x from-y width height (to-drawable null-medium) to-x to-y) nil) #+nil ; FIXME: PIXMAP class (progn (defmethod medium-copy-area ((from-drawable null-medium) from-x from-y width height (to-drawable pixmap) to-x to-y) nil) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable null-medium) to-x to-y) ()) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable pixmap) to-x to-y) ())) (defmethod medium-draw-point* ((medium null-medium) x y) ()) (defmethod medium-draw-points* ((medium null-medium) coord-seq) ()) (defmethod medium-draw-line* ((medium null-medium) x1 y1 x2 y2) ()) ;; FIXME: Invert the transformation and apply it here, as the :around ;; methods on transform-coordinates-mixin will cause it to be applied ;; twice, and we need to undo one of those. The ;; transform-coordinates-mixin stuff needs to be eliminated. (defmethod medium-draw-lines* ((medium null-medium) coord-seq) (let ((tr (invert-transformation (medium-transformation medium)))) (declare (ignore tr)) nil)) (defmethod medium-draw-polygon* ((medium null-medium) coord-seq closed filled) ()) (defmethod medium-draw-rectangle* ((medium null-medium) left top right bottom filled) ()) (defmethod medium-draw-rectangles* ((medium null-medium) position-seq filled) ()) (defmethod medium-draw-ellipse* ((medium null-medium) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) ()) (defmethod medium-draw-circle* ((medium null-medium) center-x center-y radius start-angle end-angle filled) ()) (defmethod text-style-ascent (text-style (medium null-medium)) 1) (defmethod text-style-descent (text-style (medium null-medium)) 1) (defmethod text-style-height (text-style (medium null-medium)) (+ (text-style-ascent text-style medium) (text-style-descent text-style medium))) (defmethod text-style-character-width (text-style (medium null-medium) char) 1) ;;; FIXME: this one is nominally backend-independent (defmethod text-style-width (text-style (medium null-medium)) (text-style-character-width text-style medium #\m)) (defmethod text-size ((medium null-medium) string &key text-style (start 0) end) (setf string (etypecase string (character (string string)) (string string))) (let ((width 0) (height (text-style-height text-style medium)) (x (- (or end (length string)) start)) (y 0) (baseline (text-style-ascent text-style medium))) (do ((pos (position #\Newline string :start start :end end) (position #\Newline string :start (1+ pos) :end end))) ((null pos) (values width height x y baseline)) (let ((start start) (end pos)) (setf x (- end start)) (setf y (+ y (text-style-height text-style medium))) (setf width (max width x)) (setf height (+ height (text-style-height text-style medium))) (setf baseline (+ baseline (text-style-height text-style medium))))))) (defmethod medium-draw-text* ((medium null-medium) string x y start end align-x align-y toward-x toward-y transform-glyphs) ()) #+nil (defmethod medium-buffering-output-p ((medium null-medium)) t) #+nil (defmethod (setf medium-buffering-output-p) (buffer-p (medium null-medium)) buffer-p) (defmethod medium-draw-glyph ((medium null-medium) element x y align-x align-y toward-x toward-y transform-glyphs) ()) (defmethod medium-finish-output ((medium null-medium)) ()) (defmethod medium-force-output ((medium null-medium)) ()) (defmethod medium-clear-area ((medium null-medium) left top right bottom) ()) (defmethod medium-beep ((medium null-medium)) ()) (defmethod invoke-with-special-choices (continuation (medium null-medium)) (let ((sheet (medium-sheet medium))) (funcall continuation (sheet-medium sheet)))) (defmethod medium-miter-limit ((medium null-medium)) 0) --- /project/mcclim/cvsroot/mcclim/Backends/Null/package.lisp 2006/03/24 11:45:03 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Null/package.lisp 2006/03/24 11:45:03 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- (in-package :common-lisp-user) (defpackage :clim-null (:use :clim :clim-lisp :clim-backend)) --- /project/mcclim/cvsroot/mcclim/Backends/Null/port.lisp 2006/03/24 11:45:03 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Null/port.lisp 2006/03/24 11:45:03 1.1 ;;; -*- Mode: Lisp; Package: CLIM-NULL; -*- ;;; (c) 2005 Christophe Rhodes (c.rhodes at gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-null) (defclass null-pointer (standard-pointer) ((cursor :accessor pointer-cursor :initform :upper-left) (x :initform 0) (y :initform 0))) (defclass null-port (basic-port) ((id) (pointer :accessor port-pointer :initform (make-instance 'null-pointer)) (window :initform nil :accessor null-port-window))) (defun parse-null-server-path (path) path) ;;; FIXME: if :port-type and :server-path-parser aren't CLIM-specified ;;; keywords, they should be altered to be in some mcclim-internal ;;; package instead. (setf (get :null :port-type) 'null-port) (setf (get :null :server-path-parser) 'parse-null-server-path) (defmethod initialize-instance :after ((port null-port) &rest initargs) (declare (ignore initargs)) (setf (slot-value port 'id) (gensym "NULL-PORT-")) ;; FIXME: it seems bizarre for this to be necessary (push (make-instance 'null-frame-manager :port port) (slot-value port 'climi::frame-managers))) (defmethod print-object ((object null-port) stream) (print-unreadable-object (object stream :identity t :type t) (format stream "~S ~S" :id (slot-value object 'id)))) (defmethod port-set-mirror-region ((port null-port) mirror mirror-region) ()) (defmethod port-set-mirror-transformation ((port null-port) mirror mirror-transformation) ()) (defmethod realize-mirror ((port null-port) (sheet mirrored-sheet-mixin)) nil) (defmethod destroy-mirror ((port null-port) (sheet mirrored-sheet-mixin)) ()) (defmethod mirror-transformation ((port null-port) mirror) ()) (defmethod port-set-sheet-region ((port null-port) (graft graft) region) ()) (defmethod port-set-sheet-transformation ((port null-port) (graft graft) transformation) ()) (defmethod port-set-sheet-transformation ((port null-port) (sheet mirrored-sheet-mixin) transformation) ()) (defmethod port-set-sheet-region ((port null-port) (sheet mirrored-sheet-mixin) region) ()) (defmethod port-enable-sheet ((port null-port) (mirror mirrored-sheet-mixin)) ()) (defmethod port-disable-sheet ((port null-port) (mirror mirrored-sheet-mixin)) ()) (defmethod destroy-port :before ((port null-port)) ()) (defmethod port-motion-hints ((port null-port) (mirror mirrored-sheet-mixin)) ()) (defmethod (setf port-motion-hints) (value (port null-port) (sheet mirrored-sheet-mixin)) value) (defmethod get-next-event ((port null-port) &key wait-function (timeout nil)) ()) (defmethod make-graft ((port null-port) &key (orientation :default) (units :device)) (make-instance 'null-graft :port port :mirror (gensym) :orientation orientation :units units)) (defmethod make-medium ((port null-port) sheet) (make-instance 'null-medium :sheet sheet)) (defmethod text-style-mapping ((port null-port) text-style &optional character-set) ()) (defmethod (setf text-style-mapping) (font-name (port null-port) (text-style text-style) &optional character-set) ()) (defmethod port-character-width ((port null-port) text-style char) ()) (defmethod port-string-width ((port null-port) text-style string &key (start 0) end) ()) (defmethod port-mirror-width ((port null-port) sheet) ()) (defmethod port-mirror-height ((port null-port) sheet) ()) (defmethod graft ((port null-port)) (first (climi::port-grafts port))) (defmethod port-allocate-pixmap ((port null-port) sheet width height) ()) (defmethod port-deallocate-pixmap ((port null-port) pixmap) #+nil (when (port-lookup-mirror port pixmap) (destroy-mirror port pixmap))) (defmethod pointer-position ((pointer null-pointer)) (values (slot-value pointer 'x) (slot-value pointer 'y))) (defmethod pointer-button-state ((pointer null-pointer)) ()) (defmethod port-modifier-state ((port null-port)) ()) (defmethod synthesize-pointer-motion-event ((pointer null-pointer)) ()) ;;; Set the keyboard input focus for the port. (defmethod %set-port-keyboard-focus (focus (port null-port) &key timestamp) ()) (defmethod port-force-output ((port null-port)) ()) ;; FIXME: What happens when CLIM code calls tracking-pointer recursively? (defmethod port-grab-pointer ((port null-port) pointer sheet) [25 lines skipped] From crhodes at common-lisp.net Fri Mar 24 12:03:31 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 24 Mar 2006 07:03:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Null Message-ID: <20060324120331.D32891B005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Null In directory clnet:/tmp/cvs-serv13432 Modified Files: medium.lisp Log Message: Implement (kind of) text-bounding-rectangle* for the Null backend. Somewhat astoundingly, now climacs runs well enough to inspect the text in the info pane: # --- /project/mcclim/cvsroot/mcclim/Backends/Null/medium.lisp 2006/03/24 11:45:03 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Null/medium.lisp 2006/03/24 12:03:31 1.2 @@ -126,6 +126,10 @@ (setf height (+ height (text-style-height text-style medium))) (setf baseline (+ baseline (text-style-height text-style medium))))))) +(defmethod climi::text-bounding-rectangle* + ((medium null-medium) string &key text-style (start 0) end) + (text-size medium string :text-style text-style :start start :end end)) + (defmethod medium-draw-text* ((medium null-medium) string x y start end align-x align-y From afuchs at common-lisp.net Sun Mar 26 19:57:00 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 26 Mar 2006 14:57:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060326195700.18C1E5300E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25264 Modified Files: README Log Message: Add release notes for 0.9.2. Fix README. Remove .tar.gz files. * README now mentions mcclim-devel and the correct release. * release notes: self-explanatory. * Removed the .tar.gz files, so no more uselessly gigantic checkouts. --- /project/mcclim/cvsroot/mcclim/README 2006/03/15 22:56:54 1.3 +++ /project/mcclim/cvsroot/mcclim/README 2006/03/26 19:56:59 1.4 @@ -1,4 +1,4 @@ -McCLIM 0.9 "Armistice" +McCLIM 0.9.2 "Laetare Sunday" This is McCLIM, an implementation of the "Common Lisp Interface Manager CLIM II Specification." It currently works on X Windows using @@ -14,6 +14,10 @@ Doc - the start of a manual Apps - sample applications. This includes: +Apps/Debugger - Peter Mechleborg's debugger (similar to SLIME's) +Apps/Functional-Geometry - Frank Buss and Rainer Joswig's functional + geometry package for drawing "Escher" tiles. +Apps/Inspector - Robert Strandh's inspector (similar to SLIME's) Apps/Listener - Andy Hefner's incredibly cool Lisp listener Apps/Scigraph - BBN's graphing package, currently not quite working @@ -32,4 +36,4 @@ Spec - The LaTeX source to the CLIM specification. -Please send bug reports and comments to free-clim at mikemac.com +Please send bug reports and comments to mcclim-devel at common-lisp.net \ No newline at end of file From afuchs at common-lisp.net Sun Mar 26 19:57:00 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 26 Mar 2006 14:57:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/OpenGL/archives Message-ID: <20060326195700.7B02254055@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/OpenGL/archives In directory clnet:/tmp/cvs-serv25264/Backends/OpenGL/archives Removed Files: GCL-GL.tar.gz GCL-GL2.tar.gz allegro-xlib-and-gl.tar.gz cmucl-xlib-and-gl-2000-09-18.tar.gz cmucl-xlib-and-gl-2001-03-14.tar.gz cmucl-xlib-and-gl-2001-12-05-bts.tar.gz opengl_lisp_bindings_win.zip Log Message: Add release notes for 0.9.2. Fix README. Remove .tar.gz files. * README now mentions mcclim-devel and the correct release. * release notes: self-explanatory. * Removed the .tar.gz files, so no more uselessly gigantic checkouts. From afuchs at common-lisp.net Sun Mar 26 19:57:01 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 26 Mar 2006 14:57:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage/downloads Message-ID: <20060326195701.161ED54055@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory clnet:/tmp/cvs-serv25264/Webpage/downloads Removed Files: mcclim-0.9.1.tar.gz mcclim-0.9.1.tar.gz.asc Log Message: Add release notes for 0.9.2. Fix README. Remove .tar.gz files. * README now mentions mcclim-devel and the correct release. * release notes: self-explanatory. * Removed the .tar.gz files, so no more uselessly gigantic checkouts. From afuchs at common-lisp.net Sun Mar 26 19:58:36 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 26 Mar 2006 14:58:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ReleaseNotes Message-ID: <20060326195836.3D6A160010@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ReleaseNotes In directory clnet:/tmp/cvs-serv25413/ReleaseNotes Added Files: 0-9-2-laetare-sunday Log Message: Erm. Actually add the release notes. --- /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-2-laetare-sunday 2006/03/26 19:58:36 NONE +++ /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-2-laetare-sunday 2006/03/26 19:58:36 1.1 RELEASE NOTES FOR McCLIM 0.9.2, "Laetare Sunday": Compatibility ============= This release works on CMUCL, SBCL, CLISP, OpenMCL, Allegro CL, LispWorks, and the Scieneer CL, using the CLX X Window bindings. Changes to Backends =================== Copy & Paste code in the CLX backend was improved and should now adhere more strictly to ICCCM. Support for connecting to a ssh-forwarded display was restored. Several unused parts (marked with #+unicode) of the CLX backend were removed, thus restoring buildability on installations of clisp that have the unicode feature turned on. Double buffering for panes was implemented. To use it, create panes with the :double-buffering t initarg. There is now rudimentary support for entering non-Ascii characters from X11 ports using SBCL CLX (a.k.a. telent CLX). McCLIM ships experimental support for TrueType font rendering using the FreeType libraries and the free Bitstream Vera fonts. To use it, link Experimental/freetype/mcclim-freetype.asd to one of your asdf:*central-registry* directories and load the "MCCLIM-FREETYPE" system. An experimental "Null" backend was added that should allow testing of CLIM functionality without requiring a GUI environment to run. Changes to the Documentation ============================ A new chapter on contributed applications was added. Several new figures and examples were added to the manual Clemens Fruhwirth added a CLIM tutorial paper called "A Guided Tour to CLIM". It is available in Doc/Guided-Tour/. Changes to Contributed Applications and Examples ================================================ New application: A CLIM Debugger (by Peter Mechlenborg). It resides in Apps/Debugger/. New application: Functional-Geometry by Frank Buss and Rainer Joswig. It resides in Apps/Functional-Geometry/. The Inspector now is now able to disassemble functions and inspect pathnames. The Listener can now produce vertically-aligned graphs. The Scigraph application now builds on SBCL again. A demo for drag-and-drop-translators was added. Further additions to McCLIM =========================== There is now a test suite, located in Tests/. It contains tests for regions, bounding rectangles, transformations, commands, and the PostScript backend. With the addition of the Null backend, we hope to add several more tests for more chapters of the CLIM spec. New Extension "conditional-commands": allows activation/deactivation of commands when other commands are invoked. It resides in Extensions/conditional-commands/. Status of the CLIM 2 Spec Implementation ======================================== Here is a list of what we think works, organized by chapters and sections of the CLIM 2 specification. Chapter 3 Regions Mostly finished. There are some troublesome parts of the specification that may not be implemented for all possible regions, for instance region-contains-region-p. There may not be an efficient way of implementing this function for all kinds of regions. Chapter 4, Bounding rectangles Finished Chapter 5, Affine transformations Finished Chapter 6, Overview of window facilities Finished Chapter 7, Properties of sheets Finished, though the correct behavior of sheet transformations may not have been tested. Chapter 8, Sheet protocols Finished Chapter 9, Ports, Grafts, and Mirrored sheets Finished Chapter 10, Sheet and medium output facilities Finished Chapter 11, Text styles Mostly complete. There is now experimental support for device font text styles (via make-device-font-text-style) for the CLX, PostScript, and CLX+FreeType backends. Chapter 12, Graphics Finished Chapter 13, Drawing in Color I am note sure about the state of this. I thought we were doing only full opacity and full transparency, but I see traces of more general designs. Chapter 14, General Designs The composition of designs is not supported. We do support regions as designs. Chapter 15, Extended Stream Output Extended output streams are fully supported. Chapter 16, Output Recording Output recording is mostly implemented. This release ships with a standard-tree-output-record type for the first time. The tree output record type speeds up point- and region-based queries, but slows down insertion of output records by a bit. make-design-from-output-record is not implemented. *Note*: the coordinates in output records are relative to the stream. This is in conformance with the Spec, but not necessarily compatible with other CLIM implementations. Chapter 17, Table Formatting Table formatting is completely implemented. Chapter 18, Graph Formatting Graph formatting is fully implemented. The :hash-table argument to format-graph-from-roots is ignored. Support for a :dag graph type was added, as was support for vertically oriented graphs and support for the :arc-drawer argument to format-graph-from-roots. Chapter 19, Bordered Output Bordered output is fully supported. Chapter 20, Text Formatting With the exception of the :after-line-break-initially argument to filling-output, this chapter is fully implemented. Chapter 21 Incremental Redisplay The updating-output interface to incremental redisplay is implemented. McCLIM makes no effort to move i.e., bitblit, output records; they are always erased and redrawn if their position changes. This is much more compatible with support for partial transparency. The :x, :y, :parent-x and :parent-y arguments to redisplay-output-record are ignored. McCLIM follows the spirit of 21.3 "Incremental Redisplay Protocol", but we have not tried very hard to implement the vague description in the Spec. augment-draw-set, note-output-record-child-changed and propagate-output-record-changes-p are not implemented. Incremental redisplay in McCLIM may still suffer from performance problems, despite the presence of spatially-organized compound output record types. Chapter 22, Extended Stream Input The implementation of extended input streams is quite complete. (setf* pointer-position) is not implemented. There is no stream numeric argument, so that slot of the accelerator-gesture condition is always 1. Chapter 23 Presentation Types Most of the literal specification of this chapter is implemented. Specific accept and present presentation methods for some types are not implemented, so the default method may be surprising. The output record bounding rectangle is always used or highlighting and pointer testing. presentation-default-processor is not implemented. The presentation method mechanism supports all method combinations. The body of a presentation method is surrounded with a block of the same name as the presentation method, not just the magic internal name. The method by which presentation type parameters and options are decoded for the method bodies is a bit different from real CLIM. In particular, you cannot refer to the type parameters and options in the lambda list of the method. The NIL value of presentation-single-box is now supported. Presentation type histories are now partially implemented. The gesture C-M-y should recall the last entered presentation. define-drag-and-drop-translator is now implemented. Chapter 24 Input Editing and Completion Facilities with-input-editor-typeout is not implemented. The noise strings produced by input-editor-format and the strings produced by presentation-replace-input are not read-only. This could lead to interesting "issues" if the user edits them. Only a few of the suggested editing commands are implemented. An additional command that is implemented is control-meta-B, which drops into the debugger. add-input-editor-command is not implemented. with-accept-help is not implemented. Chapter 25 Menu Facilities The protocol is implemented, but McCLIM doesn't use it to draw command table menus. Chapter 26 Dialog Facilities McCLIM contains a basic, somewhat buggy implementation of accepting-values. There is little user feedback as to what has been accepted in a dialog. The user has to press the "OK" button to exit the dialog; there are no short cuts. There are no special accept-present-default methods for member or subset presentation types. Command-buttons are not implemented. There is no gadget-based implementation of accepting-values. The internal structure of accepting-values should be "culturally compatible" with real CLIM; if you have some spiffy hack, check the source. :own-window is now supported in accepting-values. Chapter 27 Command Processing command-line-complete-input is not implemented (the functionality does exist in the accept method for command-name). display-command-table-menu and menu-choose-command-from-table are not implemented. Menu-command-parser is not implemented, though the functionality obviously is. Nothing is done about partial menu commands. There is no support for numeric arguments. The command-or-form presentation type is not implemented. Chapter 28 Application Frames raise-frame, bury-frame and notify-user are not implemented. :accept-values panes are not implemented. frame-maintain-presentation-histories is not implemented. frame-drag-and-drop-feedback and frame-drag-and-drop-highlighting are now implemented. execute-frame-command ignores the possibility that frame and the current frame might be different. display-command-menu isn't implemented. Chapter 29 Panes Due to the way the space-allocation protocol is implemented, it is not easy to create application-specific layout-panes. Client code needs to know about :AROUND methods to compose-space, but they are not mentioned in the spec. restraining-pane is partially implemented. Chapter 30 Gadgets This chapter is implemented. with-output-as-gadget is not quite working yet, but it was improved since the last release. From afuchs at common-lisp.net Sun Mar 26 20:06:01 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 26 Mar 2006 15:06:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ReleaseNotes Message-ID: <20060326200601.8D82E6200C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ReleaseNotes In directory clnet:/tmp/cvs-serv26981a Modified Files: 0-9-2-laetare-sunday Log Message: Added note about INSTALL files. --- /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-2-laetare-sunday 2006/03/26 19:58:36 1.1 +++ /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-2-laetare-sunday 2006/03/26 20:06:01 1.2 @@ -6,6 +6,16 @@ This release works on CMUCL, SBCL, CLISP, OpenMCL, Allegro CL, LispWorks, and the Scieneer CL, using the CLX X Window bindings. +Changes to the Install Process +============================== + +Implementation-specific INSTALL.* files were removed. Generic and +implementation-specific Installation instructions were improved and +merged into the file INSTALL. + +This release requires the "spatial-trees" library by Christophe +Rhodes. Get it via asdf-install or at http://cliki.net/spatial-trees. + Changes to Backends =================== From afuchs at common-lisp.net Sun Mar 26 20:19:53 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 26 Mar 2006 15:19:53 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage/downloads Message-ID: <20060326201953.82918640CD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory clnet:/tmp/cvs-serv29247/downloads Modified Files: index.html Log Message: Change link to 0.9.2 tarball --- /project/mcclim/cvsroot/mcclim/Webpage/downloads/index.html 2005/07/30 17:11:36 1.12 +++ /project/mcclim/cvsroot/mcclim/Webpage/downloads/index.html 2006/03/26 20:19:53 1.13 @@ -46,13 +46,13 @@ A compressed tar file of the sources is made nightly.

Releases

- The most recent release of McCLIM is 0.9.1, in March 2005, available here: mcclim-0.9.1.tar.gz. It is also available via ASDF-INSTALL. + The most recent release of McCLIM is 0.9.2, in March 2006, available here: mcclim-0.9.2.tar.gz. It is also available via ASDF-INSTALL.

-$Date: 2005/07/30 17:11:36 $ +$Date: 2006/03/26 20:19:53 $ From crhodes at common-lisp.net Mon Mar 27 10:44:34 2006 From: crhodes at common-lisp.net (crhodes) Date: Mon, 27 Mar 2006 05:44:34 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060327104434.94D384B012@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25146 Modified Files: ports.lisp Log Message: Whoops. A missing piece of the Null backend. Put :null at the end of *server-path-search-order*. --- /project/mcclim/cvsroot/mcclim/ports.lisp 2006/03/10 21:58:13 1.50 +++ /project/mcclim/cvsroot/mcclim/ports.lisp 2006/03/27 10:44:34 1.51 @@ -25,7 +25,7 @@ (defvar *default-server-path* nil) -(defvar *server-path-search-order* '(:genera :ms-windows :gtk :clx :x11 :opengl :beagle)) +(defvar *server-path-search-order* '(:genera :ms-windows :gtk :clx :x11 :opengl :beagle :null)) (defun find-default-server-path () (loop for port in *server-path-search-order* From crhodes at common-lisp.net Mon Mar 27 10:46:11 2006 From: crhodes at common-lisp.net (crhodes) Date: Mon, 27 Mar 2006 05:46:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060327104611.86E9B5300F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26653 Modified Files: gadgets.lisp panes.lisp Log Message: Patch from Paul Werkowski for with-output-as-gadget. Still not good, but better, as I understand it. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/03/10 21:58:13 1.96 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/03/27 10:46:11 1.97 @@ -2656,17 +2656,15 @@ (defclass gadget-output-record (basic-output-record displayed-output-record) ((gadget :initarg :gadget :accessor gadget))) -(defmethod initialize-instance :after ((record gadget-output-record) &key child x y) - (let* ((sr (compose-space child)) - (width (space-requirement-width sr)) - (height (space-requirement-height sr))) - (allocate-space child width height) - (setf (gadget record) child - (rectangle-edges* record) (values x y (+ x width) (+ y height))))) +(defmethod initialize-instance :after ((record gadget-output-record) &key x y) + (setf (output-record-position record) (values x y))) (defmethod note-output-record-got-sheet ((record gadget-output-record) sheet) (multiple-value-bind (x y) (output-record-position record) (sheet-adopt-child sheet (gadget record)) + (allocate-space (gadget record) + (rectangle-width record) + (rectangle-height record)) (move-sheet (gadget record) x y))) (defmethod note-output-record-lost-sheet ((record gadget-output-record) sheet) @@ -2686,15 +2684,19 @@ (= oy gy)) (move-sheet (gadget record) ox oy))))) -(defun setup-gadget-record (sheet record x y) - ;; Here we modify the height of the current text line. This is necessary so - ;; that when the cursor advances to the next line, it does not start writing - ;; underneath the gadget. This is probably a less than optimal solution. - (with-slots (height) sheet - (setf height (max height (bounding-rectangle-height record)))) - (setf (stream-cursor-position sheet) - (values (+ x (bounding-rectangle-width record)) - y))) +(defun setup-gadget-record (sheet record) + (let* ((child (gadget record)) + (sr (compose-space child)) + (width (space-requirement-width sr)) + (height (space-requirement-height sr))) + (multiple-value-bind (x y)(output-record-position record) + (setf (rectangle-edges* record) (values x y (+ x width) (+ y height))) + (when t ; :move-cursor t + ;; Almost like LWW, except baseline of text should align with bottom + ;; of gadget? FIXME + (setf (stream-cursor-position sheet) + (values (+ x (bounding-rectangle-width record)) + (+ y (bounding-rectangle-height record)))))))) ;; The CLIM 2.0 spec does not really say what this macro should return. ;; Existing code written for "Real CLIM" assumes it returns the gadget pane @@ -2702,22 +2704,36 @@ ;; For compatibility I'm having it return (values GADGET GADGET-OUTPUT-RECORD) (defmacro with-output-as-gadget ((stream &rest options) &body body) - (declare (type symbol stream) - (ignorable options)) - (when (eq stream t) - (setq stream '*standard-output*)) - (let ((gadget (gensym)) - (gadget-output-record (gensym)) - (x (gensym)) - (y (gensym))) - `(multiple-value-bind (,x ,y) (stream-cursor-position ,stream) - (let* ((,gadget (progn , at body)) - (,gadget-output-record (make-instance 'gadget-output-record - :child ,gadget :x (round ,x) :y (round ,y)))) - (stream-add-output-record ,stream ,gadget-output-record) - (setup-gadget-record ,stream ,gadget-output-record (round ,x) (round ,y)) - (values ,gadget ,gadget-output-record))))) - + ;; NOTE - incremental-redisplay 12/28/05 will call this on redisplay + ;; unless wrapped in (updating-output (stream :cache-value t) ...) + ;; Otherwise, new gadget-output-records are generated but only the first + ;; gadget is ever adopted, and an erase-output-record called on a newer + ;; gadget-output-record will face a sheet-not-child error when trying + ;; to disown the never adopted gadget. + (let ((gadget-output-record (gensym)) + (x (gensym)) + (y (gensym))) + `(multiple-value-bind (,x ,y)(stream-cursor-position ,stream) + (flet ((with-output-as-gadget-continuation (,stream record) + (flet ((with-output-as-gadget-body (,stream) + (declare (ignorable ,stream)) + (progn , at body))) + (setf (gadget record) + (with-output-as-gadget-body ,stream)))) + (gadget-output-record-constructor () + (make-instance 'gadget-output-record + , at options :x ,x :y ,y))) + (declare (dynamic-extent with-output-as-gadget-continuation + gadget-output-record-constructor)) + (let ((,gadget-output-record + (invoke-with-output-to-output-record + ,stream + #'with-output-as-gadget-continuation + nil + #'gadget-output-record-constructor))) + (setup-gadget-record ,stream ,gadget-output-record) + (stream-add-output-record ,stream ,gadget-output-record) + (values (gadget ,gadget-output-record) ,gadget-output-record)))))) ;;; (defclass orientation-from-parent-mixin () ()) --- /project/mcclim/cvsroot/mcclim/panes.lisp 2006/03/10 21:58:13 1.167 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2006/03/27 10:46:11 1.168 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.167 2006/03/10 21:58:13 tmoore Exp $ +;;; $Id: panes.lisp,v 1.168 2006/03/27 10:46:11 crhodes Exp $ (in-package :clim-internals) @@ -2654,7 +2654,8 @@ (let ((frame (pane-frame stream))) (when frame (disown-frame (frame-manager frame) frame))) - (call-next-method)) + (when (next-method-p) + (call-next-method))) (define-application-frame a-window-stream (standard-encapsulating-stream standard-extended-input-stream From crhodes at common-lisp.net Wed Mar 29 09:36:30 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 29 Mar 2006 04:36:30 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20060329093630.6D6991703B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv4918 Modified Files: method-browser.lisp Log Message: Use a bit more of clim-mop in the method browser. May now work on scieneer. --- /project/mcclim/cvsroot/mcclim/Examples/method-browser.lisp 2005/03/06 20:35:40 1.2 +++ /project/mcclim/cvsroot/mcclim/Examples/method-browser.lisp 2006/03/29 09:36:30 1.3 @@ -46,11 +46,11 @@ ;;; * Portable MOP provided by CLIM-MOP package ;;; TODO: -;;; * EQL specializers on implementations other than SBCL/CMUCL -;;; * Nicer, more clever display of methods than simply listing them in a row. -;;; To do this right really involes some nonportable fun and a codewalker. -;;; You could probably write something that just understood the standard -;;; method combination and qualifiers with substantially less work. +;;; * Nicer, more clever display of methods than simply listing them +;;; in a row. To do this right really involes some nonportable +;;; fun and a codewalker. You could probably write something that +;;; just understood the standard method combination and qualifiers +;;; with substantially less work. ;;; * Change focus behavior of McCLIM text entry gadget ;;; * Implement focus-aware cursor shapes in McCLIM and/or Goatee ;;; (actually I did this ages ago, but let it rot away on my disk..) @@ -67,23 +67,19 @@ collect (remove-duplicates (mapcar (lambda (specs) (nth index specs)) specializers))))) +;;; FIXME: why is this necessary? I'm pretty sure the #+CMU clause +;;; here has been superseded by events for quite a while now. (Should +;;; clim-mop:class not cater for these implementation differences?) (defun classp (x) (or (typep x 'cl:class) - #+CMU (typep x 'pcl::class))) - -(defun eql-specializer-p (x) - #+SBCL (typep x 'sb-mop:eql-specializer) - #+CMU (typep x 'pcl:eql-specializer)) - -(defun eql-specializer-object (x) - #+SBCL (sb-mop:eql-specializer-object x) - #+CMU (pcl::eql-specializer-object x)) + #+CMU (typep x 'pcl::class) + #+scl (typep x 'clos::std-class))) (defun compute-applicable-methods-from-specializers (gf specializers) (clim-mop:compute-applicable-methods gf (mapcar (lambda (spec) - (cond ((eql-specializer-p spec) - (eql-specializer-object spec)) + (cond ((typep spec 'clim-mop:eql-specializer) + (clim-mop:eql-specializer-object spec)) ((classp spec) (clim-mop:class-prototype spec)) (t (error "Can't compute effective methods, specializer ~A is not understood." spec)))) @@ -104,17 +100,17 @@ (classp b)) (string< (class-name a) (class-name b))) - ((and (eql-specializer-p a) - (not (eql-specializer-p b))) + ((and (typep a 'clim-mop:eql-specializer) + (not (typep b 'clim-mop:eql-specializer))) nil) - ((and (not (eql-specializer-p a)) - (eql-specializer-p b)) + ((and (not (typep a 'clim-mop:eql-specializer)) + (typep b 'clim-mop:eql-specializer)) t) - ((and (eql-specializer-p a) - (eql-specializer-p b)) + ((and (typep a 'clim-mop:eql-specializer) + (typep b 'clim-mop:eql-specializer)) (string< - (princ-to-string (eql-specializer-object a)) - (princ-to-string (eql-specializer-object b)))) + (princ-to-string (clim-mop:eql-specializer-object a)) + (princ-to-string (clim-mop:eql-specializer-object b)))) (t (warn "Received specializer of unknown type") nil) )))) (compute-gf-specializers gf))) @@ -135,8 +131,8 @@ "Pretty print the name of a method specializer" (cond ((classp spec) (princ-to-string (class-name spec))) - ((eql-specializer-p spec) - (format nil "(EQL '~A)" (eql-specializer-object spec))) + ((typep spec 'clim-mop:eql-specializer) + (format nil "(EQL '~A)" (clim-mop:eql-specializer-object spec))) (t (princ-to-string spec)))) (defun maybe-find-gf (name) @@ -174,7 +170,7 @@ ;; commands within your application, a menu bar, etc. ;; The :panes option is typically used to define and name the important -;; elements of your interface. CLIM provides some syntactic sugare, for +;; elements of your interface. CLIM provides some syntactic sugar, for ;; example (arg-pane :vrack-pane) below is equivalent to ;; (arg-pane (make-pane 'vrack-pane)). From tmoore at common-lisp.net Wed Mar 29 10:43:37 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 29 Mar 2006 05:43:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060329104337.82FAD704B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv13084 Modified Files: bordered-output.lisp events.lisp frames.lisp gadgets.lisp graphics.lisp mcclim.asd menu-choose.lisp panes.lisp protocol-classes.lisp recording.lisp stream-output.lisp text-formatting.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2005/01/02 05:24:49 1.13 +++ /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2006/03/29 10:43:36 1.14 @@ -101,11 +101,11 @@ :filled nil) (draw-rectangle* stream right-edge (+ top-edge offset) - (+ right-edge offset) bottom-edge :filled T) + (+ right-edge offset) bottom-edge :filled t) (draw-rectangle* stream (+ left-edge offset) bottom-edge (+ right-edge offset) (+ bottom-edge offset) - :filled T))) + :filled t))) (define-border-type :underline (stream record) (labels ((fn (record) --- /project/mcclim/cvsroot/mcclim/events.lisp 2006/03/10 21:58:12 1.28 +++ /project/mcclim/cvsroot/mcclim/events.lisp 2006/03/29 10:43:36 1.29 @@ -59,7 +59,11 @@ (defclass standard-event (event) ((timestamp :initarg :timestamp :initform nil - :reader event-timestamp))) + :reader event-timestamp) + ;; This slot is pretty much required in order to call handle-event. Some + ;; events have something other than a sheet in this slot, which is gross. + (sheet :initarg :sheet + :reader event-sheet))) (defmethod initialize-instance :after ((event standard-event) &rest initargs) (declare (ignore initargs)) @@ -79,11 +83,28 @@ ; (if (null position) ; :event ; (intern (subseq type 0 position) :keyword)))) +;;; Reintroduce something like that definition, with defmethod goodness. +;;; -- moore -(defclass device-event (standard-event) - ((sheet :initarg :sheet - :reader event-sheet) - (modifier-state :initarg :modifier-state +(defmacro define-event-class (name supers slots &rest options) + (let* ((event-tag (string '#:-event)) + (name-string (string name)) + (pos (search event-tag name-string :from-end t))) + (when (or (null pos) + (not (eql (+ pos (length event-tag)) (length name-string)))) + (error "~S does not end in ~A and is not a valid event name for ~ + define-event-class." + name event-tag)) + (let ((type (intern (subseq name-string 0 pos) :keyword))) + `(progn + (defclass ,name ,supers + ,slots + , at options) + (defmethod event-type ((event ,name)) + ',type))))) + +(define-event-class device-event (standard-event) + ((modifier-state :initarg :modifier-state :reader event-modifier-state) (x :initarg :x :reader device-event-native-x) @@ -94,21 +115,19 @@ (graft-y :initarg :graft-y :reader device-event-native-graft-y))) -(defclass keyboard-event (device-event) +(define-event-class keyboard-event (device-event) ((key-name :initarg :key-name :reader keyboard-event-key-name) (key-character :initarg :key-character :reader keyboard-event-character :initform nil))) -(defclass key-press-event (keyboard-event) - ( - )) - -(defclass key-release-event (keyboard-event) - ( - )) +(define-event-class key-press-event (keyboard-event) + ()) -(defclass pointer-event (device-event) +(define-event-class key-release-event (keyboard-event) + ()) + +(define-event-class pointer-event (device-event) ((pointer :initarg :pointer :reader pointer-event-pointer) (button :initarg :button @@ -149,33 +168,28 @@ (defmethod device-event-y ((event device-event)) (get-pointer-position ((event-sheet event) event) y)) -(defclass pointer-button-event (pointer-event) - ( - )) +(define-event-class pointer-button-event (pointer-event) + ()) -(defclass pointer-button-press-event (pointer-button-event) ()) +(define-event-class pointer-button-press-event (pointer-button-event) ()) -(defclass pointer-button-release-event (pointer-button-event) ()) +(define-event-class pointer-button-release-event (pointer-button-event) ()) -(defclass pointer-button-hold-event (pointer-button-event) ()) +(define-event-class pointer-button-hold-event (pointer-button-event) ()) -(defclass pointer-button-click-event (pointer-button-event) - ( - )) +(define-event-class pointer-button-click-event (pointer-button-event) + ()) -(defclass pointer-button-double-click-event (pointer-button-event) - ( - )) +(define-event-class pointer-button-double-click-event (pointer-button-event) + ()) -(defclass pointer-button-click-and-hold-event (pointer-button-event) - ( - )) +(define-event-class pointer-button-click-and-hold-event (pointer-button-event) + ()) -(defclass pointer-motion-event (pointer-event) - ( - )) +(define-event-class pointer-motion-event (pointer-event) + ()) (defclass motion-hint-mixin () () @@ -185,28 +199,22 @@ (defclass pointer-motion-hint-event (pointer-motion-event motion-hint-mixin) ()) -(defclass pointer-boundary-event (pointer-motion-event) - ( - )) +(define-event-class pointer-boundary-event (pointer-motion-event) + ()) -(defclass pointer-enter-event (pointer-boundary-event) - ( - )) +(define-event-class pointer-enter-event (pointer-boundary-event) + ()) -(defclass pointer-exit-event (pointer-boundary-event) - ( - )) +(define-event-class pointer-exit-event (pointer-boundary-event) + ()) -(defclass pointer-ungrab-event (pointer-exit-event) +(define-event-class pointer-ungrab-event (pointer-exit-event) ()) -(defclass window-event (standard-event) - ((sheet :initarg :sheet - :reader event-sheet) - (region :initarg :region - :reader window-event-native-region) - )) +(define-event-class window-event (standard-event) + ((region :initarg :region + :reader window-event-native-region))) (defmethod window-event-region ((event window-event)) (untransform-region (sheet-native-transformation (event-sheet event)) @@ -215,7 +223,7 @@ (defmethod window-event-mirrored-sheet ((event window-event)) (sheet-mirror (event-sheet event))) -(defclass window-configuration-event (window-event) +(define-event-class window-configuration-event (window-event) ((x :initarg :x :reader window-configuration-event-native-x) (y :initarg :y :reader window-configuration-event-native-y) (width :initarg :width :reader window-configuration-event-width) @@ -235,64 +243,27 @@ (defmethod window-configuration-event-y ((event window-configuration-event)) (get-window-position ((event-sheet event) event) y)) -(defclass window-unmap-event (window-event) +(define-event-class window-unmap-event (window-event) ()) -(defclass window-destroy-event (window-event) +(define-event-class window-destroy-event (window-event) ()) -(defclass window-repaint-event (window-event) - ( - )) +(define-event-class window-repaint-event (window-event) + ()) -(defclass window-manager-event (standard-event) ()) +(define-event-class window-manager-event (standard-event) ()) -(defclass window-manager-delete-event (window-manager-event) - ((sheet :initarg :sheet ; not required by the spec but we need - :reader event-sheet) ; to know which window to delete - mikemac - )) +(define-event-class window-manager-delete-event (window-manager-event) + ;; sheet (inherited from standard-event) is not required by the spec but we + ;; need to know which window to delete - mikemac + ()) -(defclass timer-event (standard-event) - ((sheet - :initarg :sheet - :reader event-sheet) - (token +(define-event-class timer-event (standard-event) + ((token :initarg :token :reader event-token))) -(defmethod event-instance-slots ((self event)) - '(timestamp)) - -(defmethod event-instance-slots ((self device-event)) - '(timestamp modifier-state sheet)) - -(defmethod event-instance-slots ((self keyboard-event)) - '(timestamp modifier-state sheet key-name)) - -(defmethod event-instance-slots ((self pointer-event)) - '(timestamp modifier-state sheet pointer button x y root-x root-y)) - -(defmethod event-instance-slots ((self window-event)) - '(timestamp region)) - -;(defmethod print-object ((self event) sink) -; (print-object-with-slots self (event-instance-slots self) sink)) - -;(defmethod translate-event ((self pointer-event) dx dy) -; (apply #'make-instance (class-of self) -; :x (+ dx (pointer-event-x self)) -; :y (+ dy (pointer-event-y self)) -; (fetch-slots-as-kwlist self (event-instance-slots self)))) - -;(defmethod translate-event ((self window-event) dx dy) -; (apply #'make-instance (class-of self) -; :region (translate-region (window-event-region self) dx dy) -; (fetch-slots-as-kwlist self (event-instance-slots self)))) - -;(defmethod translate-event ((self event) dx dy) -; (declare (ignore dx dy)) -; self) - ;;; Constants dealing with events (defconstant +pointer-left-button+ #x01) @@ -339,32 +310,6 @@ (check-modifier (,m) (not (zerop (logand ,m ,modifier-state))))) (and ,@(do-substitutes clauses)))))) -(defmethod event-type ((event device-event)) :device) -(defmethod event-type ((event keyboard-event)) :keyboard) -(defmethod event-type ((event key-press-event)) :key-press) -(defmethod event-type ((event key-release-event)) :key-release) -(defmethod event-type ((event pointer-event)) :pointer) -(defmethod event-type ((event pointer-button-event)) :pointer-button) -(defmethod event-type ((event pointer-button-press-event)) :pointer-button-press) -(defmethod event-type ((event pointer-button-release-event)) :pointer-button-release) -(defmethod event-type ((event pointer-button-hold-event)) :pointer-button-hold) -(defmethod event-type ((event pointer-motion-event)) :pointer-motion) -(defmethod event-type ((event pointer-boundary-event)) :pointer-boundary) -(defmethod event-type ((event pointer-enter-event)) :pointer-enter) -(defmethod event-type ((event pointer-exit-event)) :pointer-exit) -(defmethod event-type ((event window-event)) :window) -(defmethod event-type ((event window-configuration-event)) :window-configuration) -(defmethod event-type ((event window-repaint-event)) :window-repaint) -(defmethod event-type ((event window-manager-event)) :window-manager) -(defmethod event-type ((event window-manager-delete-event)) :window-manager-delete) -(defmethod event-type ((event timer-event)) :timer) - -;; keyboard-event-character keyboard-event -;; pointer-event-native-x pointer-event -;; pointer-event-native-y pointer-event -;; window-event-native-region window-event -;; window-event-mirrored-sheet window-event - ;; Key names are a symbol whose value is port-specific. Key names ;; corresponding to the set of standard characters (such as the ;; alphanumerics) will be a symbol in the keyword package. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/15 15:38:39 1.117 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/29 10:43:37 1.118 @@ -581,7 +581,7 @@ #+NIL (read-command (frame-command-table frame) :use-keystrokes nil :stream stream) (read-command (frame-command-table frame) :use-keystrokes t :stream stream)) -(defclass execute-command-event (window-manager-event) +(define-event-class execute-command-event (window-manager-event) ((sheet :initarg :sheet :reader event-sheet) (command :initarg :command :reader execute-command-event-command))) --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/03/27 10:46:11 1.97 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/03/29 10:43:37 1.98 @@ -115,11 +115,14 @@ ;; - make NIL a valid label, and take it into account when applying ;; spacing. -;;;; ------------------------------------------------------------------------------------------ +;;;; -------------------------------------------------------------------------- ;;;; ;;;; 30.3 Basic Gadget Classes ;;;; +;;; XXX I'm not sure that *application-frame* should be rebound like this. What +;;; about gadgets in accepting-values windows? An accepting-values window +;;; shouldn't be bound to *application-frame*. -- moore (defun invoke-callback (pane callback &rest more-arguments) (when callback (let ((*application-frame* (pane-frame pane))) @@ -1421,6 +1424,14 @@ (declare (ignore new-value invoke-callback)) (scroll-bar/update-display pane)) +(defmethod* (setf scroll-bar-values) + (min-value max-value thumb-size value (scroll-bar scroll-bar-pane)) + (setf (slot-value scroll-bar 'min-value) min-value + (slot-value scroll-bar 'max-value) max-value + (slot-value scroll-bar 'thumb-size) thumb-size + (slot-value scroll-bar 'value) value) + (scroll-bar/update-display scroll-bar)) + ;;;; geometry (defparameter +minimum-thumb-size-in-pixels+ 30) @@ -2818,3 +2829,31 @@ (defmethod note-sheet-grafted ((sheet clim-extensions:box-adjuster-gadget)) (setf (sheet-pointer-cursor sheet) :rotate)) + +;;; Support for definition of callbacks and associated callback events. A +;;; callback event is used by a backend when a high-level notification of a +;;; gadget state change is delivered in the CLIM event process -- by a native +;;; gadget, for example -- and must be delivered in the application process. + +(define-event-class callback-event (standard-event) + ((sheet :initarg :gadget :reader event-gadget + :documentation "An alias for sheet, for readability") + (callback-function :initarg :callback-function :reader callback-function) + (client :initarg :client :reader event-client) + (client-id :initarg :client-id :reader event-client-id) + (other-args :initarg :other-args :reader event-other-args :initform nil))) + +(defun queue-callback (fn gadget client client-id &rest other-args) + (queue-event gadget (make-instance 'callback-event + :callback-function fn + :gadget gadget + :client client + :client-id client-id + :other-args other-args))) + +(defmethod handle-event ((gadget basic-gadget) (event callback-event)) + (apply (callback-function event) + (event-client event) + (event-client-id event) + (event-other-args event))) + --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2005/09/10 11:53:15 1.51 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2006/03/29 10:43:37 1.52 @@ -111,7 +111,7 @@ (if (null line-style) (setf line-style old-line-style)) (when (or line-unit line-thickness dashes-p line-joint-shape line-cap-shape) - (setf changed-line-style T) + (setf changed-line-style t) (setf line-style (make-line-style :unit (or line-unit (line-style-unit line-style)) @@ -130,7 +130,7 @@ (medium-merged-text-style medium))) (setf text-style (medium-merged-text-style medium))) (when (or text-family-p text-face-p text-size-p) - (setf changed-text-style T) + (setf changed-text-style t) (setf text-style (merge-text-styles (make-text-style text-family text-face text-size) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/24 11:45:03 1.15 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/29 10:43:37 1.16 @@ -51,10 +51,11 @@ ;;; Make CLX asdf-loadable on Allegro 6.2 ;;; possibly this should be further refined to funciton properly for ;;; Allegro on Windows platforms. [2005/04/18:rpg] + #+allegro (progn (defclass requireable-system (asdf:system) - ()) + ()) (defmethod asdf:perform ((op asdf:load-op) (system requireable-system)) (require (intern (slot-value system 'asdf::name) :keyword))) (defmethod asdf::traverse ((op asdf:load-op) (system requireable-system)) @@ -62,7 +63,6 @@ (defsystem :clx :class requireable-system)) - (defmacro clim-defsystem ((module &key depends-on) &rest components) `(progn (asdf:defsystem ,module --- /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2006/02/23 17:39:32 1.17 +++ /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2006/03/29 10:43:37 1.18 @@ -43,7 +43,7 @@ ;;; + menu frame size ;;; + layout -(in-package :CLIM-INTERNALS) +(in-package :clim-internals) (defgeneric menu-choose (items --- /project/mcclim/cvsroot/mcclim/panes.lisp 2006/03/27 10:46:11 1.168 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2006/03/29 10:43:37 1.169 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.168 2006/03/27 10:46:11 crhodes Exp $ +;;; $Id: panes.lisp,v 1.169 2006/03/29 10:43:37 tmoore Exp $ (in-package :clim-internals) @@ -1515,7 +1515,7 @@ (space-requirement-major sr)))) srs))) #+nil - (format T "~&;; ~S: allot=~S, wanted=~S, excess=~S, qs=~S~%" + (format t "~&;; ~S: allot=~S, wanted=~S, excess=~S, qs=~S~%" 'allot-space-xically allot wanted excess qs) (let ((sum (reduce #'+ qs))) (cond ((zerop sum) @@ -1592,11 +1592,11 @@ (- width xs)))) #+nil (progn - (format T "~&;; row space requirements = ~S." rsrs) - (format T "~&;; col space requirements = ~S." csrs) - (format T "~&;; row allotment: needed = ~S result = ~S (sum ~S)." height rows (reduce #'+ rows)) - (format T "~&;; col allotment: needed = ~S result = ~S (sum ~S)." width cols (reduce #'+ cols)) - (format T "~&;; align-x = ~S, align-y ~S~%" + (format t "~&;; row space requirements = ~S." rsrs) + (format t "~&;; col space requirements = ~S." csrs) + (format t "~&;; row allotment: needed = ~S result = ~S (sum ~S)." height rows (reduce #'+ rows)) + (format t "~&;; col allotment: needed = ~S result = ~S (sum ~S)." width cols (reduce #'+ cols)) + (format t "~&;; align-x = ~S, align-y ~S~%" (pane-align-x pane) (pane-align-y pane))) ;; now finally layout each child @@ -1882,7 +1882,7 @@ ;; ;; One might argue that in case of no scroll-bars the ;; application programmer can just skip the scroller - ;; pane altogether. But I think that the then needed + ;; pane altogether. Bu I think that the then needed ;; special casing on having a scroller pane or a bare ;; viewport at hand is an extra burden, that can be ;; avoided. @@ -1899,6 +1899,12 @@ :x-spacing 4 :y-spacing 4)) +(defgeneric scroll-bar-values (scroll-bar) + (:documentation "Returns the min value, max value, thumb size, and value of a + scroll bar. When Setf-ed, updates the scroll bar graphics")) + +(defgeneric* (setf scroll-bar-values) (min-value max-value thumb-size value scroll-bar)) + (defmacro scrolling ((&rest options) &body contents) `(let ((viewport (make-pane 'viewport-pane :contents (list , at contents)))) (make-pane 'scroller-pane , at options :contents (list viewport)))) @@ -1973,11 +1979,7 @@ 0 (* (/ (gadget-value vscrollbar) (gadget-max-value vscrollbar)) max)))) - (setf (gadget-min-value vscrollbar) min - (gadget-max-value vscrollbar) max - (scroll-bar-thumb-size vscrollbar) ts - (gadget-value vscrollbar :invoke-callback nil) val))) - + (setf (scroll-bar-values vscrollbar) (values min max ts val)))) (when hscrollbar (let* ((scrollee (first (sheet-children viewport))) (min 0) @@ -1989,11 +1991,7 @@ 0 (* (/ (gadget-value hscrollbar) (gadget-max-value hscrollbar)) max)))) - (setf (gadget-min-value hscrollbar) min - (gadget-max-value hscrollbar) max - (scroll-bar-thumb-size hscrollbar) ts - (gadget-value hscrollbar :invoke-callback nil) val))) - + (setf (scroll-bar-values hscrollbar) (values min max ts val)))) (when viewport (setf (sheet-transformation viewport) (make-translation-transformation @@ -2009,17 +2007,24 @@ "Callback for the vertical scroll-bar of a scroller-pane." (with-slots (viewport hscrollbar vscrollbar) pane (let ((scrollee (first (sheet-children viewport)))) - (scroll-extent scrollee - (if hscrollbar (gadget-value hscrollbar) 0) - new-value)))) + (when (pane-viewport scrollee) + (move-sheet scrollee + (round (if hscrollbar + (- (gadget-value hscrollbar)) + 0)) + (round (- new-value))))))) (defmethod scroller-pane/horizontal-drag-callback ((pane scroller-pane) new-value) "Callback for the horizontal scroll-bar of a scroller-pane." (with-slots (viewport hscrollbar vscrollbar) pane (let ((scrollee (first (sheet-children viewport)))) - (scroll-extent scrollee - new-value - (if vscrollbar (gadget-value vscrollbar) 0))))) + (when (pane-viewport scrollee) + (move-sheet scrollee + (round (- new-value)) + (round (if vscrollbar + (- (gadget-value vscrollbar)) + 0))))))) + (defmethod scroller-pane/update-scroll-bars ((pane scroller-pane)) (with-slots (viewport hscrollbar vscrollbar) pane @@ -2028,24 +2033,27 @@ (viewport-sr (sheet-region viewport))) ;; (when hscrollbar - (setf (gadget-min-value hscrollbar) (bounding-rectangle-min-x scrollee-sr) - (gadget-max-value hscrollbar) (max (- (bounding-rectangle-max-x scrollee-sr) - (bounding-rectangle-width viewport-sr)) - (bounding-rectangle-min-x scrollee-sr)) - (scroll-bar-thumb-size hscrollbar) (bounding-rectangle-width viewport-sr) - (gadget-value hscrollbar :invoke-callback nil) - (- (nth-value 0 (transform-position (sheet-transformation scrollee) 0 0))) - )) + (setf (scroll-bar-values hscrollbar) + (values (bounding-rectangle-min-x scrollee-sr) + (max (- (bounding-rectangle-max-x scrollee-sr) + (bounding-rectangle-width viewport-sr)) + (bounding-rectangle-min-x scrollee-sr)) + (bounding-rectangle-width viewport-sr) + (- (nth-value 0 (transform-position + (sheet-transformation scrollee) 0 0)))))) ;; (when vscrollbar - (setf (gadget-min-value vscrollbar) (bounding-rectangle-min-y scrollee-sr) - (gadget-max-value vscrollbar) (max (- (bounding-rectangle-max-y scrollee-sr) - (bounding-rectangle-height viewport-sr)) - (bounding-rectangle-min-y scrollee-sr)) - (scroll-bar-thumb-size vscrollbar) (bounding-rectangle-height viewport-sr) - (gadget-value vscrollbar :invoke-callback nil) - (- (nth-value 1 (transform-position (sheet-transformation scrollee) 0 0))) - ))))) + (setf (scroll-bar-values vscrollbar) + (values (bounding-rectangle-min-y scrollee-sr) + (max (- (bounding-rectangle-max-y scrollee-sr) + (bounding-rectangle-height viewport-sr)) + (bounding-rectangle-min-y scrollee-sr)) + (bounding-rectangle-height viewport-sr) + (- (nth-value 1 (transform-position + (sheet-transformation scrollee) + 0 + 0))))))))) + (defmethod initialize-instance :after ((pane scroller-pane) &key contents &allow-other-keys) (sheet-adopt-child pane (first contents)) --- /project/mcclim/cvsroot/mcclim/protocol-classes.lisp 2006/03/10 21:58:13 1.1 +++ /project/mcclim/cvsroot/mcclim/protocol-classes.lisp 2006/03/29 10:43:37 1.2 @@ -22,10 +22,15 @@ (in-package :clim-internals) (defmacro define-protocol-class (name super-classes &optional slots &rest options) - (let ((protocol-predicate - (intern (concatenate 'string (symbol-name name) (if (find #\- (symbol-name name)) "-" "") "P"))) - (predicate-docstring - (concatenate 'string "Protocol predicate checking for class " (symbol-name name)))) + (let* ((sym-name (symbol-name name)) + (protocol-predicate + (intern (concatenate 'string + sym-name + (if (find #\- sym-name) "-" "") + (symbol-name '#:p)))) + (predicate-docstring + (concatenate 'string + "Protocol predicate checking for class " sym-name))) `(progn (defclass ,name ,super-classes ,slots , at options) --- /project/mcclim/cvsroot/mcclim/recording.lisp 2006/03/10 21:58:13 1.124 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2006/03/29 10:43:37 1.125 @@ -844,7 +844,7 @@ (>= cx2 old-max-x) (>= cy2 old-max-y)) (values (min cx1 ox1) (min cy1 oy1) (max cx2 ox2) (max cy2 oy2))) - (T (%tree-recompute-extent* record))) + (t (%tree-recompute-extent* record))) ;; XXX banish x, y (with-slots (x y) record @@ -2337,7 +2337,7 @@ (bounding-rectangle region)))) (with-bounding-rectangle* (x1 y1 x2 y2) region (with-output-recording-options (stream :record nil) - (draw-rectangle* stream x1 y1 x2 y2 :filled T :ink +background-ink+))) + (draw-rectangle* stream x1 y1 x2 y2 :filled t :ink +background-ink+))) (stream-replay stream region))))) (defmethod handle-repaint ((stream output-recording-stream) region) --- /project/mcclim/cvsroot/mcclim/stream-output.lisp 2006/03/10 21:58:13 1.58 +++ /project/mcclim/cvsroot/mcclim/stream-output.lisp 2006/03/29 10:43:37 1.59 @@ -107,8 +107,8 @@ (defun decode-cursor-visibility (visibility) "Given :on, :off, or nil, returns the needed active and state attributes for the cursor." (ecase visibility - ((:on T) (values T T)) - (:off (values T nil)) + ((:on t) (values t t)) + (:off (values t nil)) ((nil) (values nil nil)))) (defmethod cursor-visibility ((cursor cursor-mixin)) @@ -116,7 +116,7 @@ (s (cursor-state cursor))) (cond ((and a s) :on) ((and a (not s)) :off) - (T nil)))) + (t nil)))) (defmethod (setf cursor-visibility) (nv (cursor cursor-mixin)) (multiple-value-bind (active state) --- /project/mcclim/cvsroot/mcclim/text-formatting.lisp 2003/11/10 21:40:34 1.8 +++ /project/mcclim/cvsroot/mcclim/text-formatting.lisp 2006/03/29 10:43:37 1.9 @@ -143,8 +143,8 @@ (setq seg-start (1+ i)))) (foo seg-start end))))) -(defmacro indenting-output ((stream indent &key (move-cursor T)) &body body) - (when (eq stream T) +(defmacro indenting-output ((stream indent &key (move-cursor t)) &body body) + (when (eq stream t) (setq stream '*standard-output*)) (with-gensyms (old-x old-y) `(multiple-value-bind (,old-x ,old-y) From tmoore at common-lisp.net Wed Mar 29 10:43:37 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 29 Mar 2006 05:43:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20060329104337.CAD2E78001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv13084/Apps/Listener Modified Files: dev-commands.lisp file-types.lisp icons.lisp listener.lisp util.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/03/15 22:56:54 1.33 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/03/29 10:43:37 1.34 @@ -158,41 +158,41 @@ (define-presentation-translator class-name-to-class (class-name class lisp-dev-commands :documentation ((object stream) (format stream "Class object ~A" object)) - :gesture T) + :gesture t) (object) (find-class object)) (define-presentation-translator symbol-to-class (symbol class lisp-dev-commands :documentation ((object stream) (format stream "Class object ~A" object)) - :gesture T + :gesture t :tester ((object) (not (not (find-class object nil)))) - :tester-definitive T) + :tester-definitive t) (object) (find-class object)) (define-presentation-translator symbol-to-class-name (symbol class-name lisp-dev-commands :documentation ((object stream) (format stream "Class ~A" object)) - :gesture T + :gesture t :tester ((object) (not (not (find-class object nil)))) - :tester-definitive T) + :tester-definitive t) (object) object) (define-presentation-translator class-to-class-name (class class-name lisp-dev-commands :documentation ((object stream) (format stream "Class of ~A" object)) - :gesture T) + :gesture t) (object) (clim-mop:class-name object)) (define-presentation-translator symbol-to-function-name (symbol function-name lisp-dev-commands :documentation ((object stream) (format stream "Function ~A" object)) - :gesture T + :gesture t :tester ((object) (fboundp object)) - :tester-definitive T) + :tester-definitive t) (object) object) ;;; Application commands @@ -214,7 +214,7 @@ :provide-output-destination-keyword t) ((program 'string :prompt "command") (args '(sequence string) :default nil :prompt "args")) - (run-program program args :wait T :input nil)) + (run-program program args :wait t :input nil)) ;; I could replace this command with a keyword to COM-RUN.. (define-command (com-background-run :name "Background Run" @@ -327,10 +327,10 @@ (let ((symbols (remove-if-not (lambda (sym) (apropos-applicable-p domain sym)) (apropos-list string real-package)))) (dolist (sym symbols) - (apropos-present-symbol sym *standard-output* T) + (apropos-present-symbol sym *standard-output* t) (terpri)) (setf *apropos-list* symbols) - (note "Results have been saved to ~W~%" '*APROPOS-LIST*)))) + (note "Results have been saved to ~W~%" '*apropos-list*)))) (define-command (com-trace :name "Trace" :command-table lisp-commands @@ -340,8 +340,8 @@ (if (fboundp fsym) (progn (eval `(trace ,fsym)) - (format T "~&Tracing ~W.~%" fsym)) - (format T "~&Function ~W is not defined.~%" fsym))) + (format t "~&Tracing ~W.~%" fsym)) + (format t "~&Function ~W is not defined.~%" fsym))) (define-command (com-untrace :name "Untrace" :command-table lisp-commands @@ -351,8 +351,8 @@ (if (fboundp fsym) (progn (eval `(untrace ,fsym)) - (format T "~&~W will no longer be traced.~%" fsym)) - (format T "~&Function ~W is not defined.~%" fsym))) + (format t "~&~W will no longer be traced.~%" fsym)) + (format t "~&Function ~W is not defined.~%" fsym))) (define-command (com-load-file :name "Load File" @@ -453,7 +453,7 @@ (princ (clim-mop:class-name class) stream)))) ;) inferior-fun :stream stream - :merge-duplicates T + :merge-duplicates t :graph-type :tree :orientation orientation :arc-drawer @@ -528,30 +528,30 @@ (direct-slots (direct-slot-definitions class name)) (readers (reduce #'append (filtermap direct-slots #'clim-mop:slot-definition-readers))) (writers (reduce #'append (filtermap direct-slots #'clim-mop:slot-definition-writers))) - (documentation (first (filtermap direct-slots (lambda (x) (documentation x T))))) + (documentation (first (filtermap direct-slots (lambda (x) (documentation x t))))) (*standard-output* stream)) (macrolet ((with-ink ((var) &body body) - `(with-drawing-options (T :ink ,(intern (concatenate 'string "*SLOT-" (symbol-name var) "-INK*"))) + `(with-drawing-options (t :ink ,(intern (concatenate 'string "*SLOT-" (symbol-name var) "-INK*"))) , at body)) (fcell ((var align-x &rest cell-opts) &body body) - `(formatting-cell (T :align-x ,align-x , at cell-opts) + `(formatting-cell (t :align-x ,align-x , at cell-opts) (with-ink (,var) , at body) ))) (fcell (name :left) - (with-output-as-presentation (T slot 'slot-definition) + (with-output-as-presentation (t slot 'slot-definition) (princ name)) - (unless (eq type T) + (unless (eq type t) (fresh-line) (with-ink (type) (princ type)))) (fcell (initargs :right) (dolist (x initargs) - (format T "~W~%" x))) + (format t "~W~%" x))) (fcell (initform :left) (if initfunc - (format T "~W" initform) + (format t "~W" initform) (note "No initform"))) #+NIL ; argh, shouldn't this work? @@ -567,19 +567,19 @@ (dolist (writer writers) (format T "~A~%" writer)) (note "No writers")))))) - (formatting-cell (T :align-x :left) + (formatting-cell (t :align-x :left) (if (not (or readers writers)) (note "No accessors") (progn (with-ink (readers) - (if readers (dolist (reader readers) (format T "~A~%" reader)) + (if readers (dolist (reader readers) (format t "~A~%" reader)) (note "No readers~%"))) (with-ink (writers) - (if writers (dolist (writer writers) (format T "~A~%" writer)) + (if writers (dolist (writer writers) (format t "~A~%" writer)) (note "No writers")))))) (fcell (documentation :left) - (when documentation (with-text-family (T :serif) (princ documentation)))) + (when documentation (with-text-family (t :serif) (princ documentation)))) ))) @@ -601,18 +601,18 @@ (position (earliest-slot-definer b class) cpl)))))) (defun print-slot-table-heading () - (formatting-row (T) + (formatting-row (t) (dolist (name '("Slot name" "Initargs" "Initform" "Accessors")) - (formatting-cell (T :align-x :center) - (underlining (T) - (with-text-family (T :sans-serif) + (formatting-cell (t :align-x :center) + (underlining (t) + (with-text-family (t :sans-serif) (princ name))))))) (defun present-slot-list (slots class) - (formatting-table (T) + (formatting-table (t) (print-slot-table-heading) (dolist (slot slots) - (formatting-row (T) + (formatting-row (t) (present-slot slot class))))) (defun friendly-slot-allocation-type (allocation) @@ -626,11 +626,11 @@ (other-slots (set-difference slots instance-slots)) (allocation-types (remove-duplicates (mapcar #'clim-mop:slot-definition-allocation other-slots)))) (when other-slots - (underlining (T) (format T "~&Instance Slots~%"))) + (underlining (t) (format t "~&Instance Slots~%"))) (present-slot-list instance-slots class) (dolist (alloc allocation-types) - (underlining (T) - (format T "~&Allocation: ~A~%" (friendly-slot-allocation-type alloc))) + (underlining (t) + (format t "~&Allocation: ~A~%" (friendly-slot-allocation-type alloc))) (present-slot-list (remove-if (lambda (x) (not (eq alloc (clim-mop:slot-definition-allocation x)))) other-slots) @@ -643,17 +643,17 @@ ((class-name 'clim:symbol :prompt "class name")) (let ((class (find-class class-name nil))) (if (null class) - (format T "~&~A is not a defined class.~%" class-name) + (format t "~&~A is not a defined class.~%" class-name) (let ((slots (clim-mop:class-slots class))) (if (null slots) (note "~%This class has no slots.~%~%") (progn ; oddly, looks much better in courier, because of all the capital letters. -; (with-text-family (T :sans-serif) +; (with-text-family (t :sans-serif) (invoke-as-heading (lambda () - (format T "~&Slots for ") - (with-output-as-presentation (T (clim-mop:class-name class) 'class-name) + (format t "~&Slots for ") + (with-output-as-presentation (t (clim-mop:class-name class) 'class-name) (princ (clim-mop:class-name class))))) (present-the-slots class) )))))) @@ -697,7 +697,7 @@ (symbol-package b))) (string< (package-name (symbol-package a)) (package-name (symbol-package b)))) - (T (string< (symbol-name a) + (t (string< (symbol-name a) (symbol-name b)))) (string< (princ-to-string a) (princ-to-string b)))))) @@ -714,10 +714,10 @@ (let ((funcs (sort (class-funcs class) (lambda (a b) (slot-name-sortp (clim-mop:generic-function-name a) (clim-mop:generic-function-name b)))))) - (with-text-size (T :small) + (with-text-size (t :small) (format-items funcs :printer (lambda (item stream) (present item 'generic-function :stream stream)) - :move-cursor T)))))) + :move-cursor t)))))) (defun method-applicable-to-args-p (method args arg-types) (loop @@ -1026,7 +1026,7 @@ :type (pathname-type pathname) :version (pathname-version pathname)))))) -(defun pretty-pretty-pathname (pathname stream &key (long-name T)) +(defun pretty-pretty-pathname (pathname stream &key (long-name t)) (with-output-as-presentation (stream pathname 'clim:pathname) (let ((icon (icon-of pathname))) (when icon (draw-icon stream icon :extra-spacing 3))) @@ -1077,10 +1077,10 @@ &key (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") + (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?") + (group-directories 'boolean :default t :prompt "group directories?") (full-names 'boolean :default nil :prompt "show full name?") (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?")) @@ -1092,18 +1092,18 @@ (list-directory-with-all-direct-subdirectories wild-pathname) (list-directory wild-pathname)))) - (with-text-family (T :sans-serif) + (with-text-family (t :sans-serif) (invoke-as-heading (lambda () - (format T "Directory contents of ") + (format t "Directory contents of ") (present (directory-namestring pathname) 'pathname) (when (pathname-type pathname) - (format T " (only files of type ~a)" (pathname-type pathname))))) + (format t " (only files of type ~a)" (pathname-type pathname))))) (when (parent-directory 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~%"))) + (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 sort-by)) (unless show-all @@ -1120,7 +1120,7 @@ (declare (ignore stream)) (pretty-pretty-pathname x *standard-output* :long-name full-names))) (goatee::reposition-stream-cursor *standard-output*) - (vertical-gap T)) + (vertical-gap t)) (list (dolist (ent group) (let ((ent (merge-pathnames ent pathname))) ;; This is for CMUCL, see above. (fixme!) ;; And breaks some things for SBCL.. (mgr) @@ -1131,7 +1131,7 @@ (clim:pathname com-show-directory filesystem-commands :gesture :select :pointer-documentation ((object stream) (format stream "Show directory ~A" object)) - :tester-definitive T + :tester-definitive t :tester ((object) (directoryp object))) (object) @@ -1147,7 +1147,7 @@ (note "~A does not exist." pathname)) ((not (directoryp pathname)) (note "~A is not a directory." pathname)) - (T (change-directory (merge-pathnames pathname))) ))) + (t (change-directory (merge-pathnames pathname))) ))) (define-command (com-up-directory :name "Up Directory" :menu t @@ -1156,8 +1156,8 @@ (let ((parent (parent-directory *default-pathname-defaults*))) (when parent (change-directory parent) - (italic (T) - (format T "~&The current directory is now ") + (italic (t) + (format t "~&The current directory is now ") (present (truename parent)) (terpri))))) @@ -1283,18 +1283,18 @@ (directoryp pathname));; FIXME: Need smart conversion to directories, here and elsewhere. (progn (push *default-pathname-defaults* *directory-stack*) (com-change-directory pathname)) - (italic (T) + (italic (t) (fresh-line) (present (truename pathname)) - (format T " does not exist or is not a directory.~%")) )) + (format t " does not exist or is not a directory.~%")) )) (compute-dirstack-command-eligibility *application-frame*)) (defun comment-on-dir-stack () (if *directory-stack* (progn - (format T "~&The top of the directory stack is now ") + (format t "~&The top of the directory stack is now ") (present (truename (first *directory-stack*))) (terpri)) - (format T "~&The directory stack is now empty.~%"))) + (format t "~&The directory stack is now empty.~%"))) (define-command (com-pop-directory :name "Pop Directory" :menu t @@ -1304,16 +1304,16 @@ (note "The directory stack is empty!") (progn (com-change-directory (pop *directory-stack*)) - (italic (T) (comment-on-dir-stack)))) + (italic (t) (comment-on-dir-stack)))) (compute-dirstack-command-eligibility *application-frame*)) (define-command (com-drop-directory :name "Drop Directory" :menu t :command-table directory-stack-commands) () - (italic (T) + (italic (t) (if (null *directory-stack*) - (format T "~&The directory stack is empty!~%") + (format t "~&The directory stack is empty!~%") (progn (setf *directory-stack* (rest *directory-stack*)) (comment-on-dir-stack)))) @@ -1323,9 +1323,9 @@ :menu t :command-table directory-stack-commands) () - (italic (T) + (italic (t) (if (null *directory-stack*) - (format T "~&The directory stack is empty!~%") + (format t "~&The directory stack is empty!~%") (progn (psetf (first *directory-stack*) *default-pathname-defaults* *default-pathname-defaults* (first *directory-stack*)) @@ -1412,21 +1412,21 @@ "Hack of the day.. let McCLIM determine presentation type to use, except for lists, because the list presentation method is inappropriate for lisp return values." (typecase object (sequence (present object 'expression)) - (T (present object)))) + (t (present object)))) (defun display-evalues (values) - (with-drawing-options (T :ink +olivedrab+) [29 lines skipped] --- /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2006/03/15 22:56:54 1.9 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2006/03/29 10:43:37 1.10 @@ -136,7 +136,7 @@ (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))) + (t (let ((mime-class (find-class (pathname-mime-type pathname) nil))) (if mime-class (or (gethash (class-name mime-class) *icon-mapping*) (icon-of (clim-mop:class-prototype (find-class (pathname-mime-type pathname) nil)))) @@ -201,15 +201,15 @@ (defun read-slashified-line (stream &optional (accumulation nil)) (let ((line (read-line stream nil))) (cond ((null line) (values nil nil)) - ((zerop (length line)) (values accumulation T)) + ((zerop (length line)) (values accumulation t)) ((and (null accumulation) ;; # Comment (char= (elt line 0) #\#)) - (values nil T)) - (T (if (char= #\\ (elt line (1- (length line)))) + (values nil t)) + (t (if (char= #\\ (elt line (1- (length line)))) (read-slashified-line stream (concatenate 'string accumulation (subseq line 0 (1- (length line))))) - (values (concatenate 'string accumulation line) T)))))) + (values (concatenate 'string accumulation line) t)))))) (defun read-the-lines (pathname) (let ((elements nil)) @@ -273,7 +273,7 @@ (when split-pos (let* ((foo (subseq string start split-pos)) (pos (skip-whitespace string (1+ split-pos)))) -; (format T "~%***** foo=~A~%" foo) +; (format t "~%***** foo=~A~%" foo) (when pos (let* ((end (or (if (eql (elt string pos) #\") (1+ (position-if (lambda (c) @@ -299,7 +299,7 @@ (when (eq keysym :type) (setf (gethash :subtype table) (nth-value 2 (read-mime-type bar))) (setf (gethash :media-type table) (read-mime-type bar))) -; (format T "~&~W => ~W~%" foo bar) +; (format t "~&~W => ~W~%" foo bar) (setf (gethash keysym table) value) (parse-netscrapings table string end) )))))) table) @@ -335,7 +335,7 @@ (exts (gethash :exts elt))) (eval `(define-mime-type (,media-type ,subtype) (:extensions , at exts)))) - #+nil(format T "Ignoring ~W, unknown media type.~%" (gethash :type elt))))) + #+nil(format t "Ignoring ~W, unknown media type.~%" (gethash :type elt))))) (defun parse-mime-types-file (pathname) (mapcar (lambda (x) (process-mime-type (parse-mt-elt x))) @@ -401,7 +401,7 @@ (when (< index (1- (length string))) (push (elt string (incf index)) chars))) ((eql c #\;) (return-from poop chars)) - (T (push c chars))) + (t (push c chars))) (incf index))) (values (string-trim *whitespace* (concatenate 'string (nreverse chars))) @@ -411,7 +411,7 @@ (let* ((sep-pos (position #\= string)) (field-name (subseq string 0 (or sep-pos (length string))))) (values (intern (string-upcase field-name) (find-package :keyword)) - (ignore-errors (or (when sep-pos (subseq string (1+ sep-pos))) T))))) + (ignore-errors (or (when sep-pos (subseq string (1+ sep-pos))) t))))) (defun parse-mailcap-entry (line) "Parses a line of the mailcap file, returning either nil or the properties @@ -469,7 +469,7 @@ *mime.types-search-path*))) (dolist (path (reverse search-path)) (when (probe-file path) - (format T "Loading mime types from ~A~%" path) + (format t "Loading mime types from ~A~%" path) (parse-mime-types-file path))))) (defun load-mailcaps () @@ -477,7 +477,7 @@ *mailcap-search-path*))) (dolist (path (reverse search-path)) (when (probe-file path) - (format T "Loading mailcap from ~A~%" path) + (format t "Loading mailcap from ~A~%" path) (parse-mailcap-file path))))) @@ -544,7 +544,7 @@ (cond ((eql d #\s) (princ (quote-shell-characters (namestring (truename pathname))) out)) ((eql d #\t) (princ (gethash :type spec) out)) ((eql d #\u) (princ (pathname-to-uri-string pathname) out)) - (T (debugf "Ignoring unknown % syntax." d)))) + (t (debugf "Ignoring unknown % syntax." d)))) (write-char c out)))))) (defun find-viewspec (pathname) @@ -571,13 +571,13 @@ (test (gethash :test def)) (needsterminal (gethash :needsterminal def))) (if needsterminal - (format T "Sorry, the viewer app needs a terminal (fixme!)~%") + (format t "Sorry, the viewer app needs a terminal (fixme!)~%") (progn (when test (debugf "Sorry, ignoring TEST option right now.. " test)) (if view-command (run-program "/bin/sh" `("-c" ,(gen-view-command-line def pathname) "&")) - (format T "~&No view-command!~%")))))))) + (format t "~&No view-command!~%")))))))) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2006/01/01 10:14:50 1.4 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2006/03/29 10:43:37 1.5 @@ -52,11 +52,11 @@ ;; Icon functions -(defmethod icon-of ((object T)) +(defmethod icon-of ((object t)) *object-icon*) (defun draw-icon (stream pattern &key (extra-spacing 0) ) - (let ((stream (if (eq stream T) *standard-output* stream))) + (let ((stream (if (eq stream t) *standard-output* stream))) (multiple-value-bind (x y) (stream-cursor-position stream) (draw-pattern* stream pattern x y) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/03/22 09:14:30 1.24 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/03/29 10:43:37 1.25 @@ -84,22 +84,22 @@ #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) #+clisp (values (sys::%room)) #-(or cmu scl sbcl lispworks openmcl clisp) 0)) - (with-text-family (T :serif) - (formatting-table (T :x-spacing '(3 :character)) - (formatting-row (T) + (with-text-family (t :serif) + (formatting-table (t :x-spacing '(3 :character)) + (formatting-row (t) (macrolet ((cell ((align-x) &body body) - `(formatting-cell (T :align-x ,align-x) , at body))) - (cell (:left) (format T "~A@~A" username sitename)) + `(formatting-cell (t :align-x ,align-x) , at body))) + (cell (:left) (format t "~A@~A" username sitename)) (cell (:center) - (format T "Package ") - (print-package-name T)) + (format t "Package ") + (print-package-name t)) (cell (:center) (when (probe-file *default-pathname-defaults*) - (with-output-as-presentation (T (truename *default-pathname-defaults*) 'pathname) - (format T "~A" (frob-pathname *default-pathname-defaults*)))) + (with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname) + (format t "~A" (frob-pathname *default-pathname-defaults*)))) (when *directory-stack* - (with-output-as-presentation (T *directory-stack* 'directory-stack) - (format T " (~D deep)" (length *directory-stack*))))) + (with-output-as-presentation (t *directory-stack* 'directory-stack) + (format t " (~D deep)" (length *directory-stack*))))) ;; Although the CLIM spec says the item formatter should try to fill ;; the available width, I can't get either the item or table formatters ;; to really do so such that the memory usage appears right justified. @@ -157,7 +157,7 @@ ((system-command-reader :accessor system-command-reader :initarg :system-command-reader :initform t)) - (:panes (interactor :interactor :scroll-bars T + (:panes (interactor :interactor :scroll-bars t :display-function #'listener-initial-display-function :display-time t) (doc :pointer-documentation) @@ -218,7 +218,7 @@ (restart-case (call-next-method) (return-to-listener () :report "Return to listener." - (throw 'return-to-listener T))))))) + (throw 'return-to-listener t))))))) ;; Oops. As we've ditched our custom toplevel, we now have to duplicate all ;; this setup work to implement one little trick. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2006/03/15 22:56:54 1.20 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2006/03/29 10:43:37 1.21 @@ -42,7 +42,7 @@ (mapcar #'(lambda (x) (cond ((stringp x) `((princ ,x *trace-output*))) - (T `((princ ',x *trace-output*) + (t `((princ ',x *trace-output*) (princ "=" *trace-output*) (write ,x :stream *trace-output*) (princ #\space *trace-output*))))) @@ -96,8 +96,8 @@ (defun sbcl-frob-to-pathname (pathname string) "This just keeps getting more disgusting." (let* ((parent (strip-filespec pathname)) - (pn (merge-pathnames (make-pathname :name (subseq string 0 (position #\. string :start 1 :from-end T)) - :type (let ((x (position #\. string :start 1 :from-end T))) + (pn (merge-pathnames (make-pathname :name (subseq string 0 (position #\. string :start 1 :from-end t)) + :type (let ((x (position #\. string :start 1 :from-end t))) (if x (subseq string (1+ x)) nil))) parent)) (dir (ignore-errors (sb-posix:opendir (namestring pn))))) @@ -168,7 +168,7 @@ ;;; This ought to change the current directory to *default-pathname-defaults*.. ;;; (see above) -(defun run-program (program args &key (wait T) (output *standard-output*) (input *standard-input*)) +(defun run-program (program args &key (wait t) (output *standard-output*) (input *standard-input*)) #+(or CMU scl) (ext:run-program program args :input input :output output :wait wait) @@ -182,7 +182,7 @@ #+clisp (ext:run-program program :arguments args :wait wait) #-(or CMU scl SBCL lispworks clisp) - (format T "~&Sorry, don't know how to run programs in your CL.~%")) + (format t "~&Sorry, don't know how to run programs in your CL.~%")) ;;;; CLIM/UI utilities @@ -216,12 +216,12 @@ (truncate (/ (text-style-ascent (medium-text-style stream) stream) fraction)))) (defun invoke-as-heading (cont &optional ink) - (with-drawing-options (T :ink (or ink +royal-blue+) :text-style (make-text-style :sans-serif :bold nil)) + (with-drawing-options (t :ink (or ink +royal-blue+) :text-style (make-text-style :sans-serif :bold nil)) (fresh-line) - (bordering (T :underline) + (bordering (t :underline) (funcall cont)) (fresh-line) - (vertical-gap T))) + (vertical-gap t))) (defun indent-to (stream x &optional (spacing 0) ) "Advances cursor horizontally to coordinate X. If the cursor is already past @@ -451,7 +451,7 @@ ;; Disgusting hacks to make input default to nil, as CMUCL's run-program seems ;; to hang randomly unless I do that. But sometimes I'll need to really change these.. ;; ** Goddamn CMUCL's run-program likes to hang randomly even with this dumb hack. Beware.. -(defparameter *run-output* T) +(defparameter *run-output* t) (defparameter *run-input* nil) ;; We attempt to translate keywords and a few types of lisp objects @@ -459,7 +459,7 @@ (defgeneric transform-program-arg (arg)) -(defmethod transform-program-arg ((arg T)) +(defmethod transform-program-arg ((arg t)) (values (prin1-to-string arg))) (defmethod transform-program-arg ((arg string)) From tmoore at common-lisp.net Wed Mar 29 10:43:38 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 29 Mar 2006 05:43:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Scigraph/dwim Message-ID: <20060329104338.09D967900B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim In directory clnet:/tmp/cvs-serv13084/Apps/Scigraph/dwim Modified Files: tv.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/tv.lisp 2006/03/23 10:09:50 1.8 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/tv.lisp 2006/03/29 10:43:37 1.9 @@ -457,7 +457,7 @@ (clim:enable-frame frame) (clim:panes-need-redisplay frame) (clim:redisplay-frame-panes frame)) - (T (clim:start-frame frame wait-until-done))))) + (t (clim:start-frame frame wait-until-done))))) (:clim-1.0 (labels ((set-backing-store (window value) #+xlib From tmoore at common-lisp.net Wed Mar 29 10:43:38 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 29 Mar 2006 05:43:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/PostScript Message-ID: <20060329104338.753147A002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv13084/Backends/PostScript Modified Files: afm.lisp class.lisp encoding.lisp font.lisp graphics.lisp package.lisp sheet.lisp standard-metrics.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/afm.lisp 2005/08/13 14:28:23 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/afm.lisp 2006/03/29 10:43:38 1.5 @@ -25,7 +25,7 @@ ;;; - Kerning, ligatures. ;;; - Full AFM/AMFM/ACFM support. -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) (defun space-char-p (char) (member char '(#\Space #\Tab))) --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/class.lisp 2006/02/06 16:47:47 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/class.lisp 2006/03/29 10:43:38 1.9 @@ -32,7 +32,7 @@ ;;; ;;;--GB -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) ;;;; Medium --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/encoding.lisp 2004/12/03 11:42:43 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/encoding.lisp 2006/03/29 10:43:38 1.2 @@ -23,7 +23,7 @@ ;;; Boston, MA 02111-1307 USA. -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) (defvar *iso-latin-1-symbolic-names* '#(NIL NIL NIL NIL --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/font.lisp 2006/03/10 10:56:01 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/font.lisp 2006/03/29 10:43:38 1.10 @@ -23,7 +23,7 @@ ;;; - Kerning, ligatures. ;;; - device fonts -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) (defclass font-info () ((name :type string :initarg :name :reader font-info-name) --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2006/03/10 10:56:01 1.16 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2006/03/29 10:43:38 1.17 @@ -37,7 +37,7 @@ ;;; - structure this file ;;; - set miter limit? -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) ;;; Postscript output utilities (defun write-number (stream number) --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/package.lisp 2002/07/19 06:42:49 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/package.lisp 2006/03/29 10:43:38 1.8 @@ -18,24 +18,23 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -(in-package :COMMON-LISP-USER) +(in-package :cl-user) -(defpackage "CLIM-POSTSCRIPT" - (:use "CLIM" "CLIM-EXTENSIONS" "CLIM-LISP") - (:export "LOAD-AFM-FILE") - (:import-from "CLIM-INTERNALS" - "GET-ENVIRONMENT-VARIABLE" - "MAP-REPEATED-SEQUENCE" - "ATAN*" - - "ELLIPSE-NORMAL-RADII*" - - "GET-TRANSFORMATION" - "UNTRANSFORM-ANGLE" - "WITH-TRANSFORMED-POSITION" +(defpackage #:clim-postscript + (:use #:clim #:clim-extensions #:clim-lisp) + (:export #:load-afm-file) + (:import-from #:clim-internals + #:get-environment-variable + #:map-repeated-sequence + #:atan* - "MAXF" + #:ellipse-normal-radii* - "PORT-TEXT-STYLE-MAPPINGS" - )) + #:get-transformation + #:untransform-angle + #:with-transformed-position + + #:maxf + + #:port-text-style-mappings)) --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/sheet.lisp 2006/03/07 15:43:44 1.13 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/sheet.lisp 2006/03/29 10:43:38 1.14 @@ -35,7 +35,7 @@ ;;; ;;;--GB -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) (defmacro with-output-to-postscript-stream ((stream-var file-stream &rest options) --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/standard-metrics.lisp 2005/08/13 14:28:23 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/standard-metrics.lisp 2006/03/29 10:43:38 1.3 @@ -1,6 +1,6 @@ -(IN-PACKAGE :CLIM-POSTSCRIPT) -(DEFINE-FONT-METRICS '"Times-Roman" +(in-package :clim-postscript) +(define-font-metrics '"Times-Roman" '683 '217 '0 @@ -209,7 +209,7 @@ (-1 "Yacute" 722 890 0 -22 703) (-1 "brokenbar" 200 676 14 -67 133) (-1 "onehalf" 750 676 14 -31 746))) -(DEFINE-FONT-METRICS '"Times-Bold" +(define-font-metrics '"Times-Bold" '676 '205 '0 @@ -419,7 +419,7 @@ (-1 "Yacute" 722 928 0 -15 699) (-1 "brokenbar" 220 691 19 -66 154) (-1 "onehalf" 750 688 12 7 775))) -(DEFINE-FONT-METRICS '"Times-Italic" +(define-font-metrics '"Times-Italic" '683 '205 '-15.5 @@ -630,7 +630,7 @@ (-1 "Yacute" 556 876 0 -78 633) (-1 "brokenbar" 275 666 18 -105 171) (-1 "onehalf" 750 676 10 -34 749))) -(DEFINE-FONT-METRICS '"Times-BoldItalic" +(define-font-metrics '"Times-BoldItalic" '699 '205 '-15 @@ -836,7 +836,7 @@ (-1 "Yacute" 611 904 0 -73 659) (-1 "brokenbar" 220 685 18 -66 154) (-1 "onehalf" 750 683 14 9 723))) -(DEFINE-FONT-METRICS '"Courier" +(define-font-metrics '"Courier" '629 '157 '0 @@ -1077,7 +1077,7 @@ (-1 "aring" 600 627 15 -53 559) (-1 "yacute" 600 672 157 -7 592) (-1 "icircumflex" 600 654 0 -94 505))) -(DEFINE-FONT-METRICS '"Courier-Oblique" +(define-font-metrics '"Courier-Oblique" '629 '157 '-12 @@ -1319,7 +1319,7 @@ (-1 "aring" 600 627 15 -76 569) (-1 "yacute" 600 672 157 4 683) (-1 "icircumflex" 600 654 0 -95 551))) -(DEFINE-FONT-METRICS '"Courier-Bold" +(define-font-metrics '"Courier-Bold" '626 '142 '0 @@ -1558,7 +1558,7 @@ (-1 "aring" 600 678 15 -35 570) (-1 "yacute" 600 661 142 4 601) (-1 "icircumflex" 600 657 0 -63 523))) -(DEFINE-FONT-METRICS '"Courier-BoldOblique" +(define-font-metrics '"Courier-BoldOblique" '626 '142 '-12 @@ -1798,7 +1798,7 @@ (-1 "aring" 600 678 15 -62 592) (-1 "yacute" 600 661 142 20 694) (-1 "icircumflex" 600 657 0 -77 566))) -(DEFINE-FONT-METRICS '"Helvetica" +(define-font-metrics '"Helvetica" '718 '207 '0 @@ -2006,7 +2006,7 @@ (-1 "Yacute" 667 929 0 -14 653) (-1 "brokenbar" 260 737 19 -94 167) (-1 "onehalf" 834 703 19 -43 773))) -(DEFINE-FONT-METRICS '"Helvetica-Oblique" +(define-font-metrics '"Helvetica-Oblique" '718 '207 '-12 @@ -2215,7 +2215,7 @@ (-1 "Yacute" 667 929 0 -167 806) (-1 "brokenbar" 260 737 19 -90 324) (-1 "onehalf" 834 703 19 -114 839))) -(DEFINE-FONT-METRICS '"Helvetica-Bold" +(define-font-metrics '"Helvetica-Bold" '718 '207 '0 @@ -2423,7 +2423,7 @@ (-1 "Yacute" 667 936 0 -15 653) (-1 "brokenbar" 280 737 19 -84 196) (-1 "onehalf" 834 710 19 -26 794))) -(DEFINE-FONT-METRICS '"Helvetica-BoldOblique" +(define-font-metrics '"Helvetica-BoldOblique" '718 '207 '-12 From tmoore at common-lisp.net Wed Mar 29 10:43:38 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 29 Mar 2006 05:43:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/output Message-ID: <20060329104338.A72E9A0E6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory clnet:/tmp/cvs-serv13084/Backends/beagle/output Modified Files: medium.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/Backends/beagle/output/medium.lisp 2005/05/28 19:56:07 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/output/medium.lisp 2006/03/29 10:43:38 1.5 @@ -93,7 +93,7 @@ (send (medium-bezier-path medium) :set-line-width width) (when dashes - (when (eq dashes T) + (when (eq dashes t) ;; Provide default dash pattern... no idea why, but when I use ;; #(5.0 5.0) as the dafault dash, it gets displayed as a solid ;; line (no dashing). So the default is larger than it needs to @@ -694,7 +694,7 @@ (defmethod medium-draw-point* ((medium beagle-medium) x y) (let ((width (coerce (line-style-thickness (medium-line-style medium)) 'short-float))) - (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) T))) + (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -709,7 +709,7 @@ (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (let ((width (coerce (line-style-thickness (medium-line-style medium)) 'short-float))) (do-sequence ((x y) coord-seq) - (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) T))))) + (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) t))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From tmoore at common-lisp.net Wed Mar 29 10:43:43 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 29 Mar 2006 05:43:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/windowing Message-ID: <20060329104343.B1F8412041@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory clnet:/tmp/cvs-serv13084/Backends/beagle/windowing Modified Files: mirror.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/mirror.lisp 2005/06/05 19:52:57 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/mirror.lisp 2006/03/29 10:43:38 1.7 @@ -455,7 +455,7 @@ (send (send mirror 'window) :frame-rect-for-content-rect rect :style-mask (%beagle-style-mask-for-frame sheet)) - :display T)))) + :display t)))) (defun %beagle-style-mask-for-frame (sheet) From tmoore at common-lisp.net Wed Mar 29 10:43:43 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 29 Mar 2006 05:43:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20060329104343.EC8A914007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv13084/Examples Modified Files: demodemo.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2005/02/01 05:35:30 1.7 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/03/29 10:43:43 1.8 @@ -211,4 +211,4 @@ -(format T "~&;; try (CLIM-DEMO::DEMODEMO)~%") +(format t "~&;; try (CLIM-DEMO::DEMODEMO)~%") From tmoore at common-lisp.net Wed Mar 29 10:43:46 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 29 Mar 2006 05:43:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental Message-ID: <20060329104346.4AA5B19012@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental In directory clnet:/tmp/cvs-serv13084/Experimental Modified Files: pointer-doc-hack.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/Experimental/pointer-doc-hack.lisp 2003/06/01 15:07:58 1.1 +++ /project/mcclim/cvsroot/mcclim/Experimental/pointer-doc-hack.lisp 2006/03/29 10:43:44 1.2 @@ -235,7 +235,7 @@ ((eql button +pointer-left-button+) *icon-mouse-left*) ((eql button +pointer-middle-button+) *icon-mouse-middle*) ((eql button +pointer-right-button+) *icon-mouse-right*) - (T name))) + (t name))) (if (not (typep name 'indexed-pattern)) (format pstream "~A: " name) (multiple-value-bind (x y) (stream-cursor-position pstream) (draw-pattern* pstream name x y) From tmoore at common-lisp.net Wed Mar 29 10:43:47 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 29 Mar 2006 05:43:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/unzip Message-ID: <20060329104347.46E151E005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/unzip In directory clnet:/tmp/cvs-serv13084/Experimental/unzip Modified Files: inflate.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/Experimental/unzip/inflate.lisp 2003/03/21 15:15:09 1.2 +++ /project/mcclim/cvsroot/mcclim/Experimental/unzip/inflate.lisp 2006/03/29 10:43:46 1.3 @@ -220,7 +220,7 @@ ;; needed. We loop, until we have enough bits to make a ;; sensible decision. `((lambda (ht) - (declare (type (simple-array T (*)) ht)) + (declare (type (simple-array t (*)) ht)) (let ((m ',(car ms)) (b 0) x) (declare (type (unsigned-byte 24) b)) ;; (bs/ensure-n-bits 24) @@ -246,7 +246,7 @@ `((lambda (huffman-tree n) (declare (type (integer 0 1000) n)) (let ((res (make-array n :initial-element 0))) - (declare (type (simple-array T (*)) res)) + (declare (type (simple-array t (*)) res)) (do ((i 0 i)) ((>= i n)) (declare (type (integer 0 1000) i)) @@ -507,7 +507,7 @@ n-hclen (+ 4 (bs/read-byte 4)) hclens (make-array 19 :initial-element 0)) (locally - (declare (type (simple-array T (*)) hclens) + (declare (type (simple-array t (*)) hclens) (type (unsigned-byte 6) n-hdist) (type (unsigned-byte 5) n-hclen)) (loop From tmoore at common-lisp.net Wed Mar 29 10:43:48 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 29 Mar 2006 05:43:48 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Lisp-Dep Message-ID: <20060329104348.2C72C3A003@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv13084/Lisp-Dep Modified Files: fix-acl.lisp mp-acl.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/fix-acl.lisp 2005/02/07 21:16:58 1.10 +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/fix-acl.lisp 2006/03/29 10:43:48 1.11 @@ -11,107 +11,107 @@ (defpackage :clim-mop (:use :clos :common-lisp) - (:export "ACCESSOR-METHOD-SLOT-DEFINITION" - "ADD-DEPENDENT" - "ADD-DIRECT-METHOD" - "ADD-DIRECT-SUBCLASS" - "ADD-METHOD" - "ALLOCATE-INSTANCE" - "BUILT-IN-CLASS" - "CLASS" - "CLASS-DEFAULT-INITARGS" - "CLASS-DIRECT-DEFAULT-INITARGS" - "CLASS-DIRECT-SLOTS" - "CLASS-DIRECT-SUBCLASSES" - "CLASS-DIRECT-SUPERCLASSES" - "CLASS-FINALIZED-P" - "CLASS-NAME" - "CLASS-PRECEDENCE-LIST" - "CLASS-PROTOTYPE" - "CLASS-SLOTS" - "COMPUTE-APPLICABLE-METHODS" - "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" - "COMPUTE-CLASS-PRECEDENCE-LIST" - "COMPUTE-DEFAULT-INITARGS" - "COMPUTE-DISCRIMINATING-FUNCTION" - "COMPUTE-EFFECTIVE-METHOD" - "COMPUTE-EFFECTIVE-SLOT-DEFINITION" - "COMPUTE-SLOTS" - "DIRECT-SLOT-DEFINITION" - "DIRECT-SLOT-DEFINITION-CLASS" - "EFFECTIVE-SLOT-DEFINITION" - "EFFECTIVE-SLOT-DEFINITION-CLASS" - "ENSURE-CLASS" - "ENSURE-CLASS-USING-CLASS" - "ENSURE-GENERIC-FUNCTION" - "ENSURE-GENERIC-FUNCTION-USING-CLASS" - "EQL-SPECIALIZER" - "EQL-SPECIALIZER-OBJECT" - "EXTRACT-LAMBDA-LIST" - "EXTRACT-SPECIALIZER-NAMES" - "FINALIZE-INHERITANCE" - "FIND-METHOD-COMBINATION" - "FORWARD-REFERENCED-CLASS" - "FUNCALLABLE-STANDARD-CLASS" - "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" - "FUNCALLABLE-STANDARD-OBJECT" - "FUNCTION" - "GENERIC-FUNCTION" - "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" - "GENERIC-FUNCTION-DECLARATIONS" - "GENERIC-FUNCTION-LAMBDA-LIST" - "GENERIC-FUNCTION-METHOD-CLASS" - "GENERIC-FUNCTION-METHOD-COMBINATION" - "GENERIC-FUNCTION-METHODS" - "GENERIC-FUNCTION-NAME" - "INTERN-EQL-SPECIALIZER" - "MAKE-INSTANCE" - "MAKE-METHOD-LAMBDA" - "MAP-DEPENDENTS" - "METAOBJECT" - "METHOD" - "METHOD-COMBINATION" - "METHOD-FUNCTION" - "METHOD-GENERIC-FUNCTION" - "METHOD-LAMBDA-LIST" - "METHOD-QUALIFIERS" - "METHOD-SPECIALIZERS" - "READER-METHOD-CLASS" - "REMOVE-DEPENDENT" - "REMOVE-DIRECT-METHOD" - "REMOVE-DIRECT-SUBCLASS" - "REMOVE-METHOD" - "SET-FUNCALLABLE-INSTANCE-FUNCTION" - "SLOT-BOUNDP-USING-CLASS" - "SLOT-DEFINITION" - "SLOT-DEFINITION-ALLOCATION" - "SLOT-DEFINITION-INITARGS" - "SLOT-DEFINITION-INITFORM" - "SLOT-DEFINITION-INITFUNCTION" - "SLOT-DEFINITION-LOCATION" - "SLOT-DEFINITION-NAME" - "SLOT-DEFINITION-READERS" - "SLOT-DEFINITION-TYPE" - "SLOT-DEFINITION-WRITERS" - "SLOT-MAKUNBOUND-USING-CLASS" - "SLOT-VALUE-USING-CLASS" - "SPECIALIZER" - "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" - "SPECIALIZER-DIRECT-METHODS" - "STANDARD-ACCESSOR-METHOD" - "STANDARD-CLASS" - "STANDARD-DIRECT-SLOT-DEFINITION" - "STANDARD-EFFECTIVE-SLOT-DEFINITION" - "STANDARD-GENERIC-FUNCTION" - "STANDARD-INSTANCE-ACCESS" - "STANDARD-METHOD" - "STANDARD-OBJECT" - "STANDARD-READER-METHOD" - "STANDARD-SLOT-DEFINITION" - "STANDARD-WRITER-METHOD" - "UPDATE-DEPENDENT" - "VALIDATE-SUPERCLASS" - "WRITER-METHOD-CLASS")) + (:export #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:add-method + #:allocate-instance + #:built-in-class + #:class + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-name + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition + #:direct-slot-definition-class + #:effective-slot-definition + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function + #:ensure-generic-function-using-class + #:eql-specializer + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-instance-access + #:funcallable-standard-object + #:function + #:generic-function + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #:make-instance + #:make-method-lambda + #:map-dependents + #:metaobject + #:method + #:method-combination + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-qualifiers + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:remove-method + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-accessor-method + #:standard-class + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-generic-function + #:standard-instance-access + #:standard-method + #:standard-object + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + #:update-dependent + #:validate-superclass + #:writer-method-class)) ;;;(eval-when (:compile-toplevel :load-toplevel :execute) ;;; (do-external-symbols (sym :clos) @@ -165,3 +165,6 @@ .args.)))))) (t `(defun ,fun ,args , at body)))) ) + + + --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-acl.lisp 2004/03/10 12:03:45 1.5 +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-acl.lisp 2006/03/29 10:43:48 1.6 @@ -23,7 +23,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -(in-package :CLIM-INTERNALS) +(in-package :clim-internals) (defconstant *multiprocessing-p* t) From tmoore at common-lisp.net Wed Mar 29 10:43:52 2006 From: tmoore at common-lisp.net (tmoore) Date: Wed, 29 Mar 2006 05:43:52 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Looks Message-ID: <20060329104352.777E058318@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Looks In directory clnet:/tmp/cvs-serv13084/Looks Modified Files: pixie.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2003/10/08 17:00:56 1.15 +++ /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2006/03/29 10:43:50 1.16 @@ -1,4 +1,4 @@ -(in-package :CLIM-INTERNALS) +(in-package :clim-internals) ;;; ; @@ -341,6 +341,7 @@ ; We derive from the slider, since the slider is the same, only ; less so. +;;; XXX Probably should derive from scroll-bar too. (defconstant +pixie-scroll-bar-pane-thumb-size+ 5000.0) (defconstant +pixie-scroll-bar-thumb-half-height+ 17) @@ -476,6 +477,14 @@ (yb (translate-range-value (+ v ts) minv (+ maxv ts) y1 y2))) (make-rectangle* x1 (- ya 1) x2 (+ yb 1))))))))) +(defmethod* (setf scroll-bar-values) + (min-value max-value thumb-size value (scroll-bar pixie-scroll-bar-pane)) + (setf (slot-value scroll-bar 'min-value) min-value + (slot-value scroll-bar 'max-value) max-value + (slot-value scroll-bar 'thumb-size) thumb-size + (slot-value scroll-bar 'value) value) + (dispatch-repaint scroll-bar (sheet-region scroll-bar))) + (defmethod handle-event ((pane pixie-scroll-bar-pane) (event pointer-button-release-event)) (with-slots (armed dragging repeating was-repeating) pane (setf was-repeating repeating) From crhodes at common-lisp.net Thu Mar 30 09:37:02 2006 From: crhodes at common-lisp.net (crhodes) Date: Thu, 30 Mar 2006 04:37:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage Message-ID: <20060330093702.B2D034B00F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage In directory clnet:/tmp/cvs-serv7900 Modified Files: index.html Log Message: Update the webpage. --- /project/mcclim/cvsroot/mcclim/Webpage/index.html 2005/07/30 17:10:47 1.11 +++ /project/mcclim/cvsroot/mcclim/Webpage/index.html 2006/03/30 09:37:02 1.12 @@ -55,43 +55,58 @@

Releases

A compressed tar file of the sources is made nightly.

- The most recent release of McCLIM is 0.9.1, in March 2005, available here: mcclim-0.9.1.tar.gz. It is also available via ASDF-INSTALL. + The most recent release of McCLIM is 0.9.2, in March 2006, available here: mcclim-0.9.2.tar.gz. It is also available via ASDF-INSTALL.

Recent News

- McCLIM CVS hosting moved to - common-lisp.net; - if you're a developer you should already have heard about - this (if not, mail admin at common-lisp.net). -

- Tim Moore presented a - paper - written by Robert Strandh and himself - at the International Lisp Conference during the last week of October 2002. + 2006-03-26: McCLIM 0.9.2 "Laetare Sunday" released. +

+

+ 2005-03-06: McCLIM 0.9.1 "Mothering Sunday" released. +

+ 2004-12-09: McCLIM CVS hosting moved to common-lisp.net; if you're + a developer you should already have heard about this (if not, + mail admin at common-lisp.net). +

+

+ 2002-10-29: Tim Moore presented a paper written by Robert Strandh and + himself at the International Lisp Conference during the last + week of October 2002.

Who's involved?

McCLIM is written by a diverse group of individuals from across the world. - The primary developers include: + Contributors past and present include:

    +
  • Daniel Barlow
  • Gilbert Baumann
  • Julien Boninfan
  • Alexey Dejneka
  • +
  • Clemens Fruhwirth
  • +
  • Andreas Fuchs
  • +
  • Robert Goldman
  • Iban Hatchondo
  • Andy Hefner
  • +
  • Brian Mastenbrook
  • Mike McDonald
  • Timothy Moore
  • Edena Pixel
  • +
  • Max-Gerd Retzlaff
  • +
  • Christophe Rhodes
  • +
  • Duncan Rose
  • Arnaud Rouanet
  • Lionel Salabartan
  • +
  • Rudi Schlatte
  • Brian Spilsbury
  • Robert Strandh


-$Date: 2005/07/30 17:10:47 $ +$Date: 2006/03/30 09:37:02 $ From crhodes at common-lisp.net Thu Mar 30 10:06:09 2006 From: crhodes at common-lisp.net (crhodes) Date: Thu, 30 Mar 2006 05:06:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage Message-ID: <20060330100609.1920950002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage In directory clnet:/tmp/cvs-serv11257 Modified Files: index.html Log Message: Link to binaries; note their highly-experimental status --- /project/mcclim/cvsroot/mcclim/Webpage/index.html 2006/03/30 09:37:02 1.12 +++ /project/mcclim/cvsroot/mcclim/Webpage/index.html 2006/03/30 10:06:08 1.13 @@ -59,6 +59,15 @@

Recent News

+ 2006-03-30: Highly-experimental binaries of McCLIM 0.9.2, set + up to start up the McCLIM listener, and incorporating the + McCLIM demos as well as a graphical debugger and inspector, + are available for download. Supported platforms: PPC/OS + X, x86/Linux. + +

2006-03-26: McCLIM 0.9.2 "Laetare Sunday" released.

@@ -106,7 +115,7 @@


-$Date: 2006/03/30 09:37:02 $ +$Date: 2006/03/30 10:06:08 $ From tmoore at common-lisp.net Thu Mar 30 12:07:59 2006 From: tmoore at common-lisp.net (tmoore) Date: Thu, 30 Mar 2006 07:07:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060330120759.6E505A0E6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25437 Modified Files: gadgets.lisp package.lisp Log Message: Fix up scroll bars in Beagle. Use the high level gadget events to signal scroll bar changes to the application. Document the unintuitive scroll-bar-thumb-size slot in the scroll-bar gadget. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/03/29 10:43:37 1.98 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/03/30 12:07:59 1.99 @@ -460,8 +460,11 @@ :initform nil :reader scroll-bar-scroll-up-page-callback) (thumb-size :initarg :thumb-size :initform 1/4 - :accessor scroll-bar-thumb-size) - ) + :accessor scroll-bar-thumb-size + :documentation "The size of the scroll bar thumb (slug) in the + units of the gadget value. When the scroll bar is drawn the empty region of + the scroll bar and the thumb are drawn in proportion to the values of the + gadget range and thumb size.")) (:default-initargs :value 0 :min-value 0 :max-value 1 @@ -2853,6 +2856,7 @@ (defmethod handle-event ((gadget basic-gadget) (event callback-event)) (apply (callback-function event) + (event-gadget event) (event-client event) (event-client-id event) (event-other-args event))) --- /project/mcclim/cvsroot/mcclim/package.lisp 2006/03/15 22:56:54 1.53 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2006/03/30 12:07:59 1.54 @@ -1947,6 +1947,7 @@ #:port-set-sheet-region #:port-set-sheet-transformation #:port-ungrab-pointer + #:queue-callback #:%set-port-keyboard-focus #:set-sheet-pointer-cursor #:synthesize-pointer-motion-event From tmoore at common-lisp.net Thu Mar 30 12:07:59 2006 From: tmoore at common-lisp.net (tmoore) Date: Thu, 30 Mar 2006 07:07:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle Message-ID: <20060330120759.9D5E412034@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory clnet:/tmp/cvs-serv25437/Backends/beagle Modified Files: package.lisp Log Message: Fix up scroll bars in Beagle. Use the high level gadget events to signal scroll bar changes to the application. Document the unintuitive scroll-bar-thumb-size slot in the scroll-bar gadget. --- /project/mcclim/cvsroot/mcclim/Backends/beagle/package.lisp 2005/05/17 20:26:37 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/package.lisp 2006/03/30 12:07:59 1.5 @@ -18,27 +18,15 @@ (:import-from :climi #:+alt-key+ ;; - #:mirror-transformation - #:port-set-sheet-region - #:port-set-sheet-transformation #:port-text-style-mappings #:port-lookup-mirror #:port-register-mirror - #:port-allocate-pixmap - #:port-deallocate-pixmap - #:port-mirror-width - #:port-mirror-height + #:port-event-process #:port-grafts - #:port-enable-sheet - #:port-disable-sheet - #:port-motion-hints - #:port-force-output #:%set-port-keyboard-focus #:set-sheet-pointer-cursor ;; - #:port-set-mirror-region - #:port-set-mirror-transformation #:update-mirror-geometry #:%sheet-mirror-region #:%sheet-mirror-transformation @@ -69,7 +57,6 @@ ;; #:space-requirement ;used as slot, very bogus ;; fbound #:medium-device-region - #:medium-draw-circle* #:draw-image #:text-style-character-width #:height ;this seems bogus @@ -81,9 +68,7 @@ #:port-ungrab-pointer ;; #:invoke-with-special-choices - #:medium-draw-glyph #:medium-miter-limit - #:make-graft ;; classes: #:mirrored-pixmap #:window-destroy-event From tmoore at common-lisp.net Thu Mar 30 12:07:59 2006 From: tmoore at common-lisp.net (tmoore) Date: Thu, 30 Mar 2006 07:07:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/native-panes Message-ID: <20060330120759.E9C8A13022@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes In directory clnet:/tmp/cvs-serv25437/Backends/beagle/native-panes Modified Files: beagle-scroll-bar-pane.lisp Log Message: Fix up scroll bars in Beagle. Use the high level gadget events to signal scroll bar changes to the application. Document the unintuitive scroll-bar-thumb-size slot in the scroll-bar gadget. --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-scroll-bar-pane.lisp 2006/02/22 10:55:41 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-scroll-bar-pane.lisp 2006/03/30 12:07:59 1.8 @@ -4,13 +4,7 @@ ;;; Limitations: ;;; ;;; - ignores different NSControl sizes -;;; - inherits from the 'standard' scroll-bar-pane, rather than from the abstract -;;; scroll bar -;;; Inheriting from 'scroll-bar' will probably work if we use the :default-initargs -;;; hackery out of gadgets.lisp (but shouldn't these be part of the abstract type?) - -;;;(defclass beagle-scroll-bar-pane (scroll-bar) (defclass beagle-scroll-bar-pane (scroll-bar) ((tk-obj :initform (%null-ptr) :accessor toolkit-object))) @@ -83,6 +77,54 @@ :min-height width :height width)))) +;;; Change the value of the scroll bar in the application process i.e., +;;; consistently with respect to events that have been received. + +(defmethod drag-callback :before + ((gadget beagle-scroll-bar-pane) client gadget-id value) + (declare (ignore client gadget-id)) + (setf (slot-value gadget 'climi::value) value)) + +(defun update-cocoa-scroll-bar (scroll-bar) + (let* ((range (- (gadget-max-value scroll-bar) + (gadget-min-value scroll-bar))) + (value (if (zerop range) + 0.0 + (/ (- (gadget-value scroll-bar) + (gadget-min-value scroll-bar)) + range))) + (ts (climi::scroll-bar-thumb-size scroll-bar)) + (loz-size (if (<= range 0) + 1.0 + (/ ts (+ range ts))))) + (send (toolkit-object scroll-bar) + :set-float-value (coerce (clamp value 0.0 1.0) 'short-float) + :knob-proportion (coerce (clamp loz-size 0.0 1.0) 'short-float)))) + +(defmethod (setf gadget-min-value) :after + (new-value (pane beagle-scroll-bar-pane)) + (declare (ignore new-value)) + (update-cocoa-scroll-bar pane)) + +(defmethod (setf gadget-max-value) :after (new-value (pane beagle-scroll-bar-pane)) + (declare (ignore new-value)) + (update-cocoa-scroll-bar pane)) + +(defmethod (setf climi::scroll-bar-thumb-size) :after (new-value (pane beagle-scroll-bar-pane)) + (declare (ignore new-value)) + (update-cocoa-scroll-bar pane)) + +(defmethod (setf gadget-value) :after (new-value (pane beagle-scroll-bar-pane) &key invoke-callback) + (declare (ignore new-value invoke-callback)) + (update-cocoa-scroll-bar pane)) + +(climi::defmethod* (setf climi::scroll-bar-values) + (min-value max-value thumb-size value (scroll-bar beagle-scroll-bar-pane)) + (setf (slot-value scroll-bar 'climi::min-value) min-value + (slot-value scroll-bar 'climi::max-value) max-value + (slot-value scroll-bar 'climi::thumb-size) thumb-size + (slot-value scroll-bar 'climi::value) value) + (update-cocoa-scroll-bar scroll-bar)) ;;; No need to update the scrollbar (most of the time) since Cocoa will move ;;; the 'thumb' appropriately. Stick some debug in to see when it's invoked. @@ -91,6 +133,7 @@ ;;; I believe it's safe to leave this alone though since the sb will only be ;;; redrawn once through the event loop it shouldn't be too inefficient to ;;; be changing its value regularly. +#-(and) (defmethod (setf gadget-value) :before (value (gadget beagle-scroll-bar-pane) &key invoke-callback) (declare (ignore invoke-callback)) @@ -101,12 +144,10 @@ (let* ((range (- (gadget-max-value gadget) (gadget-min-value gadget))) - (size (if (eq (gadget-orientation gadget) :vertical) - (bounding-rectangle-height gadget) - (bounding-rectangle-width gadget))) + (size (climi::scroll-bar-thumb-size gadget)) (position (if (<= range 0) 0.0 - (/ value range))) + (/ (- value (gadget-min-value gadget) range))) (loz-size (if (<= range 0) 1.0 (/ size range)))) @@ -115,6 +156,7 @@ :knob-proportion (coerce loz-size 'short-float)))) +;;; Called in the Cocoa App thread. (defun scroll-bar-action-handler (pane sender) ;; Now we need to decide exactly what we do with these events... not sure @@ -132,28 +174,33 @@ (let ((hit-part (send sender 'hit-part))) (cond ((or (eq hit-part #$NSScrollerKnob) ; drag knob (eq hit-part #$NSScrollerKnobSlot)) ; click on knob (or alt-click on slot) - (let ((value (* (send sender 'float-value) ; 0.0 - 1.0 + (let ((value (+ (* (send sender 'float-value) ; 0.0 - 1.0 (- (gadget-max-value pane) ; range; 0.0 -> max extent ... - (gadget-min-value pane))))) ; ... (probably) - (clim:drag-callback pane - (gadget-client pane) - (gadget-id pane) - value))) + (gadget-min-value pane))) + (gadget-min-value pane)))) ; ... (probably) + (queue-callback #'clim:drag-callback + pane + (gadget-client pane) + (gadget-id pane) + value))) ((eq hit-part #$NSScrollerDecrementLine) - (clim:scroll-up-line-callback pane - (gadget-client pane) - (gadget-id pane))) + (queue-callback #'clim:scroll-up-line-callback + pane + (gadget-client pane) + (gadget-id pane))) ((eq hit-part #$NSScrollerDecrementPage) - (clim:scroll-up-page-callback pane - (gadget-client pane) - (gadget-id pane))) + (queue-callback #'clim:scroll-up-page-callback + pane + (gadget-client pane) + (gadget-id pane))) ((eq hit-part #$NSScrollerIncrementLine) - (clim:scroll-down-line-callback pane - (gadget-client pane) - (gadget-id pane))) + (queue-callback #'clim:scroll-down-line-callback + pane + (gadget-client pane) + (gadget-id pane))) ((eq hit-part #$NSScrollerIncrementPage) - (clim:scroll-down-page-callback pane - (gadget-client pane) - (gadget-id pane)))))) - + (queue-callback #'clim:scroll-down-page-callback + pane + (gadget-client pane) + (gadget-id pane)))))) From afuchs at common-lisp.net Thu Mar 30 20:31:06 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 30 Mar 2006 15:31:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20060330203106.D8AAE50002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22364 Modified Files: decls.lisp Log Message: Fix invoke-with-new-output-record and invoke-with-output-to-output-record's arg lists to conform to the Franz User Guide, as noted in recording.lisp. --- /project/mcclim/cvsroot/mcclim/decls.lisp 2006/03/15 15:38:39 1.37 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2006/03/30 20:31:06 1.38 @@ -321,9 +321,9 @@ ;; with-output-recording-options (stream &key record draw) &body body [Macro] (defgeneric invoke-with-output-recording-options (stream continuation record draw)) ;; with-new-output-record (stream &optional record-type record &rest initargs) &body body [MAcro] -(defgeneric invoke-with-new-output-record (stream continuation record-type &rest initargs &key parent)) +(defgeneric invoke-with-new-output-record (stream continuation record-type constructor &key &allow-other-keys)) ;; with-output-to-output-record (stream &optional record-type record &rest initargs)) &body body [Macro] -(defgeneric invoke-with-output-to-output-record (stream continuation record-type &rest initargs &key)) +(defgeneric invoke-with-output-to-output-record (stream continuation record-type constructor &rest initargs &key &allow-other-keys)) (defgeneric make-design-from-output-record (record)) ;;;; 21.2