gui.lisp

   1 (in-package :gsharp)
   2
   3 (defparameter *icon-path*
   4   ;;  sb-ext:*core-pathname*
   5   "/Users/dlewis/lisp/gsharp/Icons/")
   6 (defun make-initial-cursor (buffer)
   7   (let* ((segment (segmentno buffer 0))
   8          (layer (layerno segment 0))
   9          (slice (body layer))
  10          (bar (barno slice 0)))
  11   (make-cursor bar 0)))
  12
  13 (defclass gsharp-minibuffer-pane (minibuffer-pane)
  14   ()
  15   (:default-initargs
  16       :height 20 :max-height 20 :min-height 20))
  17
  18 (define-command-table total-melody-table
  19     :inherit-from (melody-table global-gsharp-table gsharp))
  20 (define-command-table total-rhythmic-melody-table
  21     :inherit-from (melody-table rhythmic-table global-gsharp-table gsharp))
  22 (define-command-table total-cluster-table
  23     :inherit-from (cluster-table melody-table global-gsharp-table gsharp))
  24 (define-command-table total-lyrics-table
  25     :inherit-from (lyrics-table global-gsharp-table gsharp))
  26
  27 (defclass orchestra-view (score-pane:score-view)
  28   ((cursor :initarg :cursor :reader cursor)
  29    (buffer :initarg :buffer :reader buffer)))
  30
  31 ;;; FIXME: we need to sort out Drei's definition of accept methods for
  32 ;;; the general VIEW type.
  33 ;;;
  34 ;;; FIXME: we should name our views so that they can be found by a
  35 ;;; string name, rather than the unreadable-object print.  There's a
  36 ;;; SUBSCRIPTABLE-NAME-MIXIN in ESA-UTILS that is used for this
  37 ;;; purpose in the analogous place in Climacs.
  38 (define-presentation-method accept
  39     ((type orchestra-view) stream (view textual-view)
  40      &key (default nil defaultp) (default-type type))
  41   (multiple-value-bind (object success string)
  42       (complete-input stream
  43                       (lambda (so-far action)
  44                         (complete-from-possibilities
  45                          so-far (views *esa-instance*) '()
  46                          :action action
  47                          :name-key #'princ-to-string
  48                          :value-key #'identity))
  49                       :partial-completers '(#\Space))
  50     (cond
  51       (success (values object type))
  52       ((and defaultp (= (length string) 0)) (values default default-type))
  53       (t (input-not-of-required-type string type)))))
  54
  55 ;;; exists for the sole purpose of a :before method that updates the
  56 ;;; measures of each modified buffer.
  57 (defclass gsharp-pane-mixin () ())
  58
  59 (defclass gsharp-pane (score-pane:score-pane gsharp-pane-mixin)
  60   ((view :initarg :view :accessor view)))
  61
  62 (defvar *info-bg-color* +gray85+)
  63 (defvar *info-fg-color* +black+)
  64
  65 (defclass gsharp-info-pane (info-pane gsharp-pane-mixin)
  66   ()
  67   (:default-initargs
  68       :height 20 :max-height 20 :min-height 20
  69       :display-function 'display-info
  70       :incremental-redisplay t))
  71
  72 (defun display-info (frame pane)
  73   (declare (ignore frame))
  74   (let* ((master-pane (master-pane pane))
  75          (view (view master-pane))
  76          (buffer (buffer view)))
  77     (princ "   " pane)
  78     (princ (cond ((and (needs-saving buffer)
  79                        (read-only-p buffer)
  80                        "%*"))
  81                  ((needs-saving buffer) "**")
  82                  ((read-only-p buffer) "%%")
  83                  (t "--"))
  84            pane)
  85     (princ "  " pane)
  86     (with-text-face (pane :bold)
  87       (format pane "~25A" (name buffer)))
  88     (princ "  " pane)
  89     (format pane "[~a/~a]"
  90             (score-pane:current-page-number view)
  91             (score-pane:number-of-pages view))
  92     (princ "  " pane)
  93     (with-text-family (pane :sans-serif)
  94       (princ (if (recordingp *application-frame*)
  95                  "Def"
  96                  "")
  97              pane))))
  98
  99 (defun x-offset-label (frame pane)
 100   (declare (ignore frame))
 101   (when (handler-case (cur-cluster)
 102           (gsharp-condition () nil))
 103     (princ (gsharp-buffer::xoffset (cur-element)) pane)))
 104 (defun x-pad-label (frame pane)
 105   (declare (ignore frame))
 106   (when (handler-case (cur-cluster)
 107           (gsharp-condition () nil))
 108     (princ (gsharp-buffer::left-pad (cur-element)) pane)))
 109
 110 (define-application-frame gsharp (esa-frame-mixin
 111                                   standard-application-frame)
 112   ((views :initarg :views :initform '() :accessor views)
 113    (input-state :initarg :input-state :accessor input-state))
 114   (:default-initargs :input-state (make-input-state))
 115   (:menu-bar menubar-command-table :height 25)
 116   (:pointer-documentation t)
 117   (:panes
 118    (score (let* ((win (make-pane 'gsharp-pane
 119                                  :width 400 :height 500
 120                                  :name "score"
 121                                  ;; :incremental-redisplay t
 122                                  :double-buffering t
 123                                  :display-function 'display-score
 124                                  :command-table 'total-melody-table))
 125                  (info (make-pane 'gsharp-info-pane
 126                                   :master-pane win
 127                                   :background *info-bg-color*
 128                                   :foreground *info-fg-color*)))
 129             (setf (windows *application-frame*) (list win))
 130             (setf (view win) (car (views *application-frame*)))
 131             (vertically ()
 132               (scrolling (:width 750 :height 500
 133                           :min-height 400 :max-height 20000)
 134                 win)
 135               info)))
 136    (state (make-pane 'score-pane:score-pane
 137                      :width 50 :height 200
 138                      :name "state"
 139                      :display-function 'display-state))
 140    (element (make-pane 'score-pane:score-pane
 141                        :width 50 :height 300
 142                        :min-height 100 :max-height 20000
 143                        :name "element"
 144                        :display-function 'display-element))
 145    (interactor (make-pane 'gsharp-minibuffer-pane :width 900)))
 146   (:layouts
 147    (default
 148      (vertically ()
 149        (horizontally ()
 150          score
 151          (vertically ()
 152                      (scrolling (:width 80 :height 200) state)
 153                      (scrolling (:width 80 :height 300
 154                                  :min-height 300 :max-height 20000)
 155                                 element)))
 156        interactor)))
 157   (:top-level (esa-top-level)))
 158
 159 (defun simple-button (label function &key panes)
 160   (make-pane 'push-button :label label
 161              :height 20
 162              :activate-callback
 163              (lambda (gadget)
 164                (declare (ignore gadget))
 165                (funcall function)
 166                (dolist (pane-keyword panes)
 167                  (redisplay-frame-pane
 168                   *application-frame*
 169                   (pane-from-keyword *application-frame* pane-keyword)
 170                   :force-p t)))))
 171
 172 (defgeneric pane-from-keyword (frame pane-keyword))
 173 (defmethod pane-from-keyword (frame (pane-keyword (eql :state)))
 174   (find-pane-named frame 'state))
 175 (defmethod pane-from-keyword (frame (pane-keyword (eql :element)))
 176   (find-pane-named frame 'element))
 177 (defmethod pane-from-keyword (frame (pane-keyword (eql :score)))
 178   (get-main-score-pane))
 179
 180 (defun istate-button (label function)
 181   (simple-button label function :panes '(:state)))
 182 (defun element-button (label function)
 183   (simple-button label function :panes '(:score :element)))
 184
 185 (defun istate-notehead-button (label value)
 186   (make-pane 'push-button
 187              :label label
 188              :activate-callback
 189              (lambda (gadget)
 190                (declare (ignore gadget))
 191                (setf (notehead (input-state *application-frame*))
 192                      value)
 193                (when (find-pane-named *application-frame* 'state)
 194                  (redisplay-frame-pane *application-frame*
 195                                        (find-pane-named *application-frame* 'state)
 196                                        :force-p t)))
 197              :height 20))
 198
 199 (defmethod buffers ((application-frame gsharp))
 200   (let (result)
 201     (dolist (window (windows application-frame) (nreverse result))
 202       (let ((view (view window)))
 203         (when view
 204           (pushnew (buffer view) result))))))
 205
 206 (defmethod esa-current-buffer ((application-frame gsharp))
 207   (buffer (view (car (windows application-frame)))))
 208
 209 (defun current-cursor ()
 210   (cursor (view (car (windows *application-frame*)))))
 211
 212 (defmethod execute-frame-command :around ((frame gsharp) command)
 213   (handler-case
 214       (let ((buffer (if (views frame)
 215                         (list (buffer (car (views frame)))))))
 216         (drei::with-undo (buffer)
 217           (call-next-method)))
 218     (gsharp-condition (condition) (beep) (display-message "~a" condition))))
 219
 220 (defmethod display-state ((frame gsharp) pane)
 221   (let ((state (input-state *application-frame*)))
 222     (score-pane:with-score-pane pane
 223       (score-pane:with-staff-size 10
 224         (score-pane:with-vertical-score-position (pane 100)
 225           (let ((xpos 30))
 226             (score-pane:draw-notehead pane (notehead state) xpos 4)
 227             (when (not (member (notehead state) '(:whole :breve)))
 228               (when (or (eq (stem-direction state) :auto)
 229                         (eq (stem-direction state) :down))
 230                 (when (eq (notehead state) :filled)
 231                   (score-pane:with-notehead-left-offsets (left down)
 232                     (declare (ignore down))
 233                     (let ((x (+ xpos left)))
 234                       (loop repeat (rbeams state)
 235                             for staff-step from -4 by 2 do
 236                             (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0))
 237                       (loop repeat (lbeams state)
 238                             for staff-step from -4 by 2 do
 239                             (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0)))))
 240                 (score-pane:draw-left-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step -4))))
 241               (when (or (eq (stem-direction state) :auto)
 242                         (eq (stem-direction state) :up))
 243                 (when (eq (notehead state) :filled)
 244                   (score-pane:with-notehead-right-offsets (right up)
 245                     (declare (ignore up))
 246                     (let ((x (+ xpos right)))
 247                       (loop repeat (rbeams state)
 248                             for staff-step downfrom 12 by 2 do
 249                             (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0))
 250                       (loop repeat (lbeams state)
 251                             for staff-step downfrom 12 by 2 do
 252                             (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0)))))
 253                 (score-pane:draw-right-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step 12)))))
 254             (score-pane:with-notehead-right-offsets (right up)
 255               (declare (ignore up))
 256               (loop repeat (dots state)
 257                     for dx from (+ right 5) by 5 do
 258                     (score-pane:draw-dot pane (+ xpos dx) 4)))))))))
 259
 260 (defun update-page-numbers (frame)
 261   (loop for window in (windows frame)
 262         do (let ((page-number 0)
 263                  (view (view window)))
 264              (gsharp-measure::new-map-over-obseq-subsequences
 265               (lambda (all-measures)
 266                 (incf page-number)
 267                 (when (member-if (lambda (measure) (member (bar (cursor view))
 268                                                            (measure-bars measure)
 269                                                            :test #'eq))
 270                                  all-measures)
 271                   (setf (score-pane:current-page-number view) page-number)))
 272               (buffer view))
 273              (setf (score-pane:number-of-pages view) page-number))))
 274
 275 ;;; I tried making this a :before method on redisplay-frame-panes,
 276 ;;; but it turns out that McCLIM calls redisplay-frame-pane from
 277 ;;; places other than redisplay-frame-panes.
 278 (defmethod redisplay-frame-pane :before ((frame gsharp) (pane gsharp-pane-mixin) &key force-p)
 279   (declare (ignore pane force-p))
 280   (mapc #'recompute-measures (buffers frame))
 281   (update-page-numbers frame))
 282
 283 (defmethod display-score ((frame gsharp) pane)
 284   (let* ((buffer (buffer (view pane)))
 285          (zoom (gsharp-buffer::zoom-level buffer)))
 286     (with-drawing-options (pane :transformation (make-scaling-transformation zoom zoom))
 287       (score-pane:with-score-pane pane
 288         (draw-buffer pane buffer (current-cursor)
 289                      (left-margin buffer) 100)
 290         (draw-the-cursor pane (current-cursor) (cursor-element (current-cursor))
 291                          (last-note (input-state *application-frame*)))
 292         (multiple-value-bind (minx miny maxx maxy)
 293             (bounding-rectangle* (stream-output-history pane))
 294           (declare (ignore minx maxx))
 295           (change-space-requirements pane :height (+ maxy miny)))))))
 296
 297 (defmethod window-clear ((pane score-pane:score-pane))
 298   (let ((output-history (stream-output-history pane)))
 299     (with-bounding-rectangle* (left top right bottom) output-history
 300       (medium-clear-area (sheet-medium pane) left top right bottom))
 301     (clear-output-record output-history))
 302   (window-erase-viewport pane))
 303
 304 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 305 ;;;
 306 ;;; Element pane
 307
 308 (defmethod note-position ((note note))
 309   (let ((clef (clef note)))
 310     (- (pitch note)
 311        (bottom-line clef))))
 312
 313 (defmethod display-element ((frame gsharp) pane)
 314   (when (handler-case (cur-element)
 315           (gsharp-condition () nil))
 316     (draw-current-element pane (cur-element))))
 317
 318 (defgeneric draw-current-element (pane element)
 319   (:method (pane element) nil))
 320 (defmethod draw-current-element (pane (cluster cluster))
 321   (score-pane:with-score-pane pane
 322     (score-pane:with-staff-size 10
 323       (score-pane:with-vertical-score-position (pane 10)
 324         (let* ((xpos 30)
 325                (notehead (notehead cluster))
 326                (rbeams (rbeams cluster))
 327                (lbeams (lbeams cluster))
 328                (dots (dots cluster))
 329                (notes (notes cluster))
 330                (stem-direction (stem-direction cluster)))
 331           (declare (ignore stem-direction notehead lbeams rbeams dots))
 332           (loop for note in notes do
 333                (draw-ellipse* pane xpos (- 120 (* 15 (note-position note))) 7 0 0 7)
 334                (score-pane:draw-accidental pane (accidentals note)
 335                                            (- xpos (if (oddp (note-position note)) 15 25))
 336                                            (- (* 3 (note-position note)) 24)))
 337           (when notes
 338             (draw-ellipse* pane xpos (- 120 (* 15 (note-position (cur-note))))
 339                            7 0 0 7 :ink +red+))
 340           (loop for s from 0 by 30
 341              repeat 5 do
 342                (draw-line* pane (- xpos 25) s (+ xpos 25) s))
 343
 344           (clim::draw-text* pane (format nil "x-offset: ~A"
 345                                          (gsharp-buffer::xoffset cluster))
 346                             5 140))))))
 347 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 348 ;;;
 349 ;;; messages to the user
 350
 351 ;;; FIXME: do this better
 352 (defun message (format-string &rest format-args)
 353   (apply #'format *error-output* format-string format-args))
 354
 355 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 356 ;;;
 357 ;;; menu bar
 358
 359 (make-command-table
 360  'menubar-command-table
 361  :errorp nil
 362  :menu '(("File" :menu esa-io-menu-table)
 363          ("Macros" :menu keyboard-macro-menu-table)
 364          ("Buffer" :menu buffer-command-table)
 365          ("Stuff" :menu segment-command-table)
 366          ("Segment" :menu segment-command-table)
 367          ("Layer" :menu layer-command-table)
 368          ("Slice" :menu slice-command-table)
 369          ("Measure" :menu measure-command-table)
 370          ("Modes" :menu modes-command-table)
 371          ("Staves" :menu staves-command-table)
 372          ("Play" :menu play-command-table)
 373          ("Help" :menu help-menu-table)))
 374
 375 (define-gsharp-command (com-new-buffer :name t) ()
 376   (let* ((buffer (make-instance 'buffer))
 377          (cursor (make-initial-cursor buffer))
 378          (staff (car (staves buffer)))
 379          (input-state (make-input-state))
 380          (view (make-instance 'orchestra-view
 381                               :buffer buffer
 382                               :cursor cursor)))
 383     (push view (views *application-frame*))
 384     (setf (view (car (windows *application-frame*))) view)
 385     (setf (input-state *application-frame*) input-state
 386           (staves (car (layers (car (segments buffer))))) (list staff))))
 387
 388 (defmethod frame-find-file :around ((application-frame gsharp) filepath)
 389   (declare (ignore filepath))
 390   (let* ((buffer (call-next-method))
 391          (input-state (make-input-state))
 392          (cursor (make-initial-cursor buffer))
 393          (view (make-instance 'orchestra-view
 394                               :buffer buffer
 395                               :cursor cursor)))
 396     (push view (views *application-frame*))
 397     (setf (view (car (windows *application-frame*))) view
 398           (input-state *application-frame*) input-state
 399           (filepath buffer) filepath)
 400     (select-layer cursor (car (layers (segment (current-cursor)))))))
 401
 402 (define-gsharp-command (com-quit :name t) ()
 403   (frame-exit *application-frame*))
 404
 405 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 406 ;;;
 407 ;;; buffer menu
 408
 409 (make-command-table
 410  'buffer-command-table
 411  :errorp nil
 412  :menu '(("Play" :command com-play-buffer)
 413          ("Delete Current" :command com-delete-buffer)))
 414
 415 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 416 ;;;
 417 ;;; segment menu
 418
 419 (make-command-table
 420  'segment-command-table
 421  :errorp nil
 422  :menu '(("Forward" :command com-forward-segment)
 423          ("Backward" :command com-backward-segment)
 424          ("Delete Current" :command com-delete-segment)
 425          ("Insert After Current" :command com-insert-segment-after)
 426          ("Insert Before Current" :command com-insert-segment-before)))
 427
 428 (define-gsharp-command (com-forward-segment :name t) ()
 429   (forward-segment (current-cursor)))
 430
 431 (define-gsharp-command (com-backward-segment :name t) ()
 432   (backward-segment (current-cursor)))
 433
 434 (define-gsharp-command (com-delete-segment :name t) ()
 435   (delete-segment (current-cursor)))
 436
 437 (define-gsharp-command (com-insert-segment-before :name t) ()
 438   (let ((cursor (current-cursor)))
 439     (insert-segment-before (make-instance 'segment :staff (car (staves (current-buffer))))
 440                            cursor)
 441     (backward-segment cursor)))
 442
 443 (define-gsharp-command (com-insert-segment-after :name t) ()
 444   (let ((cursor (current-cursor)))
 445     (insert-segment-after (make-instance 'segment :staff (car (staves (current-buffer))))
 446                           cursor)
 447     (forward-segment cursor)))
 448
 449 (define-gsharp-command (com-set-segment-tempo :name t) ((tempo 'integer :prompt "Tempo"))
 450   (let ((segment (segment (current-cursor))))
 451     (setf (tempo segment) tempo)))
 452
 453 (define-gsharp-command (com-set-segment-tuning-regular-temperament :name t)
 454     ((octave-cents 'cl:number :prompt "Octave size in cents")
 455      (fifth-cents 'cl:number :prompt "Fifth size in cents")
 456      (quartertone-cents 'cl:number :prompt "Quartertone size in cents"))
 457   ;; TODO: prompt for sizes of various microtonal accidentals
 458   (let ((segment (segment (current-cursor))))
 459     (setf (tuning segment) (make-instance 'regular-temperament
 460                                           :octave-cents octave-cents
 461                                           :fifth-cents fifth-cents
 462                                           :quartertone-cents quartertone-cents))))
 463
 464 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 465 ;;;
 466 ;;; layer menu
 467
 468 (make-command-table
 469  'layer-command-table
 470  :errorp nil
 471  :menu '(("Select" :command com-select-layer)
 472          ("Rename" :command com-rename-layer)
 473          ("New"    :command com-add-layer)
 474          ("Delete" :command com-delete-layer)))
 475
 476 (define-condition layer-name-not-unique (gsharp-condition) ()
 477   (:report
 478    (lambda (condition stream)
 479      (declare (ignore condition))
 480      (format stream "Layer name already exists"))))
 481
 482 (defun acquire-unique-layer-name (prompt)
 483   (let ((name (accept 'string :prompt prompt)))
 484     (assert (not (member name (layers (segment (current-cursor)))
 485                          :test #'string= :key #'name))
 486             () `layer-name-not-unique)
 487     name))
 488
 489 (define-condition no-such-layer (gsharp-condition) ()
 490   (:report
 491    (lambda (condition stream)
 492      (declare (ignore condition))
 493      (format stream "No such layer"))))
 494
 495 (define-presentation-method accept
 496     ((type layer) stream (view textual-view) &key)
 497   (multiple-value-bind (layer success string)
 498       (handler-case (complete-input stream
 499                                     (lambda (so-far mode)
 500                                       (complete-from-possibilities
 501                                        so-far
 502                                        (layers (segment (current-cursor)))
 503                                        '()
 504                                        :action mode
 505                                        :predicate (constantly t)
 506                                        :name-key #'name
 507                                        :value-key #'identity)))
 508         (simple-parse-error () (error 'no-such-layer)))
 509     (declare (ignore string))
 510     (if success layer (error 'no-such-layer))))
 511
 512 (defgeneric find-applicable-gsharp-command-table (layer element))
 513
 514 (defmethod find-applicable-gsharp-command-table ((layer melody-layer) element)
 515   (declare (ignore element))
 516   (find-command-table 'total-melody-table))
 517
 518 (defmethod find-applicable-gsharp-command-table ((layer melody-layer) (element rhythmic-element))
 519   (find-command-table 'total-rhythmic-melody-table))
 520
 521 (defmethod find-applicable-gsharp-command-table ((layer melody-layer) (element cluster))
 522   (find-command-table 'total-cluster-table))
 523
 524 (defmethod find-applicable-gsharp-command-table ((layer lyrics-layer) element)
 525   (declare (ignore element))
 526   (find-command-table 'total-lyrics-table))
 527
 528 (defmethod find-applicable-command-table ((frame gsharp))
 529   (let* ((cursor (current-cursor))
 530          (layer (layer cursor))
 531          (element (if (beginning-of-bar-p cursor) nil (current-element cursor))))
 532     (find-applicable-gsharp-command-table layer element)))
 533
 534 (define-gsharp-command (com-select-layer :name t) ()
 535   (let ((selected-layer (accept 'layer :prompt "Select layer")))
 536     (select-layer (current-cursor) selected-layer)))
 537
 538 (define-gsharp-command (com-rename-layer :name t) ()
 539   (setf (name (accept 'layer :prompt "Rename layer"))
 540         (acquire-unique-layer-name "New name of layer")))
 541
 542 (define-gsharp-command (com-add-layer :name t) ()
 543   (let* ((name (acquire-unique-layer-name "Name of new layer"))
 544          (staff (accept 'score-pane:staff :prompt "Initial staff of new layer"))
 545          (new-layer (make-layer (list staff) :name name)))
 546     (add-layer new-layer (segment (current-cursor)))
 547     (select-layer (current-cursor) new-layer)))
 548
 549 (define-gsharp-command (com-delete-layer :name t) ()
 550   (delete-layer (current-cursor)))
 551
 552 (define-gsharp-command (com-jump-to-here :name t)
 553     ((element 'element))
 554   (let ((cursor (current-cursor)))
 555     (setf (gsharp-cursor::bar cursor) (bar element)
 556           (gsharp-cursor::pos cursor) (1+ (position element
 557                                                     (elements (bar element)))))))
 558
 559 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 560 ;;;
 561 ;;; slice menu
 562
 563 (make-command-table
 564  'slice-command-table
 565  :errorp nil
 566  :menu '(("Head" :command com-head-slice)
 567          ("Body" :command com-body-slice)
 568          ("Tail" :command com-tail-slisce)))
 569
 570 (define-gsharp-command (com-head-slice :name t) ()
 571   (head-slice (current-cursor)))
 572
 573 (define-gsharp-command (com-body-slice :name t) ()
 574   (body-slice (current-cursor)))
 575
 576 (define-gsharp-command (com-tail-slice :name t) ()
 577   (tail-slice (current-cursor)))
 578
 579 (define-gsharp-command (com-forward-slice :name t) ()
 580   (forward-slice (current-cursor)))
 581
 582 (define-gsharp-command (com-backward-slice :name t) ()
 583   (backward-slice (current-cursor)))
 584
 585 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 586 ;;;
 587 ;;; bar menu
 588
 589 (make-command-table
 590  'measure-command-table
 591  :errorp nil
 592  :menu '(("Forward" :command (com-forward-measure 1))
 593          ("Backward" :command (com-backward-measure 1))))
 594
 595 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 596 ;;;
 597 ;;; modes menu
 598
 599 (make-command-table
 600  'modes-command-table
 601  :errorp nil
 602  :menu '(("Fundamental" :command com-fundamental)))
 603
 604 (define-gsharp-command (com-fundamental :name t) ()
 605   nil)
 606
 607 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 608 ;;;
 609 ;;; staves menu
 610
 611 (make-command-table
 612  'staves-command-table
 613  :errorp nil
 614  :menu '(("Rotate" :command com-rotate-staves)))
 615
 616 (define-gsharp-command (com-rotate-staves :name t) ()
 617   (let ((layer (layer (current-cursor))))
 618     (setf (staves layer)
 619           (append (cdr (staves layer)) (list (car (staves layer)))))))
 620
 621 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 622 ;;;
 623 ;;; play menu
 624
 625 (make-command-table
 626  'play-command-table
 627  :errorp nil
 628  :menu '(("Buffer" :command com-play-buffer)
 629          ("Segment" :command com-play-segment)
 630          ("Layer" :command com-play-layer)))
 631
 632 (define-gsharp-command (com-play-buffer :name t) ()
 633   (play-buffer (buffer (current-cursor))))
 634
 635 (define-gsharp-command (com-play-segment :name t) ()
 636   (play-segment (segment (current-cursor))))
 637
 638 (define-gsharp-command (com-play-layer :name t) ()
 639   (play-layer (layer (current-cursor))))
 640
 641 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 642 ;;;
 643 ;;; main entry points
 644
 645 (defun gsharp (&rest args &key new-process process-name width height)
 646   "Start a Gsharp session with a fresh empty buffer"
 647   (declare (ignore new-process process-name width height))
 648   (apply #'gsharp-common '(com-new-buffer) args))
 649
 650 (defun edit-file (filename &rest args
 651                   &key new-process process-name width height)
 652   "Start a Gsharp session editing a given file"
 653   (declare (ignore new-process process-name width height))
 654   (apply #'gsharp-common `(esa-io::com-find-file ,filename) args))
 655
 656 (defun gsharp-common (command &key new-process (process-name "Gsharp") width height)
 657   (let* ((frame (make-application-frame 'gsharp :width width :height height))
 658          (*application-frame* frame)
 659          (*esa-instance* frame))
 660     (adopt-frame (find-frame-manager) *application-frame*)
 661     (execute-frame-command *application-frame* command)
 662     (flet ((run () (run-frame-top-level frame)))
 663       (if new-process
 664           (clim-sys:make-process #'run :name process-name)
 665           (run)))))
 666
 667 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 668 ;;;
 669 ;;; development and debugging aids
 670
 671 ;;; FIXME: you might expect that this was in an ESA component, but in
 672 ;;; fact it's not.  Maybe it should be?
 673 (define-gsharp-command (com-eval-expression :name t)
 674     ((expression 'expression :prompt "Eval"))
 675   "Prompt for and evaluate a lisp expression.
 676 Prints the results in the minibuffer."
 677   (let* ((*package* (find-package :gsharp))
 678          (values (multiple-value-list
 679                   (handler-case (eval expression)
 680                     (error (condition)
 681                       (beep)
 682                       (display-message "~a" condition)
 683                       (return-from com-eval-expression nil)))))
 684          (result (format nil "~:[; No values~;~:*~{~S~^,~}~]" values)))
 685     (display-message result)))
 686
 687 (define-gsharp-command (com-raster+ :name t) ()
 688   (let ((score-pane (get-main-score-pane)))
 689     (incf (gsharp-buffer::rastral-size (buffer (current-cursor))))
 690     (redisplay-frame-pane *application-frame* score-pane :force-p t)))
 691 (define-gsharp-command (com-raster- :name t) ()
 692   (let ((score-pane (get-main-score-pane)))
 693     (unless (<= (gsharp-buffer::rastral-size (buffer (current-cursor))) 6)
 694       (decf (gsharp-buffer::rastral-size (buffer (current-cursor))))
 695       (redisplay-frame-pane *application-frame* score-pane :force-p t))))
 696
 697 (defun get-main-score-pane ()
 698   (find "score"
 699         (frame-current-panes *application-frame*)
 700         :key #'pane-name
 701         :test #'string=))
 702
 703 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 704 ;;;
 705 ;;; note insertion commands
 706
 707 (defun insert-cluster ()
 708   (let* ((state (input-state *application-frame*))
 709          (cursor (current-cursor))
 710          (cluster (make-cluster
 711                    :notehead (notehead state)
 712                    :lbeams (if (eq (notehead state) :filled) (lbeams state) 0)
 713                    :rbeams (if (eq (notehead state) :filled) (rbeams state) 0)
 714                    :dots (dots state)
 715                    :stem-direction (stem-direction state))))
 716     (insert-element cluster cursor)
 717     (forward-element cursor)
 718     cluster))
 719
 720 (defparameter *current-cluster* nil)
 721 (defparameter *current-note* nil)
 722
 723 (defun insert-note (pitch cluster accidentals)
 724   (let* ((state (input-state *application-frame*))
 725          (staff (car (staves (layer (slice (bar cluster))))))
 726          (note (make-note pitch staff
 727                  :head (notehead state)
 728                  :accidentals accidentals
 729                  :dots (dots state))))
 730     (setf *current-cluster* cluster
 731           *current-note* note)
 732     (add-note cluster note)))
 733
 734 (defun compute-and-adjust-note (pitch)
 735   (let* ((state (input-state *application-frame*))
 736          (old-pitch (mod (last-note state) 7))
 737          (diff (- pitch old-pitch)))
 738     (incf (last-note state)
 739           (cond ((> diff 3) (- diff 7))
 740                 ((< diff -3) (+ diff 7))
 741                 (t diff)))))
 742
 743 (defun insert-numbered-note-new-cluster (pitch)
 744   (let* ((new-pitch (compute-and-adjust-note pitch))
 745          (accidentals (aref (alterations (keysig (current-cursor))) (mod new-pitch 7))))
 746     (insert-note new-pitch (insert-cluster) accidentals)))
 747
 748 (define-gsharp-command (com-insert-note-a :keystroke #\a) ()
 749   (insert-numbered-note-new-cluster 5))
 750
 751 (define-gsharp-command (com-insert-note-b :keystroke #\b) ()
 752   (insert-numbered-note-new-cluster 6))
 753
 754 (define-gsharp-command (com-insert-note-c :keystroke #\c) ()
 755   (insert-numbered-note-new-cluster 0))
 756
 757 (define-gsharp-command (com-insert-note-d :keystroke #\d) ()
 758   (insert-numbered-note-new-cluster 1))
 759
 760 (define-gsharp-command (com-insert-note-e :keystroke #\e) ()
 761   (insert-numbered-note-new-cluster 2))
 762
 763 (define-gsharp-command (com-insert-note-f :keystroke #\f) ()
 764   (insert-numbered-note-new-cluster 3))
 765
 766 (define-gsharp-command (com-insert-note-g :keystroke #\g) ()
 767   (insert-numbered-note-new-cluster 4))
 768
 769 (define-gsharp-command com-insert-rest ()
 770   (let* ((state (input-state *application-frame*))
 771          (cursor (current-cursor))
 772          (rest (make-rest (car (staves (layer (current-cursor))))
 773                  :rbeams (if (eq (notehead state) :filled) (rbeams state) 0)
 774                  :lbeams (if (eq (notehead state) :filled) (lbeams state) 0)
 775                  :dots (dots state)
 776                  :notehead (notehead state))))
 777     (insert-element rest cursor)
 778     (forward-element cursor)
 779     rest))
 780
 781 (define-gsharp-command com-insert-empty-cluster ()
 782   (insert-cluster))
 783
 784 (defun cur-elementp ()
 785   (handler-case
 786       (cur-element)
 787     (not-on-an-element () nil)))
 788 (defun cur-clusterp ()
 789   (handler-case
 790       (cur-cluster)
 791     (not-on-a-cluster () nil)))
 792 (defun cur-notep ()
 793   (handler-case
 794       (cur-note)
 795     (not-on-a-cluster () nil)
 796     (not-on-an-element () nil)))
 797
 798 (defun cur-cluster ()
 799   (current-cluster (current-cursor)))
 800
 801 (defun cur-element ()
 802   (current-element (current-cursor)))
 803
 804 (defun cur-note ()
 805   (let ((cluster (cur-cluster)))
 806     (if (eq *current-cluster* cluster) ; it has not moved since last time
 807         (or (car (member *current-note* (notes cluster) :test #'eq))
 808             (setf *current-note* (car (notes cluster))))
 809         (setf *current-cluster* cluster
 810               *current-note* (car (notes cluster))))))
 811
 812 (define-gsharp-command com-current-increment ()
 813   (let* ((cluster (cur-cluster))
 814          (notes (notes cluster))
 815          (rest (member (cur-note) notes :test #'eq)))
 816     (unless (null (cdr rest))
 817       (setf *current-note* (cadr rest)))))
 818
 819 (define-gsharp-command com-current-decrement ()
 820   (let* ((cluster (cur-cluster))
 821          (notes (notes cluster))
 822          (pos (position (cur-note) notes :test #'eq)))
 823     (unless (zerop pos)
 824       (setf *current-note* (nth (1- pos) notes)))))
 825
 826 (defun insert-numbered-note-current-cluster (pitch)
 827   (let* ((new-pitch (compute-and-adjust-note pitch))
 828          (accidentals (aref (alterations (keysig (current-cursor))) (mod new-pitch 7))))
 829     (insert-note new-pitch (cur-cluster) accidentals)))
 830
 831 (define-gsharp-command com-add-note-a ()
 832   (insert-numbered-note-current-cluster 5))
 833
 834 (define-gsharp-command com-add-note-b ()
 835   (insert-numbered-note-current-cluster 6))
 836
 837 (define-gsharp-command com-add-note-c ()
 838   (insert-numbered-note-current-cluster 0))
 839
 840 (define-gsharp-command com-add-note-d ()
 841   (insert-numbered-note-current-cluster 1))
 842
 843 (define-gsharp-command com-add-note-e ()
 844   (insert-numbered-note-current-cluster 2))
 845
 846 (define-gsharp-command com-add-note-f ()
 847   (insert-numbered-note-current-cluster 3))
 848
 849 (define-gsharp-command com-add-note-g ()
 850   (insert-numbered-note-current-cluster 4))
 851
 852 (macrolet ((define-duration-altering-command (name &body body)
 853                `(define-gsharp-command ,name ()
 854                  (let ((element (cur-element)))
 855                    ,@body
 856                    (gsharp-buffer::maybe-update-key-signatures
 857                     (bar (current-cursor)))))))
 858   (define-duration-altering-command com-more-dots ()
 859     (setf (dots element) (min (1+ (dots element)) 3)))
 860   (define-duration-altering-command com-fewer-dots ()
 861     (setf (dots element) (max (1- (dots element)) 0)))
 862   (define-duration-altering-command com-more-rbeams ()
 863     (setf (rbeams element) (min (1+ (rbeams element)) 3)))
 864   (define-duration-altering-command com-fewer-lbeams ()
 865     (setf (lbeams element) (max (1- (lbeams element)) 0)))
 866   (define-duration-altering-command com-more-lbeams ()
 867     (setf (lbeams element) (min (1+ (lbeams element)) 3)))
 868   (define-duration-altering-command com-fewer-rbeams ()
 869     (setf (rbeams element) (max (1- (rbeams element)) 0)))
 870   (define-duration-altering-command com-rotate-notehead ()
 871     (setf (notehead element)
 872           (ecase (notehead element)
 873             (:breve :long)
 874             (:whole :breve)
 875             (:half :whole)
 876             (:filled :half)
 877             (:long :filled)))))
 878
 879 (define-gsharp-command com-rotate-stem-direction ()
 880   (setf (stem-direction (cur-cluster))
 881         (ecase (stem-direction (cur-cluster))
 882           (:auto :up)
 883           (:up :down)
 884           (:down :auto))))
 885
 886 (define-gsharp-command com-toggle-staccato ()
 887   (let ((cluster (cur-cluster)))
 888     (if (member :staccato (annotations cluster))
 889         (setf (annotations cluster) (remove :staccato (annotations cluster)))
 890         (push :staccato (annotations cluster)))))
 891
 892 (define-gsharp-command com-toggle-tenuto ()
 893   (let ((cluster (cur-cluster)))
 894     (if (member :tenuto (annotations cluster))
 895         (setf (annotations cluster) (remove :tenuto (annotations cluster)))
 896         (push :tenuto (annotations cluster)))))
 897
 898 (define-gsharp-command com-down ()
 899   (let ((element (cur-element)))
 900     (if (typep element 'cluster)
 901         (let* ((note (cur-note))
 902                (new-note (make-note (1- (pitch note)) (staff note)
 903                            :head (head note)
 904                            :accidentals (accidentals note)
 905                            :dots (dots note))))
 906           (remove-note note)
 907           (add-note element new-note)
 908           (setf *current-note* new-note))
 909         (let ((rbeams (rbeams element))
 910               (lbeams (lbeams element))
 911               (dots (dots element))
 912               (notehead (notehead element))
 913               (staff-pos (staff-pos element))
 914               (staff (staff element))
 915               (cursor (current-cursor)))
 916           (backward-element cursor)
 917           (delete-element cursor)
 918           (insert-element (make-rest staff
 919                             :staff-pos (- staff-pos 2)
 920                             :notehead notehead :dots dots
 921                             :rbeams rbeams :lbeams lbeams)
 922                           cursor)
 923           (forward-element cursor)))))
 924
 925 (define-gsharp-command com-up ()
 926   (let ((element (cur-element)))
 927     (if (typep element 'cluster)
 928         (let* ((note (cur-note))
 929                (new-note (make-note (1+ (pitch note)) (staff note)
 930                            :head (head note)
 931                            :accidentals (accidentals note)
 932                            :dots (dots note))))
 933           (remove-note note)
 934           (add-note element new-note)
 935           (setf *current-note* new-note))
 936         (let ((rbeams (rbeams element))
 937               (lbeams (lbeams element))
 938               (dots (dots element))
 939               (notehead (notehead element))
 940               (staff-pos (staff-pos element))
 941               (staff (staff element))
 942               (cursor (current-cursor)))
 943           (backward-element cursor)
 944           (delete-element cursor)
 945           (insert-element (make-rest staff
 946                             :staff-pos (+ staff-pos 2)
 947                             :notehead notehead :dots dots
 948                             :rbeams rbeams :lbeams lbeams)
 949                           cursor)
 950           (forward-element cursor)))))
 951
 952 (define-gsharp-command com-octave-down ()
 953   (let ((element (cur-element)))
 954     (let* ((note (cur-note))
 955            (new-note (make-note (- (pitch note) 7) (staff note)
 956                         :head (head note)
 957                         :accidentals (accidentals note)
 958                         :dots (dots note))))
 959       (remove-note note)
 960       (add-note element new-note)
 961       (setf *current-note* new-note))))
 962
 963 (define-gsharp-command com-octave-up ()
 964   (let ((element (cur-element)))
 965     (let* ((note (cur-note))
 966            (new-note (make-note (+ (pitch note) 7) (staff note)
 967                         :head (head note)
 968                         :accidentals (accidentals note)
 969                         :dots (dots note))))
 970       (remove-note note)
 971       (add-note element new-note)
 972       (setf *current-note* new-note))))
 973
 974 (defmacro define-microtonal-accidentals (&rest microaccidentals)
 975   `(progn
 976     (setf (symbol-plist 'microsharpen)
 977           ',(loop for (a b) on microaccidentals
 978                   if b collect a and collect b
 979                   else collect a and collect a))
 980     (setf (symbol-plist 'microflatten)
 981           ',(loop for (a b) on (reverse microaccidentals)
 982                   if b collect a and collect b
 983                   else collect a and collect a))
 984     (deftype accidental () '(member ,@microaccidentals))
 985     (defun microsharpen (accidental)
 986       (or (getf (symbol-plist 'microsharpen) accidental)
 987           (error 'type-error :datum accidental :expected-type 'microaccidental)))
 988     (defun microflatten (accidental)
 989       (or (getf (symbol-plist 'microflatten) accidental)
 990           (error 'type-error :datum accidental :expected-type 'microaccidental)))))
 991
 992 (defmacro define-accidentals (&rest accidentals)
 993   `(progn
 994     (deftype accidental () '(member ,@accidentals))
 995     (defun sharpen (accidental)
 996       (do ((a (microsharpen accidental) (microsharpen a))
 997            (olda accidental a))
 998           ((or (eq a olda) (member a ',accidentals)) a)))
 999     (defun flatten (accidental)
1000       (do ((a (microflatten accidental) (microflatten a))
1001            (olda accidental a))
1002           ((or (eq a olda) (member a ',accidentals)) a)))))
1003
1004 (define-microtonal-accidentals :double-flat :sesquiflat :flat :semiflat
1005                                :natural
1006                                :semisharp :sharp :sesquisharp :double-sharp)
1007
1008 (define-accidentals :double-flat :flat :natural :sharp :double-sharp)
1009
1010 (define-gsharp-command com-sharper ()
1011   (let* ((cluster (cur-cluster))
1012          (note (cur-note))
1013          (new-note (make-note (pitch note) (staff note)
1014                      :head (head note)
1015                      :accidentals (sharpen (accidentals note))
1016                      :dots (dots note))))
1017     (remove-note note)
1018     (add-note cluster new-note)
1019     (setf *current-note* new-note)))
1020
1021 (define-gsharp-command com-microsharper ()
1022   ;; FIXME: what are CUR-CLUSTER and CUR-NOTE and how do they relate
1023   ;; to CURRENT-CLUSTER &c?
1024   (let* ((cluster (cur-cluster))
1025          (note (cur-note))
1026          (new-note (make-note (pitch note) (staff note)
1027                      :head (head note)
1028                      :accidentals (microsharpen (accidentals note))
1029                      :dots (dots note))))
1030     (remove-note note)
1031     (add-note cluster new-note)
1032     (setf *current-note* new-note)))
1033
1034 (define-gsharp-command com-flatter ()
1035   (let* ((cluster (cur-cluster))
1036          (note (cur-note))
1037          (new-note (make-note (pitch note) (staff note)
1038                      :head (head note)
1039                      :accidentals (flatten (accidentals note))
1040                      :dots (dots note))))
1041     (remove-note note)
1042     (add-note cluster new-note)
1043     (setf *current-note* new-note)))
1044
1045 (define-gsharp-command com-microflatter ()
1046   (let* ((cluster (cur-cluster))
1047          (note (cur-note))
1048          (new-note (make-note (pitch note) (staff note)
1049                      :head (head note)
1050                      :accidentals (microflatten (accidentals note))
1051                      :dots (dots note))))
1052     (remove-note note)
1053     (add-note cluster new-note)
1054     (setf *current-note* new-note)))
1055
1056 (define-gsharp-command com-remove-current-note ()
1057   (let ((cluster (cur-cluster))
1058         (note (cur-note)))
1059     (when note
1060       (remove-note note)
1061       ;; try to set current-note to the highest note lower than the
1062       ;; removed note.  If that fails, to the lowest note higher than
1063       ;; it.
1064       (setf *current-note* (or (cluster-lower-bound cluster note)
1065                                (cluster-upper-bound cluster note)))
1066       (unless *current-note*
1067         (com-erase-element 1)))))
1068
1069 (defun insert-keysig ()
1070   (let* ((state (input-state *application-frame*))
1071          (cursor (current-cursor))
1072          (staff (car (staves (layer cursor))))
1073          (keysig (if (keysig cursor)
1074                      (make-key-signature
1075                       staff :alterations (copy-seq (alterations (keysig cursor))))
1076                      (make-key-signature staff))))
1077     ;; FIXME: should only invalidate elements temporally after the
1078     ;; cursor.
1079     (gsharp-measure::invalidate-everything-using-staff (current-buffer) staff)
1080     (insert-element keysig cursor)
1081     (forward-element cursor)
1082     keysig))
1083
1084 (define-gsharp-command com-insert-keysig ()
1085   (insert-keysig))
1086
1087 (defun insert-clef (clef)
1088   (let ((cursor (current-cursor)))
1089     (gsharp-measure::invalidate-everything-using-staff (current-buffer) (staff clef))
1090     (insert-element clef cursor)
1091     (forward-element cursor)
1092     clef))
1093
1094 (defun insert-timesig (numerator denominator)
1095   (let* ((cursor (current-cursor))
1096          (staff (car (staves (layer cursor))))
1097          (timesig (make-time-signature :staff staff
1098                                        :components
1099                                        (list (if denominator
1100                                                  (cons numerator denominator)
1101                                                  numerator)))))
1102     (insert-element timesig cursor)
1103     (forward-element cursor)
1104     timesig))
1105
1106 (define-gsharp-command (com-insert-timesig :name t)
1107     ((numerator '(integer 1 8) :prompt "Numerator")
1108      (denominator '(integer 1 8) :prompt "Denominator"))
1109   (insert-timesig numerator denominator))
1110
1111 (define-gsharp-command (com-insert-clef :name t) ()
1112   (let* ((type (accept 'clef-type :prompt "Type of clef"))
1113          (line (accept 'integer :prompt "Line of clef"))
1114          (clef (make-clef type :lineno line)))
1115     (setf (slot-value clef 'gsharp-buffer::%staff) (car (staves (layer (current-cursor)))))
1116     (insert-clef clef)))
1117
1118 (defmethod remove-element :before ((element staffwise-element) (bar bar))
1119   (let ((staff (staff element)))
1120     (setf (staffwise-elements staff)
1121           (remove element (staffwise-elements staff)))
1122     (gsharp-measure::invalidate-everything-using-staff (current-buffer) staff)))
1123
1124 ;;; FIXME: this isn't quite right (argh) for the case of two
1125 ;;; temporally coincident zero-duration elements on the same staff in
1126 ;;; different layers: essentially all bets are off.
1127 (defun starts-before-p (thing bar element-or-nil)
1128   ;; does THING start before the temporal position denoted by BAR and
1129   ;; ELEMENT-OR-NIL?
1130   (assert (or (null element-or-nil) (eq (bar element-or-nil) bar)))
1131   (when (null (bar thing))
1132     ;; THING is probably the key signature at the start of the piece,
1133     ;; in which case it is definitely before whatever else happens.
1134     (assert (typep thing 'key-signature))
1135     (return-from starts-before-p t))
1136   (let ((barno (number bar)))
1137     (cond
1138       ((> (number (bar thing)) barno) nil)
1139       ((< (number (bar thing)) barno) t)
1140       (t (let ((thing-start-time (loop for e in (elements (bar thing))
1141                                        if (eq e element-or-nil)
1142                                        do (return-from starts-before-p nil)
1143                                        until (eq e thing) sum (duration e)))
1144                (element-start-time
1145                 ;; this is actually the right answer for
1146                 ;; ELEMENT-OR-NIL = NIL, which means "end of bar"
1147                 (loop for e in (elements bar)
1148                       if (eq e thing) do (return-from starts-before-p t)
1149                       until (eq e element-or-nil) sum (duration e))))
1150            (or (> element-start-time thing-start-time)
1151                (and (= element-start-time thing-start-time)
1152                     (or (null element-or-nil)
1153                         (> (duration element-or-nil) 0)))))))))
1154
1155 (defun %keysig (staff key-signatures bar element-or-nil)
1156   (or (and key-signatures
1157            (find-if (lambda (x) (starts-before-p x bar element-or-nil))
1158                     key-signatures :from-end t))
1159       (keysig staff)))
1160
1161 (defmethod keysig ((cursor gsharp-cursor))
1162   ;; FIXME: not just a cursor but _the_ cursor (i.e. in a given staff)
1163   ;; otherwise the operation for getting the staff [(CAR (STAVES
1164   ;; (LAYER CURSOR)))] need not return the staff that we're interested
1165   ;; in.
1166   (assert (eq cursor (current-cursor)))
1167   (let* ((staff (car (staves (layer cursor))))
1168          (key-signatures (key-signatures staff))
1169          (bar (bar cursor))
1170          (element-or-nil (cursor-element cursor)))
1171     (%keysig staff key-signatures bar element-or-nil)))
1172
1173 (defmethod keysig ((note note))
1174   (let* ((staff (staff note))
1175          (key-signatures (key-signatures staff))
1176          (bar (bar (cluster note)))
1177          (element-or-nil (cluster note)))
1178     (%keysig staff key-signatures bar element-or-nil)))
1179
1180 (defmethod keysig ((cluster cluster))
1181   (error "Called ~S (a staff-scope operation) on an element with no ~
1182           associated staff: ~S"
1183          'keysig cluster))
1184
1185 (defmethod keysig ((element element))
1186   (let* ((staff (staff element))
1187          (key-signatures (key-signatures staff))
1188          (bar (bar element)))
1189     (%keysig staff key-signatures bar element)))
1190
1191 ;; These are copied from the keysig equivalents, which seem to work...
1192 (defun %clef (staff clefs bar element-or-nil)
1193   (or (and clefs
1194            (find-if (lambda (x) (starts-before-p x bar element-or-nil))
1195                     clefs :from-end t))
1196       (clef staff)))
1197
1198 (defmethod clef ((cursor gsharp-cursor))
1199   (assert (eq cursor (current-cursor)))
1200   (let* ((staff (car (staves (layer cursor))))
1201          (clefs (clefs staff))
1202          (bar (bar cursor))
1203          (element-or-nil (cursor-element cursor)))
1204     (%clef staff clefs bar element-or-nil)))
1205
1206 (defmethod clef ((note note))
1207   (let* ((staff (staff note))
1208          (clefs (clefs staff))
1209          (bar (bar (cluster note)))
1210          (element-or-nil (cluster note)))
1211     (%clef staff clefs bar element-or-nil)))
1212
1213 (defmethod clef ((cluster cluster))
1214   (error "Called ~S (a staff-scope operation) on an element with no ~
1215           associated staff: ~S"
1216          'clef cluster))
1217
1218 (defmethod clef ((element element))
1219   ;; Obviously, only works for elemnts with a staff (i.e. not a
1220   ;; cluster
1221   (let* ((staff (staff element))
1222          (clefs (clefs staff))
1223          (bar (bar element)))
1224     (%clef staff clefs bar element)))
1225
1226 (define-gsharp-command com-tie-note-left ()
1227   (let ((note (cur-note)))
1228     (when note
1229       (setf (tie-left note) t))))
1230
1231 (define-gsharp-command com-untie-note-left ()
1232   (let ((note (cur-note)))
1233     (when note
1234       (setf (tie-left note) nil))))
1235
1236 (define-gsharp-command com-tie-note-right ()
1237   (let ((note (cur-note)))
1238     (when note
1239       (setf (tie-right note) t))))
1240
1241 (define-gsharp-command com-untie-note-right ()
1242   (let ((note (cur-note)))
1243     (when note
1244       (setf (tie-right note) nil))))
1245
1246 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1247 ;;;
1248 ;;; motion by element
1249
1250 (define-gsharp-command com-forward-element
1251     ((count 'integer :prompt "Number of Elements" :default 1))
1252   "Move forward by element."
1253   (loop repeat count
1254         do (forward-element (current-cursor))))
1255
1256 (define-gsharp-command com-backward-element
1257     ((count 'integer :prompt "Number of Elements" :default 1))
1258   "Move backward by element."
1259   (loop repeat count
1260         do (backward-element (current-cursor))))
1261
1262 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1263 ;;;
1264 ;;; motion by measure
1265
1266 (define-gsharp-command com-forward-measure
1267     ((count 'integer :prompt "Number of Measures" :default 1))
1268   "Move forward by measure."
1269   (loop repeat count do (forward-bar (current-cursor))))
1270
1271 (define-gsharp-command com-backward-measure
1272     ((count 'integer :prompt "Number of Measures" :default 1))
1273   "Move backward by measure."
1274   (loop repeat count do (backward-bar (current-cursor))))
1275
1276 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1277 ;;;
1278 ;;; motion by entire score
1279
1280 (define-gsharp-command com-end-of-score ()
1281   (loop until (last-segment-p (current-cursor))
1282         do (forward-segment (current-cursor)))
1283   (loop until (last-bar-p (current-cursor))
1284         do (forward-bar (current-cursor)))
1285   (loop until (end-of-bar-p (current-cursor))
1286         do (forward-element (current-cursor))))
1287
1288 (define-gsharp-command com-beginning-of-score ()
1289   (loop until (first-segment-p (current-cursor))
1290         do (backward-segment (current-cursor)))
1291   (loop until (first-bar-p (current-cursor))
1292         do (backward-bar (current-cursor)))
1293   (loop until (beginning-of-bar-p (current-cursor))
1294         do (backward-element (current-cursor))))
1295
1296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1297 ;;;
1298 ;;; motion by layout (page or line)
1299
1300 ;;; support routines, needed because we're not cacheing the page
1301 ;;; breaks (other than in the buffer Obseq) nor the linebreaks (at
1302 ;;; all)
1303 (defun position-containing-current-bar (sequence)
1304   (let ((bar (bar (current-cursor))))
1305     (position-if (lambda (measure) (member bar (measure-bars measure)))
1306                  sequence)))
1307 (defun get-page-lines (buffer page-measures)
1308   (score-pane:with-staff-size (gsharp-buffer::rastral-size buffer)
1309     (let* (;; all this untimely ripp'd from DRAW-BUFFER in
1310            ;; drawing.lisp.  Needs to be kept in sync, otherwise the
1311            ;; layout for motion will be different from the layout on
1312            ;; the screen...
1313            (staves (staves buffer))
1314            (timesig-offset (gsharp-drawing::compute-timesig-offset staves page-measures))
1315            (method (let ((old-method (buffer-cost-method buffer)))
1316                      (make-measure-cost-method (min-width old-method)
1317                                                (spacing-style old-method)
1318                                                (- (line-width old-method) timesig-offset)
1319                                                (lines-per-page old-method))))
1320            (systems-per-page (gsharp-measure::systems-per-page buffer)))
1321       (gsharp-drawing::layout-page page-measures systems-per-page method))))
1322
1323 ;;; FIXME: these routines should implement numeric-argument handling
1324 (define-gsharp-command (com-forward-page :name t)
1325     ()
1326   (let ((cursor (current-cursor)))
1327     (gsharp-measure::new-map-over-obseq-subsequences
1328      (lambda (page-measures)
1329        (let ((position (position-containing-current-bar page-measures)))
1330          (when position
1331            (loop repeat (- (length page-measures) position)
1332                  if (last-bar-p cursor)
1333                  do (go-to-end-of-bar cursor) (return-from com-forward-page)
1334                  else do (forward-bar cursor)
1335                  finally (return-from com-forward-page)))))
1336      (current-buffer))))
1337 (define-gsharp-command (com-backward-page :name t)
1338     ()
1339   (let ((cursor (current-cursor)))
1340     (gsharp-measure::new-map-over-obseq-subsequences
1341      (let ((last 0))
1342        (lambda (page-measures)
1343          (let ((position (position-containing-current-bar page-measures)))
1344            (when position
1345              (loop repeat (+ position last)
1346                    do (backward-bar cursor)
1347                    finally (progn
1348                              (go-to-beginning-of-bar cursor)
1349                              (return-from com-backward-page)))))
1350          (setf last (length page-measures))))
1351      (current-buffer))))
1352
1353 (define-gsharp-command (com-end-of-line :name t)
1354     ()
1355   (let ((buffer (current-buffer))
1356         (cursor (current-cursor)))
1357     (gsharp-measure::new-map-over-obseq-subsequences
1358      (lambda (page-measures)
1359        (when (position-containing-current-bar page-measures)
1360          (let ((lines (get-page-lines buffer page-measures)))
1361            (dolist (line lines)
1362              (let ((position (position-containing-current-bar line)))
1363                (when position
1364                  (loop repeat (- (length line) position 1)
1365                        do (forward-bar cursor)
1366                        finally (progn
1367                                  (go-to-end-of-bar cursor)
1368                                  (return-from com-end-of-line)))))))))
1369      buffer)))
1370 (define-gsharp-command (com-beginning-of-line :name t)
1371     ()
1372   (let ((buffer (current-buffer))
1373         (cursor (current-cursor)))
1374     (gsharp-measure::new-map-over-obseq-subsequences
1375      (lambda (page-measures)
1376        (when (position-containing-current-bar page-measures)
1377          (let ((lines (get-page-lines buffer page-measures)))
1378            (dolist (line lines)
1379              (let ((position (position-containing-current-bar line)))
1380                (when position
1381                  (loop repeat position
1382                        do (backward-bar cursor)
1383                        finally (progn
1384                                  (go-to-beginning-of-bar cursor)
1385                                  (return-from com-beginning-of-line)))))))))
1386      buffer)))
1387
1388 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1389 ;;;
1390 ;;; selecting layers based on layout (next/previous staff)
1391
1392 ;;; FIXME: numeric argument handling again
1393 (define-gsharp-command (com-previous-staff :name t)
1394     ()
1395   (let ((staff (car (staves (layer (current-cursor))))))
1396     (loop for (prev curr) on (staves (current-buffer))
1397           if (eq curr staff)
1398           do (let ((layers (layers (segment (current-cursor)))))
1399                (dolist (layer layers)
1400                  (when (member prev (staves layer))
1401                    (select-layer (current-cursor) layer)
1402                    (do ()
1403                        ((eq prev (car (staves layer))))
1404                      (com-rotate-staves))
1405                    (return-from com-previous-staff)))))))
1406 (define-gsharp-command (com-next-staff :name t)
1407     ()
1408   (let ((staff (car (staves (layer (current-cursor))))))
1409     (loop for (curr next) on (staves (current-buffer))
1410           if (eq curr staff)
1411           do (let ((layers (layers (segment (current-cursor)))))
1412                (dolist (layer layers)
1413                  (when (member next (staves layer))
1414                    (select-layer (current-cursor) layer)
1415                    (do ()
1416                        ((eq next (car (staves layer))))
1417                      (com-rotate-staves))
1418                    (return-from com-next-staff)))))))
1419
1420 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1421 ;;;
1422 ;;; delete commands
1423
1424 (defun go-to-beginning-of-bar (cursor)
1425   (loop until (beginning-of-bar-p cursor)
1426         do (backward-element cursor)))
1427
1428 (defun go-to-end-of-bar (cursor)
1429   (loop until (end-of-bar-p cursor)
1430         do (forward-element cursor)))
1431
1432 ;;; assume cursor is at the end of the bar
1433 (defun fuse-bar-with-next (cursor)
1434   (go-to-beginning-of-bar cursor)
1435   (let ((elements '()))
1436     (loop until (end-of-bar-p cursor) do
1437           (push (cursor-element cursor) elements)
1438           (delete-element cursor))
1439     (delete-bar cursor)
1440     (loop for element in (nreverse elements) do
1441           (insert-element element cursor)
1442           (forward-element cursor))))
1443
1444 (define-gsharp-command com-delete-element
1445     ((count 'integer :prompt "Number of Elements" :default 1))
1446   "Delete element forwards."
1447   (let ((cursor (current-cursor)))
1448     (loop repeat count
1449           do (progn
1450                ;; this will signal a condition if in last bar and
1451                ;; interrupt the execution of the command
1452                (forward-element cursor)
1453                (backward-element cursor)
1454                (if (end-of-bar-p cursor)
1455                    (fuse-bar-with-next cursor)
1456                    (delete-element cursor))))))
1457
1458 (define-gsharp-command com-erase-element
1459     ((count 'integer :prompt "Number of Elements" :default 1))
1460   "Delete element backwards."
1461   (let ((cursor (current-cursor)))
1462     (loop repeat count
1463           do (progn
1464                (backward-element cursor)
1465                (if (end-of-bar-p cursor)
1466                    (fuse-bar-with-next cursor)
1467                    (delete-element cursor))))))
1468
1469 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1470 ;;;
1471 ;;; Input State Settings
1472
1473 (define-gsharp-command com-istate-more-dots ()
1474   (setf (dots (input-state *application-frame*))
1475         (min (1+ (dots (input-state *application-frame*))) 3)))
1476
1477 (define-gsharp-command com-istate-fewer-dots ()
1478   (setf (dots (input-state *application-frame*))
1479         (max (1- (dots (input-state *application-frame*))) 0)))
1480
1481 (define-gsharp-command com-istate-more-rbeams ()
1482   (setf (rbeams (input-state *application-frame*))
1483         (min (1+ (rbeams (input-state *application-frame*))) 3)))
1484
1485 (define-gsharp-command com-istate-fewer-lbeams ()
1486   (setf (lbeams (input-state *application-frame*))
1487         (max (1- (lbeams (input-state *application-frame*))) 0)))
1488
1489 (define-gsharp-command com-istate-more-lbeams ()
1490   (setf (lbeams (input-state *application-frame*))
1491         (min (1+ (lbeams (input-state *application-frame*))) 3)))
1492
1493 (define-gsharp-command com-istate-fewer-rbeams ()
1494   (setf (rbeams (input-state *application-frame*))
1495         (max (1- (rbeams (input-state *application-frame*))) 0)))
1496
1497 (define-gsharp-command com-istate-rotate-notehead ()
1498   (setf (notehead (input-state *application-frame*))
1499         (ecase (notehead (input-state *application-frame*))
1500           (:breve :long)
1501           (:whole :breve)
1502           (:half :whole)
1503           (:filled :half)
1504           (:long :filled))))
1505
1506 (define-gsharp-command com-istate-rotate-notehead-downwards ()
1507   (setf (notehead (input-state *application-frame*))
1508         (ecase (notehead (input-state *application-frame*))
1509           (:long :breve)
1510           (:breve :whole)
1511           (:whole :half)
1512           (:half :filled)
1513           (:filled :long))))
1514
1515 (define-gsharp-command com-istate-rotate-stem-direction ()
1516   (setf (stem-direction (input-state *application-frame*))
1517         (ecase (stem-direction (input-state *application-frame*))
1518           (:auto :up)
1519           (:up :down)
1520           (:down :auto))))
1521
1522 (define-gsharp-command (com-set-clef :name t) ()
1523   (let ((staff (accept 'score-pane:fiveline-staff :prompt "Set clef of staff"))
1524         (type (accept 'clef-type :prompt "Type of clef"))
1525         (line (accept 'integer :prompt "Line of clef")))
1526     (setf (clef staff) (make-clef type :lineno line))))
1527
1528 (define-gsharp-command com-higher ()
1529   (incf (last-note (input-state *application-frame*)) 7))
1530
1531 (define-gsharp-command com-lower ()
1532   (decf (last-note (input-state *application-frame*)) 7))
1533
1534 (define-gsharp-command com-insert-barline ()
1535   (let ((cursor (current-cursor))
1536         (elements '()))
1537     (loop until (end-of-bar-p cursor)
1538           do (push (cursor-element cursor) elements)
1539           do (delete-element cursor))
1540     (insert-bar-after (make-instance (class-of (bar cursor))) cursor)
1541     (forward-bar cursor)
1542     (loop for element in elements
1543           do (insert-element element cursor))))
1544
1545 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1546 ;;;
1547 ;;; Adding, deleting, and modifying staves
1548
1549 (define-condition no-such-staff (gsharp-condition) ()
1550   (:report
1551    (lambda (condition stream)
1552      (declare (ignore condition))
1553      (format stream "No such staff"))))
1554
1555 (define-presentation-method accept
1556     ((type score-pane:staff) stream (view textual-view) &key)
1557   (multiple-value-bind (staff success string)
1558       (handler-case (complete-input stream
1559                                     (lambda (so-far mode)
1560                                       (complete-from-possibilities
1561                                        so-far
1562                                        (staves (current-buffer))
1563                                        '()
1564                                        :action mode
1565                                        :predicate (constantly t)
1566                                        :name-key #'name
1567                                        :value-key #'identity)))
1568         (simple-parse-error () (error 'no-such-staff)))
1569     (declare (ignore string))
1570     (if success staff (error 'no-such-staff))))
1571
1572 (define-presentation-method accept
1573     ((type score-pane:fiveline-staff) stream (view textual-view) &key)
1574   (multiple-value-bind (staff success string)
1575       (handler-case (complete-input stream
1576                                     (lambda (so-far mode)
1577                                       (complete-from-possibilities
1578                                        so-far
1579                                        (staves (current-buffer))
1580                                        '()
1581                                        :action mode
1582                                        :predicate (lambda (obj) (typep obj 'fiveline-staff))
1583                                        :name-key #'name
1584                                        :value-key #'identity)))
1585         (simple-parse-error () (error 'no-such-staff)))
1586     (declare (ignore string))
1587     (if success staff (error 'no-such-staff))))
1588
1589 (defun symbol-name-lowcase (symbol)
1590   (string-downcase (symbol-name symbol)))
1591
1592 (define-presentation-type staff-type ())
1593
1594 (define-condition no-such-staff-type (gsharp-condition) ()
1595   (:report
1596    (lambda (condition stream)
1597      (declare (ignore condition))
1598      (format stream "No such staff type"))))
1599
1600 (define-presentation-method accept
1601     ((type staff-type) stream (view textual-view) &key)
1602   (multiple-value-bind (type success string)
1603       (handler-case (complete-input stream
1604                                     (lambda (so-far mode)
1605                                       (complete-from-possibilities
1606                                        so-far
1607                                        '(:fiveline :lyrics)
1608                                        '()
1609                                        :action mode
1610                                        :predicate (constantly t)
1611                                        :name-key #'symbol-name-lowcase
1612                                        :value-key #'identity)))
1613         (simple-completion-error () (error 'no-such-staff-type)))
1614     (declare (ignore string))
1615     (if success type (error 'no-such-staff-type))))
1616
1617 (define-presentation-type clef-type ())
1618
1619 (define-presentation-method accept
1620     ((type clef-type) stream (view textual-view) &key)
1621   (multiple-value-bind (type success string)
1622       (handler-case (complete-input stream
1623                                     (lambda (so-far mode)
1624                                       (complete-from-possibilities
1625                                        so-far
1626                                        '(:treble :treble8 :bass :c :percussion)
1627                                        '()
1628                                        :action mode
1629                                        :predicate (constantly t)
1630                                        :name-key #'symbol-name-lowcase
1631                                        :value-key #'identity)))
1632         (simple-completion-error () (error 'no-such-staff-type)))
1633     (declare (ignore string))
1634     (if success
1635         type
1636         (error "no such staff type"))))
1637
1638 (define-condition staff-name-not-unique (gsharp-condition) ()
1639   (:report
1640    (lambda (condition stream)
1641      (declare (ignore condition))
1642      (format stream "Staff name already exists"))))
1643
1644 (defun acquire-unique-staff-name (prompt)
1645   (let ((name (accept 'string :prompt prompt)))
1646     (assert (not (member name (staves (current-buffer)) :test #'string= :key #'name))
1647             () `staff-name-not-unique)
1648     name))
1649
1650 (defun acquire-new-staff ()
1651   (let ((name (acquire-unique-staff-name "Name of new staff")))
1652     (ecase (accept 'staff-type :prompt "Type")
1653       (:fiveline (let* ((clef-name (accept 'clef-type :prompt "Clef type of new staff"))
1654                         (line (accept 'integer :prompt "Line of clef"))
1655                         (clef (make-clef clef-name :lineno line)))
1656                    (make-fiveline-staff :name name :clef clef)))
1657       (:lyrics (make-lyrics-staff :name name)))))
1658
1659 (define-gsharp-command (com-insert-staff-above :name t) ()
1660   (add-staff-before-staff (accept 'score-pane:staff :prompt "Insert staff above staff")
1661                           (acquire-new-staff)
1662                           (current-buffer)))
1663
1664 (define-gsharp-command (com-insert-staff-below :name t) ()
1665   (add-staff-after-staff (accept 'score-pane:staff :prompt "Insert staff below staff")
1666                          (acquire-new-staff)
1667                          (current-buffer)))
1668
1669 (define-gsharp-command (com-delete-staff :name t) ()
1670   (remove-staff-from-buffer (accept 'score-pane:staff :prompt "Staff")
1671                             (current-buffer)))
1672
1673 (define-gsharp-command (com-rename-staff :name t) ()
1674   (let* ((staff (accept 'score-pane:staff :prompt "Rename staff"))
1675          (name (acquire-unique-staff-name "New name of staff"))
1676          (buffer (current-buffer)))
1677     (rename-staff name staff buffer)))
1678
1679 (define-gsharp-command (com-add-staff-to-layer :name t) ()
1680   (let ((staff (accept 'score-pane:staff :prompt "Add staff to layer"))
1681         (layer (layer (current-cursor))))
1682     (add-staff-to-layer staff layer)))
1683
1684 ;;; FIXME restrict to staves that are actually in the layer.
1685 (define-gsharp-command (com-delete-staff-from-layer :name t) ()
1686   (let ((staff (accept 'score-pane:staff :prompt "Delete staff from layer"))
1687         (layer (layer (current-cursor))))
1688     (remove-staff-from-layer staff layer)))
1689
1690 (define-gsharp-command com-more-sharps ()
1691   (more-sharps (keysig (current-cursor))))
1692
1693 (define-gsharp-command com-more-flats ()
1694   (more-flats (keysig (current-cursor))))
1695
1696 (define-presentation-to-command-translator jump-to-here
1697     (element gsharp::com-jump-to-here gsharp
1698                                      :gesture :select
1699                                      :documentation "Move cursor here")
1700     (presentation) (list (presentation-object presentation)))
1701
1702 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1703 ;;;
1704 ;;; Lyrics
1705
1706 (defun insert-lyrics-element ()
1707   (let* ((state (input-state *application-frame*))
1708          (cursor (current-cursor))
1709          (element (make-lyrics-element (car (staves (layer (current-cursor))))
1710                     :rbeams (if (eq (notehead state) :filled) (rbeams state) 0)
1711                     :lbeams (if (eq (notehead state) :filled) (lbeams state) 0)
1712                     :dots (dots state)
1713                     :notehead (notehead state))))
1714     (insert-element element cursor)
1715     (forward-element cursor)
1716     element))
1717
1718 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1719 ;;;
1720 ;;; I/O
1721
1722 (defmethod frame-make-buffer-from-stream ((frame gsharp) stream)
1723   (read-buffer-from-stream stream))
1724
1725 (defmethod frame-make-new-buffer ((frame gsharp) &key &allow-other-keys)
1726   (make-instance 'buffer))
1727
1728
1729 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1730 ;;;
1731 ;;; Buffer / View handling
1732
1733 ;;; FIXME: these utility functions should live elsewhere.
1734 (defun current-view ()
1735   (view (current-window)))
1736
1737 (defun not-current-view ()
1738   (find (current-view) (views *application-frame*) :test (complement #'eq)))
1739
1740 (defun not-current-view-or-first ()
1741   (or (not-current-view) (car (views *application-frame*))))
1742
1743 (defun next-or-new-buffer-view ()
1744   (or (not-current-view)
1745       (progn (com-new-buffer)
1746              (car (views *application-frame*)))))
1747
1748 (define-gsharp-command (com-switch-to-view :name t)
1749     ((view 'orchestra-view :default (not-current-view-or-first)))
1750   (setf (view (current-window)) view))
1751
1752 (define-gsharp-command (com-kill-view :name t)
1753     ((view 'orchestra-view :default (current-view)))
1754   (let ((views (views *application-frame*)))
1755     (setf (views *application-frame*) (remove view views))
1756     (when (eq view (current-view))
1757       (let ((next-view (next-or-new-buffer-view)))
1758         (setf (view (current-window)) next-view)))))
1759
1760 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1761 ;;;
1762 ;;; Printing
1763
1764 (defun print-buffer-filename ()
1765   (let* ((buffer (current-buffer))
1766          (filepath (filepath buffer))
1767          (name (name buffer))
1768          (defaults (or filepath (merge-pathnames (make-pathname :name name)
1769                                                  (user-homedir-pathname)))))
1770     (merge-pathnames (make-pathname :type "ps") defaults)))
1771
1772 (defparameter *scale* 0.8)
1773 (defparameter *top-margin* 100)
1774
1775 (define-gsharp-command (com-print-buffer-to-file :name t)
1776     ((filepath 'pathname
1777                :prompt "Print To: " :prompt-mode :raw
1778                :default (print-buffer-filename) :default-type 'pathname
1779                :insert-default t))
1780   (with-open-file (ps filepath :direction :output :if-exists :supersede)
1781     (let* ((type (pathname-type filepath))
1782            (epsp (string-equal type "EPS")))
1783       (with-output-to-postscript-stream (s ps :device-type (when epsp :eps))
1784         (setf (stream-default-view s)
1785               ;; FIXME: should probably get the class of the view from
1786               ;; the current buffer or window or something.
1787               (make-instance 'orchestra-view :light-glyphs-ink +black+
1788                              :buffer (current-buffer)
1789                              :cursor (current-cursor)))
1790         (setf (medium-transformation s)
1791               ;; FIXME: not a very flexible or intelligent scaling system
1792               (compose-scaling-with-transformation
1793                (medium-transformation s) *scale* *scale*))
1794         (print-buffer s (current-buffer) (current-cursor)
1795                       (left-margin (current-buffer)) *top-margin*)))))
1796
1797 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1798 ;;
1799 ;; File dialogue box
1800 ;;
1801
1802 (define-gsharp-command (com-load-score-file :name "Load file" :menu t)
1803     ()
1804   (let ((file (gui-get-pathname :extensions '("gsh" "mxml" "xml"))))
1805     (when (pathnamep file)
1806       (com-find-file file))))
1807
1808 (define-gsharp-command (com-save-score-file-as :name "Save file as" :menu t)
1809     ()
1810   (com-write-buffer (gui-get-pathname :extensions '("gsh" "mxml" "xml"))))
1811
1812 (define-gsharp-command (com-zoom-in :name t :menu t)
1813     ()
1814   (unless (<= (gsharp-buffer::zoom-level (buffer (current-cursor))) 64)
1815     (incf (gsharp-buffer::zoom-level (buffer (current-cursor))) 1/4)))
1816 (define-gsharp-command (com-zoom-out :name t :menu t)
1817     ()
1818   (unless (<= (gsharp-buffer::zoom-level (buffer (current-cursor))) 1/4)
1819     (decf (gsharp-buffer::zoom-level (buffer (current-cursor))) 1/4)))
1820
1821 (define-command (com-undo :name t :command-table gsharp) ()
1822   (handler-case (drei::undo (drei::undo-tree (current-buffer)))
1823     (drei-undo:no-more-undo () (beep) (display-message "No more undo"))))
1824 (define-command (com-redo :name t :command-table gsharp) ()
1825   (handler-case (drei::redo (drei::undo-tree (current-buffer)))
1826     (drei-undo:no-more-undo () (beep) (display-message "No more redo"))))