Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv19540

Modified Files: gui.lisp Log Message: Replaced (current-buffer *application-frame*) by (current-buffer) as required by ESA now.

Also, untabified to make editing with Climacs easier.

--- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/11/16 12:58:23 1.73 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2007/01/16 05:17:40 1.74 @@ -2,9 +2,9 @@

(defun make-initial-cursor (buffer) (let* ((segment (segmentno buffer 0)) - (layer (layerno segment 0)) - (slice (body layer)) - (bar (barno slice 0))) + (layer (layerno segment 0)) + (slice (body layer)) + (bar (barno slice 0))) (make-cursor bar 0)))

(defclass gsharp-minibuffer-pane (minibuffer-pane) @@ -30,7 +30,7 @@ (defclass gsharp-pane-mixin () ())

(defclass gsharp-pane (score-pane:score-pane gsharp-pane-mixin) - ((view :initarg :view :accessor view))) + ((view :initarg :view :accessor view)))

(defvar *info-bg-color* +gray85+) (defvar *info-fg-color* +black+) @@ -45,82 +45,82 @@ (defun display-info (frame pane) (declare (ignore frame)) (let* ((master-pane (master-pane pane)) - (view (view master-pane)) - (buffer (buffer view))) + (view (view master-pane)) + (buffer (buffer view))) (princ " " pane) (princ (cond ((and (needs-saving buffer) - (read-only-p buffer) - "%*")) - ((needs-saving buffer) "**") - ((read-only-p buffer) "%%") - (t "--")) - pane) + (read-only-p buffer) + "%*")) + ((needs-saving buffer) "**") + ((read-only-p buffer) "%%") + (t "--")) + pane) (princ " " pane) (with-text-face (pane :bold) (format pane "~25A" (name buffer))) (princ " " pane) (format pane "[~a/~a]" - (score-pane:current-page-number view) - (score-pane:number-of-pages view)) + (score-pane:current-page-number view) + (score-pane:number-of-pages view)) (princ " " pane) (with-text-family (pane :sans-serif) (princ (if (recordingp *application-frame*) - "Def" - "") - pane)))) + "Def" + "") + pane))))

