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 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-clef (clef)
1084   (let ((cursor (current-cursor)))
1085     (gsharp-measure::invalidate-everything-using-staff (current-buffer) (staff clef))
1086     (insert-element clef cursor)
1087     (forward-element cursor)
1088     clef))
1089
1090 (defun insert-timesig (numerator denominator)
1091   (let* ((cursor (current-cursor))
1092          (staff (car (staves (layer cursor))))
1093          (timesig (make-time-signature :staff staff
1094                                        :components
1095                                        (list (if denominator
1096                                                  (cons numerator denominator)
1097                                                  numerator)))))
1098     (insert-element timesig cursor)
1099     (forward-element cursor)
1100     timesig))
1101
1102 (define-gsharp-command (com-insert-timesig :name t)
1103     ((numerator '(integer 1 8) :prompt "Numerator")
1104      (denominator '(integer 1 8) :prompt "Denominator"))
1105   (insert-timesig numerator denominator))
1106
1107 (define-gsharp-command (com-insert-clef :name t) ()
1108   (let* ((type (accept 'clef-type :prompt "Type of clef"))
1109          (line (accept 'integer :prompt "Line of clef"))
1110          (clef (make-clef type :lineno line)))
1111     (setf (slot-value clef 'gsharp-buffer::%staff) (car (staves (layer (current-cursor)))))
1112     (insert-clef clef)))
1113
1114 (defmethod remove-element :before ((element staffwise-element) (bar bar))
1115   (let ((staff (staff element)))
1116     (setf (staffwise-elements staff)
1117           (remove element (staffwise-elements staff)))
1118     (gsharp-measure::invalidate-everything-using-staff (current-buffer) staff)))
1119
1120 ;;; FIXME: this isn't quite right (argh) for the case of two
1121 ;;; temporally coincident zero-duration elements on the same staff in
1122 ;;; different layers: essentially all bets are off.
1123 (defun starts-before-p (thing bar element-or-nil)
1124   ;; does THING start before the temporal position denoted by BAR and
1125   ;; ELEMENT-OR-NIL?
1126   (assert (or (null element-or-nil) (eq (bar element-or-nil) bar)))
1127   (when (null (bar thing))
1128     ;; THING is probably the key signature at the start of the piece,
1129     ;; in which case it is definitely before whatever else happens.
1130     (assert (typep thing 'key-signature))
1131     (return-from starts-before-p t))
1132   (let ((barno (number bar)))
1133     (cond
1134       ((> (number (bar thing)) barno) nil)
1135       ((< (number (bar thing)) barno) t)
1136       (t (let ((thing-start-time (loop for e in (elements (bar thing))
1137                                        if (eq e element-or-nil)
1138                                        do (return-from starts-before-p nil)
1139                                        until (eq e thing) sum (duration e)))
1140                (element-start-time
1141                 ;; this is actually the right answer for
1142                 ;; ELEMENT-OR-NIL = NIL, which means "end of bar"
1143                 (loop for e in (elements bar)
1144                       if (eq e thing) do (return-from starts-before-p t)
1145                       until (eq e element-or-nil) sum (duration e))))
1146            (or (> element-start-time thing-start-time)
1147                (and (= element-start-time thing-start-time)
1148                     (or (null element-or-nil)
1149                         (> (duration element-or-nil) 0)))))))))
1150
1151 (defun %keysig (staff key-signatures bar element-or-nil)
1152   (or (and key-signatures
1153            (find-if (lambda (x) (starts-before-p x bar element-or-nil))
1154                     key-signatures :from-end t))
1155       (keysig staff)))
1156
1157 (defmethod keysig ((cursor gsharp-cursor))
1158   ;; FIXME: not just a cursor but _the_ cursor (i.e. in a given staff)
1159   ;; otherwise the operation for getting the staff [(CAR (STAVES
1160   ;; (LAYER CURSOR)))] need not return the staff that we're interested
1161   ;; in.
1162   (assert (eq cursor (current-cursor)))
1163   (let* ((staff (car (staves (layer cursor))))
1164          (key-signatures (key-signatures staff))
1165          (bar (bar cursor))
1166          (element-or-nil (cursor-element cursor)))
1167     (%keysig staff key-signatures bar element-or-nil)))
1168
1169 (defmethod keysig ((note note))
1170   (let* ((staff (staff note))
1171          (key-signatures (key-signatures staff))
1172          (bar (bar (cluster note)))
1173          (element-or-nil (cluster note)))
1174     (%keysig staff key-signatures bar element-or-nil)))
1175
1176 (defmethod keysig ((cluster cluster))
1177   (error "Called ~S (a staff-scope operation) on an element with no ~
1178           associated staff: ~S"
1179          'keysig cluster))
1180
1181 (defmethod keysig ((element element))
1182   (let* ((staff (staff element))
1183          (key-signatures (key-signatures staff))
1184          (bar (bar element)))
1185     (%keysig staff key-signatures bar element)))
1186
1187 ;; These are copied from the keysig equivalents, which seem to work...
1188 (defun %clef (staff clefs bar element-or-nil)
1189   (or (and clefs
1190            (find-if (lambda (x) (starts-before-p x bar element-or-nil))
1191                     clefs :from-end t))
1192       (clef staff)))
1193
1194 (defmethod clef ((cursor gsharp-cursor))
1195   (assert (eq cursor (current-cursor)))
1196   (let* ((staff (car (staves (layer cursor))))
1197          (clefs (clefs staff))
1198          (bar (bar cursor))
1199          (element-or-nil (cursor-element cursor)))
1200     (%clef staff clefs bar element-or-nil)))
1201
1202 (defmethod clef ((note note))
1203   (let* ((staff (staff note))
1204          (clefs (clefs staff))
1205          (bar (bar (cluster note)))
1206          (element-or-nil (cluster note)))
1207     (%clef staff clefs bar element-or-nil)))
1208
1209 (defmethod clef ((cluster cluster))
1210   (error "Called ~S (a staff-scope operation) on an element with no ~
1211           associated staff: ~S"
1212          'clef cluster))
1213
1214 (defmethod clef ((element element))
1215   ;; Obviously, only works for elemnts with a staff (i.e. not a
1216   ;; cluster
1217   (let* ((staff (staff element))
1218          (clefs (clefs staff))
1219          (bar (bar element)))
1220     (%clef staff clefs bar element)))
1221
1222 (define-gsharp-command com-tie-note-left ()
1223   (let ((note (cur-note)))
1224     (when note
1225       (setf (tie-left note) t))))
1226
1227 (define-gsharp-command com-untie-note-left ()
1228   (let ((note (cur-note)))
1229     (when note
1230       (setf (tie-left note) nil))))
1231
1232 (define-gsharp-command com-tie-note-right ()
1233   (let ((note (cur-note)))
1234     (when note
1235       (setf (tie-right note) t))))
1236
1237 (define-gsharp-command com-untie-note-right ()
1238   (let ((note (cur-note)))
1239     (when note
1240       (setf (tie-right note) nil))))
1241
1242 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1243 ;;;
1244 ;;; motion by element
1245
1246 (define-gsharp-command com-forward-element
1247     ((count 'integer :prompt "Number of Elements" :default 1))
1248   "Move forward by element."
1249   (loop repeat count
1250         do (forward-element (current-cursor))))
1251
1252 (define-gsharp-command com-backward-element
1253     ((count 'integer :prompt "Number of Elements" :default 1))
1254   "Move backward by element."
1255   (loop repeat count
1256         do (backward-element (current-cursor))))
1257
1258 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1259 ;;;
1260 ;;; motion by measure
1261
1262 (define-gsharp-command com-forward-measure
1263     ((count 'integer :prompt "Number of Measures" :default 1))
1264   "Move forward by measure."
1265   (loop repeat count do (forward-bar (current-cursor))))
1266
1267 (define-gsharp-command com-backward-measure
1268     ((count 'integer :prompt "Number of Measures" :default 1))
1269   "Move backward by measure."
1270   (loop repeat count do (backward-bar (current-cursor))))
1271
1272 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1273 ;;;
1274 ;;; motion by entire score
1275
1276 (define-gsharp-command com-end-of-score ()
1277   (loop until (last-segment-p (current-cursor))
1278         do (forward-segment (current-cursor)))
1279   (loop until (last-bar-p (current-cursor))
1280         do (forward-bar (current-cursor)))
1281   (loop until (end-of-bar-p (current-cursor))
1282         do (forward-element (current-cursor))))
1283
1284 (define-gsharp-command com-beginning-of-score ()
1285   (loop until (first-segment-p (current-cursor))
1286         do (backward-segment (current-cursor)))
1287   (loop until (first-bar-p (current-cursor))
1288         do (backward-bar (current-cursor)))
1289   (loop until (beginning-of-bar-p (current-cursor))
1290         do (backward-element (current-cursor))))
1291
1292 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1293 ;;;
1294 ;;; motion by layout (page or line)
1295
1296 ;;; support routines, needed because we're not cacheing the page
1297 ;;; breaks (other than in the buffer Obseq) nor the linebreaks (at
1298 ;;; all)
1299 (defun position-containing-current-bar (sequence)
1300   (let ((bar (bar (current-cursor))))
1301     (position-if (lambda (measure) (member bar (measure-bars measure)))
1302                  sequence)))
1303 (defun get-page-lines (buffer page-measures)
1304   (score-pane:with-staff-size (gsharp-buffer::rastral-size buffer)
1305     (let* (;; all this untimely ripp'd from DRAW-BUFFER in
1306            ;; drawing.lisp.  Needs to be kept in sync, otherwise the
1307            ;; layout for motion will be different from the layout on
1308            ;; the screen...
1309            (staves (staves buffer))
1310            (timesig-offset (gsharp-drawing::compute-timesig-offset staves page-measures))
1311            (method (let ((old-method (buffer-cost-method buffer)))
1312                      (make-measure-cost-method (min-width old-method)
1313                                                (spacing-style old-method)
1314                                                (- (line-width old-method) timesig-offset)
1315                                                (lines-per-page old-method))))
1316            (systems-per-page (gsharp-measure::systems-per-page buffer)))
1317       (gsharp-drawing::layout-page page-measures systems-per-page method))))
1318
1319 ;;; FIXME: these routines should implement numeric-argument handling
1320 (define-gsharp-command (com-forward-page :name t)
1321     ()
1322   (let ((cursor (current-cursor)))
1323     (gsharp-measure::new-map-over-obseq-subsequences
1324      (lambda (page-measures)
1325        (let ((position (position-containing-current-bar page-measures)))
1326          (when position
1327            (loop repeat (- (length page-measures) position)
1328                  if (last-bar-p cursor)
1329                  do (go-to-end-of-bar cursor) (return-from com-forward-page)
1330                  else do (forward-bar cursor)
1331                  finally (return-from com-forward-page)))))
1332      (current-buffer))))
1333 (define-gsharp-command (com-backward-page :name t)
1334     ()
1335   (let ((cursor (current-cursor)))
1336     (gsharp-measure::new-map-over-obseq-subsequences
1337      (let ((last 0))
1338        (lambda (page-measures)
1339          (let ((position (position-containing-current-bar page-measures)))
1340            (when position
1341              (loop repeat (+ position last)
1342                    do (backward-bar cursor)
1343                    finally (progn
1344                              (go-to-beginning-of-bar cursor)
1345                              (return-from com-backward-page)))))
1346          (setf last (length page-measures))))
1347      (current-buffer))))
1348
1349 (define-gsharp-command (com-end-of-line :name t)
1350     ()
1351   (let ((buffer (current-buffer))
1352         (cursor (current-cursor)))
1353     (gsharp-measure::new-map-over-obseq-subsequences
1354      (lambda (page-measures)
1355        (when (position-containing-current-bar page-measures)
1356          (let ((lines (get-page-lines buffer page-measures)))
1357            (dolist (line lines)
1358              (let ((position (position-containing-current-bar line)))
1359                (when position
1360                  (loop repeat (- (length line) position 1)
1361                        do (forward-bar cursor)
1362                        finally (progn
1363                                  (go-to-end-of-bar cursor)
1364                                  (return-from com-end-of-line)))))))))
1365      buffer)))
1366 (define-gsharp-command (com-beginning-of-line :name t)
1367     ()
1368   (let ((buffer (current-buffer))
1369         (cursor (current-cursor)))
1370     (gsharp-measure::new-map-over-obseq-subsequences
1371      (lambda (page-measures)
1372        (when (position-containing-current-bar page-measures)
1373          (let ((lines (get-page-lines buffer page-measures)))
1374            (dolist (line lines)
1375              (let ((position (position-containing-current-bar line)))
1376                (when position
1377                  (loop repeat position
1378                        do (backward-bar cursor)
1379                        finally (progn
1380                                  (go-to-beginning-of-bar cursor)
1381                                  (return-from com-beginning-of-line)))))))))
1382      buffer)))
1383
1384 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1385 ;;;
1386 ;;; selecting layers based on layout (next/previous staff)
1387
1388 ;;; FIXME: numeric argument handling again
1389 (define-gsharp-command (com-previous-staff :name t)
1390     ()
1391   (let ((staff (car (staves (layer (current-cursor))))))
1392     (loop for (prev curr) on (staves (current-buffer))
1393           if (eq curr staff)
1394           do (let ((layers (layers (segment (current-cursor)))))
1395                (dolist (layer layers)
1396                  (when (member prev (staves layer))
1397                    (select-layer (current-cursor) layer)
1398                    (do ()
1399                        ((eq prev (car (staves layer))))
1400                      (com-rotate-staves))
1401                    (return-from com-previous-staff)))))))
1402 (define-gsharp-command (com-next-staff :name t)
1403     ()
1404   (let ((staff (car (staves (layer (current-cursor))))))
1405     (loop for (curr next) on (staves (current-buffer))
1406           if (eq curr staff)
1407           do (let ((layers (layers (segment (current-cursor)))))
1408                (dolist (layer layers)
1409                  (when (member next (staves layer))
1410                    (select-layer (current-cursor) layer)
1411                    (do ()
1412                        ((eq next (car (staves layer))))
1413                      (com-rotate-staves))
1414                    (return-from com-next-staff)))))))
1415
1416 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1417 ;;;
1418 ;;; delete commands
1419
1420 (defun go-to-beginning-of-bar (cursor)
1421   (loop until (beginning-of-bar-p cursor)
1422         do (backward-element cursor)))
1423
1424 (defun go-to-end-of-bar (cursor)
1425   (loop until (end-of-bar-p cursor)
1426         do (forward-element cursor)))
1427
1428 ;;; assume cursor is at the end of the bar
1429 (defun fuse-bar-with-next (cursor)
1430   (go-to-beginning-of-bar cursor)
1431   (let ((elements '()))
1432     (loop until (end-of-bar-p cursor) do
1433           (push (cursor-element cursor) elements)
1434           (delete-element cursor))
1435     (delete-bar cursor)
1436     (loop for element in (nreverse elements) do
1437           (insert-element element cursor)
1438           (forward-element cursor))))
1439
1440 (define-gsharp-command com-delete-element
1441     ((count 'integer :prompt "Number of Elements" :default 1))
1442   "Delete element forwards."
1443   (let ((cursor (current-cursor)))
1444     (loop repeat count
1445           do (progn
1446                ;; this will signal a condition if in last bar and
1447                ;; interrupt the execution of the command
1448                (forward-element cursor)
1449                (backward-element cursor)
1450                (if (end-of-bar-p cursor)
1451                    (fuse-bar-with-next cursor)
1452                    (delete-element cursor))))))
1453
1454 (define-gsharp-command com-erase-element
1455     ((count 'integer :prompt "Number of Elements" :default 1))
1456   "Delete element backwards."
1457   (let ((cursor (current-cursor)))
1458     (loop repeat count
1459           do (progn
1460                (backward-element cursor)
1461                (if (end-of-bar-p cursor)
1462                    (fuse-bar-with-next cursor)
1463                    (delete-element cursor))))))
1464
1465 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1466 ;;;
1467 ;;; Input State Settings
1468
1469 (define-gsharp-command com-istate-more-dots ()
1470   (setf (dots (input-state *application-frame*))
1471         (min (1+ (dots (input-state *application-frame*))) 3)))
1472
1473 (define-gsharp-command com-istate-fewer-dots ()
1474   (setf (dots (input-state *application-frame*))
1475         (max (1- (dots (input-state *application-frame*))) 0)))
1476
1477 (define-gsharp-command com-istate-more-rbeams ()
1478   (setf (rbeams (input-state *application-frame*))
1479         (min (1+ (rbeams (input-state *application-frame*))) 3)))
1480
1481 (define-gsharp-command com-istate-fewer-lbeams ()
1482   (setf (lbeams (input-state *application-frame*))
1483         (max (1- (lbeams (input-state *application-frame*))) 0)))
1484
1485 (define-gsharp-command com-istate-more-lbeams ()
1486   (setf (lbeams (input-state *application-frame*))
1487         (min (1+ (lbeams (input-state *application-frame*))) 3)))
1488
1489 (define-gsharp-command com-istate-fewer-rbeams ()
1490   (setf (rbeams (input-state *application-frame*))
1491         (max (1- (rbeams (input-state *application-frame*))) 0)))
1492
1493 (define-gsharp-command com-istate-rotate-notehead ()
1494   (setf (notehead (input-state *application-frame*))
1495         (ecase (notehead (input-state *application-frame*))
1496           (:breve :long)
1497           (:whole :breve)
1498           (:half :whole)
1499           (:filled :half)
1500           (:long :filled))))
1501
1502 (define-gsharp-command com-istate-rotate-notehead-downwards ()
1503   (setf (notehead (input-state *application-frame*))
1504         (ecase (notehead (input-state *application-frame*))
1505           (:long :breve)
1506           (:breve :whole)
1507           (:whole :half)
1508           (:half :filled)
1509           (:filled :long))))
1510
1511 (define-gsharp-command com-istate-rotate-stem-direction ()
1512   (setf (stem-direction (input-state *application-frame*))
1513         (ecase (stem-direction (input-state *application-frame*))
1514           (:auto :up)
1515           (:up :down)
1516           (:down :auto))))
1517
1518 (define-gsharp-command (com-set-clef :name t) ()
1519   (let ((staff (accept 'score-pane:fiveline-staff :prompt "Set clef of staff"))
1520         (type (accept 'clef-type :prompt "Type of clef"))
1521         (line (accept 'integer :prompt "Line of clef")))
1522     (setf (clef staff) (make-clef type :lineno line))))
1523
1524 (define-gsharp-command com-higher ()
1525   (incf (last-note (input-state *application-frame*)) 7))
1526
1527 (define-gsharp-command com-lower ()
1528   (decf (last-note (input-state *application-frame*)) 7))
1529
1530 (define-gsharp-command com-insert-barline ()
1531   (let ((cursor (current-cursor))
1532         (elements '()))
1533     (loop until (end-of-bar-p cursor)
1534           do (push (cursor-element cursor) elements)
1535           do (delete-element cursor))
1536     (insert-bar-after (make-instance (class-of (bar cursor))) cursor)
1537     (forward-bar cursor)
1538     (loop for element in elements
1539           do (insert-element element cursor))))
1540
1541 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1542 ;;;
1543 ;;; Adding, deleting, and modifying staves
1544
1545 (define-condition no-such-staff (gsharp-condition) ()
1546   (:report
1547    (lambda (condition stream)
1548      (declare (ignore condition))
1549      (format stream "No such staff"))))
1550
1551 (define-presentation-method accept
1552     ((type score-pane:staff) stream (view textual-view) &key)
1553   (multiple-value-bind (staff success string)
1554       (handler-case (complete-input stream
1555                                     (lambda (so-far mode)
1556                                       (complete-from-possibilities
1557                                        so-far
1558                                        (staves (current-buffer))
1559                                        '()
1560                                        :action mode
1561                                        :predicate (constantly t)
1562                                        :name-key #'name
1563                                        :value-key #'identity)))
1564         (simple-parse-error () (error 'no-such-staff)))
1565     (declare (ignore string))
1566     (if success staff (error 'no-such-staff))))
1567
1568 (define-presentation-method accept
1569     ((type score-pane:fiveline-staff) stream (view textual-view) &key)
1570   (multiple-value-bind (staff success string)
1571       (handler-case (complete-input stream
1572                                     (lambda (so-far mode)
1573                                       (complete-from-possibilities
1574                                        so-far
1575                                        (staves (current-buffer))
1576                                        '()
1577                                        :action mode
1578                                        :predicate (lambda (obj) (typep obj 'fiveline-staff))
1579                                        :name-key #'name
1580                                        :value-key #'identity)))
1581         (simple-parse-error () (error 'no-such-staff)))
1582     (declare (ignore string))
1583     (if success staff (error 'no-such-staff))))
1584
1585 (defun symbol-name-lowcase (symbol)
1586   (string-downcase (symbol-name symbol)))
1587
1588 (define-presentation-type staff-type ())
1589
1590 (define-condition no-such-staff-type (gsharp-condition) ()
1591   (:report
1592    (lambda (condition stream)
1593      (declare (ignore condition))
1594      (format stream "No such staff type"))))
1595
1596 (define-presentation-method accept
1597     ((type staff-type) stream (view textual-view) &key)
1598   (multiple-value-bind (type success string)
1599       (handler-case (complete-input stream
1600                                     (lambda (so-far mode)
1601                                       (complete-from-possibilities
1602                                        so-far
1603                                        '(:fiveline :lyrics)
1604                                        '()
1605                                        :action mode
1606                                        :predicate (constantly t)
1607                                        :name-key #'symbol-name-lowcase
1608                                        :value-key #'identity)))
1609         (simple-completion-error () (error 'no-such-staff-type)))
1610     (declare (ignore string))
1611     (if success type (error 'no-such-staff-type))))
1612
1613 (define-presentation-type clef-type ())
1614
1615 (define-presentation-method accept
1616     ((type clef-type) stream (view textual-view) &key)
1617   (multiple-value-bind (type success string)
1618       (handler-case (complete-input stream
1619                                     (lambda (so-far mode)
1620                                       (complete-from-possibilities
1621                                        so-far
1622                                        '(:treble :treble8 :bass :c :percussion)
1623                                        '()
1624                                        :action mode
1625                                        :predicate (constantly t)
1626                                        :name-key #'symbol-name-lowcase
1627                                        :value-key #'identity)))
1628         (simple-completion-error () (error 'no-such-staff-type)))
1629     (declare (ignore string))
1630     (if success
1631         type
1632         (error "no such staff type"))))
1633
1634 (define-condition staff-name-not-unique (gsharp-condition) ()
1635   (:report
1636    (lambda (condition stream)
1637      (declare (ignore condition))
1638      (format stream "Staff name already exists"))))
1639
1640 (defun acquire-unique-staff-name (prompt)
1641   (let ((name (accept 'string :prompt prompt)))
1642     (assert (not (member name (staves (current-buffer)) :test #'string= :key #'name))
1643             () `staff-name-not-unique)
1644     name))
1645
1646 (defun acquire-new-staff ()
1647   (let ((name (acquire-unique-staff-name "Name of new staff")))
1648     (ecase (accept 'staff-type :prompt "Type")
1649       (:fiveline (let* ((clef-name (accept 'clef-type :prompt "Clef type of new staff"))
1650                         (line (accept 'integer :prompt "Line of clef"))
1651                         (clef (make-clef clef-name :lineno line)))
1652                    (make-fiveline-staff :name name :clef clef)))
1653       (:lyrics (make-lyrics-staff :name name)))))
1654
1655 (define-gsharp-command (com-insert-staff-above :name t) ()
1656   (add-staff-before-staff (accept 'score-pane:staff :prompt "Insert staff above staff")
1657                           (acquire-new-staff)
1658                           (current-buffer)))
1659
1660 (define-gsharp-command (com-insert-staff-below :name t) ()
1661   (add-staff-after-staff (accept 'score-pane:staff :prompt "Insert staff below staff")
1662                          (acquire-new-staff)
1663                          (current-buffer)))
1664
1665 (define-gsharp-command (com-delete-staff :name t) ()
1666   (remove-staff-from-buffer (accept 'score-pane:staff :prompt "Staff")
1667                             (current-buffer)))
1668
1669 (define-gsharp-command (com-rename-staff :name t) ()
1670   (let* ((staff (accept 'score-pane:staff :prompt "Rename staff"))
1671          (name (acquire-unique-staff-name "New name of staff"))
1672          (buffer (current-buffer)))
1673     (rename-staff name staff buffer)))
1674
1675 (define-gsharp-command (com-add-staff-to-layer :name t) ()
1676   (let ((staff (accept 'score-pane:staff :prompt "Add staff to layer"))
1677         (layer (layer (current-cursor))))
1678     (add-staff-to-layer staff layer)))
1679
1680 ;;; FIXME restrict to staves that are actually in the layer.
1681 (define-gsharp-command (com-delete-staff-from-layer :name t) ()
1682   (let ((staff (accept 'score-pane:staff :prompt "Delete staff from layer"))
1683         (layer (layer (current-cursor))))
1684     (remove-staff-from-layer staff layer)))
1685
1686 (define-gsharp-command com-more-sharps ()
1687   (more-sharps (keysig (current-cursor))))
1688
1689 (define-gsharp-command com-more-flats ()
1690   (more-flats (keysig (current-cursor))))
1691
1692 (define-presentation-to-command-translator jump-to-here
1693     (element gsharp::com-jump-to-here gsharp
1694                                      :gesture :select
1695                                      :documentation "Move cursor here")
1696     (presentation) (list (presentation-object presentation)))
1697
1698 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1699 ;;;
1700 ;;; Lyrics
1701
1702 (defun insert-lyrics-element ()
1703   (let* ((state (input-state *application-frame*))
1704          (cursor (current-cursor))
1705          (element (make-lyrics-element (car (staves (layer (current-cursor))))
1706                     :rbeams (if (eq (notehead state) :filled) (rbeams state) 0)
1707                     :lbeams (if (eq (notehead state) :filled) (lbeams state) 0)
1708                     :dots (dots state)
1709                     :notehead (notehead state))))
1710     (insert-element element cursor)
1711     (forward-element cursor)
1712     element))
1713
1714 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1715 ;;;
1716 ;;; I/O
1717
1718 (defmethod frame-make-buffer-from-stream ((frame gsharp) stream)
1719   (read-buffer-from-stream stream))
1720
1721 (defmethod frame-make-new-buffer ((frame gsharp) &key &allow-other-keys)
1722   (make-instance 'buffer))
1723
1724
1725 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1726 ;;;
1727 ;;; Buffer / View handling
1728
1729 ;;; FIXME: these utility functions should live elsewhere.
1730 (defun current-view ()
1731   (view (current-window)))
1732
1733 (defun not-current-view ()
1734   (find (current-view) (views *application-frame*) :test (complement #'eq)))
1735
1736 (defun not-current-view-or-first ()
1737   (or (not-current-view) (car (views *application-frame*))))
1738
1739 (defun next-or-new-buffer-view ()
1740   (or (not-current-view)
1741       (progn (com-new-buffer)
1742              (car (views *application-frame*)))))
1743
1744 (define-gsharp-command (com-switch-to-view :name t)
1745     ((view 'orchestra-view :default (not-current-view-or-first)))
1746   (setf (view (current-window)) view))
1747
1748 (define-gsharp-command (com-kill-view :name t)
1749     ((view 'orchestra-view :default (current-view)))
1750   (let ((views (views *application-frame*)))
1751     (setf (views *application-frame*) (remove view views))
1752     (when (eq view (current-view))
1753       (let ((next-view (next-or-new-buffer-view)))
1754         (setf (view (current-window)) next-view)))))
1755
1756 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1757 ;;;
1758 ;;; Printing
1759
1760 (defun print-buffer-filename ()
1761   (let* ((buffer (current-buffer))
1762          (filepath (filepath buffer))
1763          (name (name buffer))
1764          (defaults (or filepath (merge-pathnames (make-pathname :name name)
1765                                                  (user-homedir-pathname)))))
1766     (merge-pathnames (make-pathname :type "ps") defaults)))
1767
1768 (defparameter *scale* 0.8)
1769 (defparameter *top-margin* 100)
1770
1771 (define-gsharp-command (com-print-buffer-to-file :name t)
1772     ((filepath 'pathname
1773                :prompt "Print To: " :prompt-mode :raw
1774                :default (print-buffer-filename) :default-type 'pathname
1775                :insert-default t))
1776   (with-open-file (ps filepath :direction :output :if-exists :supersede)
1777     (let* ((type (pathname-type filepath))
1778            (epsp (string-equal type "EPS")))
1779       (with-output-to-postscript-stream (s ps :device-type (when epsp :eps))
1780         (setf (stream-default-view s)
1781               ;; FIXME: should probably get the class of the view from
1782               ;; the current buffer or window or something.
1783               (make-instance 'orchestra-view :light-glyphs-ink +black+
1784                              :buffer (current-buffer)
1785                              :cursor (current-cursor)))
1786         (setf (medium-transformation s)
1787               ;; FIXME: not a very flexible or intelligent scaling system
1788               (compose-scaling-with-transformation
1789                (medium-transformation s) *scale* *scale*))
1790         (print-buffer s (current-buffer) (current-cursor)
1791                       (left-margin (current-buffer)) *top-margin*)))))
1792
1793 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1794 ;;
1795 ;; File dialogue box
1796 ;;
1797
1798 (define-gsharp-command (com-load-score-file :name "Load file" :menu t)
1799     ()
1800   (let ((file (gui-get-pathname :extensions '("gsh" "mxml" "xml"))))
1801     (when (pathnamep file)
1802       (com-find-file file))))
1803
1804 (define-gsharp-command (com-save-score-file-as :name "Save file as" :menu t)
1805     ()
1806   (com-write-buffer (gui-get-pathname :extensions '("gsh" "mxml" "xml"))))
1807
1808 (define-gsharp-command (com-zoom-in :name t :menu t)
1809     ()
1810   (unless (<= (gsharp-buffer::zoom-level (buffer (current-cursor))) 64)
1811     (incf (gsharp-buffer::zoom-level (buffer (current-cursor))) 1/4)))
1812 (define-gsharp-command (com-zoom-out :name t :menu t)
1813     ()
1814   (unless (<= (gsharp-buffer::zoom-level (buffer (current-cursor))) 1/4)
1815     (decf (gsharp-buffer::zoom-level (buffer (current-cursor))) 1/4)))