[CM] CMN - ligature marks
Anders Vinjar
anders.vinjar@notam02.no
20 Sep 2002 10:49:40 +0200
--=-=-=
>>> "BS" == Bill Sack <wsack@acsu.buffalo.edu> writes:
BS> i'm looking for a way to display the mark transcribers
BS> use to indicate there was a ligature in the original
BS> music (if you don't know what i'm talking about, lucky
BS> you).
Heres a general duration-bracket mark which might provide you
with a start. Called with an empty string as argument it just
places a bracket over the notes in question.
(cmn (c5 q (begin-duration-bracket ""))
g4 q (c4 q (end-duration-bracket)))
--=-=-=
Content-Type: application/octet-stream
Content-Disposition: attachment; filename=duration-bracket.lisp
Content-Description: duration-bracket
;;;
;;; ---------------- duration bracket
;;;
(defclass duration-bracket (sundry font-mixin)
((duration :initarg :duration :initform nil :accessor duration)
(justification :initarg :justification :initform :up :accessor justification)
(note0 :initarg :note0 :initform nil :accessor note0)
(note1 :initarg :note1 :initform nil :accessor note1)
(max-line :initarg :max-line :initform nil :accessor max-line)
(duration-bracket-ender :initarg :duration-bracket-ender :initform t :accessor duration-bracket-ender)
(vertical-separation :initarg :vertical-separation :initform 3 :accessor vertical-separation)
(font-name :initform "Times-Bold")
(font-scaler :initform .5)))
(deferred-action duration-bracket-ender)
(defmethod descry ((duration duration-bracket) &optional stream controller)
(format stream "~A~A~A~A~A~A~A~A~A~A"
(if (not controller) (format nil "(duration-bracket") "")
(if (duration duration) (format nil " :duration ~D" (duration duration)) "")
(if (note0 duration) (format nil " :note0 ~A" (note0 duration)) "")
(if (note1 duration) (format nil " :note1 ~A" (note1 duration)) "")
(if (max-line duration) (format nil " :max-line ~D" (max-line duration)) "")
(format nil " :vertical-separation ~A" (vertical-separation duration))
(format nil " :ender '~A" (duration-bracket-ender duration))
(if (next-method-p) (call-next-method duration stream (or controller duration)) "")
(if (not controller) ")" "")))
(defmethod copy ((duration duration-bracket) &optional object)
(let ((new-duration (if (not object) (make-instance 'duration-bracket)
(if (write-protected object) (copy object)
object))))
(setf (duration new-duration) (duration duration))
(setf (max-line new-duration) (max-line duration))
(setf (vertical-separation new-duration) (vertical-separation duration))
(setf (duration-bracket-ender new-duration) (duration-bracket-ender duration))
(if (next-method-p) (call-next-method duration new-duration))
new-duration))
(defun start-duration-bracket (dur &rest args)
(make-self-acting
:action #'(lambda (note &rest rest)
(declare (ignore rest))
(let ((new-8 (make-instance 'duration-bracket
:note0 note
:duration dur
:mark #'display-duration
:name :duration)))
(setf duration-stack new-8)
(if args (loop for arg in args do
(if (self-acting-p arg)
(funcall (action arg) new-8 (argument arg)))))
nil))
:argument nil))
(defun end-duration-bracket (&rest args)
;;(declare (ignore args))
(make-self-acting
:action #'(lambda (note &rest rest)
(declare (ignore rest))
(if (not duration-stack)
(funcall (action (start-duration-bracket dur)) note nil))
(add-to-marks (note0 duration-stack) (list duration-stack))
(setf (note1 duration-stack) note)
(setf duration-stack nil))
:argument nil))
(defgeneric (setf durationd) (val obj))
;;(defgeneric (setf store-data) (val obj))
(defun start-and-end-duration-bracket (dur &rest args)
(make-self-acting
:action #'(lambda (note &rest rest)
(declare (ignore rest))
;;(setf (durationd note) t)
(add-to-marks note (list (let ((new-8 (make-instance 'duration-bracket
:note0 note
:note1 note
:mark #'display-duration
:duration dur
:name :duration)))
(if args (loop for arg in args do
(if (self-acting-p arg)
(funcall (action arg) new-8 (argument arg)))))
new-8))))
:argument nil))
(setf begin-duration-bracket (start-duration-bracket 4))
(setf duration-bracket (start-and-end-duration-bracket 4))
(setf end-duration-bracket-bracket (end-duration-bracket))
(defun begin-duration-bracket (dur &rest args) (apply #'start-duration-bracket dur args))
(defun duration-bracket (dur &rest args) (apply #'start-and-end-duration-bracket dur args))
(defun end-duration-bracket-bracket (&rest args) (apply #'end-duration-bracket args))
(defun floating-dur-note (score quarters head-type stem-up matrix)
(let ((nh (get-note-head quarters head-type))
(nflags (how-many-flags quarters))
(ndots (how-many-dots quarters))
(stem-length (if stem-up .7 -.7)))
(matrix-front score matrix)
(moveto score 0 0)
(funcall (draw-func nh) score);;(if (sundry-p nh) (display nh t score justifying))
(when (< quarters 4)
(let ((x0 (if stem-up (- (width nh) *half-stem-width*) 0)))
(setf (line-width score) *stem-width*)
(moveto score x0 0)
(rlineto score 0 stem-length)
(draw score)
(setf (line-width score) 0)
(when (plusp nflags)
(draw-flags score nh nflags stem-up stem-length -0.01))))
(when (plusp ndots)
(loop for i from 1 to ndots and xd from .5 by *dot-spacing* do
(cmn-dot score xd 0.0)))
(matrix-back score)))
(defun display-duration (sundry note score &optional justifying)
(if (and (not justifying) )
(let ((no-start (not (note0 sundry)))
(no-end (not (note1 sundry))))
(if (and (note0 sundry)
(note1 sundry)
(/= (staff-y0 (note0 sundry)) (staff-y0 (note1 sundry))))
(let* ((all-data (staff-data *cmn-staff*))
(n0 (note0 sundry))
(n1 (note1 sundry))
(s0 (staff-y0 n0))
(s1 (staff-y0 n1))
(curs s0))
;; loop through the staves in the data list looking for the end staff and inserting no-start-or-end
;; markers for any in-between -- first find overall staff (*cmn-staff* used here -- bad form)
(loop while (not (eq n0 (first all-data))) do (pop all-data))
(let ((first-notes nil))
(loop while (not (eq n1 (first all-data))) do
(let* ((curn (pop all-data))
(curns (if (audible-p curn) (staff-y0 curn) curs)))
(if (and (/= s1 curns) (/= curs curns))
(progn
(push curn first-notes)
(setf curs curns)))))
(when first-notes
(loop for firno in first-notes do
(add-to-marks firno
(list (make-instance 'duration-bracket
:name :duration
:mark #'display-duration
:note0 nil
:dx (vis-dx sundry)
:dy (vis-dy sundry)
:duration (duration sundry)
:max-line nil))))))
(add-to-marks (note1 sundry)
(list (make-instance 'duration-bracket
:name :duration
:mark #'display-duration
:note0 nil
:dx (vis-dx sundry)
:dy (vis-dy sundry)
:note1 (note1 sundry)
:duration (duration sundry)
:max-line nil)))
(setf no-end t)
(setf (note1 sundry) nil)))
(if no-start
(setf (note0 sundry) (make-instance 'note
:line 0
:x0 (if *cmn-staff* (box-x0 *cmn-staff*) (box-x0 score)))))
(if no-end
(setf (note1 sundry) (make-instance 'note
:line 0
:x1 (if *cmn-staff* (box-x1 *cmn-staff*) (box-x1 score)))))
(let* ((direction (justification sundry))
(durations (duration sundry))
(x0 (- (x0 (note0 sundry)) (if no-start 0 .2)))
(x1 (+ (x1 (note1 sundry)) (vis-dx (note1 sundry)) (x1 sundry)))
(y0 (+ (staff-y0 note)
(if (eq direction :up)
(* (max 12
(+ (vertical-separation sundry)
(or (max-line sundry) 0)))
*staff-line-separation*)
(* (min -4
(- (or (max-line sundry) (minimum-line note) 0)
(vertical-separation sundry)))
*staff-line-separation*))))
(durmsg (if (text-p durations) durations (format nil "~A" durations)))
(siz (scr-size score))
(mid-y0 (+ y0 (if (eq direction :up) .2 -.2)))
;;(px1 (* (+ x0 0.7)))
(px1 (min (* (+ x0 1.0)) (+ x0 (- (/ (- x1 x0) 2.0) 0.15))))
)
(incf x0 (vis-dx sundry))
(incf y0 (vis-dy sundry))
(incf mid-y0 (vis-dy sundry))
(incf px1 (vis-dx sundry))
(when (not no-start)
(moveto score x0 y0)
(lineto score x0 mid-y0)
(lineto score (+ x0 0.2) mid-y0)
(draw score))
(when (not no-start)
(moveto score (+ x0 0.2) mid-y0)
(lineto score px1 mid-y0
;;:pattern (map 'list #'(lambda (pt) (* pt (/ (scr-size score) 40))) (pattern sundry))
))
(when (not no-start)
(if (note-p durations)
(floating-dur-note score
(quarters durations)
(note-head durations)
(eq direction :up)
(scale-matrix
(translate-matrix score sundry
(+ px1 0.1 (dx durations))
(+ (dy durations)
(- mid-y0
(if (eq direction :up) 0.1 -0.1))))
0.8 0.8))
(if (sundry-p durations)
(progn (matrix-front score
(translate-matrix
score sundry 0.7 (if (eq direction :up) 0.3 -2.2)))
(funcall (sundry-mark durations) durations note score)
(matrix-back score))
(show score (cmn-text :font-name (font-name sundry)
:font-scaler (font-scaler sundry)
:letters durmsg)
:matrix (translate-matrix score sundry (+ px1 0.1) (- y0 (if (eq direction :up) 0 .4)))))))
(when (< (+ px1 .5) x1)
(moveto score (+ px1 (if (note-p durations) 0.5
(if (sundry-p durations) 1.6
(* 0.3 (length durmsg) )))) mid-y0)
(lineto score (- x1 0.1) mid-y0 :pattern (map 'list #'(lambda (pt)
(* pt (/ (scr-size score) 40)))
(pattern sundry)))
(draw score))
(cond ((member (duration-bracket-ender sundry) '(:arrow arrow))
(progn (moveto score (+ x1 0.1) mid-y0)
(lineto score (- x1 0.2) (+ mid-y0 0.1))
(lineto score (- x1 0.05) mid-y0)
(lineto score (- x1 0.2) (- mid-y0 0.1))
(lineto score (+ x1 0.1) mid-y0)
(fill-in score)))
((or no-end
(member (duration-bracket-ender sundry) '(:none none))
(not (duration-bracket-ender sundry)))
t)
(t (progn
(moveto score (- x1 0.1) mid-y0)
(lineto score x1 mid-y0)
(lineto score x1 y0)
(draw score))))))))
#|
(cmn (size 20) staff treble
(c5 q (begin-duration-bracket ""))
g4 q (c4 q (end-duration-bracket))
(c4 q (begin-duration-bracket ""
(justification :up) (duration-bracket-ender :arrow)
(x1 -0.3)))
c4 q (c4 q (end-duration-bracket))
(c4 q (begin-duration-bracket (c4 q)))
c4 q (c4 q (end-duration-bracket))
(c4 q (begin-duration-bracket "3 s." ))
c4 q (c4 q (end-duration-bracket)))
|#
--=-=-=--