Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv18655

Modified Files: drawing.lisp gui.lisp score-pane.lisp sdl.lisp Log Message: Changed the sheet transformation of the score pane to be the default for CLIM stream panes (0,0) in the upper-left corner. This was in order to simplify the rest of the code, and in particular the output recording stuff. There are probably some edge cases that don't yet work like they are supposed to with the possibility of off-by-a-pixel errors.

Removed all the rectangle output records in favor of calls to draw-rectangle*.

Temporarily removed the double buffering as a preparation for better seeing what is going on with incremental redisplay.

Getting incremental redisplay to work might require fixing a problem in McCLIM which does not necessarily rely on the output-record protocol, but instead sometimes assume the existence of a slot in the record, whereas no such slot is required by the specification. The result is that the user cannot define his or her own output records and have them work with incremental redisplay.

Date: Mon Aug 1 01:36:57 2005 Author: rstrandh

Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.8 gsharp/drawing.lisp:1.9 --- gsharp/drawing.lisp:1.8 Sat Jul 24 22:09:55 2004 +++ gsharp/drawing.lisp Mon Aug 1 01:36:56 2005 @@ -117,7 +117,7 @@ (draw-measure pane measure min-dist compress x method draw-cursor) (incf x width) (score-pane:draw-bar-line pane x - (score-pane:staff-step 8) + (- (score-pane:staff-step 8)) (staff-yoffset (car (last staves)))))))

(defmethod draw-buffer (pane (buffer buffer) *cursor* x y draw-cursor) @@ -141,7 +141,8 @@ (- (line-width old-method) timesig-offset)))) (right-edge (right-edge buffer))) (loop for staff in staves - for offset downfrom 0 by 90 do + for offset from 0 by 90 do +;; for offset downfrom 0 by 90 do (setf (staff-yoffset staff) offset)) (let ((yy y)) (gsharp-measure::new-map-over-obseq-subsequences @@ -151,7 +152,7 @@ (draw-system pane measures (+ x (left-offset buffer) timesig-offset) widths method staves draw-cursor) (score-pane:draw-bar-line pane x - (score-pane:staff-step 8) + (- (score-pane:staff-step 8)) (staff-yoffset (car (last staves))))) (loop for staff in staves do (score-pane:with-vertical-score-position (pane yy) @@ -159,7 +160,7 @@ (draw-staff-and-clef pane staff x right-edge) (score-pane:with-light-glyphs pane (draw-staff-and-clef pane staff x right-edge)))) - (decf yy 90)))) + (incf yy 90)))) buffer)))))

(define-added-mixin velement () melody-element @@ -367,7 +368,7 @@ (draw-element pane element (element-xpos element) nil))))))

(defun draw-cursor (pane x) - (draw-line* pane x (score-pane:staff-step -4) x (score-pane:staff-step 12) :ink +red+)) + (draw-line* pane x (- (score-pane:staff-step -4)) x (- (score-pane:staff-step 12)) :ink +red+))

(defmethod draw-bar (pane (bar melody-bar) x width time-alist draw-cursor) (compute-element-x-positions bar x time-alist) @@ -619,11 +620,11 @@ (unless (eq (notehead element) :whole) (if (eq direction :up) (score-pane:draw-right-stem pane x - (+ (score-pane:staff-step min-pos) min-yoffset) - (+ (score-pane:staff-step stem-pos) stem-yoffset)) + (- min-yoffset (score-pane:staff-step min-pos)) + (- stem-yoffset (score-pane:staff-step stem-pos))) (score-pane:draw-left-stem pane x - (+ (score-pane:staff-step max-pos) max-yoffset) - (+ (score-pane:staff-step stem-pos) stem-yoffset))))))) + (- max-yoffset (score-pane:staff-step max-pos)) + (- stem-yoffset (score-pane:staff-step stem-pos))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.20 gsharp/gui.lisp:1.21 --- gsharp/gui.lisp:1.20 Mon Jul 25 13:14:37 2005 +++ gsharp/gui.lisp Mon Aug 1 01:36:56 2005 @@ -7,8 +7,6 @@ (bar (barno slice 0))) (make-cursor bar 0)))

-(defvar *gsharp-frame* nil) - (defclass gsharp-minibuffer-pane (minibuffer-pane) () (:default-initargs @@ -28,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)) @@ -63,7 +61,7 @@ (gsharp-condition (condition) (message "~a~%" condition))))

(defmethod display-state ((frame gsharp) pane) - (let ((state (input-state *gsharp-frame*))) + (let ((state (input-state *application-frame*))) (score-pane:with-score-pane pane (score-pane:with-staff-size 10 (score-pane:with-vertical-score-position (pane 800) @@ -103,8 +101,8 @@ (score-pane:draw-dot pane (+ xpos dx) 4)))))))))

