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