From 73ffd86644877fbbb8e19d328faaf8dea45ac080 Mon Sep 17 00:00:00 2001
From: Julian Squires <tek@wiw.org>
Date: Tue, 28 Dec 2004 02:49:32 +0100
Subject: [PATCH] Basic volume support.

---
 examples/demo-y.mbl     | 10 ++++++----
 src/classes.lisp        |  8 ++++++++
 src/music-parser.lisp   | 32 ++++++++++++++++++++++++++++++++
 src/replay-ymamoto.lisp | 12 +++++++++---
 4 files changed, 55 insertions(+), 7 deletions(-)

diff --git a/examples/demo-y.mbl b/examples/demo-y.mbl
index bfe20db..2b372b8 100644
--- a/examples/demo-y.mbl
+++ b/examples/demo-y.mbl
@@ -27,7 +27,8 @@ copyright "Julian Squires / 2004"
 ;;;; D minor.
 
 ABC t140
-B q4
+A v12
+B q4 v8
 
 A o2     d1            | f                 |
 B o4 @a1 [d8d16d]3 d8d | @a2 [c8c16c]3 c8c |
@@ -38,7 +39,7 @@ B [f8f16f]3 f8f | @a1 e8e16ee8e @a2 ee16ee8e |
 C r | r |
 
 ABC !loop
-C q8
+C v11 q8
 
 A q6 d4 d d d8>d<   | f4 f f f8e        |
 B @a1 [d8d16d]3 d8d | @a2 [c8c16c]3 c8c |
@@ -70,8 +71,9 @@ C c2 e4 a                    | b-2 a4 >c+                           |
 
 ;;;; A minor.
 
-B @a0 q4
-C q4
+A v-
+B @a0 q4 v+
+C q4 v+
 A o1 a4 a a a8>a   | c4 c c c8<b   |
 B o3 [a8a16a]3 a8a | [g8g16g]3 g8g |
 C o4 a8>cec a4 g   | >c4 <b8a g4 e |
diff --git a/src/classes.lisp b/src/classes.lisp
index 5649ac6..a1a42ec 100644
--- a/src/classes.lisp
+++ b/src/classes.lisp
@@ -25,6 +25,12 @@
     (setf (slot-value cmd 'value) staccato)
     cmd))
 
+(defun make-simple-volume-command (n)
+  (let ((cmd (make-instance 'music-command)))
+    (setf (slot-value cmd 'type) :volume)
+    (setf (slot-value cmd 'value) n)
+    cmd))
+
 ;; This might become a special macro-command later.
 (defun make-arpeggio-command (n)
   (let ((cmd (make-instance 'music-command)))
@@ -65,6 +71,7 @@ the current channel tempo."))
   ((octave :accessor channel-octave)
    (tempo :accessor channel-tempo)
    (staccato :accessor channel-staccato)
+   (volume :accessor channel-volume)
    (duration :accessor channel-default-duration)
    (loop-point :accessor channel-loop-point)
    ;; repeats is kind of an ugly kludge.
@@ -77,6 +84,7 @@ the current channel tempo."))
 	  (channel-tempo channel) *default-tempo*
 	  (channel-staccato channel) *default-staccato*
 	  (channel-default-duration channel) *default-duration*
+	  (channel-volume channel) 0
 	  (channel-loop-point channel) nil
 	  (channel-repeats channel) nil)
 
diff --git a/src/music-parser.lisp b/src/music-parser.lisp
index 5a6c374..dc5f36c 100644
--- a/src/music-parser.lisp
+++ b/src/music-parser.lisp
@@ -162,6 +162,32 @@
     (values (second mapping) index (funcall (third mapping) stream))))
 
 
+(defun handle-simple-volume (stream channels)
+  (assert (char= (read-char stream) #\v))
+  (let ((next-char (peek-char nil stream)))
+    (cond ((find next-char *duration-digits*)
+	   (let ((volume (expect-int stream)))
+	     (dolist (c channels)
+	       (vector-push-extend
+		(make-simple-volume-command volume)
+		(channel-data-stream c))
+	       (setf (channel-volume c) volume))))
+	  ((char= next-char #\+)
+	   (read-char stream)
+	   (dolist (c channels)
+	     (vector-push-extend
+	      (make-simple-volume-command (1+ (channel-volume c)))
+	      (channel-data-stream c))))
+	  ((char= next-char #\-)
+	   (read-char stream)
+	   (dolist (c channels)
+	     (vector-push-extend
+	      (make-simple-volume-command (1- (channel-volume c)))
+	      (channel-data-stream c))))
+	  (t (error "~&Bad volume character: v~A" next-char)))))
+
+
+
 ;;;; HIGH-LEVEL PARSE ROUTINES.
 
 ;;; We should really just create a readtable for the use of all the
@@ -311,6 +337,11 @@ Highly intolerant of malformed inputs."
 	   (dolist (c current-channels)
 	     (incf (channel-octave c))))
 
+	  ;; (Non-venv) volume changes.
+	  ((char= next-char #\v)
+	   (assert current-channels () "Command outside channels.")
+	   (handle-simple-volume stream current-channels))
+
 	  ;; Notes and rests.
 	  ((find next-char *note-characters*)
 	   (assert current-channels () "Command outside channels.")
@@ -427,6 +458,7 @@ Highly intolerant of malformed inputs."
 	 (dolist (c channels)
 	   (setf (channel-loop-point c) (channel-current-position c))))
       (END
+       (format t "~&I'm afraid !end is currently unsupported.")
        ;;; XXX how to handle this nicely?
        #+nil(dolist (c channels)
 	      (vector-push-extend (make-track-end-command)
diff --git a/src/replay-ymamoto.lisp b/src/replay-ymamoto.lisp
index 9c0a7b2..38f764e 100644
--- a/src/replay-ymamoto.lisp
+++ b/src/replay-ymamoto.lisp
@@ -93,19 +93,25 @@ multiple loops."
 	*total-frames* 0
 	*total-bytes* 0)
   (do* ((note-> 0 (1+ note->))
-	(note (aref notes note->) (aref notes note->))
+	note
 	(channel-pos 0 (1+ channel-pos)))
        ((>= note-> (length notes)))
+    (setf note (aref notes note->))
     (case (music-command-type note)
       (:note (ymamoto-output-note note channel stream))
       (:arpeggio
        (format stream "~&~8TDC.W $~X"
-	       (logior (ash #b11000000 8) (music-command-value note)))
+	       (logior (ash #b11000001 8) (music-command-value note)))
        (incf *total-bytes* 2))
       (:tempo
        (setf (channel-tempo channel) (music-command-value note)))
       (:staccato
-       (setf (channel-staccato channel) (music-command-value note))))
+       (setf (channel-staccato channel) (music-command-value note)))
+      (:volume
+       (setf (channel-volume channel) (music-command-value note))
+       (format stream "~&~8TDC.W $~X"
+	       (logior (ash #b11000011 8) (music-command-value note)))
+       (incf *total-bytes* 2)))
     (when (and (channel-loop-point channel)
 	       (= (channel-loop-point channel)
 		  channel-pos))
-- 
2.11.4.GIT