src/classes.lisp

   1 ;;;; CLASSES AND DATA STRUCTURES.
   2 ;;; (and elementary helper functions associated with specific classes.)
   3 ;;;
   4 ;;; Julian Squires <tek@wiw.org> / 2004
   5
   6 (in-package :mumble)
   7
   8 (defun make-duration (denom)
   9   (when denom (/ 1 denom)))
  10
  11
  12 (defclass music-command ()
  13   ((type :reader music-command-type)
  14    (value :reader music-command-value)))
  15
  16 (defun make-tempo-command (tempo)
  17   (let ((cmd (make-instance 'music-command)))
  18     (setf (slot-value cmd 'type) :tempo)
  19     (setf (slot-value cmd 'value) tempo)
  20     cmd))
  21
  22 (defun make-staccato-command (staccato)
  23   (let ((cmd (make-instance 'music-command)))
  24     (setf (slot-value cmd 'type) :staccato)
  25     (setf (slot-value cmd 'value) staccato)
  26     cmd))
  27
  28 (defun make-simple-volume-command (n)
  29   (let ((cmd (make-instance 'music-command)))
  30     (setf (slot-value cmd 'type) :volume)
  31     (setf (slot-value cmd 'value) n)
  32     cmd))
  33
  34 ;; This might become a special macro-command later.
  35 (defun make-arpeggio-command (n)
  36   (let ((cmd (make-instance 'music-command)))
  37     (setf (slot-value cmd 'type) :arpeggio)
  38     (setf (slot-value cmd 'value) n)
  39     cmd))
  40
  41 ;; This might become a special macro-command later.
  42 (defun make-volume-envelope-command (n)
  43   (let ((cmd (make-instance 'music-command)))
  44     (setf (slot-value cmd 'type) :volume-envelope)
  45     (setf (slot-value cmd 'value) n)
  46     cmd))
  47
  48 ;; This might become a special macro-command later.
  49 (defun make-vibrato-command (n)
  50   (let ((cmd (make-instance 'music-command)))
  51     (setf (slot-value cmd 'type) :vibrato)
  52     (setf (slot-value cmd 'value) n)
  53     cmd))
  54
  55
  56 (defclass note (music-command)
  57   ((tone :reader note-tone)
  58    (duration :reader note-duration))
  59   (:documentation "Notes encapsulate an absolute pitch (the TONE slot)
  60 and a relative length (the DURATION slot).  DURATION is relative to
  61 the current channel tempo."))
  62
  63 (defun make-note (tone duration)
  64   (let ((note (make-instance 'note)))
  65     (setf (slot-value note 'type) :note)
  66     (setf (slot-value note 'tone) tone)
  67     (setf (slot-value note 'duration) duration)
  68     note))
  69
  70 (defmethod print-object ((obj note) stream)
  71   (print-unreadable-object (obj stream :type t)
  72     (princ (note-tone obj) stream)
  73     (princ #\Space stream)
  74     (princ (note-duration obj) stream)))
  75
  76
  77 (defclass channel ()
  78   ((octave :accessor channel-octave)
  79    (tempo :accessor channel-tempo)
  80    (staccato :accessor channel-staccato)
  81    (volume :accessor channel-volume)
  82    (duration :accessor channel-default-duration)
  83    (loop-point :accessor channel-loop-point)
  84    ;; repeats is kind of an ugly kludge.
  85    (repeats :accessor channel-repeats)
  86    (data-stream :accessor channel-data-stream)))
  87
  88 (defun make-channel ()
  89   (let ((channel (make-instance 'channel)))
  90     (setf (channel-octave channel) *default-octave*
  91           (channel-tempo channel) *default-tempo*
  92           (channel-staccato channel) *default-staccato*
  93           (channel-default-duration channel) *default-duration*
  94           (channel-volume channel) 0
  95           (channel-loop-point channel) nil
  96           (channel-repeats channel) nil)
  97
  98     (setf (channel-data-stream channel)
  99           (make-array '(0) :adjustable t :fill-pointer 0))
 100     channel))
 101
 102 (defun channel-current-position (channel)
 103   (fill-pointer (channel-data-stream channel)))
 104
 105 (defun copy-and-append-channel-data (channel begin end)
 106   (loop for x from begin to end
 107        do (vector-push-extend (aref (channel-data-stream channel) x)
 108                               (channel-data-stream channel))))
 109
 110
 111 (defclass tune ()
 112   ((channels :accessor tune-channels)
 113    (replay :accessor tune-replay)
 114    (tables :accessor tune-tables)
 115    (metadata :accessor tune-metadata)))
 116
 117 (defun make-tune ()
 118   (let ((tune (make-instance 'tune)))
 119     (setf (tune-metadata tune) nil)
 120     (setf (tune-tables tune) nil)
 121     tune))
 122
 123 (defun tune-get-table (tune table-sym)
 124   (cdr (assoc table-sym (tune-tables tune))))
 125
 126 (defun (setf tune-get-table) (value tune table-sym)
 127   (setf (cdr (assoc table-sym (tune-tables tune))) value))
 128
 129 (defun tune-add-table (tune table-sym)
 130   (push (cons table-sym (make-array '(0) :initial-element nil
 131                                     :adjustable t))
 132         (tune-tables tune)))
 133
 134 (defun tune-add-to-table (tune table-sym index entry)
 135   (let ((table (tune-get-table tune table-sym)))
 136     (when (>= index (length table))
 137       (setf table (adjust-array table (list (1+ index))
 138                                 :initial-element nil)))
 139     (when (aref table index)
 140       (format t "~&WARNING: ~A entry ~A already exists; replacing."
 141               table-sym index))
 142     (setf (aref table index) entry)
 143     (setf (tune-get-table tune table-sym) table)))