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 ;; This might become a special macro-command later.
  29 (defun make-arpeggio-command (n)
  30   (let ((cmd (make-instance 'music-command)))
  31     (setf (slot-value cmd 'type) :arpeggio)
  32     (setf (slot-value cmd 'value) n)
  33     cmd))
  34
  35 ;; This might become a special macro-command later.
  36 (defun make-volume-envelope-command (n)
  37   (let ((cmd (make-instance 'music-command)))
  38     (setf (slot-value cmd 'type) :volume-envelope)
  39     (setf (slot-value cmd 'value) n)
  40     cmd))
  41
  42
  43 (defclass note (music-command)
  44   ((tone :reader note-tone)
  45    (duration :reader note-duration))
  46   (:documentation "Notes encapsulate an absolute pitch (the TONE slot)
  47 and a relative length (the DURATION slot).  DURATION is relative to
  48 the current channel tempo."))
  49
  50 (defun make-note (tone duration)
  51   (let ((note (make-instance 'note)))
  52     (setf (slot-value note 'type) :note)
  53     (setf (slot-value note 'tone) tone)
  54     (setf (slot-value note 'duration) duration)
  55     note))
  56
  57 (defmethod print-object ((obj note) stream)
  58   (print-unreadable-object (obj stream :type t)
  59     (princ (note-tone obj) stream)
  60     (princ #\Space stream)
  61     (princ (note-duration obj) stream)))
  62
  63
  64 (defclass channel ()
  65   ((octave :accessor channel-octave)
  66    (tempo :accessor channel-tempo)
  67    (staccato :accessor channel-staccato)
  68    (duration :accessor channel-default-duration)
  69    (loop-point :accessor channel-loop-point)
  70    ;; repeats is kind of an ugly kludge.
  71    (repeats :accessor channel-repeats)
  72    (data-stream :accessor channel-data-stream)))
  73
  74 (defun make-channel ()
  75   (let ((channel (make-instance 'channel)))
  76     (setf (channel-octave channel) *default-octave*
  77           (channel-tempo channel) *default-tempo*
  78           (channel-staccato channel) *default-staccato*
  79           (channel-default-duration channel) *default-duration*
  80           (channel-loop-point channel) nil
  81           (channel-repeats channel) nil)
  82
  83     (setf (channel-data-stream channel)
  84           (make-array '(0) :adjustable t :fill-pointer 0))
  85     channel))
  86
  87 (defun channel-current-position (channel)
  88   (fill-pointer (channel-data-stream channel)))
  89
  90 (defun copy-and-append-channel-data (channel begin end)
  91   (loop for x from begin to end
  92        do (vector-push-extend (aref (channel-data-stream channel) x)
  93                               (channel-data-stream channel))))
  94
  95
  96 (defclass tune ()
  97   ((channels :accessor tune-channels)
  98    (replay :accessor tune-replay)
  99    (tables :accessor tune-tables)
 100    (metadata :accessor tune-metadata)))
 101
 102 (defun make-tune ()
 103   (let ((tune (make-instance 'tune)))
 104     (setf (tune-metadata tune) nil)
 105     (setf (tune-tables tune) nil)
 106     tune))
 107
 108 (defun tune-get-table (tune table-sym)
 109   (cdr (assoc table-sym (tune-tables tune))))
 110
 111 (defun (setf tune-get-table) (value tune table-sym)
 112   (setf (cdr (assoc table-sym (tune-tables tune))) value))
 113
 114 (defun tune-add-table (tune table-sym)
 115   (push (cons table-sym (make-array '(0) :initial-element nil
 116                                     :adjustable t))
 117         (tune-tables tune)))
 118
 119 (defun tune-add-to-table (tune table-sym index entry)
 120   (let ((table (tune-get-table tune table-sym)))
 121     (when (>= index (length table))
 122       (setf table (adjust-array table (list (1+ index))
 123                                 :initial-element nil)))
 124     (when (aref table index)
 125       (format t "~&WARNING: ~A entry ~A already exists; replacing."
 126               table-sym index))
 127     (setf (aref table index) entry)
 128     (setf (tune-get-table tune table-sym) table)))