lyrics.lisp

   1 (in-package :gsharp-buffer)
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;;;
   5 ;;; staff
   6
   7 (defclass lyrics-staff (staff) ())
   8
   9 (defun make-lyrics-staff (&rest args &key name)
  10   (declare (ignore name))
  11   (apply #'make-instance 'lyrics-staff args))
  12
  13 (defun read-lyrics-staff-v3 (stream char n)
  14   (declare (ignore char n))
  15   (apply #'make-instance 'lyrics-staff (read-delimited-list #\] stream t)))
  16
  17 (set-dispatch-macro-character #\[ #\L
  18   #'read-lyrics-staff-v3
  19   *gsharp-readtable-v3*)
  20
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;;
  23 ;;; Lyrics element
  24
  25 (defclass lyrics-element (rhythmic-element)
  26   ((staff :initarg :staff :reader staff)
  27    (text :initarg :text
  28          :initform (make-array 5 :adjustable t :element-type 'fixnum :fill-pointer 0)
  29          :reader text)
  30    (%tie-right :initform nil :initarg :tie-right :accessor tie-right)
  31    (%tie-left :initform nil :initarg :tie-left :accessor tie-left)))
  32
  33 (defmethod initialize-instance :after ((elem lyrics-element) &rest args)
  34   (declare (ignore args))
  35   (with-slots (text) elem
  36      (unless (adjustable-array-p text)
  37        (let ((length (length text)))
  38          (setf text (make-array length :adjustable t :element-type 'fixnum
  39                                 :fill-pointer length :initial-contents text))))))
  40
  41 (defun make-lyrics-element (staff &rest args
  42                             &key (notehead :filled) (lbeams 0) (rbeams 0)
  43                             (dots 0) (xoffset 0))
  44   (declare (type staff staff)
  45            (type (member :long :breve :whole :half :filled) notehead)
  46            (type (integer 0 5) lbeams)
  47            (type (integer 0 5) rbeams)
  48            (type (integer 0 3) dots)
  49            (type number xoffset)
  50            (ignore notehead lbeams rbeams dots xoffset))
  51   (apply #'make-instance 'lyrics-element
  52          :staff staff args))
  53
  54 (defmethod slots-to-be-saved append ((elem lyrics-element))
  55   '(staff text))
  56
  57 (defun read-lyrics-element-v3 (stream char n)
  58   (declare (ignore char n))
  59   (apply #'make-instance 'lyrics-element (read-delimited-list #\] stream t)))
  60
  61 (set-dispatch-macro-character #\[ #\A
  62   #'read-lyrics-element-v3
  63   *gsharp-readtable-v3*)
  64
  65 (defmethod append-char ((elem lyrics-element) char)
  66   (vector-push-extend char (text elem)))
  67
  68 (defmethod erase-char ((elem lyrics-element))
  69   (unless (zerop (fill-pointer (text elem)))
  70     (decf (fill-pointer (text elem)))))
  71
  72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73 ;;;
  74 ;;; Lyrics bar
  75
  76 (defclass lyrics-bar (bar) ())
  77
  78 (defun make-lyrics-bar (&rest args &key elements)
  79   (declare (type list elements)
  80            (ignore elements))
  81   (apply #'make-instance 'lyrics-bar args))
  82
  83 (defmethod make-bar-for-staff ((staff lyrics-staff) &rest args &key elements)
  84   (declare (ignore elements))
  85   (apply #'make-instance 'lyrics-bar args))
  86
  87 (defun read-lyrics-bar-v3 (stream char n)
  88   (declare (ignore char n))
  89   (apply #'make-instance 'lyrics-bar (read-delimited-list #\] stream t)))
  90
  91 (set-dispatch-macro-character #\[ #\C
  92   #'read-lyrics-bar-v3
  93   *gsharp-readtable-v3*)
  94
  95 (defmethod remove-bar ((bar lyrics-bar))
  96   (with-slots (slice) bar
  97     (assert slice () 'bar-not-in-slice)
  98     (with-slots (bars) slice
  99       (setf bars (delete bar bars :test #'eq))
 100       (unless bars
 101         ;; make sure there is one bar left
 102         (add-bar (make-lyrics-bar) slice 0)))
 103     (setf slice nil)))
 104
 105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 106 ;;;
 107 ;;; Lyrics layer
 108
 109 (defclass lyrics-layer (layer) ())
 110
 111 (defun read-lyrics-layer-v3 (stream char n)
 112   (declare (ignore char n))
 113   (apply #'make-instance 'lyrics-layer (read-delimited-list #\] stream t)))
 114
 115 (set-dispatch-macro-character #\[ #\M
 116   #'read-lyrics-layer-v3
 117   *gsharp-readtable-v3*)
 118
 119 (defmethod make-layer-for-staff ((staff lyrics-staff) &rest args &key staves head body tail &allow-other-keys)
 120   (declare (ignore staves head body tail))
 121   (apply #'make-instance 'lyrics-layer args))
 122