mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim
by ahefner 09 Nov '08

09 Nov '08

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv10292 Modified Files: gadgets.lisp Log Message: Nicer gadget range handling, and handle stream designators in w-o-a-g. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/05/09 22:16:11 1.111 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/11/09 19:49:17 1.112 @@ -1405,12 +1405,15 @@ (:vertical +identity-transformation+) (:horizontal (make-transformation 0 1 1 0 0 0)))) -(defun translate-range-value (a mina maxa mino maxo) +(defun translate-range-value (a mina maxa mino maxo + &optional (empty-result (/ (+ mino maxo) 2))) "When \arg{a} is some value in the range from \arg{mina} to \arg{maxa}, proportionally translate the value into the range \arg{mino} to \arg{maxo}." - (+ mino (* (/ (- a mina) - (- maxa mina)) ;### avoid divide by zero here. - (- maxo mino)))) + (if (zerop (- maxa mina)) + empty-result + (+ mino (* (/ (- a mina) + (- maxa mina)) + (- maxo mino))))) ;;;; SETF :after methods @@ -1487,18 +1490,13 @@ (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb) (declare (ignore y3)) (multiple-value-bind (minv maxv) (gadget-range* sb) - (if (= y1 y2) ;### fix this in translate-range-value - minv - (translate-range-value y y1 y2 minv maxv))))) + (translate-range-value y y1 y2 minv maxv minv)))) (defun scroll-bar/map-value-to-coordinate (sb v) (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb) (declare (ignore y3)) (multiple-value-bind (minv maxv) (gadget-range* sb) - ;; oops, if the range is empty we lose! - (if (= minv maxv) ;### fix this in translate-range-value - y1 - (round (translate-range-value v minv maxv y1 y2)))))) + (round (translate-range-value v minv maxv y1 y2 y1))))) (defmethod scroll-bar-thumb-region ((sb scroll-bar-pane)) (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-bed-region sb) @@ -2666,6 +2664,7 @@ ;; 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. + (setf stream (stream-designator-symbol stream '*standard-output*)) (let ((gadget-output-record (gensym)) (x (gensym)) (y (gensym)))

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 23 Oct '08

23 Oct '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory cl-net:/tmp/cvs-serv11848 Modified Files: dev-commands.lisp util.lisp Log Message: Listener fixes from Willem Broekema. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/10/22 23:58:12 1.63 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/10/23 20:54:53 1.64 @@ -681,6 +681,7 @@ #+openmcl-partial-mop (openmcl-mop:specializer-direct-generic-functions specializer) #+scl (clos:specializer-direct-generic-functions specializer) + #+allegro (mop: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 --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/10/22 23:58:12 1.27 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/10/23 20:54:54 1.28 @@ -31,7 +31,7 @@ (defun directoryp (path) "Determine if PATH designates a directory" - #+allegro (excl:file-directory-p pathname) + #+allegro (excl:file-directory-p path) #-allegro (flet ((f (x) (if (eq x :unspecific) nil x))) (if (or (f (pathname-name path))

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 23 Oct '08

23 Oct '08

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv11017 Modified Files: stream-output.lisp Log Message: SEOS-WRITE-STRING fix wrt. zero-length strings from Mike Watters. --- /project/mcclim/cvsroot/mcclim/stream-output.lisp 2008/04/15 19:28:04 1.62 +++ /project/mcclim/cvsroot/mcclim/stream-output.lisp 2008/10/23 20:49:58 1.63 @@ -287,7 +287,9 @@ :text-style text-style) while (<= sub-width delta) finally (return (1- i))))) - + (when (eql end 0) + (return-from seos-write-string)) + (with-slots (baseline height vspace) stream (multiple-value-bind (cx cy) (stream-cursor-position stream) (when (> new-baseline baseline)

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 23 Oct '08

23 Oct '08

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv10938 Modified Files: commands.lisp Log Message: MAP-OVER-COMMAND-TABLE-TRANSLATORS and ADD-ACTUAL-PRESENTATION-TRANSLATOR-TO-COMMAND-TABLE from Mike Watters. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/04/20 07:19:10 1.79 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/10/23 20:49:41 1.80 @@ -480,6 +480,39 @@ (map-over-command-table-menu-items function table)))) (values))) +(defun map-over-command-table-translators + (function command-table &key (inherited t)) + (flet ((map-func (table) + (maphash #'(lambda (k v) + (declare (ignore k)) + (funcall function v)) + (slot-value + (presentation-translators table) + 'translators)))) + (let ((command-table (find-command-table command-table))) + (if inherited + (apply-with-command-table-inheritance #'map-func command-table) + (map-func command-table))))) + +;(defun add-presentation-translator-to-command-table +; (command-table translator-name &key (errorp t))) +; - fixme; spec says this fun is given a translator name, but that +; find-presentation-translator needs a translator name and a command +; table designator +(defun add-actual-presentation-translator-to-command-table + (command-table translator &key (errorp t)) + (let ((translators + (presentation-translators + (find-command-table command-table)))) + (when (and errorp + (second + (multiple-value-list + (gethash (name translator) + (slot-value translators 'translators))))) + (error 'command-already-present + :command-table-name command-table)) + (add-translator translators translator))) + ;; At this point we should still see the gesture name as supplied by the ;; programmer in 'gesture' (defun %add-keystroke-item (command-table gesture item errorp)

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by thenriksen 23 Oct '08

23 Oct '08

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory cl-net:/tmp/cvs-serv10847/Backends/CLX Modified Files: port.lisp Log Message: `decode-x-button-code' fix from Mike Watters. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/10/20 17:31:41 1.135 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/10/23 20:49:12 1.136 @@ -615,10 +615,11 @@ +pointer-wheel-up+ +pointer-wheel-down+ +pointer-wheel-left+ - +pointer-wheel-right+))) - (and (> code 0) - (<= code (length button-mapping)) - (aref button-mapping (1- code))))) + +pointer-wheel-right+)) + (code (1- code))) + (when (and (>= code 0) + (< code (length button-mapping))) + (aref button-mapping code)))) ;; From "Inter-Client Communication Conventions Manual", Version 2.0.xf86.1, ;; section 4.1.5:

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 23 Oct '08

23 Oct '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory cl-net:/tmp/cvs-serv10588/Drei Modified Files: drei-clim.lisp Log Message: Spelling fixes from Mike Watters. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/05/01 06:48:21 1.45 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/10/23 20:47:57 1.46 @@ -57,10 +57,10 @@ ;;; though. ;;; Cursors are output records. After a cursor is created, The owning -;;; Drei instance instnace should add it to the output stream. The -;;; owner of the cursor (a Drei instance) is responsible for removing -;;; the cursor once it is done with it. Cursors can be active/inactive -;;; and enabled/disabled and have the same activity-status as their +;;; Drei instance should add it to the output stream. The owner of the +;;; cursor (a Drei instance) is responsible for removing the cursor +;;; once it is done with it. Cursors can be active/inactive and +;;; enabled/disabled and have the same activity-status as their ;;; associated view. (defclass drei-cursor (standard-sequence-output-record) ((%view :reader view

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 23 Oct '08

23 Oct '08

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv10588 Modified Files: input-editing.lisp Log Message: Spelling fixes from Mike Watters. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/07 20:20:04 1.74 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/10/23 20:47:57 1.75 @@ -28,7 +28,7 @@ (in-package :clim-internals) (defvar *use-goatee* nil - "I true, use the Goatee editing component instead of Drei. The + "If true, use the Goatee editing component instead of Drei. The Goatee component is faster and more mature than Drei.") (defvar *activation-gestures* nil

1 0

[mcclim-cvs] CVS mcclim
by ahefner 23 Oct '08

23 Oct '08

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv22219 Modified Files: graphics.lisp Log Message: make-pattern-from-bitmap-file: Fix width/height - image matrices are row-major. --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/04/14 16:46:37 1.61 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/10/23 00:23:06 1.62 @@ -1016,7 +1016,8 @@ (medium (design rgb-image-design) &rest options &key (x 0) (y 0) &allow-other-keys) (with-medium-options (medium options) - (medium-draw-image-design* medium design x y))) + (medium-draw-image-design* medium design x y)) + (values)) ;;;; @@ -1203,8 +1204,8 @@ (if read-designs (make-pattern res (or designs read-designs)) (make-instance 'rgb-pattern :image (make-instance 'rgb-image - :width (array-dimension res 0) - :height (array-dimension res 1) + :width (array-dimension res 1) + :height (array-dimension res 0) :data res))))) (define-bitmap-file-reader :xpm (pathname)

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 22 Oct '08

22 Oct '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory cl-net:/tmp/cvs-serv8102 Modified Files: dev-commands.lisp util.lisp Log Message: Fix a couple careless oversights, and add a backdoor variable to disable threaded evaluation. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/10/20 17:04:29 1.62 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/10/22 23:58:12 1.63 @@ -1155,7 +1155,7 @@ (setf (stream-cursor-position *standard-output*) (values 0 y)))) (:list (dolist (ent group) (let ((ent (merge-pathnames ent pathname))) - (pretty-pretty-pathname ent *standard-output* :long-name full-names)))))))))) + (pretty-pretty-pathname ent *standard-output* full-names)))))))))) #+nil ; OBSOLETE (define-presentation-to-command-translator show-directory-translator @@ -1175,7 +1175,7 @@ ((pathname 'pathname :prompt "pathname")) (let ((pathname (merge-pathnames ;; helpfully fix things if trailing slash wasn't entered - (directorify-pathname pathname)))) + (coerce-to-directory pathname)))) (if (not (probe-file pathname)) (note "~A does not exist.~%" pathname) (change-directory pathname)))) @@ -1311,7 +1311,7 @@ :menu t :command-table directory-stack-commands) ((pathname 'pathname :prompt "directory")) - (let ((pathname (merge-pathnames (directorify-pathname pathname)))) + (let ((pathname (merge-pathnames (coerce-to-directory pathname)))) (if (not (probe-file pathname)) (note "~A does not exist.~%" pathname) (progn (push *default-pathname-defaults* *directory-stack*) @@ -1324,7 +1324,7 @@ (format t "~&The top of the directory stack is now ") (present (truename (first *directory-stack*))) (terpri)) - (format "~&The directory stack is now empty.~%"))) + (format t "~&The directory stack is now empty.~%"))) (define-command (com-pop-directory :name "Pop Directory" :menu t @@ -1504,6 +1504,13 @@ ** * * (first values))) +;;; The background evaluation feature is neat, but some people (namely +;;; myself) sometimes need a backdoor to disable it when evaluating +;;; code which does a lot of graphics in the listener, due to thread +;;; safety issues with concurrent access to a CLIM stream. +(defparameter *use-background-eval* t + "Perform evaluation in a background thread, which can be interrupted.") + (define-command (com-eval :menu t :command-table lisp-commands) ((form 'clim:form :prompt "form")) (let ((standard-output *standard-output*) @@ -1527,7 +1534,7 @@ ;; interrupt it. (let ((start-time (get-internal-real-time))) (destructuring-bind (result . value) - (if clim-sys:*multiprocessing-p* + (if (and *use-background-eval* clim-sys:*multiprocessing-p*) (catch 'done (let* ((orig-process (clim-sys:current-process)) (evaluating t) @@ -1571,7 +1578,7 @@ :command-table show-commands) ((table 'clim:command-table :prompt "command table") &key - (locally 'boolean :default nil :mentioned-default t) + ;;(locally 'boolean :default nil :mentioned-default t) (show-commands 'boolean :default t)) (let ((our-tables nil) (processed-commands (make-hash-table :test #'eq))) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/10/20 17:04:29 1.26 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/10/22 23:58:12 1.27 @@ -505,8 +505,7 @@ (with-drawing-options (stream :ink ink) (unless (zerop range) (when (eql t scale-y) - (setf scale-y (/ 250 range)) - #+NIL (hef:debugf scale-y)) + (setf scale-y (/ 250 range))) (draw-thin-bar-graph-1 stream (lambda (i) (funcall key (aref vector i))) @@ -533,3 +532,4 @@ (float (/ height (- max-y min-y)) 0.0f0) min-x max-x (/ (- max-x min-x) width)))))) +

1 0

[mcclim-cvs] CVS mcclim
by ahefner 22 Oct '08

22 Oct '08

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv1885 Modified Files: clim-listener.asd Log Message: Oops, do load appearance.lisp in clim-listener system. --- /project/mcclim/cvsroot/mcclim/clim-listener.asd 2008/04/14 16:46:37 1.4 +++ /project/mcclim/cvsroot/mcclim/clim-listener.asd 2008/10/22 23:26:58 1.5 @@ -12,11 +12,12 @@ :pathname #.(make-pathname :directory '(:relative "Apps" "Listener")) :components ((:file "package") + (:file "appearance" :depends-on ("package")) (:file "util" :depends-on ("package")) (:file "icons" :depends-on ("package" "util")) (:file "file-types" :depends-on ("package" "icons" "util")) - (:file "dev-commands" :depends-on ("package" "icons" "file-types" "util")) + (:file "dev-commands" :depends-on ("package" "appearance" "icons" "file-types" "util")) (:file "wholine" :depends-on ("package" "dev-commands" "util")) (:file "listener" :depends-on ("package" "wholine" "file-types" "icons" "dev-commands" "util")) - #+CMU (:file "cmu-hacks" :depends-on ("package")))))) +

1 0

← Newer
1
...
5
6
7
8
9
10
11
...
170
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs