gui.lisp

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