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