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