From ahefner at common-lisp.net Sat Jun 2 20:30:53 2007 From: ahefner at common-lisp.net (ahefner) Date: Sat, 2 Jun 2007 16:30:53 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20070602203053.C105E21056@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv32451 Modified Files: dev-commands.lisp listener.lisp Log Message: Added port and frame-manager args to run-listener. Changed value printing at the repl - if there are no values, print nothing. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2007/01/05 12:45:22 1.41 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2007/06/02 20:30:53 1.42 @@ -1469,8 +1469,7 @@ :single-box t) (present value 'expression)))) (with-drawing-options (t :ink +olivedrab+) - (cond ((null values) - (format t "No values.~%")) + (cond ((null values) #+NIL (format t "No values.~%")) ((= 1 (length values)) (present-value (first values)) (fresh-line)) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/02/05 03:27:14 1.34 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/06/02 20:30:53 1.35 @@ -155,8 +155,13 @@ (defun run-listener (&key (new-process nil) (width 760) (height 550) + port + frame-manager (process-name "Listener")) - (let ((frame (make-application-frame 'listener + (let* ((fm (or frame-manager + (find-frame-manager :port (or port (find-port))))) + (frame (make-application-frame 'listener + :frame-manager fm :width width :height height))) (flet ((run () (run-frame-top-level frame))) From ahefner at common-lisp.net Sun Jun 3 18:47:03 2007 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Jun 2007 14:47:03 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070603184703.74AE54D059@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3786 Modified Files: recording.lisp Log Message: Revert to Robert Strandh's version of recompute-extent-for-changed-child, which I appear to have broken. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2007/03/20 01:48:38 1.131 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2007/06/03 18:47:03 1.132 @@ -779,73 +779,65 @@ old-min-x old-min-y old-max-x old-max-y) (with-bounding-rectangle* (ox1 oy1 ox2 oy2) record (with-bounding-rectangle* (cx1 cy1 cx2 cy2) changed-child - (let ((child-was-empty (and (= old-min-x old-min-y) ; =( - (= old-max-x old-max-y)))) - ;; If record is currently empty, use the child's bbox directly. Else.. - ;; Does the new rectangle of the child contain the original rectangle? - ;; If so, we can use min/max to grow record's current rectangle. - ;; If not, the child has shrunk, and we need to fully recompute. - (multiple-value-bind (nx1 ny1 nx2 ny2) - (cond - ;; The child has been deleted, but none of its edges contribute - ;; to the bounding rectangle of the parent, so the bounding - ;; rectangle cannot be changed by its deletion. - ;; This is also true if the child was empty. - ((or child-was-empty - (and (output-record-parent changed-child) - (> old-min-x ox1) - (> old-min-y oy1) - (< old-max-x ox2) - (< old-max-y oy2))) - (values ox1 oy1 ox2 oy2)) - ;; The child has been deleted; who knows what the - ;; new bounding box might be. - ((not (output-record-parent changed-child)) - (%tree-recompute-extent* record)) - ;; Only one child of record, and we already have the bounds. - ((eql (output-record-count record) 1) - (values cx1 cy1 cx2 cy2)) - ;; If our record occupied no space (had no children, or had only - ;; children similarly occupying no space, hackishly determined by - ;; null-bounding-rectangle-p), recompute the extent now, otherwise - ;; the next COND clause would, as an optimization, attempt to extend - ;; our current bounding rectangle, which is invalid. - ((null-bounding-rectangle-p record) - (%tree-recompute-extent* record)) - ;; In the following cases, we can grow the new bounding rectangle - ;; from its previous state: - ((or - ;; If the child was originally empty, it should not have affected - ;; previous computation of our bounding rectangle. - child-was-empty - ;; No child edge which may have defined the bounding rectangle of - ;; the parent has shrunk inward, so min/max the new child rectangle - ;; against the existing rectangle. Other edges of the child may have - ;; moved, but this can't affect the parent bounding rectangle. - (and (or (> old-min-x ox1) (>= old-min-x cx1)) - (or (> old-min-y oy1) (>= old-min-y cy1)) - (or (< old-max-x ox2) (<= old-max-x cx2)) - (or (< old-max-y oy2) (<= old-max-y cy2)))) - ;; In these cases, we can grow the rectangle using min/max. - (values (min cx1 ox1) (min cy1 oy1) - (max cx2 ox2) (max cy2 oy2))) - ;; No shortcuts - we must compute a new bounding box from those of - ;; all our children. We want to avoid this - in worst cases, such as - ;; a toplevel output history, large graph, or table, there may exist - ;; thousands of children. Without the above optimizations, - ;; construction becomes O(N^2) due to bounding rectangle calculation. - (t (%tree-recompute-extent* record))) - ;; XXX banish x, y - (with-slots (x y) - record - (setf x nx1 y ny1) - (setf (rectangle-edges* record) (values nx1 ny1 nx2 ny2)) - (let ((parent (output-record-parent record))) - (unless (or (null parent) - (and (= nx1 ox1) (= ny1 oy1) - (= nx2 ox2) (= nx2 oy2))) - (recompute-extent-for-changed-child parent record - ox1 oy1 ox2 oy2)))))))) + ;; If record is currently empty, use the child's bbox directly. Else.. + ;; Does the new rectangle of the child contain the original rectangle? + ;; If so, we can use min/max to grow record's current rectangle. + ;; If not, the child has shrunk, and we need to fully recompute. + (multiple-value-bind (nx1 ny1 nx2 ny2) + (cond + ;; The child has been deleted; who knows what the + ;; new bounding box might be. + ((not (output-record-parent changed-child)) + (%tree-recompute-extent* record)) + ;; Only one child of record, and we already have the bounds. + ((eql (output-record-count record) 1) + (values cx1 cy1 cx2 cy2)) + ;; If our record occupied no space (had no children, or had only + ;; children similarly occupying no space, hackishly determined by + ;; null-bounding-rectangle-p), recompute the extent now, otherwise + ;; the next COND clause would, as an optimization, attempt to extend + ;; our current bounding rectangle, which is invalid. + ((null-bounding-rectangle-p record) + (%tree-recompute-extent* record)) + ;; In the following cases, we can grow the new bounding rectangle + ;; from its previous state: + ((or + ;; If the child was originally empty, it should not have affected + ;; previous computation of our bounding rectangle. + ;; This is hackish for reasons similar to the above. + (and (zerop old-min-x) (zerop old-min-y) + (zerop old-max-x) (zerop old-max-y)) + ;; For each old child coordinate, either it was not + ;; involved in determining the bounding rectangle of the + ;; parent, or else it is the same as the corresponding + ;; new child coordinate. + (and (or (> old-min-x ox1) (= old-min-x cx1)) + (or (> old-min-y oy1) (= old-min-y cy1)) + (or (< old-max-x ox2) (= old-max-x cx2)) + (or (< old-max-y oy2) (= old-max-y cy2))) + ;; New child bounds contain old child bounds, so use min/max + ;; to extend the already-calculated rectangle. + (and (<= cx1 old-min-x) (<= cy1 old-min-y) + (>= cx2 old-max-x) (>= cy2 old-max-y))) + (values (min cx1 ox1) (min cy1 oy1) + (max cx2 ox2) (max cy2 oy2))) + ;; No shortcuts - we must compute a new bounding box from those of + ;; all our children. We want to avoid this - in worst cases, such as + ;; a toplevel output history, large graph, or table, there may exist + ;; thousands of children. Without the above optimizations, + ;; construction becomes O(N^2) due to bounding rectangle calculation. + (t (%tree-recompute-extent* record))) + ;; XXX banish x, y + (with-slots (x y) + record + (setf x nx1 y ny1) + (setf (rectangle-edges* record) (values nx1 ny1 nx2 ny2)) + (let ((parent (output-record-parent record))) + (unless (or (null parent) + (and (= nx1 ox1) (= ny1 oy1) + (= nx2 ox2) (= nx2 oy2))) + (recompute-extent-for-changed-child parent record + ox1 oy1 ox2 oy2))))))) record) ;; There was once an :around method on recompute-extent-for-changed-child here, From ahefner at common-lisp.net Wed Jun 6 05:03:15 2007 From: ahefner at common-lisp.net (ahefner) Date: Wed, 6 Jun 2007 01:03:15 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070606050315.11D6F140B1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4237 Modified Files: dialog.lisp Log Message: Committing some old work: implementation of notify-user, with some uncertainty as to how it works in classic CLIM. --- /project/mcclim/cvsroot/mcclim/dialog.lisp 2007/05/29 12:34:20 1.26 +++ /project/mcclim/cvsroot/mcclim/dialog.lisp 2007/06/06 05:03:12 1.27 @@ -622,3 +622,97 @@ (defun accepting-values-default-command () (loop (read-gesture :stream *accepting-values-stream*))) + + +;;;; notify-user + +;;; See http://openmap.bbn.com/hypermail/clim/0028.html for example usage. + +;;; TODO: +;;; - associated-window argument? +;;; - What is the correct return value from notify-user? We currently return +;;; the name of the action given in the :exit-boxes argument. +;;; - Invoke abort restart? Not necessary as it is with accepting-values, +;;; but probably what "Classic CLIM" does. +;;; - What are the default exit boxes? Just "Okay"? Okay and cancel? +;;; - Reimplement using accepting-values, if accepting-values is ever +;;; improved to produce comparable dialogs. +;;; - Should the user really be able to close the window from the WM? + +(defmethod notify-user (frame message &rest args) + (apply #'frame-manager-notify-user + (if frame (frame-manager frame) (find-frame-manager)) + message + :frame frame + args)) + +(define-application-frame generic-notify-user-frame () + ((message-string :initarg :message-string) + (exit-boxes :initarg :exit-boxes) + (title :initarg :title) + (style :initarg :style) + (text-style :initarg :text-style) + (return-value :initarg nil :initform :abort)) + (:pane (generate-notify-user-dialog *application-frame*))) + +(defun generate-notify-user-dialog (frame) + (with-slots (message-string exit-boxes text-style) frame + (vertically () + (spacing (:thickness 6) + (make-pane 'label-pane :label (or message-string "I'm speechless.") :text-style text-style)) + (spacing (:thickness 4) + (make-pane 'hbox-pane :contents (cons '+fill+ (generate-exit-box-buttons exit-boxes))))))) + +(defun generate-exit-box-buttons (specs) + (mapcar + (lambda (spec) + (destructuring-bind (action string &rest args) spec + (spacing (:thickness 2) + (apply #'make-pane + 'push-button + :label string + :text-style (make-text-style :sans-serif :roman :small) ; XXX + :activate-callback + (lambda (gadget) + (declare (ignore gadget)) + ;; This is fboundp business is weird, and only implied by a + ;; random message on the old CLIM list. Does the user function + ;; take arguments? + (when (or (typep action 'function) (fboundp action)) + (funcall action)) + (setf (slot-value *application-frame* 'return-value) action) + ;; This doesn't work: + #+NIL + (when (eql action :abort) + (and (find-restart 'abort) + (invoke-restart 'abort))) + (frame-exit *application-frame*)) + args)))) + specs)) + + +(defmethod frame-manager-notify-user + (frame-manager message-string &key frame associated-window + (title "") + documentation + (exit-boxes '((:exit "OK"))) + ; The 'name' arg is in the spec but absent from the Lispworks + ; manual, and I can't imagine what it would do differently + ; than 'title'. + name + style + (text-style (make-text-style :sans-serif :roman :small))) + (declare (ignore associated-window documentation)) + ;; Keywords from notify-user: + ;; associated-window title documentation exit-boxes name style text-style + (let ((frame (make-application-frame 'generic-notify-user-frame + :frame-event-queue (and frame (frame-event-queue frame)) + :pretty-name title + :message-string message-string + :frame-manager frame-manager + :exit-boxes exit-boxes + :title (or name title) + :style style + :text-style text-style))) + (run-frame-top-level frame) + (slot-value frame 'return-value)))