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