score-pane.lisp

   1 (in-package :score-pane)
   2 (defparameter *inactive-colour* +black+) ;; +gray50+
   3 (defclass score-view (view)
   4   ((light-glyphs-ink :initform *inactive-colour* :initarg :light-glyphs-ink :accessor light-glyphs-ink)
   5    (%number-of-pages :initform "-" :accessor number-of-pages)
   6    (%current-page-number :initform "-" :accessor current-page-number)))
   7
   8 (defclass score-pane (esa-pane-mixin application-pane) ())
   9
  10 (defmethod initialize-instance :after ((pane score-pane) &rest args)
  11   (declare (ignore args))
  12   (setf (stream-default-view pane) (make-instance 'score-view)))
  13
  14 (defparameter *font* nil)
  15 (defparameter *fonts* (make-array 100 :initial-element nil))
  16
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 ;;;
  19 ;;; output recording
  20
  21 (defclass score-output-record (displayed-output-record)
  22   ((parent :initarg :parent :initform nil :accessor output-record-parent)
  23    (x :initarg :x1 :initarg :x-position)
  24    (y :initarg :y1 :initarg :y-position)
  25    (width)
  26    (height)
  27    (ink :initarg :ink :reader displayed-output-record-ink)))
  28
  29 (defmethod initialize-instance :after ((record score-output-record)
  30                                        &key x2 y2 size)
  31   (declare (ignore size))
  32   (with-slots (x y width height) record
  33     (setf width (abs (- x2 x))
  34           height (abs (- y2 y)))))
  35
  36 (defmethod bounding-rectangle* ((record score-output-record))
  37   (with-slots (x y width height) record
  38     (values x y (+ x width) (+ y height))))
  39
  40 (defmethod output-record-position ((record score-output-record))
  41   (with-slots (x y) record
  42     (values x y)))
  43
  44 (defmethod (setf output-record-position) (new-x new-y (record score-output-record))
  45   (with-slots (x y) record
  46     (setf x new-x y new-y)))
  47
  48 (defmethod output-record-start-cursor-position ((record score-output-record))
  49   (values nil nil))
  50
  51 (defmethod (setf output-record-start-cursor-position) (x y (record score-output-record))
  52   (declare (ignore x y))
  53   nil)
  54
  55 (defmethod output-record-end-cursor-position ((record score-output-record))
  56   (values nil nil))
  57
  58 (defmethod (setf output-record-end-cursor-position) (x y (record score-output-record))
  59   (declare (ignore x y))
  60   nil)
  61
  62 (defmethod output-record-hit-detection-rectangle* ((record score-output-record))
  63   (bounding-rectangle* record))
  64
  65 (defmethod output-record-refined-position-test  ((record score-output-record) x y)
  66   (declare (ignore x y))
  67   t)
  68
  69 ;;; remove this when McCLIM is fixed
  70 (defmethod region-intersects-region-p (region (record score-output-record))
  71   (with-bounding-rectangle* (x1 y1 x2 y2) record
  72     (region-intersects-region-p region (make-rectangle* x1 y1 x2 y2))))
  73
  74 ;;;;;;;;;;;;;;;;;; pixmap drawing
  75
  76 (climi::def-grecording draw-pixmap (() pixmap pm-x pm-y) ()
  77   (climi::with-transformed-position ((medium-transformation medium) pm-x pm-y)
  78     (setf (slot-value climi::graphic 'pm-x) pm-x
  79           (slot-value climi::graphic 'pm-y) pm-y)
  80     (values pm-x pm-y (+ pm-x (pixmap-width pixmap)) (+ pm-y (pixmap-height pixmap)))))
  81
  82 (climi::def-graphic-op draw-pixmap (pixmap pm-x pm-y))
  83
  84 (defmethod medium-draw-pixmap* ((medium clim:medium) pixmap pm-x pm-y)
  85   (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap)
  86                     medium pm-x pm-y))
  87
  88 (climi::defmethod* (setf output-record-position) :around
  89     (nx ny (record draw-pixmap-output-record))
  90     (climi::with-standard-rectangle* (:x1 x1 :y1 y1)
  91         record
  92       (with-slots (pm-x pm-y)
  93           record
  94         (let ((dx (- nx x1))
  95               (dy (- ny y1)))
  96           (multiple-value-prog1
  97               (call-next-method)
  98             (incf pm-x dx)
  99             (incf pm-y dy))))))
 100
 101 (climi::defrecord-predicate draw-pixmap-output-record (pm-x pm-y)
 102   (and (climi::if-supplied (pm-x coordinate)
 103          (climi::coordinate= (slot-value climi::record 'pm-x) pm-x))
 104        (climi::if-supplied (pm-y coordinate)
 105          (climi::coordinate= (slot-value climi::record 'pm-y) pm-y))))
 106
 107 (defun draw-pixmap* (sheet pixmap x y
 108                            &rest args
 109                            &key clipping-region transformation)
 110   (declare (ignore clipping-region transformation))
 111   (climi::with-medium-options (sheet args)
 112     (medium-draw-pixmap* medium pixmap x y)))
 113
 114 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 115 ;;;
 116 ;;; drawing functions
 117
 118 ;;; A staff step is half of the distance between two staff lines.
 119 ;;; Given a staff-step value, determine the corresponding number of
 120 ;;; pixels in the current font.  The sign of the value returned is
 121 ;;; the same as that of the argument.
 122 ;;; But is that reasonable?  It seems more logical to have it return
 123 ;;; the opposite sign, so that the result from staff-step is always
 124 ;;; added to some y coordinate.
 125 (defun staff-step (n)
 126   (* n (/ (staff-line-distance *font*) 2)))
 127
 128 ;;;;;;;;;;;;;;;;;; notehead
 129
 130 (define-presentation-type notehead () :options (name x staff-step))
 131
 132 (defun draw-notehead (stream name x staff-step)
 133   (sdl::draw-shape stream *font*
 134                    (ecase name
 135                      ((:breve :long) :breve-notehead)
 136                      (:whole :whole-notehead)
 137                      (:half :half-notehead)
 138                      (:filled :filled-notehead))
 139                    x (staff-step (- staff-step))))
 140
 141 (define-presentation-method present
 142     (object (type notehead) stream (view score-view) &key)
 143   (with-output-as-presentation (stream object 'notehead)
 144     (draw-notehead stream name x staff-step)))
 145
 146 ;;;;;;;;;;;;;;;;;; accidental
 147
 148 (defun draw-accidental (stream name x staff-step)
 149   (sdl::draw-shape stream *font* name x (staff-step (- staff-step))))
 150
 151 ;;;;;;;;;;;;;;;;;; clef
 152
 153 (defun draw-clef (stream name x staff-step)
 154   (sdl::draw-shape stream *font*
 155                    (ecase name
 156                      ;; FIXME: while using the same glyph for :TREBLE
 157                      ;; and :TREBLE8 is fine from a musical point of
 158                      ;; view, some differentiation (by putting an
 159                      ;; italic 8 underneath, for instance) would be
 160                      ;; good.
 161                      ((:treble :treble8) :g-clef)
 162                      (:bass :f-clef)
 163                      (:c :c-clef))
 164                    x (staff-step (- staff-step))))
 165
 166 (define-presentation-type clef () :options (name x staff-step))
 167
 168 (define-presentation-method present
 169     (object (type clef) stream (view score-view) &key)
 170   (with-output-as-presentation (stream object 'clef)
 171     (draw-clef stream name x staff-step)))
 172
 173 ;;;;;;;;;;;;;;;;;; time signature
 174
 175 (defun draw-time-signature-component (stream component x)
 176   (flet ((component-name (c)
 177            (ecase c
 178              (1 :time-signature-1)
 179              (2 :time-signature-2)
 180              (3 :time-signature-3)
 181              (4 :time-signature-4)
 182              (5 :time-signature-5)
 183              (6 :time-signature-6)
 184              (7 :time-signature-7)
 185              (8 :time-signature-8))))
 186     (etypecase component
 187       ((integer 1 8)
 188        (let* ((design (sdl::ensure-design *font* (component-name component))))
 189          (sdl::draw-shape stream *font* design x (staff-step -2))
 190          (bounding-rectangle-width design)))
 191       ((cons (integer 1 8) (integer 1 8))
 192        (destructuring-bind (num . den) component
 193          (let* ((num-name (component-name num))
 194                 (den-name (component-name den))
 195                 (ndesign (sdl::ensure-design *font* num-name))
 196                 (ddesign (sdl::ensure-design *font* den-name)))
 197            (sdl::draw-shape stream *font* num-name x (staff-step -4))
 198            (sdl::draw-shape stream *font* den-name x (staff-step 0))
 199            (max (bounding-rectangle-width ndesign)
 200                 (bounding-rectangle-width ddesign))))))))
 201
 202 ;;;;;;;;;;;;;;;;;; rest
 203
 204 (defun draw-rest (stream duration x staff-step)
 205   (sdl::draw-shape stream *font*
 206                    (ecase duration
 207                      (4 :long-rest)
 208                      (2 :breve-rest)
 209                      (1 :whole-rest)
 210                      (1/2 :half-rest)
 211                      (1/4 :quarter-rest)
 212                      (1/8 :8th-rest)
 213                      (1/16 :16th-rest)
 214                      (1/32 :32nd-rest)
 215                      (1/64 :64th-rest)
 216                      ;; FIXME 128th
 217                      )
 218                    x (staff-step (- staff-step))))
 219
 220 ;;;;;;;;;;;;;;;;;; flags down
 221
 222 (defun draw-flags-down (stream nb x staff-step)
 223   (sdl::draw-shape stream *font*
 224                    (ecase nb
 225                      (1 :flags-down-1)
 226                      (2 :flags-down-2)
 227                      (3 :flags-down-3)
 228                      (4 :flags-down-4)
 229                      (5 :flags-down-5))
 230                    x (staff-step (- staff-step))))
 231
 232 ;;;;;;;;;;;;;;;;;; flags up
 233
 234 (defun draw-flags-up (stream nb x staff-step)
 235   (sdl::draw-shape stream *font*
 236                    (ecase nb
 237                      (1 :flags-up-1)
 238                      (2 :flags-up-2)
 239                      (3 :flags-up-3)
 240                      (4 :flags-up-4)
 241                      (5 :flags-up-5))
 242                    x (staff-step (- staff-step))))
 243
 244 ;;;;;;;;;;;;;;;;;; dot
 245
 246 (defun draw-dot (stream x staff-step)
 247   (sdl::draw-shape stream *font* :dot x (staff-step (- staff-step))))
 248
 249 ;;;;;;;;;;;;;;;;;; staff line
 250
 251 (defun draw-staff-line (pane x1 staff-step x2)
 252   (multiple-value-bind (down up) (staff-line-offsets *font*)
 253     (let ((y1 (+ (- (staff-step staff-step)) up))
 254           (y2 (+ (- (staff-step staff-step)) down)))
 255       (draw-rectangle* pane x1 y1 x2 y2))))
 256
 257 (defclass staff-output-record (output-record)
 258   ((parent :initarg :parent :initform nil :accessor output-record-parent)
 259    (x :initarg :x1 :initarg :x-position)
 260    (y :initarg :y1 :initarg :y-position)
 261    (width :initarg :width)
 262    (height :initarg height)
 263    (staff-lines :initform '() :reader output-record-children)))
 264
 265 (defmethod bounding-rectangle* ((record staff-output-record))
 266   (with-slots (x y width height) record
 267     (values x y (+ x width) (+ y height))))
 268
 269 (defmethod output-record-position ((record staff-output-record))
 270   (with-slots (x y) record
 271     (values x y)))
 272
 273 (defmethod (setf output-record-position) (new-x new-y (record staff-output-record))
 274   (with-slots (x y staff-lines) record
 275     (setf x new-x y new-y)
 276     (loop for staff-line in staff-lines
 277           do (multiple-value-bind (xx yy) (output-record-position staff-line)
 278                (setf (output-record-position staff-line)
 279                      (values (+ xx (- new-x x))
 280                              (+ yy (- new-y y))))))))
 281
 282 (defmethod output-record-start-cursor-position ((record staff-output-record))
 283   (values nil nil))
 284
 285 (defmethod (setf output-record-start-cursor-position) (x y (record staff-output-record))
 286   (declare (ignore x y))
 287   nil)
 288
 289 (defmethod output-record-end-cursor-position ((record staff-output-record))
 290   (values nil nil))
 291
 292 (defmethod (setf output-record-end-cursor-position) (x y (record staff-output-record))
 293   (declare (ignore x y))
 294   nil)
 295
 296 (defmethod output-record-hit-detection-rectangle* ((record staff-output-record))
 297   (bounding-rectangle* record))
 298
 299 (defmethod output-record-refined-position-test  ((record staff-output-record) x y)
 300   (declare (ignore x y))
 301   t)
 302
 303 ;;; remove this when McCLIM is fixed
 304 (defmethod region-intersects-region-p (region (record staff-output-record))
 305   (with-bounding-rectangle* (x1 y1 x2 y2) record
 306     (region-intersects-region-p region (make-rectangle* x1 y1 x2 y2))))
 307
 308 (defmethod add-output-record (child (record staff-output-record))
 309   (push child (slot-value record 'children)))
 310
 311 (defmethod delete-output-record (child (record staff-output-record) &optional (errorp t))
 312   (with-slots (staff-lines) record
 313     (when (and errorp (not (member child staff-lines :test #'eq)))
 314       (error "not a child"))
 315     (setf staff-lines (delete child staff-lines :test #'eq))))
 316
 317 (defmethod clear-output-record ((record staff-output-record))
 318   (setf (slot-value record 'staff-lines) '()))
 319
 320 (defmethod output-record-count ((record staff-output-record))
 321   (length (slot-value record 'staff-lines)))
 322
 323 (defmethod replay-output-record ((record staff-output-record) stream
 324                                  &optional (region +everywhere+)
 325                                  (x-offset 0) (y-offset 0))
 326   (loop for staff-line in (slot-value record 'staff-lines)
 327         do (replay-output-record staff-line stream region x-offset y-offset)))
 328
 329 (define-presentation-type staff () :options (x1 x2))
 330
 331 (define-presentation-type fiveline-staff () :inherit-from 'staff :options (x1 x2))
 332
 333 (defun draw-fiveline-staff (pane x1 x2)
 334   (multiple-value-bind (left right) (bar-line-offsets *font*)
 335     (loop for staff-step from 0 by 2
 336           repeat 5
 337           do (draw-staff-line pane (+ x1 left) staff-step (+ x2 right)))))
 338
 339 (define-presentation-method present
 340     (object (type fiveline-staff) stream (view score-view) &key)
 341   (with-output-as-presentation (stream object 'fiveline-staff)
 342     (draw-fiveline-staff stream x1 x2)))
 343
 344 (define-presentation-type lyrics-staff () :inherit-from 'staff :options (x1 x2))
 345
 346 (defun draw-lyrics-staff (pane x1 x2)
 347   (declare (ignore x2))
 348   (multiple-value-bind (left right) (bar-line-offsets *font*)
 349     (declare (ignore right))
 350     (draw-text* pane "--" (+ x1 left) 0)))
 351
 352 (define-presentation-method present
 353     (object (type lyrics-staff) stream (view score-view) &key)
 354   (with-output-as-presentation (stream object 'lyrics-staff)
 355     (draw-lyrics-staff stream x1 x2)))
 356
 357 ;;;;;;;;;;;;;;;;;; stem
 358
 359 (defun draw-stem (pane x y1 y2)
 360   (multiple-value-bind (left right) (stem-offsets *font*)
 361     (let ((x1 (+ x left))
 362           (x2 (+ x right)))
 363       (draw-rectangle* pane x1 y1 x2 y2))))
 364
 365 (defun draw-right-stem (pane x y1 y2)
 366   (multiple-value-bind (dx dy) (notehead-right-offsets *font*)
 367     (draw-stem pane (+ x dx) (- y1 dy) y2)))
 368
 369 (defun draw-left-stem (pane x y1 y2)
 370   (multiple-value-bind (dx dy) (notehead-left-offsets *font*)
 371     (draw-stem pane (+ x dx) (- y1 dy) y2)))
 372
 373 ;;;;;;;;;;;;;;;;;; ledger line
 374
 375 (defun draw-ledger-line (pane x staff-step)
 376   (multiple-value-bind (down up) (ledger-line-y-offsets *font*)
 377     (multiple-value-bind (left right) (ledger-line-x-offsets *font*)
 378       (let ((x1 (+ x left))
 379             (y1 (- (+ (staff-step staff-step) down)))
 380             (x2 (+ x right))
 381             (y2 (- (+ (staff-step staff-step) up))))
 382         (draw-rectangle* pane x1 y1 x2 y2)))))
 383
 384
 385 ;;;;;;;;;;;;;;;;;; bar line
 386
 387 (defun draw-bar-line (pane x y1 y2)
 388   (multiple-value-bind (left right) (bar-line-offsets *font*)
 389     (let ((x1 (+ x left))
 390           (x2 (+ x right)))
 391       ;; see comment in ROUND-COORDINATE in McCLIM's CLX backend
 392       (draw-rectangle* pane (floor (+ x1 0.5)) y1 (floor (+ x2 0.5)) y2))))
 393
 394 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 395 ;;;
 396 ;;; beam drawing
 397
 398 (defclass beam-output-record (score-output-record)
 399   ((light-glyph-p :initarg :light-glyph-p)
 400    (clipping-region :initarg :clipping-region)
 401    (thickness :initarg :thickness)))
 402
 403 ;;; draw a horizontal beam around the vertical reference
 404 ;;; point y.
 405 (defun draw-horizontal-beam (medium x1 y x2)
 406   (multiple-value-bind (down up) (beam-offsets *font*)
 407     (draw-rectangle* medium x1 (+ y up) x2 (+ y down))))
 408
 409
 410 (defclass downward-beam-output-record (beam-output-record)
 411   ())
 412
 413 (defmethod medium-draw-downward-beam* (medium x1 y1 x2 y2 thickness)
 414   (let ((inverse-slope (abs (/ (- x2 x1) (- y2 y1)))))
 415     (loop for y from y1 below y2
 416           for x from x1 by inverse-slope do
 417           (let ((upper (sdl::ensure-beam-segment-design :down :upper (- (round (+ x inverse-slope)) (round x))))
 418                 (upper-tr (make-translation-transformation (round x) y))
 419                 (lower (sdl::ensure-beam-segment-design :down :lower (- (round (+ x inverse-slope)) (round x))))
 420                 (lower-tr (make-translation-transformation (round x) (+ y thickness))))
 421             (climi::medium-draw-bezier-design* medium (transform-region upper-tr upper))
 422             (climi::medium-draw-bezier-design* medium (transform-region lower-tr lower))
 423             (medium-draw-rectangle* medium (round x) (1+ y) (round (+ x inverse-slope)) (+ y thickness) t)))))
 424
 425 (defmethod medium-draw-downward-beam*
 426     ((medium clim-postscript::postscript-medium) x1 y1 x2 y2 thickness)
 427   (draw-polygon* (medium-sheet medium) `(,x1 ,y1 ,x1 ,(+ y1 thickness) ,x2 ,(+ y2 thickness) ,x2 ,y2) :closed t :filled t))
 428
 429 (defmethod medium-draw-upward-beam* (medium x1 y1 x2 y2 thickness)
 430   (let ((inverse-slope (abs (/ (- x2 x1) (- y2 y1)))))
 431     (loop for y from y1 above y2
 432           for x from x1 by inverse-slope do
 433           (let ((upper (sdl::ensure-beam-segment-design :up :upper (- (round (+ x inverse-slope)) (round x))))
 434                 (upper-tr (make-translation-transformation (round x) y))
 435                 (lower (sdl::ensure-beam-segment-design :up :lower (- (round (+ x inverse-slope)) (round x))))
 436                 (lower-tr (make-translation-transformation (round x) (+ y thickness -1))))
 437             (climi::medium-draw-bezier-design* medium (transform-region upper-tr upper))
 438             (climi::medium-draw-bezier-design* medium (transform-region lower-tr lower))
 439             (medium-draw-rectangle* medium (round x) y (round (+ x inverse-slope)) (1- (+ y thickness)) t)))))
 440
 441 (defmethod medium-draw-upward-beam*
 442     ((medium clim-postscript::postscript-medium) x1 y1 x2 y2 thickness)
 443   (draw-polygon* (medium-sheet medium) `(,x1 ,y1 ,x1 ,(+ y1 thickness) ,x2 ,(+ y2 thickness) ,x2 ,y2) :closed t :filled t))
 444
 445 (defmethod replay-output-record ((record downward-beam-output-record) stream
 446                                  &optional (region +everywhere+)
 447                                  (x-offset 0) (y-offset 0))
 448   (declare (ignore x-offset y-offset region))
 449   (with-bounding-rectangle* (x1 y1 x2 y2) record
 450     (with-slots (thickness ink clipping-region) record
 451       (let ((medium (sheet-medium stream)))
 452         (with-drawing-options
 453             (medium :ink ink :clipping-region clipping-region)
 454           (medium-draw-downward-beam* medium x1 y1 x2 (- y2 thickness) thickness))))))
 455
 456 (defclass upward-beam-output-record (beam-output-record)
 457   ())
 458
 459 (defmethod replay-output-record ((record upward-beam-output-record) stream
 460                                  &optional (region +everywhere+)
 461                                  (x-offset 0) (y-offset 0))
 462   (declare (ignore x-offset y-offset region))
 463   (with-bounding-rectangle* (x1 y1 x2 y2) record
 464     (with-slots (thickness ink clipping-region) record
 465       (let ((medium (sheet-medium stream)))
 466         (with-drawing-options
 467             (medium :ink ink :clipping-region clipping-region)
 468           (medium-draw-upward-beam* medium x1 (- y2 thickness) x2 y1 thickness))))))
 469
 470 (defun transform-beam-attributes (transformation x1 y1 x2 y2 down up thickness)
 471   (multiple-value-bind (xx1 yy1)
 472       (transform-position transformation x1 y1)
 473     (multiple-value-bind (xx2 yy2)
 474         (transform-position transformation x2 y2)
 475       (multiple-value-bind (xd yd)
 476           (transform-distance transformation 0 down)
 477         (declare (ignore xd))
 478         (multiple-value-bind (xu yu)
 479             (transform-distance transformation 0 up)
 480           (declare (ignore xu))
 481           (multiple-value-bind (xt yt)
 482               (transform-distance transformation 0 thickness)
 483             (declare (ignore xt))
 484             (values xx1 yy1 xx2 yy2 yd yu yt)))))))
 485
 486 ;;; draw a sloped beam.  The vertical reference points
 487 ;;; of the two end points are indicated by y1 and y2.
 488 (defun draw-sloped-beam (medium x1 y1 x2 y2)
 489   (multiple-value-bind (down up) (beam-offsets *font*)
 490     (let ((transformation (medium-transformation (medium-sheet medium)))
 491           (thickness (- down up)))
 492       (cond ((< y1 y2)
 493              (when (stream-recording-p (medium-sheet medium))
 494                (multiple-value-bind (xx1 yy1 xx2 yy2 yd yu yt)
 495                    (transform-beam-attributes transformation x1 y1 x2 y2
 496                                               down up thickness)
 497                  (stream-add-output-record
 498                   (medium-sheet medium)
 499                   (make-instance 'downward-beam-output-record
 500                                  :x1 xx1 :y1 (+ yy1 yu) :x2 xx2 :y2 (+ yy2 yd)
 501                                  :thickness yt :ink (medium-ink medium)
 502                                  :clipping-region (transform-region transformation (medium-clipping-region medium))))))
 503              (when (stream-drawing-p (medium-sheet medium))
 504                (medium-draw-downward-beam* medium x1 (+ y1 up) x2 (+ y2 up) thickness)))
 505             (t
 506              (when (stream-recording-p (medium-sheet medium))
 507                (multiple-value-bind (xx1 yy1 xx2 yy2 yd yu yt)
 508                    (transform-beam-attributes transformation x1 y1 x2 y2
 509                                               down up thickness)
 510                  (stream-add-output-record
 511                   (medium-sheet medium)
 512                   (make-instance 'upward-beam-output-record
 513                                  :x1 xx1 :y1 (+ yy2 yu) :x2 xx2 :y2 (+ yy1 yd)
 514                                  :thickness yt :ink (medium-ink medium)
 515                                  :clipping-region (transform-region transformation (medium-clipping-region medium))))))
 516              (when (stream-drawing-p (medium-sheet medium))
 517                (medium-draw-upward-beam* medium x1 (+ y1 up) x2 (+ y2 up) thickness)))))))
 518
 519 ;;; an offset of -1 means hang, 0 means straddle and 1 means sit
 520 (defun draw-beam (pane x1 staff-step-1 offset1 x2 staff-step-2 offset2)
 521   (if (> x1 x2)
 522       (draw-beam pane x2 staff-step-2 offset2 x1 staff-step-1 offset1)
 523       (multiple-value-bind (left right) (stem-offsets *font*)
 524         (let* ((xx1 (+ x1 left))
 525                (xx2 (+ x2 right))
 526                (offset (beam-hang-sit-offset *font*))
 527                (y1 (- (+ (staff-step staff-step-1) (* offset1 offset))))
 528                (y2 (- (+ (staff-step staff-step-2) (* offset2 offset))))
 529                (medium (sheet-medium pane)))
 530           (if (= y1 y2)
 531               (draw-horizontal-beam pane xx1 y1 xx2)
 532               (draw-sloped-beam medium xx1 y1 xx2 y2))))))
 533
 534 (defun draw-tie-up (pane x1 x2 staff-step)
 535   (let ((dist (/ (- x2 x1) (staff-step 4/3))))
 536     (if (> dist 19)
 537         (let ((xx1 (round (+ x1 (staff-step 10))))
 538               (xx2 (round (- x2 (staff-step 10))))
 539               (y1 (- (round (staff-step (+ staff-step 11/3)))))
 540               (thickness (round (staff-step 2/3))))
 541           (sdl::draw-shape pane *font* :large-tie-up-left xx1 (staff-step (- staff-step)))
 542           (sdl::draw-shape pane *font* :large-tie-up-right xx2 (staff-step (- staff-step)))
 543           (draw-rectangle* pane xx1 y1 xx2 (+ y1 thickness)))
 544         (let ((glyph-name (cond ((> dist 18) :large-tie-10-up)
 545                                 ((> dist 17) :large-tie-9-up)
 546                                 ((> dist 16) :large-tie-8-up)
 547                                 ((> dist 15) :large-tie-7-up)
 548                                 ((> dist 14) :large-tie-6-up)
 549                                 ((> dist 13) :large-tie-5-up)
 550                                 ((> dist 12) :large-tie-4-up)
 551                                 ((> dist 11) :large-tie-3-up)
 552                                 ((> dist 10) :large-tie-2-up)
 553                                 ((> dist 9) :large-tie-1-up)
 554                                 ((> dist 8) :small-tie-8-up)
 555                                 ((> dist 7) :small-tie-7-up)
 556                                 ((> dist 6) :small-tie-6-up)
 557                                 ((> dist 5) :small-tie-5-up)
 558                                 ((> dist 4) :small-tie-4-up)
 559                                 ((> dist 3) :small-tie-3-up)
 560                                 ((> dist 2) :small-tie-2-up)
 561                                 (t :small-tie-1-up))))
 562           (sdl::draw-shape pane *font* glyph-name
 563                            (round (* 0.5 (+ x1 x2))) (staff-step (- staff-step)))))))
 564
 565 (defun draw-tie-down (pane x1 x2 staff-step)
 566   (let ((dist (/ (- x2 x1) (staff-step 4/3))))
 567     (if (> dist 19)
 568         (let ((xx1 (round (+ x1 (staff-step 10))))
 569               (xx2 (round (- x2 (staff-step 10))))
 570               (y1 (- (round (staff-step (- staff-step 8/3)))))
 571               (thickness (round (staff-step 2/3))))
 572           (sdl::draw-shape pane *font* :large-tie-down-left xx1 (staff-step (- staff-step)))
 573           (sdl::draw-shape pane *font* :large-tie-down-right xx2 (staff-step (- staff-step)))
 574           (draw-rectangle* pane xx1 y1 xx2 (+ y1 thickness)))
 575         (let ((glyph-name (cond ((> dist 18) :large-tie-10-down)
 576                                 ((> dist 17) :large-tie-9-down)
 577                                 ((> dist 16) :large-tie-8-down)
 578                                 ((> dist 15) :large-tie-7-down)
 579                                 ((> dist 14) :large-tie-6-down)
 580                                 ((> dist 13) :large-tie-5-down)
 581                                 ((> dist 12) :large-tie-4-down)
 582                                 ((> dist 11) :large-tie-3-down)
 583                                 ((> dist 10) :large-tie-2-down)
 584                                 ((> dist 9) :large-tie-1-down)
 585                                 ((> dist 8) :small-tie-8-down)
 586                                 ((> dist 7) :small-tie-7-down)
 587                                 ((> dist 6) :small-tie-6-down)
 588                                 ((> dist 5) :small-tie-5-down)
 589                                 ((> dist 4) :small-tie-4-down)
 590                                 ((> dist 3) :small-tie-3-down)
 591                                 ((> dist 2) :small-tie-2-down)
 592                                 (t :small-tie-1-down))))
 593           (sdl::draw-shape pane *font* glyph-name
 594                            (round (* 0.5 (+ x1 x2))) (staff-step (- staff-step)))))))
 595
 596 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 597 ;;;
 598 ;;; convenience macros
 599
 600 (defmacro with-notehead-right-offsets ((right up) &body body)
 601   `(multiple-value-bind (,right ,up) (notehead-right-offsets *font*)
 602     ,@body))
 603
 604 (defmacro with-notehead-left-offsets ((left down) &body body)
 605   `(multiple-value-bind (,left ,down) (notehead-left-offsets *font*)
 606     ,@body))
 607
 608 (defmacro with-suspended-note-offset (offset &body body)
 609   `(let ((,offset (suspended-note-offset *font*)))
 610     ,@body))
 611
 612 (defmacro with-score-pane (pane &body body)
 613   `(progn
 614      (clear-output-record (stream-output-history ,pane))
 615      ,@body))
 616
 617 (defmacro with-vertical-score-position ((pane yref) &body body)
 618   `(with-translation (,pane 0 ,yref)
 619     ,@body))
 620
 621 (defmacro with-staff-size (size &body body)
 622   (let ((size-var (gensym)))
 623     `(let ((,size-var ,size))
 624       (unless (aref *fonts* ,size-var)
 625         (setf (aref *fonts* ,size-var)
 626               (make-font ,size-var)))
 627       (let ((*font* (aref *fonts* ,size-var)))
 628         ,@body))))
 629
 630 (defmacro with-light-glyphs (pane &body body)
 631   `(with-drawing-options (,pane :ink (light-glyphs-ink (stream-default-view ,pane)))
 632      ,@body))