(defun draw-the-cursor (pane x) - (let* ((state (input-state *gsharp-frame*)) - (staff (car (staves (layer (cursor *gsharp-frame*))))) + (let* ((state (input-state *application-frame*)) + (staff (car (staves (layer (cursor *application-frame*))))) (yoffset (gsharp-drawing::staff-yoffset staff))) (if (typep staff 'fiveline-staff) (let* ((clef (clef staff)) @@ -112,24 +110,24 @@ (lineno clef))) (lnote-offset (score-pane:staff-step (- (last-note state) bottom-line)))) (draw-line* pane - x (+ (score-pane:staff-step 12) yoffset) - x (+ (score-pane:staff-step -4) yoffset) + x (- (+ (score-pane:staff-step 12) yoffset)) + x (- (+ (score-pane:staff-step -4) yoffset)) :ink +yellow+) (draw-line* pane - (- x 1) (+ (score-pane:staff-step -3.4) yoffset lnote-offset) - (- x 1) (+ (score-pane:staff-step 3.6) yoffset lnote-offset) + (- x 1) (- (+ (score-pane:staff-step -3.4) yoffset lnote-offset)) + (- x 1) (- (+ (score-pane:staff-step 3.6) yoffset lnote-offset)) :ink +red+) (draw-line* pane - (+ x 1) (+ (score-pane:staff-step -3.4) yoffset lnote-offset) - (+ x 1) (+ (score-pane:staff-step 3.6) yoffset lnote-offset) + (+ x 1) (- (+ (score-pane:staff-step -3.4) yoffset lnote-offset)) + (+ x 1) (- (+ (score-pane:staff-step 3.6) yoffset lnote-offset)) :ink +red+)) (progn (draw-line* pane - (+ x 1) (+ (score-pane:staff-step 2) yoffset) - (+ x 1) (+ (score-pane:staff-step -2) yoffset) + (+ x 1) (- (+ (score-pane:staff-step 2) yoffset)) + (+ x 1) (- (+ (score-pane:staff-step -2) yoffset)) :ink +red+) (draw-line* pane - (- x 1) (+ (score-pane:staff-step 2) yoffset) - (- x 1) (+ (score-pane:staff-step -2) yoffset) + (- x 1) (- (+ (score-pane:staff-step 2) yoffset)) + (- x 1) (- (+ (score-pane:staff-step -2) yoffset)) :ink +red+)))))

(defmethod display-score ((frame gsharp) pane) @@ -137,8 +135,8 @@ (recompute-measures buffer) (score-pane:with-score-pane pane (flet ((draw-cursor (x) (draw-the-cursor pane x))) - (draw-buffer pane buffer (cursor *gsharp-frame*) - (left-margin buffer) 800 #'draw-cursor))))) + (draw-buffer pane buffer (cursor *application-frame*) + (left-margin buffer) 100 #'draw-cursor)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -220,9 +218,9 @@ (cursor (make-initial-cursor buffer)) (staff (car (staves buffer))) (input-state (make-input-state))) - (setf (buffer *gsharp-frame*) buffer - (cursor *gsharp-frame*) cursor - (input-state *gsharp-frame*) input-state + (setf (buffer *application-frame*) buffer + (cursor *application-frame*) cursor + (input-state *application-frame*) input-state (staves (car (layers (car (segments buffer))))) (list staff))))

(define-presentation-type completable-pathname () @@ -306,26 +304,26 @@ (or pathname string)))

(define-gsharp-command (com-load-file :name t) () - (let* ((stream (frame-standard-input *gsharp-frame*)) + (let* ((stream (frame-standard-input *application-frame*)) (filename (handler-case (accept 'completable-pathname :stream stream :prompt "File Name") (simple-parse-error () (error 'file-not-found)))) (buffer (read-everything filename)) (input-state (make-input-state)) (cursor (make-initial-cursor buffer))) - (setf (buffer *gsharp-frame*) buffer - (input-state *gsharp-frame*) input-state - (cursor *gsharp-frame*) cursor) - (number-all (buffer *gsharp-frame*)) - (select-layer cursor (car (layers (segment (cursor *gsharp-frame*))))))) + (setf (buffer *application-frame*) buffer + (input-state *application-frame*) input-state + (cursor *application-frame*) cursor) + (number-all (buffer *application-frame*)) + (select-layer cursor (car (layers (segment (cursor *application-frame*)))))))

(define-gsharp-command (com-save-buffer-as :name t) () - (let* ((stream (frame-standard-input *gsharp-frame*)) + (let* ((stream (frame-standard-input *application-frame*)) (filename (handler-case (accept 'completable-pathname :stream stream :prompt "File Name") (simple-parse-error () (error 'file-not-found))))) (with-open-file (stream filename :direction :output) - (save-buffer-to-stream (buffer *gsharp-frame*) stream) + (save-buffer-to-stream (buffer *application-frame*) stream) (message "Saved buffer to ~A~%" filename))))

(define-gsharp-command (com-quit :name t) () @@ -355,23 +353,23 @@ ("Insert Before Current" :command com-insert-segment-before)))

(define-gsharp-command (com-forward-segment :name t) () - (forward-segment (cursor *gsharp-frame*))) + (forward-segment (cursor *application-frame*)))

(define-gsharp-command (com-backward-segment :name t) () - (backward-segment (cursor *gsharp-frame*))) + (backward-segment (cursor *application-frame*)))

(define-gsharp-command (com-delete-segment :name t) () - (delete-segment (cursor *gsharp-frame*))) + (delete-segment (cursor *application-frame*)))

(define-gsharp-command (com-insert-segment-before :name t) () - (let ((cursor (cursor *gsharp-frame*))) - (insert-segment-before (make-initialized-segment (car (staves (buffer *gsharp-frame*)))) + (let ((cursor (cursor *application-frame*))) + (insert-segment-before (make-initialized-segment (car (staves (buffer *application-frame*)))) cursor) (backward-segment cursor)))

(define-gsharp-command (com-insert-segment-after :name t) () - (let ((cursor (cursor *gsharp-frame*))) - (insert-segment-after (make-initialized-segment (car (staves (buffer *gsharp-frame*)))) + (let ((cursor (cursor *application-frame*))) + (insert-segment-after (make-initialized-segment (car (staves (buffer *application-frame*)))) cursor) (forward-segment cursor)))

@@ -395,7 +393,7 @@

(defun acquire-unique-layer-name (prompt) (let ((name (accept 'string :prompt prompt))) - (assert (not (member name (layers (segment (cursor *gsharp-frame*))) + (assert (not (member name (layers (segment (cursor *application-frame*))) :test #'string= :key #'name)) () `layer-name-not-unique) name)) @@ -413,7 +411,7 @@ (lambda (so-far mode) (complete-from-possibilities so-far - (layers (segment (cursor *gsharp-frame*))) + (layers (segment (cursor *application-frame*))) '() :action mode :predicate (constantly t) @@ -429,7 +427,7 @@

(define-gsharp-command (com-select-layer :name t) () (let ((selected-layer (accept 'layer :prompt "Select layer"))) - (select-layer (cursor *gsharp-frame*) selected-layer))) + (select-layer (cursor *application-frame*) selected-layer)))

(define-gsharp-command (com-rename-layer :name t) () (setf (name (accept 'layer :prompt "Rename layer")) @@ -439,11 +437,11 @@ (let* ((name (acquire-unique-layer-name "Name of new layer")) (staff (accept 'score-pane:staff :prompt "Initial staff of new layer")) (new-layer (make-layer name staff))) - (add-layer new-layer (segment (cursor *gsharp-frame*))) - (select-layer (cursor *gsharp-frame*) new-layer))) + (add-layer new-layer (segment (cursor *application-frame*))) + (select-layer (cursor *application-frame*) new-layer)))

(define-gsharp-command (com-delete-layer :name t) () - (delete-layer (cursor *gsharp-frame*))) + (delete-layer (cursor *application-frame*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -457,19 +455,19 @@ ("Tail" :command com-tail-slisce)))

(define-gsharp-command (com-head-slice :name t) () - (head-slice (cursor *gsharp-frame*))) + (head-slice (cursor *application-frame*)))

(define-gsharp-command (com-body-slice :name t) () - (body-slice (cursor *gsharp-frame*))) + (body-slice (cursor *application-frame*)))

(define-gsharp-command (com-tail-slice :name t) () - (tail-slice (cursor *gsharp-frame*))) + (tail-slice (cursor *application-frame*)))

(define-gsharp-command (com-forward-slice :name t) () - (forward-slice (cursor *gsharp-frame*))) + (forward-slice (cursor *application-frame*)))

(define-gsharp-command (com-backward-slice :name t) () - (backward-slice (cursor *gsharp-frame*))) + (backward-slice (cursor *application-frame*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -482,10 +480,10 @@ ("Backward" :command com-backward-measure)))

(define-gsharp-command (com-forward-measure :name t) () - (forward-bar (cursor *gsharp-frame*))) + (forward-bar (cursor *application-frame*)))

(define-gsharp-command (com-backward-measure :name t) () - (backward-bar (cursor *gsharp-frame*))) + (backward-bar (cursor *application-frame*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -509,7 +507,7 @@ :menu '(("Rotate" :command com-rotate-staves)))

(define-gsharp-command (com-rotate-staves :name t) () - (let ((layer (layer (cursor *gsharp-frame*)))) + (let ((layer (layer (cursor *application-frame*)))) (setf (staves layer) (append (cdr (staves layer)) (list (car (staves layer)))))))

@@ -571,7 +569,7 @@ (bars slice) durations))))

(define-gsharp-command (com-play-segment :name t) () - (let* ((slices (mapcar #'body (layers (car (segments (buffer *gsharp-frame*)))))) + (let* ((slices (mapcar #'body (layers (car (segments (buffer *application-frame*)))))) (durations (measure-durations slices)) (tracks (loop for slice in slices for i from 0 @@ -589,7 +587,7 @@ (error "write compatibility layer for RUN-PROGRAM")))

(define-gsharp-command (com-play-layer :name t) () - (let* ((slice (body (layer (cursor *gsharp-frame*)))) + (let* ((slice (body (layer (cursor *application-frame*)))) (durations (measure-durations (list slice))) (tracks (list (track-from-slice slice 0 durations))) (midifile (make-instance 'midifile @@ -609,13 +607,13 @@ (staff (car (staves buffer))) (input-state (make-input-state)) (cursor (make-initial-cursor buffer))) - (let ((*gsharp-frame* (make-application-frame 'gsharp + (let ((*application-frame* (make-application-frame 'gsharp :buffer buffer :input-state input-state :cursor cursor :width width :height height))) (setf (staves (car (layers (car (segments buffer))))) (list staff)) - (run-frame-top-level *gsharp-frame*)))) + (run-frame-top-level *application-frame*))))

;; (defun run-gsharp () ;; (loop for port in climi::*all-ports* @@ -625,20 +623,20 @@ ;; (staff (car (staves buffer))) ;; (input-state (make-input-state)) ;; (cursor (make-initial-cursor buffer))) -;; (setf *gsharp-frame* (make-application-frame 'gsharp +;; (setf *application-frame* (make-application-frame 'gsharp ;; :buffer buffer ;; :input-state input-state ;; :cursor cursor) ;; (staves (car (layers (car (segments buffer))))) (list staff))) -;; (run-frame-top-level *gsharp-frame*)) +;; (run-frame-top-level *application-frame*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; note insertion commands

(defun insert-cluster () - (let* ((state (input-state *gsharp-frame*)) - (cursor (cursor *gsharp-frame*)) + (let* ((state (input-state *application-frame*)) + (cursor (cursor *application-frame*)) (cluster (make-cluster (if (eq (notehead state) :filled) (rbeams state) 0) (if (eq (notehead state) :filled) (lbeams state) 0) (dots state) @@ -652,7 +650,7 @@ (defparameter *current-note* nil)

(defun insert-note (pitch cluster) - (let* ((state (input-state *gsharp-frame*)) + (let* ((state (input-state *application-frame*)) (staff (car (staves (layer (slice (bar cluster)))))) (note (make-note pitch staff @@ -664,7 +662,7 @@ (add-note cluster note)))

(defun compute-and-adjust-note (pitch) - (let* ((state (input-state *gsharp-frame*)) + (let* ((state (input-state *application-frame*)) (old-pitch (mod (last-note state) 7)) (diff (- pitch old-pitch))) (incf (last-note state) @@ -698,13 +696,13 @@ (insert-numbered-note-new-cluster 4))

(define-gsharp-command com-insert-rest () - (let* ((state (input-state *gsharp-frame*)) - (cursor (cursor *gsharp-frame*)) + (let* ((state (input-state *application-frame*)) + (cursor (cursor *application-frame*)) (rest (make-rest (if (eq (notehead state) :filled) (rbeams state) 0) (if (eq (notehead state) :filled) (lbeams state) 0) (dots state) (notehead state) - (car (staves (layer (cursor *gsharp-frame*))))))) + (car (staves (layer (cursor *application-frame*))))))) (insert-element rest cursor) (forward-element cursor) rest)) @@ -713,10 +711,10 @@ (insert-cluster))

(defun cur-cluster () - (current-cluster (cursor *gsharp-frame*))) + (current-cluster (cursor *application-frame*)))

(defun cur-element () - (current-element (cursor *gsharp-frame*))) + (current-element (cursor *application-frame*)))

(defun cur-note () (let ((cluster (cur-cluster))) @@ -821,7 +819,7 @@ (notehead (notehead element)) (staff-pos (staff-pos element)) (staff (staff element)) - (cursor (cursor *gsharp-frame*))) + (cursor (cursor *application-frame*))) (backward-element cursor) (delete-element cursor) (insert-element (make-instance 'rest @@ -849,7 +847,7 @@ (notehead (notehead element)) (staff-pos (staff-pos element)) (staff (staff element)) - (cursor (cursor *gsharp-frame*))) + (cursor (cursor *application-frame*))) (backward-element cursor) (delete-element cursor) (insert-element (make-instance 'rest @@ -898,10 +896,10 @@ ;;; motion by element

(define-gsharp-command com-forward-element () - (forward-element (cursor *gsharp-frame*))) + (forward-element (cursor *application-frame*)))

(define-gsharp-command com-backward-element () - (backward-element (cursor *gsharp-frame*))) + (backward-element (cursor *application-frame*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -928,7 +926,7 @@ (forward-element cursor))))

(define-gsharp-command com-delete-element () - (let ((cursor (cursor *gsharp-frame*))) + (let ((cursor (cursor *application-frame*))) ;;; this will signal a condition if in last bar and ;;; interrupt the execution of the command (forward-element cursor) @@ -938,7 +936,7 @@ (delete-element cursor))))

(define-gsharp-command com-erase-element () - (let ((cursor (cursor *gsharp-frame*))) + (let ((cursor (cursor *application-frame*))) (backward-element cursor) (if (end-of-bar-p cursor) (fuse-bar-with-next cursor) @@ -949,39 +947,39 @@ ;;; Input State Settings

(define-gsharp-command com-istate-more-dots () - (setf (dots (input-state *gsharp-frame*)) - (min (1+ (dots (input-state *gsharp-frame*))) 3))) + (setf (dots (input-state *application-frame*)) + (min (1+ (dots (input-state *application-frame*))) 3)))

(define-gsharp-command com-istate-fewer-dots () - (setf (dots (input-state *gsharp-frame*)) - (max (1- (dots (input-state *gsharp-frame*))) 0))) + (setf (dots (input-state *application-frame*)) + (max (1- (dots (input-state *application-frame*))) 0)))

(define-gsharp-command com-istate-more-rbeams () - (setf (rbeams (input-state *gsharp-frame*)) - (min (1+ (rbeams (input-state *gsharp-frame*))) 3))) + (setf (rbeams (input-state *application-frame*)) + (min (1+ (rbeams (input-state *application-frame*))) 3)))

(define-gsharp-command com-istate-fewer-lbeams () - (setf (lbeams (input-state *gsharp-frame*)) - (max (1- (lbeams (input-state *gsharp-frame*))) 0))) + (setf (lbeams (input-state *application-frame*)) + (max (1- (lbeams (input-state *application-frame*))) 0)))

(define-gsharp-command com-istate-more-lbeams () - (setf (lbeams (input-state *gsharp-frame*)) - (min (1+ (lbeams (input-state *gsharp-frame*))) 3))) + (setf (lbeams (input-state *application-frame*)) + (min (1+ (lbeams (input-state *application-frame*))) 3)))

(define-gsharp-command com-istate-fewer-rbeams () - (setf (rbeams (input-state *gsharp-frame*)) - (max (1- (rbeams (input-state *gsharp-frame*))) 0))) + (setf (rbeams (input-state *application-frame*)) + (max (1- (rbeams (input-state *application-frame*))) 0)))

(define-gsharp-command com-istate-rotate-notehead () - (setf (notehead (input-state *gsharp-frame*)) - (ecase (notehead (input-state *gsharp-frame*)) + (setf (notehead (input-state *application-frame*)) + (ecase (notehead (input-state *application-frame*)) (:whole :half) (:half :filled) (:filled :whole))))

(define-gsharp-command com-istate-rotate-stem-direction () - (setf (stem-direction (input-state *gsharp-frame*)) - (ecase (stem-direction (input-state *gsharp-frame*)) + (setf (stem-direction (input-state *application-frame*)) + (ecase (stem-direction (input-state *application-frame*)) (:auto :up) (:up :down) (:down :auto)))) @@ -993,13 +991,13 @@ (setf (clef staff) (make-clef type line))))

(define-gsharp-command com-higher () - (incf (last-note (input-state *gsharp-frame*)) 7)) + (incf (last-note (input-state *application-frame*)) 7))

(define-gsharp-command com-lower () - (decf (last-note (input-state *gsharp-frame*)) 7)) + (decf (last-note (input-state *application-frame*)) 7))

(define-gsharp-command com-insert-measure-bar () - (let ((cursor (cursor *gsharp-frame*)) + (let ((cursor (cursor *application-frame*)) (elements '())) (loop until (end-of-bar-p cursor) do (push (cursor-element cursor) elements) @@ -1026,7 +1024,7 @@ (lambda (so-far mode) (complete-from-possibilities so-far - (staves (buffer *gsharp-frame*)) + (staves (buffer *application-frame*)) '() :action mode :predicate (constantly t) @@ -1043,7 +1041,7 @@ (lambda (so-far mode) (complete-from-possibilities so-far - (staves (buffer *gsharp-frame*)) + (staves (buffer *application-frame*)) '() :action mode :predicate (lambda (obj) (typep obj 'fiveline-staff)) @@ -1110,7 +1108,7 @@

(defun acquire-unique-staff-name (prompt) (let ((name (accept 'string :prompt prompt))) - (assert (not (member name (staves (buffer *gsharp-frame*)) :test #'string= :key #'name)) + (assert (not (member name (staves (buffer *application-frame*)) :test #'string= :key #'name)) () `staff-name-not-unique) name))

@@ -1125,36 +1123,36 @@ (define-gsharp-command (com-insert-staff-before :name t) () (add-staff-before-staff (accept 'score-pane:staff :prompt "Insert staff before staff") (acquire-new-staff) - (buffer *gsharp-frame*))) + (buffer *application-frame*)))

(define-gsharp-command (com-insert-staff-after :name t) () (add-staff-after-staff (accept 'score-pane:staff :prompt "Insert staff after staff") (acquire-new-staff) - (buffer *gsharp-frame*))) + (buffer *application-frame*)))

(define-gsharp-command (com-delete-staff :name t) () (remove-staff-from-buffer (accept 'score-pane:staff :prompt "Staff") - (buffer *gsharp-frame*))) + (buffer *application-frame*)))

(define-gsharp-command (com-rename-staff :name t) () (let* ((staff (accept 'score-pane:staff :prompt "Rename staff")) (name (acquire-unique-staff-name "New name of staff")) - (buffer (buffer *gsharp-frame*))) + (buffer (buffer *application-frame*))) (rename-staff name staff buffer)))

(define-gsharp-command (com-add-staff-to-layer :name t) () (let ((staff (accept 'score-pane:staff :prompt "Add staff to layer")) - (layer (layer (cursor *gsharp-frame*)))) + (layer (layer (cursor *application-frame*)))) (add-staff-to-layer staff layer)))

;;; FIXME restrict to staves that are actually in the layer. (define-gsharp-command (com-delete-staff-from-layer :name t) () (let ((staff (accept 'score-pane:staff :prompt "Add staff to layer")) - (layer (layer (cursor *gsharp-frame*)))) + (layer (layer (cursor *application-frame*)))) (remove-staff-from-layer staff layer)))

(define-gsharp-command com-more-sharps () - (let ((keysig (keysig (car (staves (layer (cursor *gsharp-frame*))))))) + (let ((keysig (keysig (car (staves (layer (cursor *application-frame*))))))) (cond ((eq (aref keysig 3) :flat) (setf (aref keysig 3) :natural)) ((eq (aref keysig 0) :flat) (setf (aref keysig 0) :natural)) ((eq (aref keysig 4) :flat) (setf (aref keysig 4) :natural)) @@ -1171,7 +1169,7 @@ ((eq (aref keysig 6) :natural) (setf (aref keysig 6) :sharp)))))

(define-gsharp-command com-more-flats () - (let ((keysig (keysig (car (staves (layer (cursor *gsharp-frame*))))))) + (let ((keysig (keysig (car (staves (layer (cursor *application-frame*))))))) (cond ((eq (aref keysig 6) :sharp) (setf (aref keysig 6) :natural)) ((eq (aref keysig 2) :sharp) (setf (aref keysig 2) :natural)) ((eq (aref keysig 5) :sharp) (setf (aref keysig 5) :natural)) @@ -1192,14 +1190,14 @@ ;;; Lyrics

(defun insert-lyrics-element () - (let* ((state (input-state *gsharp-frame*)) - (cursor (cursor *gsharp-frame*)) + (let* ((state (input-state *application-frame*)) + (cursor (cursor *application-frame*)) (element (make-lyrics-element (if (eq (notehead state) :filled) (rbeams state) 0) (if (eq (notehead state) :filled) (lbeams state) 0) (dots state) (notehead state) - (car (staves (layer (cursor *gsharp-frame*))))))) + (car (staves (layer (cursor *application-frame*))))))) (insert-element element cursor) (forward-element cursor) element))

Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.7 gsharp/score-pane.lisp:1.8 --- gsharp/score-pane.lisp:1.7 Mon Jul 25 11:52:14 2005 +++ gsharp/score-pane.lisp Mon Aug 1 01:36:56 2005 @@ -103,36 +103,6 @@ (with-bounding-rectangle* (x1 y1 x2 y2) record (region-intersects-region-p region (make-rectangle* x1 y1 x2 y2))))

-;;;;;;;;;;;;;;;;;; rectangle output record - -(defclass rectangle-output-record (score-output-record) - ()) - -(defmethod replay-output-record ((record rectangle-output-record) stream - &optional (region +everywhere+) - (x-offset 0) (y-offset 0)) - (declare (ignore x-offset y-offset region)) - (with-bounding-rectangle* (x1 y1 x2 y2) record - (with-slots (ink) record - (let ((medium (sheet-medium stream))) - (with-drawing-options (medium :ink ink) - (medium-draw-rectangle* medium x1 y1 x2 y2 t)))))) - -(defun make-rectangle-record (class medium x1 y1 x2 y2) - (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 (min x1 x2) :x2 (max x1 x2) - :y1 (min y1 y2) :y2 (max y1 y2) - :ink (medium-ink medium))))) - -(defun add-new-rectangle-record (class stream x1 y1 x2 y2) - (stream-add-output-record - stream (make-rectangle-record class (sheet-medium stream) - x1 y1 x2 y2))) - ;;;;;;;;;;;;;;;;;; pixmap output record

(defclass pixmap-output-record (score-output-record) @@ -229,7 +199,7 @@ (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) (+ (staff-step staff-step) dy))))))) + (,medium-draw-name pane pixmap (+ x dx) (- dy (staff-step staff-step))))))))

;;;;;;;;;;;;;;;;;; notehead

@@ -309,40 +279,14 @@ (define-pixmap-recording (dot-output-record medium-draw-dot draw-dot ()) +glyph-dot+)

-;;;;;;;;;;;;;;;;;; helper macro - -(defmacro define-rectangle-recording ((record-name medium-draw-name draw-name args) &body body) - `(progn - (defclass ,record-name (rectangle-output-record) ()) - - (defgeneric ,medium-draw-name (medium x1 y1 x2 y2)) - - (defmethod ,medium-draw-name ((medium medium) x1 y1 x2 y2) - (medium-draw-rectangle* medium x1 y1 x2 y2 t)) - - (defmethod ,medium-draw-name ((sheet sheet) x1 y1 x2 y2) - (,medium-draw-name (sheet-medium sheet) x1 y1 x2 y2)) - - (defmethod ,medium-draw-name :around ((pane score-pane) x1 y1 x2 y2) - (when (stream-recording-p pane) - (add-new-rectangle-record ',record-name pane x1 y1 x2 y2)) - (when (stream-drawing-p pane) - (,medium-draw-name (sheet-medium pane) x1 y1 x2 y2))) - - (defun ,draw-name (pane ,@args) - ,@body))) - ;;;;;;;;;;;;;;;;;; staff line

-(define-rectangle-recording (staff-line-output-record - medium-draw-staff-line - draw-staff-line - (x1 staff-step x2)) - (multiple-value-bind (down up) (staff-line-offsets *font*) - (let ((y1 (+ (staff-step staff-step) down)) - (y2 (+ (staff-step staff-step) up))) - (medium-draw-staff-line pane x1 y1 x2 y2)))) - +(defun draw-staff-line (pane x1 staff-step x2) + (multiple-value-bind (down up) (staff-line-offsets *font*) + (let ((y1 (- (- (staff-step staff-step)) up)) + (y2 (- (- (staff-step staff-step)) down))) + (draw-rectangle* pane x1 y1 x2 y2)))) + (defclass staff-output-record (output-record) ((parent :initarg :parent :initform nil :accessor output-record-parent) (x :initarg :x1 :initarg :x-position) @@ -445,14 +389,11 @@

;;;;;;;;;;;;;;;;;; stem

-(define-rectangle-recording (stem-output-record - medium-draw-stem - draw-stem - (x y1 y2)) - (multiple-value-bind (left right) (stem-offsets *font*) - (let ((x1 (+ x left)) - (x2 (+ x right))) - (medium-draw-stem pane x1 y1 x2 y2)))) +(defun draw-stem (pane x y1 y2) + (multiple-value-bind (left right) (stem-offsets *font*) + (let ((x1 (+ x left)) + (x2 (+ x right))) + (draw-rectangle* pane x1 y1 x2 y2)))) (defun draw-right-stem (pane x y1 y2) (multiple-value-bind (dx dy) (notehead-right-offsets *font*) @@ -466,28 +407,23 @@

;;;;;;;;;;;;;;;;;; ledger line

-(define-rectangle-recording (ledger-line-output-record - medium-draw-ledger-line - draw-ledger-line - (x staff-step)) - (multiple-value-bind (down up) (ledger-line-y-offsets *font*) - (multiple-value-bind (left right) (ledger-line-x-offsets *font*) - (let ((x1 (+ x left)) - (y1 (+ (staff-step staff-step) down)) - (x2 (+ x right)) - (y2 (+ (staff-step staff-step) up))) - (medium-draw-ledger-line pane x1 y1 x2 y2))))) +(defun draw-ledger-line (pane x staff-step) + (multiple-value-bind (down up) (ledger-line-y-offsets *font*) + (multiple-value-bind (left right) (ledger-line-x-offsets *font*) + (let ((x1 (+ x left)) + (y1 (- (+ (staff-step staff-step) down))) + (x2 (+ x right)) + (y2 (- (+ (staff-step staff-step) up)))) + (draw-rectangle* pane x1 y1 x2 y2))))) + ;;;;;;;;;;;;;;;;;; bar line

-(define-rectangle-recording (bar-line-output-record - medium-draw-bar-line - draw-bar-line - (x y1 y2)) - (multiple-value-bind (left right) (bar-line-offsets *font*) - (let ((x1 (+ x left)) - (x2 (+ x right))) - (medium-draw-bar-line pane x1 y1 x2 y2)))) +(defun draw-bar-line (pane x y1 y2) + (multiple-value-bind (left right) (bar-line-offsets *font*) + (let ((x1 (+ x left)) + (x2 (+ x right))) + (draw-rectangle* pane x1 y1 x2 y2))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -496,15 +432,9 @@ (defclass beam-output-record (score-output-record) ((thickness :initarg :thickness)))

-(defclass horizontal-beam-output-record (beam-output-record rectangle-output-record) - ()) - (defun draw-horizontal-beam (medium x1 y1 x2 thickness) (let ((y2 (- y1 thickness))) - (when (stream-recording-p *pane*) - (add-new-rectangle-record 'horizontal-beam-output-record *pane* x1 y1 x2 y2)) - (when (stream-drawing-p *pane*) - (medium-draw-rectangle* medium x1 y1 x2 y2 t)))) + (draw-rectangle* medium x1 y1 x2 y2)))

(defvar *darker-gray-progressions*) (defvar *lighter-gray-progressions*) @@ -604,10 +534,8 @@ (with-drawing-options (medium :ink ink) (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) (*darker-gray-progressions* (darker-gray-progressions stream))) - ;; we replay with the identity tranformation, so - ;; we have to draw the other way - (draw-downward-beam medium x1 (1- y2) (1- (+ y1 thickness)) thickness - (/ (- x2 x1) (- y2 y1 thickness)))))))))) + (draw-upward-beam medium x1 y1 y2 thickness + (/ (- x2 x1) (- y2 y1))))))))))

(defclass downward-beam-output-record (beam-output-record) ()) @@ -623,22 +551,20 @@ (with-drawing-options (medium :ink ink) (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) (*darker-gray-progressions* (darker-gray-progressions stream))) - ;; we replay with the identity tranformation, so - ;; we have to draw the other way - (draw-upward-beam medium x1 (1- (+ y1 thickness)) (1- y2) thickness - (/ (- x2 x1) (- y2 y1 thickness)))))))))) + (draw-downward-beam medium x1 y2 y1 thickness + (/ (- x2 x1) (- y2 y1))))))))))

(defun draw-sloped-beam (medium x1 y1 x2 y2 thickness inverse-slope) (let ((transformation (medium-transformation *pane*))) (cond ((< y1 y2) (when (stream-recording-p *pane*) (multiple-value-bind (xx1 yy1) - (transform-position transformation x1 (- y1 thickness)) + (transform-position transformation x1 y1) (multiple-value-bind (xx2 yy2) (transform-position transformation x2 y2) (stream-add-output-record *pane* (make-instance 'upward-beam-output-record - :x1 xx1 :y1 yy2 :x2 xx2 :y2 yy1 + :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))) @@ -647,7 +573,7 @@ (multiple-value-bind (xx1 yy1) (transform-position transformation x1 y1) (multiple-value-bind (xx2 yy2) - (transform-position transformation x2 (- y2 thickness)) + (transform-position transformation x2 y2) (stream-add-output-record *pane* (make-instance 'downward-beam-output-record :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2 @@ -662,8 +588,8 @@ (multiple-value-bind (left right) (stem-offsets *font*) (let* ((xx1 (+ x1 left)) (xx2 (+ x2 right)) - (y1 (floor (staff-step (+ staff-step-1 1/2 (* 1/2 offset1))))) - (y2 (floor (staff-step (+ staff-step-2 1/2 (* 1/2 offset2))))) + (y1 (- (floor (staff-step (+ staff-step-1 (* 1/2 offset1)))))) + (y2 (- (floor (staff-step (+ staff-step-2 (* 1/2 offset2)))))) (slope (abs (/ (- y2 y1) (- xx2 xx1)))) (thickness (/ (staff-line-distance *font*) 2)) (medium (sheet-medium pane))) @@ -696,14 +622,14 @@ (*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) - ,@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*)) +;; (with-translation (pane 0 900) +;; (with-scaling (pane 1 -1) + ,@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)

Index: gsharp/sdl.lisp diff -u gsharp/sdl.lisp:1.4 gsharp/sdl.lisp:1.5 --- gsharp/sdl.lisp:1.4 Fri Mar 26 15:24:11 2004 +++ gsharp/sdl.lisp Mon Aug 1 01:36:56 2005 @@ -54,9 +54,9 @@ notehead-left-y-offset) font (let ((staff-line-thickness (round (/ (staff-line-distance font) 10)))) (setf staff-line-offset-down - (- (floor (/ staff-line-thickness 2))) + (floor (/ staff-line-thickness 2)) staff-line-offset-up - (+ staff-line-thickness staff-line-offset-down))) + (- staff-line-thickness staff-line-offset-down))) (let ((stem-thickness (round (/ staff-line-distance 11.9)))) (setf stem-offset-left (- (floor (/ stem-thickness 2))) @@ -103,7 +103,7 @@ (declare (ignore initargs)) (with-slots (gf-char x-offset y-offset) glyph (setf x-offset (floor (gf-char-min-m gf-char) 4) - y-offset (ceiling (1+ (gf-char-max-n gf-char)) 4)))) + y-offset (- (floor (1+ (gf-char-max-n gf-char)) 4)))))

(defmethod glyph ((font font) glyph-no) (with-slots (gf-char pixmap) (aref (glyphs font) glyph-no)