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 (aref notes note->) (aref notes note->))
  97         (channel-pos 0 (1+ channel-pos)))
  98        ((>= note-> (length notes)))
  99     (case (music-command-type note)
 100       (:note (ymamoto-output-note note channel stream))
 101       (:arpeggio
 102        (format stream "~&~8TDC.W $~X"
 103                (logior (ash #b11000000 8) (music-command-value note)))
 104        (incf *total-bytes* 2))
 105       (:tempo
 106        (setf (channel-tempo channel) (music-command-value note)))
 107       (:staccato
 108        (setf (channel-staccato channel) (music-command-value note))))
 109     (when (and (channel-loop-point channel)
 110                (= (channel-loop-point channel)
 111                   channel-pos))
 112       (setf *loop-point* *total-bytes*)))
 113   (format t "~&frames: ~A, bytes: ~A" *total-frames* *total-bytes*))
 114
 115
 116 (defun output-ymamoto-header (stream)
 117   (format stream ";;; test song, in assembler form
 118
 119         ORG 0
 120 song_header:
 121         DC.W arpeggio_table>>2  ; pointer to arpeggio table
 122         DC.W venv_table>>2      ; pointer to volume envelope table
 123         DC.B 1,0                ; number of tracks, pad"))
 124
 125
 126 (defun ymamoto-output-length-loop-list-table (stream name table)
 127   ;; note that the zeroth element of the table is skipped.
 128   (format stream "~&~8TALIGN 4~&~A:~%~8TDC.B ~D" name
 129           (max 0 (1- (length table))))
 130   (do ((i 1 (1+ i)))
 131       ((>= i (length table)))
 132     (multiple-value-bind (list loop) (find-and-remove-loop (aref table i))
 133       (format stream "~&~8TDC.B ~A, ~A~{, ~D~}" (length list) loop list))))
 134
 135
 136 ;;;; HIGH-LEVEL
 137
 138 (defun ymamoto-output-asm (tune out-file)
 139   (with-open-file (stream out-file
 140                    :direction :output
 141                    :if-exists :supersede)
 142     ;; simple header
 143     (output-ymamoto-header stream)
 144     ;; for n tracks
 145     (let ((track-num 1))
 146       (format stream "~&~8TDC.W track_~D>>2" track-num))
 147     (ymamoto-output-length-loop-list-table
 148      stream "arpeggio_table" (tune-get-table tune :arpeggio))
 149     (ymamoto-output-length-loop-list-table
 150      stream "venv_table" (tune-get-table tune :volume-envelope))
 151     ;; for n tracks
 152     (let ((track-num 1))
 153       ;; I bet the following could all be reduced to one big format
 154       ;; statement.  Yuck.
 155       (format stream "~&~8TALIGN 4~&track_~D:" track-num)
 156       (do ((c (tune-channels tune) (cdr c))
 157            (ctr (char-code #\a) (1+ ctr)))
 158           ((null c))
 159         (format stream "~&~8TDC.W channel_~A~A>>2"
 160                 track-num (code-char ctr)))
 161
 162       ;; output channels themselves.
 163       (do ((c (tune-channels tune) (cdr c))
 164            (ctr (char-code #\a) (1+ ctr)))
 165           ((null c))
 166         (format t "~&note ~A" (channel-loop-point (car c)))
 167         (format stream "~&~8TALIGN 4~&channel_~A~A:"
 168                 track-num (code-char ctr))
 169         (ymamoto-output-note-stream (channel-data-stream (car c))
 170                                     (car c)
 171                                     stream)
 172         (if (channel-loop-point (car c))
 173             (format stream "~&~8TDC.W $8001, $~X" *loop-point*)
 174             (format stream "~&~8TDC.W $8000"))))))
 175
 176 (register-replay "YMamoto"
 177                  #'ymamoto-special-handler
 178                  #'make-ymamoto-channels
 179                  #'ymamoto-output-asm)