(define-application-frame gsharp (esa-frame-mixin - standard-application-frame) + standard-application-frame) ((views :initarg :views :initform '() :accessor views) (input-state :initarg :input-state :accessor input-state)) (:menu-bar menubar-command-table :height 25) (:pointer-documentation t) (:panes (score (let* ((win (make-pane 'gsharp-pane - :width 400 :height 500 - :name "score" - ;; :incremental-redisplay t - :double-buffering t - :display-function 'display-score - :command-table 'total-melody-table)) - (info (make-pane 'gsharp-info-pane - :master-pane win - :background *info-bg-color* - :foreground *info-fg-color*))) - (setf (windows *application-frame*) (list win)) - (setf (view win) (car (views *application-frame*))) - (vertically () - (scrolling (:width 750 :height 500 - :min-height 400 :max-height 20000) - win) - info))) + :width 400 :height 500 + :name "score" + ;; :incremental-redisplay t + :double-buffering t + :display-function 'display-score + :command-table 'total-melody-table)) + (info (make-pane 'gsharp-info-pane + :master-pane win + :background *info-bg-color* + :foreground *info-fg-color*))) + (setf (windows *application-frame*) (list win)) + (setf (view win) (car (views *application-frame*))) + (vertically () + (scrolling (:width 750 :height 500 + :min-height 400 :max-height 20000) + win) + info))) (state (make-pane 'score-pane:score-pane - :width 50 :height 200 - :name "state" - :display-function 'display-state)) + :width 50 :height 200 + :name "state" + :display-function 'display-state)) (element (make-pane 'score-pane:score-pane - :width 50 :height 300 - :min-height 100 :max-height 20000 - :name "element" - :display-function 'display-element)) + :width 50 :height 300 + :min-height 100 :max-height 20000 + :name "element" + :display-function 'display-element)) (interactor (make-pane 'gsharp-minibuffer-pane :width 900))) (:layouts (default (vertically () (horizontally () score - (vertically () - (scrolling (:width 80 :height 200) state) - (scrolling (:width 80 :height 300 - :min-height 300 :max-height 20000) - element))) + (vertically () + (scrolling (:width 80 :height 200) state) + (scrolling (:width 80 :height 300 + :min-height 300 :max-height 20000) + element))) interactor))) (:top-level (esa-top-level)))

(defmethod buffers ((application-frame gsharp)) (remove-duplicates (mapcar (lambda (window) (buffer (view window))) - (windows application-frame)) - :test #'eq)) + (windows application-frame)) + :test #'eq))

(defmethod frame-current-buffer ((application-frame gsharp)) (buffer (view (car (windows application-frame))))) @@ -136,56 +136,56 @@ (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 100) - (let ((xpos 30)) - (score-pane:draw-notehead pane (notehead state) xpos 4) - (when (not (eq (notehead state) :whole)) - (when (or (eq (stem-direction state) :auto) - (eq (stem-direction state) :down)) - (when (eq (notehead state) :filled) - (score-pane:with-notehead-left-offsets (left down) - (declare (ignore down)) - (let ((x (+ xpos left))) - (loop repeat (rbeams state) - for staff-step from -4 by 2 do - (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0)) - (loop repeat (lbeams state) - for staff-step from -4 by 2 do - (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0))))) - (score-pane:draw-left-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step -4)))) - (when (or (eq (stem-direction state) :auto) - (eq (stem-direction state) :up)) - (when (eq (notehead state) :filled) - (score-pane:with-notehead-right-offsets (right up) - (declare (ignore up)) - (let ((x (+ xpos right))) - (loop repeat (rbeams state) - for staff-step downfrom 12 by 2 do - (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0)) - (loop repeat (lbeams state) - for staff-step downfrom 12 by 2 do - (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0))))) - (score-pane:draw-right-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step 12))))) - (score-pane:with-notehead-right-offsets (right up) - (declare (ignore up)) - (loop repeat (dots state) - for dx from (+ right 5) by 5 do - (score-pane:draw-dot pane (+ xpos dx) 4))))))))) + (score-pane:with-vertical-score-position (pane 100) + (let ((xpos 30)) + (score-pane:draw-notehead pane (notehead state) xpos 4) + (when (not (eq (notehead state) :whole)) + (when (or (eq (stem-direction state) :auto) + (eq (stem-direction state) :down)) + (when (eq (notehead state) :filled) + (score-pane:with-notehead-left-offsets (left down) + (declare (ignore down)) + (let ((x (+ xpos left))) + (loop repeat (rbeams state) + for staff-step from -4 by 2 do + (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0)) + (loop repeat (lbeams state) + for staff-step from -4 by 2 do + (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0))))) + (score-pane:draw-left-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step -4)))) + (when (or (eq (stem-direction state) :auto) + (eq (stem-direction state) :up)) + (when (eq (notehead state) :filled) + (score-pane:with-notehead-right-offsets (right up) + (declare (ignore up)) + (let ((x (+ xpos right))) + (loop repeat (rbeams state) + for staff-step downfrom 12 by 2 do + (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0)) + (loop repeat (lbeams state) + for staff-step downfrom 12 by 2 do + (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0))))) + (score-pane:draw-right-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step 12))))) + (score-pane:with-notehead-right-offsets (right up) + (declare (ignore up)) + (loop repeat (dots state) + for dx from (+ right 5) by 5 do + (score-pane:draw-dot pane (+ xpos dx) 4)))))))))

