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
  29 ;;;; INPUT-RELATED FUNCTIONS
  30
  31 (defun make-ymamoto-channels ()
  32   (list
  33    (make-channel)
  34    (make-channel)
  35    (make-channel)))
  36
  37
  38 (defun ymamoto-special-handler (stream channels)
  39   (read-char stream)
  40   (let ((next-char (read-char stream)))
  41     (cond ((char= next-char #\e)
  42            ;; env follow
  43            (format t "~&guilty env follow"))
  44           ;; Something else?
  45           (t (format t "~&Ignored special invocator: @~A" next-char)))))
  46
  47
  48 ;;;; OUTPUT FUNCTIONS
  49
  50 (defun ymamoto-output-note-helper (note-word frames stream
  51                                    &optional (comma nil))
  52   (incf *channel-delta* frames)
  53   (multiple-value-bind (frames leftovers) (floor *channel-delta*)
  54     (setf *channel-delta* leftovers)
  55     (setf (ldb (byte 7 8) note-word) (1- frames))
  56
  57     (when (plusp frames)
  58       (incf *total-frames* frames)
  59       (incf *total-bytes* 2)
  60       (format stream (if comma ", $~X" "~&~8TDC.W $~X") note-word))))
  61
  62
  63 (defun ymamoto-output-note (note channel stream)
  64   (let ((note-word 0)
  65         (frames (duration-to-frames (note-duration note)
  66                                     (channel-tempo channel)
  67                                     *ymamoto-frequency*))
  68         (staccato-frames 0))
  69
  70     (cond ((eql (note-tone note) :rest)
  71            (setf (ldb (byte 7 0) note-word) 127))
  72           ((eql (note-tone note) :wait)
  73            (setf (ldb (byte 7 0) note-word) 126))
  74           (t
  75            (when (/= (channel-staccato channel) 1)
  76              (setf staccato-frames (- frames (* frames
  77                                                 (channel-staccato channel))))
  78              (when (< (- frames staccato-frames) 1)
  79                (decf staccato-frames))
  80              (setf frames (- frames staccato-frames)))
  81
  82            (setf (ldb (byte 7 0) note-word) (note-tone note))))
  83
  84     (ymamoto-output-note-helper note-word frames stream)
  85     (when (plusp staccato-frames)
  86       (ymamoto-output-note-helper 127 staccato-frames stream t))))
  87
  88
  89 (defun ymamoto-output-note-stream (notes channel stream)
  90   "Traverse a note-stream, keeping track of tempo and staccato
  91   settings, and output assembly directives for this note stream."
  92   (setf *channel-delta* 0
  93         *total-frames* 0
  94         *total-bytes* 0)
  95   (do* ((note-> 0 (1+ note->))
  96         note
  97         (channel-pos 0 (1+ channel-pos)))
  98        ((>= note-> (length notes)))
  99     (setf note (aref notes note->))
 100     (case (music-command-type note)
 101       (:note (ymamoto-output-note note channel stream))
 102       (:arpeggio
 103        (format stream "~&~8TDC.W $~X"
 104                (logior (ash #b11000001 8) (music-command-value note)))
 105        (incf *total-bytes* 2))
 106       (:tempo
 107        (setf (channel-tempo channel) (music-command-value note)))
 108       (:staccato
 109        (setf (channel-staccato channel) (music-command-value note)))
 110       (:volume
 111        (setf (channel-volume channel) (music-command-value note))
 112        (format stream "~&~8TDC.W $~X"
 113                (logior (ash #b11000011 8) (music-command-value note)))
 114        (incf *total-bytes* 2)))
 115     (when (and (channel-loop-point channel)
 116                (= (channel-loop-point channel)
 117                   channel-pos))
 118       (setf *loop-point* *total-bytes*)))
 119   (format t "~&frames: ~A, bytes: ~A" *total-frames* *total-bytes*))
 120
 121
 122 (defun output-ymamoto-header (stream)
 123   (format stream ";;; test song, in assembler form
 124
 125         ORG 0
 126 song_header:
 127         DC.W arpeggio_table>>2  ; pointer to arpeggio table
 128         DC.W venv_table>>2      ; pointer to volume envelope table
 129         DC.B 1,0                ; number of tracks, pad"))
 130
 131
 132 (defun ymamoto-output-length-loop-list-table (stream name table)
 133   ;; note that the zeroth element of the table is skipped.
 134   (format stream "~&~8TALIGN 4~&~A:~%~8TDC.B ~D" name
 135           (max 0 (1- (length table))))
 136   (do ((i 1 (1+ i)))
 137       ((>= i (length table)))
 138     (multiple-value-bind (list loop) (find-and-remove-loop (aref table i))
 139       (format stream "~&~8TDC.B ~A, ~A~{, ~D~}" (length list) loop list))))
 140
 141
 142 ;;;; HIGH-LEVEL
 143
 144 (defun ymamoto-output-asm (tune out-file)
 145   (with-open-file (stream out-file
 146                    :direction :output
 147                    :if-exists :supersede)
 148     ;; simple header
 149     (output-ymamoto-header stream)
 150     ;; for n tracks
 151     (let ((track-num 1))
 152       (format stream "~&~8TDC.W track_~D>>2" track-num))
 153     (ymamoto-output-length-loop-list-table
 154      stream "arpeggio_table" (tune-get-table tune :arpeggio))
 155     (ymamoto-output-length-loop-list-table
 156      stream "venv_table" (tune-get-table tune :volume-envelope))
 157     ;; for n tracks
 158     (let ((track-num 1))
 159       ;; I bet the following could all be reduced to one big format
 160       ;; statement.  Yuck.
 161       (format stream "~&~8TALIGN 4~&track_~D:" track-num)
 162       (do ((c (tune-channels tune) (cdr c))
 163            (ctr (char-code #\a) (1+ ctr)))
 164           ((null c))
 165         (format stream "~&~8TDC.W channel_~A~A>>2"
 166                 track-num (code-char ctr)))
 167
 168       ;; output channels themselves.
 169       (do ((c (tune-channels tune) (cdr c))
 170            (ctr (char-code #\a) (1+ ctr)))
 171           ((null c))
 172         (format t "~&note ~A" (channel-loop-point (car c)))
 173         (format stream "~&~8TALIGN 4~&channel_~A~A:"
 174                 track-num (code-char ctr))
 175         (ymamoto-output-note-stream (channel-data-stream (car c))
 176                                     (car c)
 177                                     stream)
 178         (if (channel-loop-point (car c))
 179             (format stream "~&~8TDC.W $8001, $~X" *loop-point*)
 180             (format stream "~&~8TDC.W $8000"))))))
 181
 182 (register-replay "YMamoto"
 183                  #'ymamoto-special-handler
 184                  #'make-ymamoto-channels
 185                  #'ymamoto-output-asm)