src/replay-ymamoto.lisp

   1 ;;;
   2 ;;; YMamoto conversion functions for mumble output.  These functions
   3 ;;; produce hisoft-style assembly output, which can be assembled into
   4 ;;; a binary playable by the ymamoto playroutine.
   5 ;;;
   6 ;;; Julian Squires <tek@wiw.org> / 2004
   7 ;;;
   8
   9 (in-package :mumble)
  10
  11 (defparameter *ymamoto-frequency* 50)
  12 ;; XXX: A lot of these global variables will disappear soon; I'm just lazy.
  13 (defvar *channel-delta* 0)
  14 (defvar *total-frames* 0)
  15 (defvar *total-bytes* 0)
  16 (defvar *loop-point* nil)
  17
  18 ;;;; UTILITIES
  19
  20 (defun find-and-remove-loop (list)
  21   "Finds :loop in the list, and returns two values, the list with the
  22 :loop removed, and the position of the loop.  Does not support
  23 multiple loops."
  24   (aif (position :loop list)
  25        (values (remove :loop list) it)
  26        (values list 0)))
  27
  28 (defun make-env-follow-command (options)
  29   (let ((cmd (make-instance 'music-command)))
  30     (setf (slot-value cmd 'type) :envelope-follow)
  31     (setf (slot-value cmd 'value) options)
  32     cmd))
  33
  34
  35 ;;;; INPUT-RELATED FUNCTIONS
  36
  37 (defun make-ymamoto-channels ()
  38   (list
  39    (make-channel)
  40    (make-channel)
  41    (make-channel)))
  42
  43
  44 (defun ymamoto-special-handler (stream channels)
  45   (let ((special-char (read-char stream)))
  46     (cond ((char= special-char #\e)
  47            ;; env follow
  48            (let ((next-char (peek-char nil stream)))
  49              (cond ((char= next-char #\o)
  50                     (read-char stream)
  51                     (dolist (c channels)
  52                       (vector-push-extend (make-env-follow-command :octave)
  53                                           (channel-data-stream c))))
  54                    ((char= next-char #\u)
  55                     (read-char stream)
  56                     (dolist (c channels)
  57                       (vector-push-extend (make-env-follow-command :unison)
  58                                           (channel-data-stream c))))
  59                    ((char= next-char #\0)
  60                     (read-char stream)
  61                     (dolist (c channels)
  62                       (vector-push-extend (make-env-follow-command :disable)
  63                                           (channel-data-stream c))))
  64                    (t (format t "~&Ignored bad env-follow: %e~A"
  65                               next-char)))))
  66           ;; Something else?
  67           (t (format t "~&Ignored special invocator: %~A" special-char)))))
  68
  69
  70 ;;;; OUTPUT FUNCTIONS
  71
  72 (defun ymamoto-output-note-helper (note-word frames stream
  73                                    &optional (comma nil))
  74   (incf *channel-delta* frames)
  75   (multiple-value-bind (frames leftovers) (floor *channel-delta*)
  76     (setf *channel-delta* leftovers)
  77     (setf (ldb (byte 7 8) note-word) (1- frames))
  78
  79     (when (plusp frames)
  80       (incf *total-frames* frames)
  81       (incf *total-bytes* 2)
  82       (format stream (if comma ", $~X" "~&~8TDC.W $~X") note-word))))
  83
  84
  85 (defun ymamoto-output-note (note channel stream)
  86   (let ((note-word 0)
  87         (frames (duration-to-frames (note-duration note)
  88                                     (channel-tempo channel)
  89                                     *ymamoto-frequency*))
  90         (staccato-frames 0))
  91
  92     (cond ((eql (note-tone note) :rest)
  93            (setf (ldb (byte 7 0) note-word) 127))
  94           ((eql (note-tone note) :wait)
  95            (setf (ldb (byte 7 0) note-word) 126))
  96           (t
  97            (when (/= (channel-staccato channel) 1)
  98              (setf staccato-frames (- frames (* frames
  99                                                 (channel-staccato channel))))
 100              (when (< (- frames staccato-frames) 1)
 101                (decf staccato-frames))
 102              (setf frames (- frames staccato-frames)))
 103
 104            (setf (ldb (byte 7 0) note-word) (note-tone note))))
 105
 106     (ymamoto-output-note-helper note-word frames stream)
 107     (when (plusp staccato-frames)
 108       (ymamoto-output-note-helper 127 staccato-frames stream t))))
 109
 110
 111 (defun ymamoto-output-note-stream (notes channel stream)
 112   "Traverse a note-stream, keeping track of tempo and staccato
 113   settings, and output assembly directives for this note stream."
 114   (setf *channel-delta* 0
 115         *total-frames* 0
 116         *total-bytes* 0)
 117   (do* ((note-> 0 (1+ note->))
 118         note
 119         (channel-pos 0 (1+ channel-pos)))
 120        ((>= note-> (length notes)))
 121     (setf note (aref notes note->))
 122     (case (music-command-type note)
 123       (:note (ymamoto-output-note note channel stream))
 124       (:arpeggio
 125        (format stream "~&~8TDC.W $~X"
 126                (logior (ash #b11000001 8) (music-command-value note)))
 127        (incf *total-bytes* 2))
 128       (:tempo
 129        (setf (channel-tempo channel) (music-command-value note)))
 130       (:staccato
 131        (setf (channel-staccato channel) (music-command-value note)))
 132       (:volume
 133        (setf (channel-volume channel) (music-command-value note))
 134        (format stream "~&~8TDC.W $~X"
 135                (logior (ash #b11000011 8) (music-command-value note)))
 136        (incf *total-bytes* 2))
 137       (:volume-envelope
 138        (format stream "~&~8TDC.W $~X"
 139                (logior (ash #b11000100 8) (music-command-value note)))
 140        (incf *total-bytes* 2))
 141       (:vibrato
 142        (format stream "~&~8TDC.W $~X"
 143                (logior (ash #b11001011 8) (music-command-value note)))
 144        (incf *total-bytes* 2))
 145       (:envelope-follow
 146        (format stream "~&~8TDC.W $~X"
 147                (logior (ash #b11001000 8)
 148                        (ecase (music-command-value note)
 149                          (:disable 0)
 150                          (:unison 1)
 151                          (:octave #b11)))))
 152       (t (format t "~&WARNING: YMamoto ignoring ~A."
 153                  (music-command-type note))))
 154     (when (and (channel-loop-point channel)
 155                (= (channel-loop-point channel)
 156                   channel-pos))
 157       (setf *loop-point* *total-bytes*)))
 158   (format t "~&frames: ~A, bytes: ~A" *total-frames* *total-bytes*))
 159
 160
 161 (defun output-ymamoto-header (stream)
 162   (format stream ";;; test song, in assembler form
 163
 164         ORG 0
 165 song_header:
 166         DC.W arpeggio_table>>2
 167         DC.W venv_table>>2
 168         DC.W vibrato_table>>2
 169         DC.B 0,1                ; pad, number of tracks"))
 170
 171
 172 (defun ymamoto-output-length-loop-list-table (stream name table)
 173   ;; note that the zeroth element of the table is skipped.
 174   (format stream "~&~8TALIGN 4~&~A:~%~8TDC.B ~D" name
 175           (max 0 (1- (length table))))
 176   (do ((i 1 (1+ i)))
 177       ((>= i (length table)))
 178     (multiple-value-bind (list loop) (find-and-remove-loop (aref table i))
 179       (format stream "~&~8TDC.B ~A, ~A~{, ~D~}" (length list) loop list))))
 180
 181 (defun ymamoto-output-vibrato-table (stream table)
 182   ;; note that the zeroth element of the table is skipped.
 183   (format stream "~&~8TALIGN 4~&vibrato_table:~%~8TDC.B ~D"
 184           (max 0 (1- (length table))))
 185   (do ((i 1 (1+ i)))
 186       ((>= i (length table)))
 187     (flet ((get-field (list field)
 188              (nth (1+ (or (position field list)
 189                           (error "Vibrato ~A lacks ~A!" i field))) list)))
 190       (let* ((list (aref table i))
 191              (delay (get-field list 'DELAY))
 192              (depth (get-field list 'DEPTH))
 193              (speed (get-field list 'SPEED)))
 194         (format stream "~&~8TDC.B 3, ~D, ~D, ~D, ~D" delay depth
 195                 (- 5 speed) (ash 1 (- 5 speed)))))))
 196
 197
 198
 199 ;;;; HIGH-LEVEL
 200
 201 (defun ymamoto-output-asm (tune out-file)
 202   (with-open-file (stream out-file
 203                    :direction :output
 204                    :if-exists :supersede)
 205     ;; simple header
 206     (output-ymamoto-header stream)
 207     ;; for n tracks
 208     (let ((track-num 1))
 209       (format stream "~&~8TDC.W track_~D>>2" track-num))
 210     (ymamoto-output-length-loop-list-table
 211      stream "arpeggio_table" (tune-get-table tune :arpeggio))
 212     (ymamoto-output-length-loop-list-table
 213      stream "venv_table" (tune-get-table tune :volume-envelope))
 214     (ymamoto-output-vibrato-table stream (tune-get-table tune :vibrato))
 215     ;; for n tracks
 216     (let ((track-num 1))
 217       ;; I bet the following could all be reduced to one big format
 218       ;; statement.  Yuck.
 219       (format stream "~&~8TALIGN 4~&track_~D:" track-num)
 220       (do ((c (tune-channels tune) (cdr c))
 221            (ctr (char-code #\a) (1+ ctr)))
 222           ((null c))
 223         (format stream "~&~8TDC.W channel_~A~A>>2"
 224                 track-num (code-char ctr)))
 225
 226       ;; output channels themselves.
 227       (do ((c (tune-channels tune) (cdr c))
 228            (ctr (char-code #\a) (1+ ctr)))
 229           ((null c))
 230         (format t "~&note ~A" (channel-loop-point (car c)))
 231         (format stream "~&~8TALIGN 4~&channel_~A~A:"
 232                 track-num (code-char ctr))
 233         (ymamoto-output-note-stream (channel-data-stream (car c))
 234                                     (car c)
 235                                     stream)
 236         (if (channel-loop-point (car c))
 237             (format stream "~&~8TDC.W $8001, $~X" *loop-point*)
 238             (format stream "~&~8TDC.W $8000"))))))
 239
 240 (register-replay "YMamoto"
 241                  #'ymamoto-special-handler
 242                  #'make-ymamoto-channels
 243                  #'ymamoto-output-asm)