From rstrandh at common-lisp.net Tue Aug 2 00:34:43 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Tue, 2 Aug 2005 02:34:43 +0200 (CEST) Subject: [gsharp-cvs] CVS update: gsharp/esa.lisp gsharp/gui.lisp gsharp/modes.lisp gsharp/score-pane.lisp Message-ID: <20050802003443.BBF1A8815C@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv20069 Modified Files: esa.lisp gui.lisp modes.lisp score-pane.lisp Log Message: Fixed a bug in esa.lisp that made numeric arguments not work. Error messages are now displayed in the minibuffer. Some commands like forward-element, backward-element, and delete-element now accept numeric arguments. Prepared for incremental redisplay by changing inheritance of pixmap records. This is nontrivial, though, and will require some more thinking about. The best thing would be to fix McCLIM, but that looks nontrivial as well. Date: Tue Aug 2 02:34:42 2005 Author: rstrandh Index: gsharp/esa.lisp diff -u gsharp/esa.lisp:1.1 gsharp/esa.lisp:1.2 --- gsharp/esa.lisp:1.1 Mon Jul 25 11:53:28 2005 +++ gsharp/esa.lisp Tue Aug 2 02:34:41 2005 @@ -145,12 +145,12 @@ (let ((gesture (esa-read-gesture))) (cond ((event-matches-gesture-name-p gesture - '(:keyboard #\u (make-modifier-state :control))) + `(:keyboard #\u ,(make-modifier-state :control))) (let ((numarg 4)) (loop for gesture = (esa-read-gesture) while (event-matches-gesture-name-p gesture - '(:keyboard #\u (make-modifier-state :control))) + `(:keyboard #\u ,(make-modifier-state :control))) do (setf numarg (* 4 numarg)) finally (esa-unread-gesture gesture stream)) (let ((gesture (esa-read-gesture))) Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.21 gsharp/gui.lisp:1.22 --- gsharp/gui.lisp:1.21 Mon Aug 1 01:36:56 2005 +++ gsharp/gui.lisp Tue Aug 2 02:34:41 2005 @@ -58,7 +58,7 @@ (defmethod execute-frame-command :around ((frame gsharp) command) (handler-case (call-next-method) - (gsharp-condition (condition) (message "~a~%" condition)))) + (gsharp-condition (condition) (beep) (display-message "~a" condition)))) (defmethod display-state ((frame gsharp) pane) (let ((state (input-state *application-frame*))) @@ -895,10 +895,11 @@ ;;; ;;; motion by element -(define-gsharp-command com-forward-element () - (forward-element (cursor *application-frame*))) +(define-gsharp-command com-forward-element ((count 'integer :prompt "Number of Elements")) + (loop repeat count + do (forward-element (cursor *application-frame*)))) -(define-gsharp-command com-backward-element () +(define-gsharp-command com-backward-element ((count 'integer :prompt "Number of Elements")) (backward-element (cursor *application-frame*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -925,15 +926,17 @@ (insert-element element cursor) (forward-element cursor)))) -(define-gsharp-command com-delete-element () +(define-gsharp-command com-delete-element ((count 'integer :prompt "Number of Elements")) (let ((cursor (cursor *application-frame*))) - ;;; this will signal a condition if in last bar and - ;;; interrupt the execution of the command - (forward-element cursor) - (backward-element cursor) - (if (end-of-bar-p cursor) - (fuse-bar-with-next cursor) - (delete-element cursor)))) + (loop repeat count + do (progn + ;; this will signal a condition if in last bar and + ;; interrupt the execution of the command + (forward-element cursor) + (backward-element cursor) + (if (end-of-bar-p cursor) + (fuse-bar-with-next cursor) + (delete-element cursor)))))) (define-gsharp-command com-erase-element () (let ((cursor (cursor *application-frame*))) Index: gsharp/modes.lisp diff -u gsharp/modes.lisp:1.5 gsharp/modes.lisp:1.6 --- gsharp/modes.lisp:1.5 Mon Jul 25 13:14:37 2005 +++ gsharp/modes.lisp Tue Aug 2 02:34:41 2005 @@ -3,9 +3,9 @@ (define-command-table global-gsharp-table :inherit-from (global-esa-table keyboard-macro-table)) -(set-key 'com-forward-element 'global-gsharp-table '((#\f :control))) -(set-key 'com-backward-element 'global-gsharp-table '((#\b :control))) -(set-key 'com-delete-element 'global-gsharp-table '((#\d :control))) +(set-key `(com-forward-element ,*numeric-argument-marker*) 'global-gsharp-table '((#\f :control))) +(set-key `(com-backward-element ,*numeric-argument-marker*) 'global-gsharp-table '((#\b :control))) +(set-key `(com-delete-element ,*numeric-argument-marker*) 'global-gsharp-table '((#\d :control))) (set-key 'com-insert-measure-bar 'global-gsharp-table '(#\|)) (set-key 'com-more-dots 'global-gsharp-table '((#\.))) (set-key 'com-more-lbeams 'global-gsharp-table '((#\[))) Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.8 gsharp/score-pane.lisp:1.9 --- gsharp/score-pane.lisp:1.8 Mon Aug 1 01:36:56 2005 +++ gsharp/score-pane.lisp Tue Aug 2 02:34:41 2005 @@ -50,7 +50,12 @@ ;;; ;;; output recording -(defclass score-output-record (displayed-output-record) +;;; we should not have to inherit from standard-boudning-rectangle, +;;; but the implementation of incremental redisplay in McCLIM assumes +;;; that this is the case for all output records participating in +;;; incremental redisplay. + +(defclass score-output-record (displayed-output-record standard-bounding-rectangle) ((parent :initarg :parent :initform nil :accessor output-record-parent) (x :initarg :x1 :initarg :x-position) (y :initarg :y1 :initarg :y-position) From rstrandh at common-lisp.net Tue Aug 2 02:15:58 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Tue, 2 Aug 2005 04:15:58 +0200 (CEST) Subject: [gsharp-cvs] CVS update: gsharp/esa.lisp Message-ID: <20050802021558.499CC8815C@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv26130 Modified Files: esa.lisp Log Message: More bug fixes for numeric arguments (thanks to Dave Murray) Date: Tue Aug 2 04:15:57 2005 Author: rstrandh Index: gsharp/esa.lisp diff -u gsharp/esa.lisp:1.2 gsharp/esa.lisp:1.3 --- gsharp/esa.lisp:1.2 Tue Aug 2 02:34:41 2005 +++ gsharp/esa.lisp Tue Aug 2 04:15:57 2005 @@ -105,10 +105,12 @@ (defparameter *current-gesture* nil) +(defparameter *meta-digit-table* + (loop for i from 0 to 9 + collect (list :keyboard (digit-char i) (make-modifier-state :meta)))) + (defun meta-digit (gesture) - (position gesture - '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta) - (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) + (position gesture *meta-digit-table* :test #'event-matches-gesture-name-p)) (defun esa-read-gesture () From rstrandh at common-lisp.net Sun Aug 7 23:18:07 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 8 Aug 2005 01:18:07 +0200 (CEST) Subject: [gsharp-cvs] CVS update: gsharp/gui.lisp gsharp/score-pane.lisp Message-ID: <20050807231807.7630288525@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv6535 Modified Files: gui.lisp score-pane.lisp Log Message: More modifications to allow incremental redisplay. There is still a problem with beam drawing which has to be converted to use the correct superclass. Date: Mon Aug 8 01:18:03 2005 Author: rstrandh Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.22 gsharp/gui.lisp:1.23 --- gsharp/gui.lisp:1.22 Tue Aug 2 02:34:41 2005 +++ gsharp/gui.lisp Mon Aug 8 01:18:02 2005 @@ -26,7 +26,7 @@ (score (let ((win (make-pane 'score-pane:score-pane :width 400 :height 500 :name "score" -;; :display-time :no-clear + :display-time :no-clear :display-function 'display-score :command-table 'total-melody-table))) (setf (windows *application-frame*) (list win)) Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.9 gsharp/score-pane.lisp:1.10 --- gsharp/score-pane.lisp:1.9 Tue Aug 2 02:34:41 2005 +++ gsharp/score-pane.lisp Mon Aug 8 01:18:02 2005 @@ -50,12 +50,7 @@ ;;; ;;; output recording -;;; we should not have to inherit from standard-boudning-rectangle, -;;; but the implementation of incremental redisplay in McCLIM assumes -;;; that this is the case for all output records participating in -;;; incremental redisplay. - -(defclass score-output-record (displayed-output-record standard-bounding-rectangle) +(defclass score-output-record (displayed-output-record) ((parent :initarg :parent :initform nil :accessor output-record-parent) (x :initarg :x1 :initarg :x-position) (y :initarg :y1 :initarg :y-position) @@ -108,34 +103,45 @@ (with-bounding-rectangle* (x1 y1 x2 y2) record (region-intersects-region-p region (make-rectangle* x1 y1 x2 y2)))) -;;;;;;;;;;;;;;;;;; pixmap output record - -(defclass pixmap-output-record (score-output-record) - ((pixmap :initarg :pixmap))) - -(defmethod replay-output-record ((record pixmap-output-record) stream - &optional (region +everywhere+) - (x-offset 0) (y-offset 0)) - (declare (ignore x-offset y-offset region)) - (multiple-value-bind (x y) (output-record-position record) - (with-slots (pixmap) record - (let ((medium (sheet-medium stream))) - (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) - medium x y))))) +;;;;;;;;;;;;;;;;;; pixmap drawing -(defun make-pixmap-record (class medium x1 y1 x2 y2 pixmap) - (multiple-value-bind (x1 y1) - (transform-position (medium-transformation medium) x1 y1) - (multiple-value-bind (x2 y2) - (transform-position (medium-transformation medium) x2 y2) - (make-instance class :x1 x1 :x2 x2 :y1 y1 :y2 y2 :pixmap pixmap)))) - -(defun add-new-pixmap-record (class stream pixmap x y) - (let ((width (pixmap-width pixmap)) - (height (pixmap-height pixmap))) - (stream-add-output-record - stream (make-pixmap-record class (sheet-medium stream) - x y (+ x width) (+ y height) pixmap)))) +(climi::def-grecording draw-pixmap (() pixmap pm-x pm-y) () + (climi::with-transformed-position ((medium-transformation medium) pm-x pm-y) + (setf (slot-value climi::graphic 'pm-x) pm-x + (slot-value climi::graphic 'pm-y) pm-y) + (values pm-x pm-y (+ pm-x (pixmap-width pixmap)) (+ pm-y (pixmap-height pixmap))))) + +(climi::def-graphic-op draw-pixmap (pixmap pm-x pm-y)) + +(defmethod medium-draw-pixmap* ((medium clim:medium) pixmap pm-x pm-y) + (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) + medium pm-x pm-y)) + +(climi::defmethod* (setf output-record-position) :around + (nx ny (record draw-pixmap-output-record)) + (climi::with-standard-rectangle* (:x1 x1 :y1 y1) + record + (with-slots (pm-x pm-y) + record + (let ((dx (- nx x1)) + (dy (- ny y1))) + (multiple-value-prog1 + (call-next-method) + (incf pm-x dx) + (incf pm-y dy)))))) + +(climi::defrecord-predicate draw-pixmap-output-record (pm-x pm-y) + (and (climi::if-supplied (pm-x coordinate) + (climi::coordinate= (slot-value climi::record 'pm-x) pm-x)) + (climi::if-supplied (pm-y coordinate) + (climi::coordinate= (slot-value climi::record 'pm-y) pm-y)))) + +(defun draw-pixmap* (sheet pixmap x y + &rest args + &key clipping-region transformation) + (declare (ignore clipping-region transformation)) + (climi::with-medium-options (sheet args) + (medium-draw-pixmap* medium pixmap x y))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -153,10 +159,7 @@ (multiple-value-bind (dx dy) (glyph-offsets *font* (+ glyph-no extra)) (let ((x1 (+ x dx)) (y1 (+ (staff-step staff-step) dy))) - (when (stream-recording-p pane) - (add-new-pixmap-record 'pixmap-output-record pane pixmap x1 y1)) - (when (stream-drawing-p pane) - (copy-from-pixmap pixmap 0 0 width height pane x1 y1)))))) + (draw-pixmap* pane pixmap x1 y1))))) (defun draw-stack (pane glyph-lower glyph-upper glyph-two x staff-step how-many) (draw-antialiased-glyph pane glyph-lower x staff-step) @@ -179,36 +182,18 @@ ;;;;;;;;;;;;;;;;;; helper macro -(defmacro define-pixmap-recording ((record-name medium-draw-name draw-name args) &body body) - `(progn - (defclass ,record-name (pixmap-output-record) ()) - - (defgeneric ,medium-draw-name (medium pixmap x y)) - - (defmethod ,medium-draw-name ((medium medium) pixmap x y) - (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) - medium x y)) - - (defmethod ,medium-draw-name ((sheet sheet) pixmap x y) - (,medium-draw-name (sheet-medium sheet) pixmap x y)) - - (defmethod ,medium-draw-name :around ((pane score-pane) pixmap x y) - (when (stream-recording-p pane) - (add-new-pixmap-record ',record-name pane pixmap x y)) - (when (stream-drawing-p pane) - (,medium-draw-name (sheet-medium pane) pixmap x y))) - - (defun ,draw-name (pane , at args x staff-step) - (let* ((extra (if *light-glyph* 1 0)) - (glyph-no , at body) - (matrix (glyph *font* (+ glyph-no extra))) - (pixmap (pane-pixmap pane matrix))) - (multiple-value-bind (dx dy) (glyph-offsets *font* (+ glyph-no extra)) - (,medium-draw-name pane pixmap (+ x dx) (- dy (staff-step staff-step)))))))) +(defmacro define-pixmap-recording ((draw-name args) &body body) + `(defun ,draw-name (pane , at args x staff-step) + (let* ((extra (if *light-glyph* 1 0)) + (glyph-no , at body) + (matrix (glyph *font* (+ glyph-no extra))) + (pixmap (pane-pixmap pane matrix))) + (multiple-value-bind (dx dy) (glyph-offsets *font* (+ glyph-no extra)) + (draw-pixmap* pane pixmap (+ x dx) (- dy (staff-step staff-step))))))) ;;;;;;;;;;;;;;;;;; notehead -(define-pixmap-recording (notehead-output-record medium-draw-notehead draw-notehead (name)) +(define-pixmap-recording (draw-notehead (name)) (ecase name (:whole +glyph-whole+) (:half +glyph-half+) @@ -223,7 +208,7 @@ ;;;;;;;;;;;;;;;;;; accidental -(define-pixmap-recording (accidental-output-record medium-draw-accidental draw-accidental (name)) +(define-pixmap-recording (draw-accidental (name)) (ecase name (:natural +glyph-natural+) (:flat +glyph-flat+) @@ -233,7 +218,7 @@ ;;;;;;;;;;;;;;;;;; clef -(define-pixmap-recording (clef-output-record medium-draw-clef draw-clef (name)) +(define-pixmap-recording (draw-clef (name)) (ecase name (:treble +glyph-g-clef+) (:bass +glyph-f-clef+) @@ -248,7 +233,7 @@ ;;;;;;;;;;;;;;;;;; rest -(define-pixmap-recording (rest-output-record medium-draw-rest draw-rest (duration)) +(define-pixmap-recording (draw-rest (duration)) (ecase duration (1 +glyph-whole-rest+) (1/2 +glyph-half-rest+) @@ -261,7 +246,7 @@ ;;;;;;;;;;;;;;;;;; flags down -(define-pixmap-recording (flags-down-output-record medium-draw-flags-down draw-flags-down (nb)) +(define-pixmap-recording (draw-flags-down (nb)) (ecase nb (1 +glyph-flags-down-one+) (2 +glyph-flags-down-two+) @@ -271,7 +256,7 @@ ;;;;;;;;;;;;;;;;;; flags up -(define-pixmap-recording (flags-up-output-record medium-draw-flags-up draw-flags-up (nb)) +(define-pixmap-recording (draw-flags-up (nb)) (ecase nb (1 +glyph-flags-up-one+) (2 +glyph-flags-up-two+) @@ -281,7 +266,7 @@ ;;;;;;;;;;;;;;;;;; dot -(define-pixmap-recording (dot-output-record medium-draw-dot draw-dot ()) +(define-pixmap-recording (draw-dot ()) +glyph-dot+) ;;;;;;;;;;;;;;;;;; staff line @@ -505,30 +490,30 @@ (- x2 x1) 1 medium x1 (- y thickness)))) -(defun draw-upward-beam-segment (medium x1 y x2 thickness) +(defun draw-downward-beam-segment (medium x1 y x2 thickness) (draw-segment medium x1 (1+ y) x2 thickness *darker-gray-progressions* *lighter-gray-progressions*)) -(defun draw-downward-beam-segment (medium x1 y x2 thickness) +(defun draw-upward-beam-segment (medium x1 y x2 thickness) (draw-segment medium x1 y x2 thickness *lighter-gray-progressions* *darker-gray-progressions*)) -(defun draw-upward-beam (medium x1 y1 y2 thickness inverse-slope) +(defun draw-downward-beam (medium x1 y1 y2 thickness inverse-slope) (loop for y from y1 below y2 for x from x1 by inverse-slope do - (draw-upward-beam-segment medium (round x) y + (draw-downward-beam-segment medium (round x) y (round (+ x inverse-slope)) thickness))) -(defun draw-downward-beam (medium x1 y1 y2 thickness inverse-slope) +(defun draw-upward-beam (medium x1 y1 y2 thickness inverse-slope) (loop for y from y1 above y2 for x from x1 by inverse-slope do - (draw-downward-beam-segment medium (round x) y + (draw-upward-beam-segment medium (round x) y (round (+ x inverse-slope)) thickness))) -(defclass upward-beam-output-record (beam-output-record) +(defclass downward-beam-output-record (beam-output-record) ()) -(defmethod replay-output-record ((record upward-beam-output-record) (stream score-pane) +(defmethod replay-output-record ((record downward-beam-output-record) (stream score-pane) &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) @@ -539,13 +524,13 @@ (with-drawing-options (medium :ink ink) (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) (*darker-gray-progressions* (darker-gray-progressions stream))) - (draw-upward-beam medium x1 y1 y2 thickness + (draw-downward-beam medium x1 y1 y2 thickness (/ (- x2 x1) (- y2 y1)))))))))) -(defclass downward-beam-output-record (beam-output-record) +(defclass upward-beam-output-record (beam-output-record) ()) -(defmethod replay-output-record ((record downward-beam-output-record) (stream score-pane) +(defmethod replay-output-record ((record upward-beam-output-record) (stream score-pane) &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) @@ -556,7 +541,7 @@ (with-drawing-options (medium :ink ink) (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) (*darker-gray-progressions* (darker-gray-progressions stream))) - (draw-downward-beam medium x1 y2 y1 thickness + (draw-upward-beam medium x1 y2 y1 thickness (/ (- x2 x1) (- y2 y1)))))))))) (defun draw-sloped-beam (medium x1 y1 x2 y2 thickness inverse-slope) @@ -568,11 +553,11 @@ (multiple-value-bind (xx2 yy2) (transform-position transformation x2 y2) (stream-add-output-record - *pane* (make-instance 'upward-beam-output-record + *pane* (make-instance 'downward-beam-output-record :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2 :thickness thickness :ink (medium-ink medium)))))) (when (stream-drawing-p *pane*) - (draw-upward-beam medium x1 y1 y2 thickness inverse-slope))) + (draw-downward-beam medium x1 y1 y2 thickness inverse-slope))) (t (when (stream-recording-p *pane*) (multiple-value-bind (xx1 yy1) @@ -580,11 +565,11 @@ (multiple-value-bind (xx2 yy2) (transform-position transformation x2 y2) (stream-add-output-record - *pane* (make-instance 'downward-beam-output-record + *pane* (make-instance 'upward-beam-output-record :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2 :thickness thickness :ink (medium-ink medium)))))) (when (stream-drawing-p *pane*) - (draw-downward-beam medium x1 y1 y2 thickness inverse-slope)))))) + (draw-upward-beam medium x1 y1 y2 thickness inverse-slope)))))) ;;; an offset of -1 means hang, 0 means straddle and 1 means sit (defun draw-beam (pane x1 staff-step-1 offset1 x2 staff-step-2 offset2) @@ -627,14 +612,12 @@ (*darker-gray-progressions* (darker-gray-progressions pane)) (,pixmap (allocate-pixmap *pane* 800 900)) (,mirror (sheet-direct-mirror *pane*))) -;; (draw-rectangle* ,pixmap 0 0 800 900 :filled t :ink +white+) -;; (setf (sheet-direct-mirror *pane*) (climi::pixmap-mirror ,pixmap)) -;; (clear-output-record (stream-output-history *pane*)) -;; (with-translation (pane 0 900) -;; (with-scaling (pane 1 -1) - , at body ;;)) -;; (setf (sheet-direct-mirror *pane*) ,mirror) -;; (copy-from-pixmap ,pixmap 0 0 800 900 *pane* 0 0) + (draw-rectangle* ,pixmap 0 0 800 900 :filled t :ink +white+) + (setf (sheet-direct-mirror *pane*) (climi::pixmap-mirror ,pixmap)) + (clear-output-record (stream-output-history *pane*)) + , at body + (setf (sheet-direct-mirror *pane*) ,mirror) + (copy-from-pixmap ,pixmap 0 0 800 900 *pane* 0 0) (deallocate-pixmap ,pixmap)))) (defmacro with-vertical-score-position ((pane yref) &body body) From rstrandh at common-lisp.net Mon Aug 8 00:22:09 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 8 Aug 2005 02:22:09 +0200 (CEST) Subject: [gsharp-cvs] CVS update: gsharp/esa.lisp Message-ID: <20050808002209.0E61B88525@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv10388 Modified Files: esa.lisp Log Message: Copy improvements to esa.lisp made by Dave Murray for Climacs. Date: Mon Aug 8 02:22:08 2005 Author: rstrandh Index: gsharp/esa.lisp diff -u gsharp/esa.lisp:1.3 gsharp/esa.lisp:1.4 --- gsharp/esa.lisp:1.3 Tue Aug 2 04:15:57 2005 +++ gsharp/esa.lisp Mon Aug 8 02:22:07 2005 @@ -143,39 +143,65 @@ (t (unread-gesture gesture :stream stream)))) +(define-gesture-name universal-argument :keyboard (#\u :control)) + +(define-gesture-name meta-minus :keyboard (#\- :meta)) + (defun read-numeric-argument (&key (stream *standard-input*)) + "Reads gestures returning two values: prefix-arg and whether prefix given. +Accepts: EITHER C-u, optionally followed by other C-u's, optionally followed +by a minus sign, optionally followed by decimal digits; +OR An optional M-minus, optionally followed by M-decimal-digits. +You cannot mix C-u and M-digits. +C-u gives a numarg of 4. Additional C-u's multiply by 4 (e.g. C-u C-u C-u = 64). +After C-u you can enter decimal digits, possibly preceded by a minus (but not +a plus) sign. C-u 3 4 = 34, C-u - 3 4 = -34. Note that C-u 3 - prints 3 '-'s. +M-1 M-2 = 12. M-- M-1 M-2 = -12. As a special case, C-u - and M-- = -1. +In the absence of a prefix arg returns 1 (and nil)." (let ((gesture (esa-read-gesture))) (cond ((event-matches-gesture-name-p - gesture - `(:keyboard #\u ,(make-modifier-state :control))) + gesture 'universal-argument) (let ((numarg 4)) (loop for gesture = (esa-read-gesture) while (event-matches-gesture-name-p - gesture - `(:keyboard #\u ,(make-modifier-state :control))) + gesture 'universal-argument) do (setf numarg (* 4 numarg)) finally (esa-unread-gesture gesture stream)) - (let ((gesture (esa-read-gesture))) + (let ((gesture (esa-read-gesture)) + (sign +1)) + (when (and (characterp gesture) + (char= gesture #\-)) + (setf gesture (esa-read-gesture) + sign -1)) (cond ((and (characterp gesture) (digit-char-p gesture 10)) - (setf numarg (- (char-code gesture) (char-code #\0))) + (setf numarg (digit-char-p gesture 10)) (loop for gesture = (esa-read-gesture) while (and (characterp gesture) (digit-char-p gesture 10)) do (setf numarg (+ (* 10 numarg) - (- (char-code gesture) (char-code #\0)))) + (digit-char-p gesture 10))) finally (esa-unread-gesture gesture stream) - (return (values numarg t)))) + (return (values (* numarg sign) t)))) (t (esa-unread-gesture gesture stream) - (values numarg t)))))) - ((meta-digit gesture) - (let ((numarg (meta-digit gesture))) + (values (if (minusp sign) -1 numarg) t)))))) + ((or (meta-digit gesture) + (event-matches-gesture-name-p + gesture 'meta-minus)) + (let ((numarg 0) + (sign +1)) + (cond ((meta-digit gesture) + (setf numarg (meta-digit gesture))) + (t (setf sign -1))) (loop for gesture = (esa-read-gesture) while (meta-digit gesture) do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) finally (esa-unread-gesture gesture stream) - (return (values numarg t))))) + (return (values (if (and (= sign -1) (= numarg 0)) + -1 + (* sign numarg)) + t))))) (t (esa-unread-gesture gesture stream) (values 1 nil))))) From rstrandh at common-lisp.net Sun Aug 14 18:00:45 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 14 Aug 2005 20:00:45 +0200 (CEST) Subject: [gsharp-cvs] CVS update: gsharp/score-pane.lisp Message-ID: <20050814180045.CBC6588545@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv15400 Modified Files: score-pane.lisp Log Message: Fixes to beam drawing. (thanks to Christophe Rhodes) Date: Sun Aug 14 20:00:45 2005 Author: rstrandh Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.10 gsharp/score-pane.lisp:1.11 --- gsharp/score-pane.lisp:1.10 Mon Aug 8 01:18:02 2005 +++ gsharp/score-pane.lisp Sun Aug 14 20:00:45 2005 @@ -420,7 +420,8 @@ ;;; beam drawing (defclass beam-output-record (score-output-record) - ((thickness :initarg :thickness))) + ((light-glyph-p :initarg :light-glyph-p) + (thickness :initarg :thickness))) (defun draw-horizontal-beam (medium x1 y1 x2 thickness) (let ((y2 (- y1 thickness))) @@ -518,9 +519,9 @@ (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) (with-bounding-rectangle* (x1 y1 x2 y2) record - (with-slots (thickness ink) record + (with-slots (thickness ink light-glyph-p) record (let ((medium (sheet-medium stream))) - (let ((*light-glyph* (not (eq ink +black+)))) + (let ((*light-glyph* light-glyph-p)) (with-drawing-options (medium :ink ink) (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) (*darker-gray-progressions* (darker-gray-progressions stream))) @@ -535,9 +536,9 @@ (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) (with-bounding-rectangle* (x1 y1 x2 y2) record - (with-slots (thickness ink) record + (with-slots (thickness ink light-glyph-p) record (let ((medium (sheet-medium stream))) - (let ((*light-glyph* (not (eq ink +black+)))) + (let ((*light-glyph* light-glyph-p)) (with-drawing-options (medium :ink ink) (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) (*darker-gray-progressions* (darker-gray-progressions stream))) @@ -555,6 +556,7 @@ (stream-add-output-record *pane* (make-instance 'downward-beam-output-record :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2 + :light-glyph-p *light-glyph* :thickness thickness :ink (medium-ink medium)))))) (when (stream-drawing-p *pane*) (draw-downward-beam medium x1 y1 y2 thickness inverse-slope))) @@ -566,7 +568,8 @@ (transform-position transformation x2 y2) (stream-add-output-record *pane* (make-instance 'upward-beam-output-record - :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2 + :x1 xx1 :y1 yy2 :x2 xx2 :y2 yy1 + :light-glyph-p *light-glyph* :thickness thickness :ink (medium-ink medium)))))) (when (stream-drawing-p *pane*) (draw-upward-beam medium x1 y1 y2 thickness inverse-slope)))))) From rstrandh at common-lisp.net Mon Aug 15 21:45:02 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 15 Aug 2005 23:45:02 +0200 (CEST) Subject: [gsharp-cvs] CVS update: gsharp/score-pane.lisp Message-ID: <20050815214502.DC06788546@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv30499 Modified Files: score-pane.lisp Log Message: fixed the problem with horizontal beams Date: Mon Aug 15 23:45:01 2005 Author: rstrandh Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.11 gsharp/score-pane.lisp:1.12 --- gsharp/score-pane.lisp:1.11 Sun Aug 14 20:00:45 2005 +++ gsharp/score-pane.lisp Mon Aug 15 23:45:01 2005 @@ -588,7 +588,7 @@ (medium (sheet-medium pane))) (assert (< slope 1)) (if (= y1 y2) - (draw-horizontal-beam medium xx1 y1 xx2 thickness) + (draw-horizontal-beam pane xx1 y1 xx2 thickness) (draw-sloped-beam medium xx1 y1 xx2 y2 thickness (/ slope))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;