(defun update-page-numbers (frame) (loop for window in (windows frame) - do (let ((page-number 0) - (view (view window))) - (gsharp-measure::new-map-over-obseq-subsequences - (lambda (all-measures) - (incf page-number) - (when (member-if (lambda (measure) (member (bar (cursor view)) - (measure-bars measure) - :test #'eq)) - all-measures) - (setf (score-pane:current-page-number view) page-number))) - (buffer view)) - (setf (score-pane:number-of-pages view) page-number)))) + do (let ((page-number 0) + (view (view window))) + (gsharp-measure::new-map-over-obseq-subsequences + (lambda (all-measures) + (incf page-number) + (when (member-if (lambda (measure) (member (bar (cursor view)) + (measure-bars measure) + :test #'eq)) + all-measures) + (setf (score-pane:current-page-number view) page-number))) + (buffer view)) + (setf (score-pane:number-of-pages view) page-number))))

;;; I tried making this a :before method on redisplay-frame-panes, ;;; but it turns out that McCLIM calls redisplay-frame-pane from @@ -199,7 +199,7 @@ (let* ((buffer (buffer (view pane)))) (score-pane:with-score-pane pane (draw-buffer pane buffer (current-cursor) - (left-margin buffer) 100) + (left-margin buffer) 100) (gsharp-drawing::draw-the-cursor pane (current-cursor) (cursor-element (current-cursor)) (last-note (input-state *application-frame*))) (multiple-value-bind (minx miny maxx maxy) (bounding-rectangle* pane) @@ -224,30 +224,30 @@

(defmethod display-element ((frame gsharp) pane) (when (handler-case (cur-cluster) - (gsharp-condition () nil)) + (gsharp-condition () nil)) (score-pane:with-score-pane pane (score-pane:with-staff-size 10 - (score-pane:with-vertical-score-position (pane 500) - (let* ((xpos 30) - (cluster (cur-cluster)) - (notehead (notehead cluster)) - (rbeams (rbeams cluster)) - (lbeams (lbeams cluster)) - (dots (dots cluster)) - (notes (notes cluster)) - (stem-direction (stem-direction cluster))) - (declare (ignore stem-direction notehead lbeams rbeams dots)) - (loop for note in notes do - (draw-ellipse* pane xpos (* 15 (note-position note)) 7 0 0 7) - (score-pane:draw-accidental pane (accidentals note) - (- xpos (if (oddp (note-position note)) 15 25)) - (* 3 (note-position note)))) - (when notes - (draw-ellipse* pane xpos (* 15 (note-position (cur-note))) - 7 0 0 7 :ink +red+)) - (loop for s from 0 by 30 - repeat 5 do - (draw-line* pane (- xpos 25) s (+ xpos 25) s)))))))) + (score-pane:with-vertical-score-position (pane 500) + (let* ((xpos 30) + (cluster (cur-cluster)) + (notehead (notehead cluster)) + (rbeams (rbeams cluster)) + (lbeams (lbeams cluster)) + (dots (dots cluster)) + (notes (notes cluster)) + (stem-direction (stem-direction cluster))) + (declare (ignore stem-direction notehead lbeams rbeams dots)) + (loop for note in notes do + (draw-ellipse* pane xpos (* 15 (note-position note)) 7 0 0 7) + (score-pane:draw-accidental pane (accidentals note) + (- xpos (if (oddp (note-position note)) 15 25)) + (* 3 (note-position note)))) + (when notes + (draw-ellipse* pane xpos (* 15 (note-position (cur-note))) + 7 0 0 7 :ink +red+)) + (loop for s from 0 by 30 + repeat 5 do + (draw-line* pane (- xpos 25) s (+ xpos 25) s))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -265,15 +265,15 @@ 'menubar-command-table :errorp nil :menu '(("File" :menu file-command-table) - ("Buffer" :menu buffer-command-table) - ("Stuff" :menu segment-command-table) - ("Segment" :menu segment-command-table) - ("Layer" :menu layer-command-table) - ("Slice" :menu slice-command-table) - ("Measure" :menu measure-command-table) - ("Modes" :menu modes-command-table) - ("Staves" :menu staves-command-table) - ("Play" :menu play-command-table))) + ("Buffer" :menu buffer-command-table) + ("Stuff" :menu segment-command-table) + ("Segment" :menu segment-command-table) + ("Layer" :menu layer-command-table) + ("Slice" :menu slice-command-table) + ("Measure" :menu measure-command-table) + ("Modes" :menu modes-command-table) + ("Staves" :menu staves-command-table) + ("Play" :menu play-command-table)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -283,34 +283,34 @@ 'file-command-table :errorp nil :menu `(("Find" :command (esa-io::com-find-file ,esa::*unsupplied-argument-marker*)) - ("Save" :command esa-io::com-save-buffer) - ("Save as" :command (esa-io::com-write-buffer ,esa::*unsupplied-argument-marker*)) - ("Quit" :command com-quit))) + ("Save" :command esa-io::com-save-buffer) + ("Save as" :command (esa-io::com-write-buffer ,esa::*unsupplied-argument-marker*)) + ("Quit" :command com-quit)))

(define-gsharp-command (com-new-buffer :name t) () (let* ((buffer (make-instance 'buffer)) - (cursor (make-initial-cursor buffer)) - (staff (car (staves buffer))) - (input-state (make-input-state)) - (view (make-instance 'orchestra-view - :buffer buffer - :cursor cursor))) + (cursor (make-initial-cursor buffer)) + (staff (car (staves buffer))) + (input-state (make-input-state)) + (view (make-instance 'orchestra-view + :buffer buffer + :cursor cursor))) (push view (views *application-frame*)) (setf (view (car (windows *application-frame*))) view) (setf (input-state *application-frame*) input-state - (staves (car (layers (car (segments buffer))))) (list staff)))) + (staves (car (layers (car (segments buffer))))) (list staff))))

(defmethod frame-find-file :around ((application-frame gsharp) filepath) (declare (ignore filepath)) (let* ((buffer (call-next-method)) - (input-state (make-input-state)) - (cursor (make-initial-cursor buffer)) - (view (make-instance 'orchestra-view - :buffer buffer - :cursor cursor))) + (input-state (make-input-state)) + (cursor (make-initial-cursor buffer)) + (view (make-instance 'orchestra-view + :buffer buffer + :cursor cursor))) (setf (view (car (windows *application-frame*))) view - (input-state *application-frame*) input-state - (filepath buffer) filepath) + (input-state *application-frame*) input-state + (filepath buffer) filepath) (select-layer cursor (car (layers (segment (current-cursor)))))))

(define-gsharp-command (com-quit :name t) () @@ -324,7 +324,7 @@ 'buffer-command-table :errorp nil :menu '(("Play" :command com-play-buffer) - ("Delete Current" :command com-delete-buffer)))

[928 lines skipped]