;;; -*- MODE:LISP; Package:(OMIDI GLOBAL); Base:10; readtable: ZL -*-

(defvar *midi-vcmem-quad-slot* #xf8)

(defun midi-vcmem-setup ()
  (dolist (x '(0 0 0
		 #x18
		 #x01 #x18
		 #x03 #xc1
		 #x04 #xc4
		 #x05 #xea
		 ))
    (%nubus-write *midi-vcmem-quad-slot* (* #o15 4) x))
  )

(defsubst midi-vcmem-char-available-p ()
  (ldb-test (byte 1 0) (%nubus-read *midi-vcmem-quad-slot* (* #o15 4))))

(defun midi-vcmem-tyi ()
  (cond ((null (midi-vcmem-char-available-p))
	 (process-wait "Tyi" 'midi-vcmem-char-available-p)))
  (ldb (byte 8 0) (%nubus-read *midi-vcmem-quad-slot* (* #o14 4))))

(defun midi-vcmem-tyi-busy-wait ()
  (do ()
      ((midi-vcmem-char-available-p)))
  (ldb (byte 8 0) (%nubus-read *midi-vcmem-quad-slot* (* #o14 4))))

(defun midi-vcmem-tyi-busy-wait-or-throw ()
  (do ()
      ((midi-vcmem-char-available-p))
    (if (TV:KBD-HARDWARE-CHAR-AVAILABLE)
	(throw 'done nil)))
  (ldb (byte 8 0) (%nubus-read *midi-vcmem-quad-slot* (* #o14 4))))

(defvar midi-array (make-array 10000.))

(defun get-midi-array ()
  (get-midi-array-init)
  (get-midi-array-internal))

(defun get-midi-array-init ()
  (fillarray midi-array nil)
  (send *terminal-io* :clear-input)		;avoid premature dropout of below loop.
  )

(defun get-midi-array-internal ()
  (catch 'done
    (without-interrupts
      (dotimes (x (- (array-length midi-array) 10.))
	(aset (midi-vcmem-tyi-busy-wait-or-throw) midi-array x)))))

(defun print-just-notes ()
  (prog (state (i -1) char key vel)
    next
	(setq i (1+ i))
	(setq char (aref midi-array i))
	(cond ((null char)
	       (return nil))
	      ((zerop (ldb (byte 1 7) char))
	       (cond ((eq state 'on-first)
		      (setq key char)
		      (setq state 'on-second)
		      (go next))
		     ((eq state 'on-second)
		      (setq vel char)
		      (format t "~&~d ~d" key vel)
		      (setq state 'on-first)
		      (go next))
		     (t
		      (go next))))
	      ((= (ldb (byte 3 4) char) 7)
	       (go next))
	      ((= (ldb (byte 3 4) char) 1)
	       (setq state 'on-first)
	       (go next))
	      (t
	       (setq state nil)
	       (go next)))))

(defun return-just-notes ()
  (prog (state (i -1) char key vel answer)
    next
	(setq i (1+ i))
	(setq char (aref midi-array i))
	(cond ((null char)
	       (return (reverse answer)))
	      ((zerop (ldb (byte 1 7) char))
	       (cond ((eq state 'on-first)
		      (setq key char)
		      (setq state 'on-second)
		      (go next))
		     ((eq state 'on-second)
		      (setq vel char)
		      (if (not (= 0 vel))
			  (push key answer))
		      (setq state 'on-first)
		      (go next))
		     (t
		      (go next))))
	      ((= (ldb (byte 3 4) char) 7)
	       (go next))
	      ((= (ldb (byte 3 4) char) 1)
	       (setq state 'on-first)
	       (go next))
	      (t
	       (setq state nil)
	       (go next)))))

(defun print-midi-array ()
  (format t "~&")
  (do* ((i 0 (1+ i))
	(char (aref midi-array i) (aref midi-array i)))
       ((or (>= i (array-length midi-array))
	    (null char)))
    (cond ((zerop (ldb (byte 1 7) char))
	   (format t "~2x " char))
	  (t
	   (select (ldb (byte 3 4) char)
	     (0 (format t "~&OFF ~8t~x ~16t~d. ~24t~d."
			(ldb (byte 4 0) char)
			(progn (setq i (1+ i)) (aref midi-array i))
			(progn (setq i (1+ i)) (aref midi-array i))))
	     (1 (format t "~&ON ~8t~x ~16t~d. ~24t~d."
			(ldb (byte 4 0) char)
			(progn (setq i (1+ i)) (aref midi-array i))
			(progn (setq i (1+ i)) (aref midi-array i))))
	     (3 (format t "~&Control ~8t~x ~16t~d. ~24t~d."
			(ldb (byte 4 0) char)
			(progn (setq i (1+ i)) (aref midi-array i))
			(progn (setq i (1+ i)) (aref midi-array i))))
	     (4 (format t "~&Program ~8t~x ~16t~d."
			(ldb (byte 4 0) char)
			(progn (setq i (1+ i)) (aref midi-array i))))
	     (7 (format t "~&Real time ~x"
			char))
	     (t (format t "~&~x ~8t~x ~16t~d. ~24t~d."
			char
			(ldb (byte 4 0) char)
			(progn (setq i (1+ i)) (aref midi-array i))
			(progn (setq i (1+ i)) (aref midi-array i)))))))))

(defsubst midi-vcmem-output-buffer-empty-p ()
  (ldb-test (byte 1 2) (%nubus-read *midi-vcmem-quad-slot* (* #o15 4))))

(defun midi-vcmem-tyo (c)
  (do ()
      ((midi-vcmem-output-buffer-empty-p)))
  (%nubus-write *midi-vcmem-quad-slot* (* #o14 4) c))

(defun midi-tyo (char &optional status)
  (if status
      (midi-vcmem-tyo char)
    (midi-vcmem-tyo (logand #o177 char))))

;----

(defun @note-off (note &optional (channel 0) (velocity 64.))
  (midi-tyo (dpb channel (byte 4 0) #x80) t)
  (midi-tyo note)
  (midi-tyo velocity))

(defun @note-on (note &optional (channel 0) (velocity 64.))
  (midi-tyo (dpb channel (byte 4 0) #x90) t)
  (midi-tyo note)
  (midi-tyo velocity))

(defun @key-after-touch (note &optional (channel 0) (velocity 64.))
  (midi-tyo (dpb channel (byte 4 0) #xa0) t)
  (midi-tyo note)
  (midi-tyo velocity))

(defun @control-change (control-number &optional (channel 0) (value 0))
  (midi-tyo (dpb channel (byte 4 0) #xb0) t)
  (midi-tyo control-number)
  (midi-tyo value))

(defun @program-change (program-number &optional (channel 0))
  (midi-tyo (dpb channel (byte 4 0) #xc0) t)
  (midi-tyo program-number))

(defun @channel-after-touch (value &optional (channel 0))
  (midi-tyo (dpb channel (byte 4 0) #xd0) t)
  (midi-tyo value))

(defun @pitch-wheel (value &optional (channel 0))
  (midi-tyo (dpb channel (byte 4 0) #xe0) t)
  (midi-tyo (ldb (byte 7 0) value))
  (midi-tyo (ldb (byte 7 7) value)))

;----

(defun set-controller-value (controller value &optional (channel 0))
  (cond ((< controller 32.)
	 (@control-change controller channel (ldb (byte 7 0) value)) ;LSB
	 (@control-change (+ 32. controller) channel (ldb (byte 7 7) value)) ;MSB
	 )
	((< controller 122.)
	 (@control-change controller channel value))
	(t
	 (ferror nil "reserved"))))

(defun all-notes-off (&optional (channel 0))
  (@control-change 123. channel 0))

(defun omni-mode (on-p &optional (channel 0))
  (if on-p
      (@control-change 124. channel 0)
    (@control-change 125. channel 0)))

(defun poly-mode (on-p &optional (channel 0))
  on-p
  (@control-change 127. channel 0))

;----

;MKS-10 sound module stuff

;7 bits
;<0>   I or II
;<1:3> piano (long default), clavi (short), harps (long), e-piano (long)
;<4>   release time
;<7:5> normal, chorus, flanger, tremoro sine,
;      tremoro square, chorus & tremoro sine, chorus & tremoro square, flanger & tremoro sine

(defun mks-10-set-program (color chorus-or-flanger tremoro-type &optional (channel 0))
  (@program-change
   (+ (selectq chorus-or-flanger
	(chorus
	 (selectq tremoro-type
	   (sine 80.)
	   (square 96.)
	   (nil 16.)
	   (t (ferror nil "unknown"))))
	(flanger
	 (selectq tremoro-type
	   (sine 112.)
	   (nil 32.)
	   (t (ferror nil "unknown"))))
	(nil
	 (selectq tremoro-type
	   (sine 48.)
	   (square 64.)
	   (nil 0)
	   (t (ferror nil "unknown")))))
      color
      )
   channel))

(defvar *mks-10-main-color* 'piano)
(defvar *mks-10-i-or-ii* 'i)
(defvar *mks-10-default-release-time-p* 'normal)
(defvar *mks-10-chorus-or-flanger* nil)
(defvar *mks-10-tremoro-type* nil)
(defvar *default-channel* 0)

(defun mks-10-choose-program-from-menu ()
  (let ((base 10.) (ibase 10.))
    (tv:choose-variable-values
      '(
	(*default-channel* "Channel" :choose (0 1 2 3 4 5 6 7 8 9 10. 11. 12. 13. 14. 15.))
	(*mks-10-main-color* "Main Color" :choose (piano clavi harps e-piano))
	(*mks-10-i-or-ii* "Sub-color" :choose (I II))
	(*mks-10-default-release-time-p* "Release time" :choose (normal special))
	(*mks-10-chorus-or-flanger* "Chorus or Flanger" :choose (chorus flanger neither))
	(*mks-10-tremoro-type* "Tremoro type" :choose (sine square none))
	)
      ))
  (mks-10-set-program
    (+ (ash (find-position-in-list *mks-10-main-color* '(piano clavi harps e-piano)) 1)
       (if (eq *mks-10-i-or-ii* 'i) 0 1)
       (if (eq *mks-10-default-release-time-p* 'normal) 0 8))
    (if (eq *mks-10-chorus-or-flanger* 'neither) nil *mks-10-chorus-or-flanger*)
    (if (eq *mks-10-tremoro-type* 'none) nil *mks-10-tremoro-type*)
    *default-channel*))

(defun setup ()
  (mks-10-choose-program-from-menu))

(defun mks-10-damper (on-p &optional (channel 0))
  (@control-change 64. channel (if on-p #o127 0)))

;tx816 stuff

(defun yamaha-tf1-request-dump (channel format-code)
  (midi-tyo #xF0 t)
  (midi-tyo #x43)
  (midi-tyo (dpb channel (byte 4 0) #x20))
  (midi-tyo format-code)
  (midi-tyo #o367))

(defun test-request-dump (channel format-code)
  (get-midi-array-init)
  (yamaha-tf1-request-dump channel format-code)
  (get-midi-array-internal)
  (@note-on 60.)	;seems to be necessary to unwedge MKB-1000
  (process-sleep 20)
  (@note-off 60.))

(defun save-tx (filename &optional (n-tfs 4))
  (with-open-file (*standard-output* (string-append "ed-buffer:" filename) :direction :output)
    (dotimes (n n-tfs)
      (save-tf (1+ n)))))

(defun save-tf (slot)
  (format *terminal-io* "~%Please set OUT SLOT to ~D, then type MIDI channel for that TF.  " slot)
  (let ((channel (1- (read *terminal-io*))))
    (format t "~%>> slot ~d on channel ~d" slot (1+ channel))
    (test-request-dump channel 9)		;32 voice bulk
    (decode-yamaha-system-exclusive 0 t)
    (test-request-dump channel 2)
    (decode-yamaha-system-exclusive 0 t)	;64 voice bulk
    (test-request-dump channel 125.)
    (decode-yamaha-system-exclusive 0 t)	;condition acknowledge
    ))

(defun find-system-exclusive (&optional (start-idx 0) (manufacture-code #x43))		;#x43 is yamaha
  (do* ((idx start-idx (+ idx 1))
	(ch (aref midi-array idx) (aref midi-array idx))
	(system-exclusive-flag nil))
       ((null ch) nil)
    (cond ((null system-exclusive-flag)
	   (if (= ch #xF0) (setq system-exclusive-flag t)
	     (setq system-exclusive-flag nil)))
	  (t
	   (if (= ch manufacture-code) (return (1+ idx))
	     (setq system-exclusive-flag nil))))	;should skip whole system exclusive block of other manufacture.
    ))

(defun decode-yamaha-system-exclusive (&optional (start-idx 0) (dump-octal nil))
  (prog (base-idx found-block)
	(setq base-idx start-idx)
     top
	(setq start-idx base-idx)
	(setq base-idx (find-system-exclusive base-idx))
	(cond ((null base-idx)
	       (if (null found-block)
		   (ferror "unable to find block starting at ~s" start-idx))
	       (return start-idx)))
	(setq found-block t)
	(let ((sub-status-ch (aref midi-array base-idx))
	      (format-number (aref midi-array (1+ base-idx)))
	      (byte-count (dpb (aref midi-array (+ 2 base-idx))
			       (byte 7 7)
			       (aref midi-array (+ 3 base-idx)))))
	  (format t "~%Substatus ~X, format number ~X, byte count ~D"
		  sub-status-ch format-number byte-count)
	  (let ((cks 0)
		(cks-from-block (aref midi-array (+ base-idx 4 byte-count))))
	    (dotimes (bc byte-count)
	      (setq cks (+ cks (aref midi-array (+ base-idx 4 bc)))))
	    (if (zerop (logand #o177 (+ cks cks-from-block)))
		(format t "~%Checksum OK")
		(format t "~%Checksum differs! Sum of block = ~o, checksum character = ~o"
			(logand cks #o177) cks-from-block)))
	  (cond ((not (= (aref midi-array (+ base-idx 4 byte-count 1))
			 #o367))
		 (format t "~%EOX not found where expected, code is ~o"
			 (aref midi-array (+ base-idx 4 byte-count 1)))))
	  (select format-number
	    (9
	     (decode-yamaha-32-voice-bulk-data (+ base-idx 4) byte-count))
	    (2
	     (decode-yamaha-64-performance-bulk-data (+ base-idx 4) byte-count))
	    (125
	     (decode-yamaha-condition-acknowledge (+ base-idx 4) byte-count))
	    (otherwise (ferror nil "I dont know about format ~X" format-number)))
	  (cond (dump-octal
		 (format t "~%**--**~%")
		 (dotimes (c 6)
		   (format t "~3o " (aref midi-array (+ base-idx c -1))))  ;-1 starts with the #xF0.
		 (format t "~%")
		 (let ((lines (ceiling byte-count 16.)))
		   (dotimes (l lines)
		     (dotimes (p 16.)
		       (let ((byte-adr (+ (* l 16.) p)))
			 (cond ((< byte-adr byte-count)
				(format t "~3o " (aref midi-array (+ base-idx byte-adr 4)))))))
		     (format t "~%")))
		 (format t "~%check ~3o ~3o~%" (aref midi-array (+ base-idx 4 byte-count))
			 (aref midi-array (+ base-idx 4 byte-count 1)))))	;EOX
	  (setq base-idx (+ base-idx 4 byte-count 2))
	  (go top))))

;if they were old time hackers, they would have done this..
(defun 7-bit-ones-comp-add (a b)
  (let ((sum (+ a b)))
    (logand #o177 (+ sum (ldb (byte 1 7) sum)))))

(defun decode-yamaha-condition-acknowledge (base-idx byte-count)
  (cond ((not (= byte-count 16.))
	 (ferror "incorrect byte count")))
  (format t "~% System Acknowledge: ~s, Soft version ~D, rev ~D, "
	  (get-string-from-midi base-idx 10.)
	  (aref midi-array (+ base-idx 10.))
	  (aref midi-array (+ base-idx 11.)))
  (let ((parameter-ch (aref midi-array (+ base-idx 12.))))
    (format t "~%Omni ~D, Memory protect ~D, Data-entry-rcv ~D"
	    (ldb (byte 1 4) parameter-ch)
	    (ldb (byte 1 5) parameter-ch)
	    (ldb (byte 1 6) parameter-ch)))
  (format t "~%Receive-channel ~D, Battery ~D, unused ~D"
	  (aref midi-array (+ base-idx 13))
	  (aref midi-array (+ base-idx 14))
	  (aref midi-array (+ base-idx 15))))

(defun decode-yamaha-64-performance-bulk-data (base-idx byte-count)
  (cond ((not (= byte-count 4096.))
	 (ferror "incorrect byte count")))
  (dotimes (p 32.)	;only first 32. used.
    (decode-yamaha-performance-bulk p (+ base-idx (* p 64.)))))

(defun decode-yamaha-performance-bulk (p base-idx)
  (let ((a-poly (ldb (byte 1 7) (aref midi-array (+ base-idx 0))))
	(a-pbr  (ldb (byte 4 0) (aref midi-array (+ base-idx 1))))
	(a-pbs  (dpb (ldb (byte 1 7) (aref midi-array (+ base-idx 15.)))
		   (byte 1 3)
		   (ldb (byte 3 4) (aref midi-array (+ base-idx 1)))))
	(a-ptim (ldb (byte 7 0) (aref midi-array (+ base-idx 2))))
	(a-gl   (ldb (byte 1 0) (aref midi-array (+ base-idx 3))))
	(a-m    (ldb (byte 1 1) (aref midi-array (+ base-idx 3))))
	(a-mws  (ldb (byte 4 0) (aref midi-array (+ base-idx 4))))
	(a-mwa  (ldb (byte 3 4) (aref midi-array (+ base-idx 4))))
	(a-fcs  (ldb (byte 4 0) (aref midi-array (+ base-idx 5))))
	(a-fca  (ldb (byte 3 4) (aref midi-array (+ base-idx 5))))
	(a-ats  (ldb (byte 4 0) (aref midi-array (+ base-idx 6))))
	(a-ata  (ldb (byte 3 4) (aref midi-array (+ base-idx 6))))
	(a-bcs  (ldb (byte 4 0) (aref midi-array (+ base-idx 7))))
	(a-bca  (ldb (byte 3 4) (aref midi-array (+ base-idx 7))))

	(a-atn  (ldb (byte 3 0) (aref midi-array (+ base-idx 14.))))

	(b-poly (ldb (byte 1 7) (aref midi-array (+ base-idx 0 16.))))
	(b-pbr  (ldb (byte 4 0) (aref midi-array (+ base-idx 1 16.))))
	(b-pbs  (dpb (ldb (byte 1 7) (aref midi-array (+ base-idx 15. 16.)))
		   (byte 1 3)
		   (ldb (byte 3 4) (aref midi-array (+ base-idx 1 16.)))))
	(b-ptim (ldb (byte 7 0) (aref midi-array (+ base-idx 2 16.))))
	(b-gl   (ldb (byte 1 0) (aref midi-array (+ base-idx 3 16.))))
	(b-m    (ldb (byte 1 1) (aref midi-array (+ base-idx 3 16.))))
	(b-mws  (ldb (byte 4 0) (aref midi-array (+ base-idx 4 16.))))
	(b-mwa  (ldb (byte 3 4) (aref midi-array (+ base-idx 4 16.))))
	(b-fcs  (ldb (byte 4 0) (aref midi-array (+ base-idx 5 16.))))
	(b-fca  (ldb (byte 3 4) (aref midi-array (+ base-idx 5 16.))))
	(b-ats  (ldb (byte 4 0) (aref midi-array (+ base-idx 6 16.))))
	(b-ata  (ldb (byte 3 4) (aref midi-array (+ base-idx 6 16.))))
	(b-bcs  (ldb (byte 4 0) (aref midi-array (+ base-idx 7 16.))))
	(b-bca  (ldb (byte 3 4) (aref midi-array (+ base-idx 7 16.))))

	(b-atn  (ldb (byte 3 0) (aref midi-array (+ base-idx 14. 16.))))

	(kmod   (ldb (byte 2 0) (aref midi-array (+ base-idx 32.))))
	(vms    (ldb (byte 1 2) (aref midi-array (+ base-idx 32.))))
	(perf-name (get-string-from-midi (+ base-idx 34.) 30.)))
    (format t "~% Performance ~D: ~s" p perf-name)
    (format t "~%   kmod ~d, vms ~d" kmod vms)
    (format t "~% Voice A: poly ~D, pbr ~D, pbs ~d, ptim ~D, gl ~D, m ~D,
        mws ~D, mwa ~D, fcs ~D, fca ~D, ats ~D, ata ~D, bcs ~D, bca ~D, atn ~D"
	    a-poly a-pbr a-pbs a-ptim a-gl a-m
	    a-mws a-mwa a-fcs a-fca a-ats a-ata a-bcs a-bca a-atn)
    (format t "~% Voice B: poly ~D, pbr ~D, pbs ~d, ptim ~D, gl ~D, m ~D,
        mws ~D, mwa ~D, fcs ~D, fca ~D, ats ~D, ata ~D, bcs ~D, bca ~D, atn ~D"
	    b-poly b-pbr b-pbs b-ptim b-gl b-m
	    b-mws b-mwa b-fcs b-fca b-ats b-ata b-bcs b-bca b-atn)
    ))

(defun decode-yamaha-32-voice-bulk-data (base-idx byte-count)
  (cond ((not (= byte-count 4096.))
	 (ferror "incorrect byte count")))
  (dotimes (v 32.)
    (decode-yamaha-voice-bulk v (+ base-idx (* v 128.)))))

(defun decode-yamaha-voice-bulk (v base-idx)
  (let ((pr1 (ldb (byte 7 0) (aref midi-array (+ base-idx 102.))))
	(pr2 (ldb (byte 7 0) (aref midi-array (+ base-idx 103.))))
	(pr3 (ldb (byte 7 0) (aref midi-array (+ base-idx 104.))))
	(pr4 (ldb (byte 7 0) (aref midi-array (+ base-idx 105.))))
	(pl1 (ldb (byte 7 0) (aref midi-array (+ base-idx 106.))))
	(pl2 (ldb (byte 7 0) (aref midi-array (+ base-idx 107.))))
	(pl3 (ldb (byte 7 0) (aref midi-array (+ base-idx 108.))))
	(pl4 (ldb (byte 7 0) (aref midi-array (+ base-idx 109.))))
	(als (ldb (byte 5 0) (aref midi-array (+ base-idx 110.))))
	(fb (ldb (byte 3 0) (aref midi-array (+ base-idx 111.))))
	(oks (ldb (byte 1 3) (aref midi-array (+ base-idx 111.))))
	(lfs (ldb (byte 7 0) (aref midi-array (+ base-idx 112.))))
	(lfd (ldb (byte 7 0) (aref midi-array (+ base-idx 113.))))
	(lpmd (ldb (byte 7 0) (aref midi-array (+ base-idx 114.))))
	(lamd (ldb (byte 7 0) (aref midi-array (+ base-idx 115.))))
	(lfks (ldb (byte 1 0) (aref midi-array (+ base-idx 116.))))
	(lfw (ldb (byte 3 1) (aref midi-array (+ base-idx 116.))))
	(lpms (ldb (byte 3 4) (aref midi-array (+ base-idx 116.))))
	(trnp (ldb (byte 7 0) (aref midi-array (+ base-idx 117.))))
	(voice-name (get-string-from-midi (+ base-idx 118.) 10.)))
    (format t "~%***   Voice name ~s" voice-name)
    (dotimes (op 6)
      (decode-yamaha-operator-bulk v (- 6 op) (+ base-idx (* op 17.))))
    (format t "~% PR1: ~D, PR2: ~D, PR3: ~D, PR4: ~D, PL1: ~D, PL2: ~D, PL3: ~D, PL4: ~D
 ALS: ~D, FB: ~D, OKS: ~D, LFS: ~D, LFD: ~D, LPMD: ~D, LAMD: ~D, 
 LFKS: ~D, LFW: ~D, LPMS: ~D, TRNP: ~D"
	    PR1 PR2 PR3 PR4 PL1 PL2 PL3 PL4 ALS FB OKS LFS LFD LPMD LAMD LFKS LFW LPMS TRNP)))

(defun get-string-from-midi (base-idx count)
  (let ((ans (make-string count)))
    (dotimes (c count)
      (aset (aref midi-array (+ base-idx c))
	    ans
	    c))
    ans))

(defun decode-yamaha-operator-bulk (v op base-idx)
  (let ((r1 (ldb (byte 7 0) (aref midi-array base-idx)))
	(r2 (ldb (byte 7 0) (aref midi-array (+ base-idx 1))))
	(r3 (ldb (byte 7 0) (aref midi-array (+ base-idx 2))))
	(r4 (ldb (byte 7 0) (aref midi-array (+ base-idx 3))))
	(l1 (ldb (byte 7 0) (aref midi-array (+ base-idx 4))))
	(l2 (ldb (byte 7 0) (aref midi-array (+ base-idx 5))))
	(l3 (ldb (byte 7 0) (aref midi-array (+ base-idx 6))))
	(l4 (ldb (byte 7 0) (aref midi-array (+ base-idx 7))))
	(bp (ldb (byte 7 0) (aref midi-array (+ base-idx 8))))
	(ld (ldb (byte 7 0) (aref midi-array (+ base-idx 9))))
	(rd (ldb (byte 7 0) (aref midi-array (+ base-idx 10.))))
	(lc (ldb (byte 2 0) (aref midi-array (+ base-idx 11.))))
	(rc (ldb (byte 2 2) (aref midi-array (+ base-idx 11.))))
	(rs (ldb (byte 3 0) (aref midi-array (+ base-idx 12.))))
	(pd (ldb (byte 4 3) (aref midi-array (+ base-idx 12.))))
	(ams (ldb (byte 2 0) (aref midi-array (+ base-idx 13.))))
	(kvs (ldb (byte 3 2) (aref midi-array (+ base-idx 13.))))
	(ol (ldb (byte 7 0) (aref midi-array (+ base-idx 14.))))
	(m (ldb (byte 1 0) (aref midi-array (+ base-idx 15.))))
	(fc (ldb (byte 5 1) (aref midi-array (+ base-idx 15.))))
	(ff (ldb (byte 7 0) (aref midi-array (+ base-idx 16.)))))
    (format t "~%Voice ~D, OP ~D, R1 ~D, R2 ~D, R3 ~D, R4 ~D, L1 ~D, L2 ~D, L3 ~D, L4 ~D, 
   BP ~D, LD ~D, RD ~D, LC ~D, RC ~D, RS ~D, PD ~D, AMS ~D, KVS ~D, OL ~D, M ~D, FC ~D, FF ~D"
	    (1+ V) OP R1 R2 R3 R4 L1 L2 L3 L4
	    BP LD RD LC RC RS PD AMS KVS OL M FC FF)
    ))
    
;parameter block "language"
(DEFCONST 32-VOICE-BULK-DATA
	  '(repeat 6 "OP" 0 17.
		   (repeat 4 " EG-RATE"  0 1 (integer nil 0 0 99))
		   (repeat 4 " EG-LEVEL" 4 1 (integer nil 0 0 99))
		   (integer " Scaling-Break" 8 0 99 yamaha-code-to-key)
		   (integer " Left-scaling-depth" 9 0 99)
		   (integer " Right-scaling-depth" 10 0 99)
		   (byte " Left-scaling-curve" (byte 2 0) 11 0 3 yamaha-code-to-scaling-curve)
		   (byte " Right-scaling-curve" (byte 2 2) 11 0 3 yamaha-code-to-scaling-curve)
		   (byte " Osc detune" (byte 3 0) 12 0 14 yamaha-code-to-detune)
		   ))
		   
;---
;middle c is 60.

(defun play-scale (&optional (delay 20))
  (dolist (note '(60. 62. 64. 65. 67. 69. 71. 72. 71. 69. 67. 65. 64. 62. 60.))
    (@note-on note)
    (process-sleep delay)
    (@note-off note)))

(defun chromatic-scale ()
  (dotimes (i 127.)
    (play-note i 10)))

(defun chromatic-scale-down ()
  (dotimes (i 127.)
    (play-note (- 127. i) 0)))

(defun twinkle ()
  (do-forever (play-note (random 127.) 0)))

(defun play-note (note length &optional (loudness 64.))
  (unwind-protect
      (progn
	(@note-on note 0 loudness)
	(process-sleep (// length 2)))
    (@note-off note)))

(defun all-off (&optional (channel 0))
  (@control-change 123. channel 0))

(deff quiet 'all-off)

(defun win ()
  (play-note 67. 10.)
  (play-note 65. 10.)
  (play-note 67. 10.)
  (play-note 62. 20.)
  (play-note 64. 10.)
  (play-note 60. 30.)
  (play-note 72. 10.))

;----

(defmacro with-quietness-at-the-end (&body body)
  `(condition-bind ((condition) #'(lambda (&rest ignore) (quiet) nil))
     ,@body))

;simple scheme

; list of lists
;  sub-list:  (time-from-start note velocity)
(defvar *simple-note-list* nil)

(defun play-simple-notes (&optional (note-list *simple-note-list*))
  (let ((start-time (time)))
    (dolist (note-desc note-list)
      (do ()
	  ((time-lessp (time-increment start-time (fix (car note-desc)))
		       (time))))
      (cond ((numberp (cadr note-desc))
	     (@note-on (cadr note-desc) 0 (caddr note-desc)))
	    (t
	     (selectq (cadr note-desc)
	       (damper (damper (caddr note-desc)))))
	    )))
  (quiet))


(defun add-to-simple-note-list (time-from-start note velocity duration)
  (block done
    (do ((notes *simple-note-list* (cdr notes))
	 (last-cdr (locf *simple-note-list*) notes))
	((null notes)
	 (rplacd last-cdr
		 (if (numberp note)
		     (list (list time-from-start note velocity)
			   (list (+ time-from-start duration) note 0))
		   (list (list time-from-start note velocity)))))
      (cond ((<= time-from-start (caar notes))
	     (rplacd last-cdr
		     (cons (list time-from-start note velocity)
			   notes))
	     (do ((n-notes notes (cdr n-notes))
		  (dont-step-n-last-cdr nil nil)
		  (n-last-cdr (cdr last-cdr) (if dont-step-n-last-cdr
						 n-last-cdr
					       (cdr n-last-cdr)))
		  )
		 ((null n-notes)
		  (if (numberp note)
		      (rplacd n-last-cdr
			      (list (list (+ time-from-start duration) note 0))))
		  (return-from done nil))
	       (cond ((<= (+ time-from-start duration) (caar n-notes))
		      (if (numberp note)
			  (rplacd n-last-cdr
				  (cons (list (+ time-from-start duration) note 0)
					n-notes)))
		      (return-from done nil))
		     ((and (eq (cadar n-notes) note)
			   (eq (caddar n-notes) 0))
		      (rplacd n-last-cdr (cdr n-notes))
		      (setq dont-step-n-last-cdr t)
		      )
		     
		     ))))
      ))
  *simple-note-list*)

(defun triad ()
  (setq *simple-note-list* nil)
  (add-to-simple-note-list 0 60. 30. 60.)
  (add-to-simple-note-list 30. 60. 30. 60.)
  (add-to-simple-note-list 60. 64. 30. 60.)
  (add-to-simple-note-list 120. 67. 30. 60.)
  (play-simple-notes *simple-note-list*))

(defun damper (on-p)
  (mks-10-damper on-p))

(defun setup-note-properties ()
  (dotimes (octave 8)
    (do ((notes '(("C~D")
		  ("C~D#" "D~D")
		  ("D~D")
		  ("D~D#" "E~D")
		  ("E~D")
		  ("F~D")
		  ("F~D#" "G~D")
		  ("G~D")
		  ("G~D#" "A~D")
		  ("A~D")
		  ("A~D#" "B~D")
		  ("B~D"))
		(cdr notes))
	 (scale-number 0 (1+ scale-number)))
	((null notes))
      (dolist (enharmonic-note (car notes))
	(let ((sym (intern (format nil enharmonic-note octave) (symbol-package 'foo))))
	  (putprop sym
		   (+ (* (1+ octave) 12.) scale-number)
		   'note-number))))))
(setup-note-properties)

(defconst cannon
	  '(
	    (damper t)
	    ((d4 1\8) (d3 1\2) (f3# 1\2) (a3 1\2))
	    (f4# 1\8)
	    (a4 1\8)
	    (d5 1\8)
	    (damper nil)
	    (damper t)
	    ((c4# 1\8) (a2 1\2) (e3 1\2) (a3 1\2))
	    (e4 1\8)
	    (a4 1\8)
	    (c5# 1\8)
	    (damper nil)
	    (damper t)
	    ((b3 1\8) (b2 1\2) (d3 1\2) (f2# 1\2))
	    (d4 1\8)
	    (f4# 1\8)
	    (b4 1\8)
	    (damper nil)
	    (damper t)
	    ((a3 1\8) (f2# 1\2) (c3# 1\2) (f3# 1\2))
	    (c4# 1\8)
	    (f4# 1\8)
	    (a4 1\8)
	    (damper nil)
	    (damper t)
	    ((b3 1\8) (g2 1\2) (d3 1\2) (g3 1\2))
	    (d4 1\8)
	    (g4 1\8)
	    (b4 1\8)
	    (damper nil)
	    (damper t)
	    ((a3 1\8) (d2 1\2) (a2 1\2) (f3# 1\2))
	    (d4 1\8)
	    (f4# 1\8)
	    (a4 1\8)
	    (damper nil)
	    (damper t)
	    ((b3 1\8) (g2 1\2) (d3 1\2) (g3 1\2))
	    (d4 1\8)
	    (g4 1\8)
	    (b4 1\8)
	    (damper nil)
	    (damper t)
	    ((c4# 1\8) (a2 1\2) (e3 1\2) (a3 1\2))
	    (e4 1\8)
	    (a4 1\8)
	    (c5# 1\8)
	    (damper nil)


	    (damper t)
	    ((rest 1\8) (f5# 1\2) (d3 1\2))
	    (a3 1\8)
	    (d4 1\8)
	    (f4# 1\8)
	    (damper nil)
	    (damper t)
	    ((rest 1\8) (e5 1\2) (a2 1\2))
	    (a3 1\8)
	    (c4# 1\8)
	    (e4 1\8)
	    (damper nil)
	    (damper t)
	    ((rest 1\8) (d5 1\2) (b2 1\2))
	    (f3# 1\8)
	    (b3 1\8)
	    (d4 1\8)
	    (damper nil)
	    (damper t)
	    ((rest 1\8) (c5# 1\2) (f2# 1\2))
	    (a3 1\8)
	    (c4# 1\8)
	    (f4# 1\8)
	    (damper nil)
	    (damper t)
	    ((rest 1\8) (b4 1\2) (g2 1\2))
	    (g3 1\8)
	    (b3 1\8)
	    (d4 1\8)
	    (damper nil)
	    (damper t)
	    ((rest 1\8) (a4 1\2) (d2 1\2))
	    (f3# 1\8)
	    (a3 1\8)
	    (d4 1\8)
	    (damper nil)
	    (damper t)
	    ((rest 1\8) (b4 1\2) (g2 1\2))
	    (g3 1\8)
	    (b3 1\8)
	    (d4 1\8)
	    (damper nil)
	    (damper t)
	    ((rest 1\8) (c5# 1\2) (a2 1\2))
	    (a3 1\8)
	    (c4# 1\8)
	    (e4 1\8)
	    (damper nil)
	    ))

(defconst chord '(((c4# 1\2) (a2 1\2) (e3 1\2) (a3 1\2))))

(defconst *midi-package* (find-package 'midi))

(defun midintern (&rest things)
  (intern (apply #'string-append things) *midi-package*))

(defparameter *keyboard-table-sharps*
	      #((c . "") (c . "#") (d . "") (d . "#") (e . "") (f . "") (f . "#")
		(g . "") (g . "#") (a . "") (a . "#") (b . "")))

(defparameter *keyboard-table-flats*
	      #((c . "") (d . "") (d . "") (e . "") (e . "") (f . "") (g . "")
		(g . "") (a . "") (a . "") (b . "") (b . "")))

;;; 0 is c1, and chromatically-upwards we go
(defun note-from-number (n &optional (return-sharps t))
  (multiple-value-bind (octave note) (floor n 12.)
    (let ((kbd-val (aref (if return-sharps
			     *keyboard-table-sharps*
			   *keyboard-table-flats*)
			 note)))
      (midintern (car kbd-val) (format () "~D" (1- octave)) (cdr kbd-val)))))

;;; Some other stuff is in LAM3: RPK.LM; MUSE

(defconst c-chords
	  '(
	    (damper t)
	    ((c3 1\2) (e3 1\2) (g3 1\2) (c2 1\2))
	    (damper nil)
	    (rest 1\8)
	    (damper t)
	    ((c4 1\2) (e4 1\2) (g4 1\2) (c3 1\2))
	    (damper nil)
	    (rest 1\8)
	    (damper t)
	    ((c5 1\2) (e5 1\2) (g5 1\2) (c4 1\2))
	    (damper nil)))

(defconst scale '((c4 1\8)
		  (d4 1\8)
		  (e4 1\8)
		  (f4 1\8)
		  (g4 1\8)
		  (a4 1\8)
		  (b4 1\8)
		  (c5 1\8)))

(defconst c-chord '((c4 1\8)
		    (e4 1\8)
		    (g4 1\8)
		    ))

(defun make-simple-note-list (&optional (song cannon) (reset-simple-note-list t)
			      (current-time 0))
  (if reset-simple-note-list
      (setq *simple-note-list* nil))
  (dolist (clause song)
    (incf current-time (do-simple-note-clause clause current-time)))
  current-time)

(defun do-simple-note-clause (clause start-time)
  (selectq (car clause)
    (damper (add-to-simple-note-list start-time 'damper (cadr clause) 0)
	    0)
    (t
     (cond ((symbolp (car clause))
	    (do-simple-note-note-clause clause start-time))
	   (t
	    (let ((clause-length (do-simple-note-note-clause (car clause) start-time)))
	      (dolist (c clause)
		(do-simple-note-note-clause c start-time))
	      clause-length))))))

(defvar *speed* 180.)

(defun do-simple-note-note-clause (clause start-time)
  (let ((note-number (get (car clause) 'note-number))
	(quantums (* (cadr clause) *speed*)))
    (cond ((eq (car clause) 'rest)
	   quantums)
	  ((null note-number)
	   (ferror nil "bad clause ~s" clause))
	  (t
	   (add-to-simple-note-list start-time note-number 30. quantums)
	   quantums))))

(defun convert-midi-array-to-song ()
  (loop for note in (return-just-notes)
	collect (list (note-from-number note nil) 1\32)))


(defun i14 (&aux (current-time 0))
  (setq *simple-note-list* nil)
  (let ((p1 (make-simple-note-list invention-14-phrase-1-left nil current-time))
	(p2 (make-simple-note-list invention-14-phrase-1-right nil current-time)))
    (cond ((not (= p1 p2))
	   (ferror nil "phases not same length")))
    (setq current-time p1))
  (let ((p1 (make-simple-note-list invention-14-phrase-2-left nil current-time))
	(p2 (make-simple-note-list invention-14-phrase-2-right nil current-time)))
    (cond ((not (= p1 p2))
	   (ferror nil "phases not same length")))
    (setq current-time p1))

  (let ((p1 (make-simple-note-list invention-14-phrase-3-left nil current-time))
	(p2 (make-simple-note-list invention-14-phrase-3-right nil current-time)))
    (cond ((not (= p1 p2))
	   (ferror nil "phases not same length")))
    (setq current-time p1))

  (let ((p1 (make-simple-note-list invention-14-phrase-4-left nil current-time))
	(p2 (make-simple-note-list invention-14-phrase-4-right nil current-time)))
    (cond ((not (= p1 p2))
	   (ferror nil "phases not same length")))
    (setq current-time p1))

  (let ((p1 (make-simple-note-list invention-14-phrase-5-left nil current-time))
	(p2 (make-simple-note-list invention-14-phrase-5-right nil current-time)))
    (cond ((not (= p1 p2))
	   (ferror nil "phases not same length")))
    (setq current-time p1))

  (let ((p1 (make-simple-note-list invention-14-phrase-6-left nil current-time))
	(p2 (make-simple-note-list invention-14-phrase-6-right nil current-time)))
    (cond ((not (= p1 p2))
	   (ferror nil "phases not same length")))
    (setq current-time p1))

  (play-simple-notes))

(defun old-foo ()      ;Whoever left this named foo: sorry, you cant have that name.
  (setq *simple-note-list* nil)
  (make-simple-note-list invention-14-phrase-6-left nil)
  (make-simple-note-list invention-14-phrase-6-right nil)
  (play-simple-notes))


(defconst invention-14-phrase-1-left
	  '((rest 1\16)
	    (B4 1\32)
	    (C5 1\32)
	    ;.
	    (D5 1\32)
	    (C5 1\32)
	    (B4 1\16)
	    ;.
	    (F5 1\16)
	    (D5 1\16)
	    ;.
	    (B5 1\16)
	    (F5 1\16)
	    ;.
	    (D5 1\16)
	    (F5 1\32)
	    (E5 1\32)
	    ;.
	    (D5 1\32)
	    (e5 1\32)
	    (F5 1\16)
	    ;.
	    (B4 1\16)
	    (D5 1\16)
	    ;.
	    (f4 1\16)
	    (A4 1\16)
            ;---
	    (G4 1\16)
	    (E4 1\32)
	    (F4 1\32)
	    ;.
	    (G4 1\32)
	    (F4 1\32)
	    (E4 1\16)
	    ;.
	    (B4 1\16)
	    (G4 1\16)
	    ;.
	    (E5 1\16)
	    (B4 1\16)
	    ;.
	    (G4 1\16)
	    (B4 1\32)
	    (A4 1\32)
	    ;.
	    (G4 1\32)
	    (A4 1\32)
	    (B4 1\16)
	    ;.
	    (E4 1\16)
	    (G4 1\16)
	    ;.
	    (C4 1\16)
	    (E4 1\16)
	    ;---
	    (A3 1\16)
	    (C4 1\32)
	    (D4 1\32)
	    ;.
	    (E4 1\32)
	    (D4 1\32)
	    (C4 1\16)
	    ;.
	    (A4 1\16)
	    (F4 1\16)
	    ;.
	    (C5 1\16)
	    (A4 1\16)
	    ;.
	    (E5 1\16)
	    (F4 1\32)
	    (G4 1\32)
	    ;.
	    (A4 1\32)
	    (G4 1\32)
	    (F4 1\16)
	    ;.
	    (C5 1\16)
	    (A4 1\16)
	    ;.
	    (F5 1\16)
	    (C5 1\16)))

(defconst invention-14-phrase-1-right
	  '((B3 1\8)
	    (B2 1\8)
	    (D3 1\8)
	    (F3 1\8)
	    (B3 1\4)
	    (rest 1\4)
	    ;---
	    (rest 1\8)
	    (B2 1\8)
	    (E3 1\8)
	    (G3 1\8)
	    (B3 1\4)
	    (rest 1\4)
	    ;---
	    (rest 1\8)
	    (B2 1\8)
	    (C3 1\8)
	    (E3 1\8)
	    (A3 1\4)
	    (rest 1\4)))

(defconst invention-14-phrase-2-left
	  '((D5 1\8)
	    (rest 1\8)
	    (rest 1\16)
	    (G5 1\32)
	    (F5 1\32)
	    (E5 1\32)
	    (F5 1\32)
	    (G5 1\16)
	    (C5 1\8)
	    (rest 1\8)
	    (rest 1\16)
	    (F5 1\32)
	    (E5 1\32)
	    (D5 1\32)
	    (E5 1\32)
	    (F5 1\16)
	    ;---
	    (B4 1\8)
	    (rest 1\8)
	    (rest 1\16)
	    (E5 1\32)
	    (D5 1\32)
	    (C5 1\32)
	    (D5 1\32)
	    (e5 1\16)
	    (A4 1\16)
	    (C5 1\32)
	    (B4 1\32)
	    (A4 1\32)
	    (B4 1\32)
	    (C5 1\16)
	    (F4 1\8)
	    (rest 1\8)
	    ))

(defconst invention-14-phrase-2-right
	  '((rest 1\16)
	    (B3 1\32)
	    (C4 1\32)
	    (D4 1\32)
	    (C4 1\32)
	    (B3 1\16)
	    (E4 1\8)
	    (rest 1\8)
	    (rest 1\16)
	    (A3 1\32)
	    (B3 1\32)
	    (C4 1\32)
	    (B3 1\32)
	    (A3 1\16)
	    (D4 1\8)
	    (rest 1\8)
	    ;---
	    (rest 1\16)
	    (G3 1\32)
	    (A3 1\32)
	    (B3 1\32)
	    (A3 1\32)
	    (G3 1\16)
	    (C4 1\16)
	    (C3 1\32)
	    (D3 1\32)
	    (E3 1\32)
	    (D3 1\32)
	    (C3 1\16)
	    (F3 1\8)
	    (F2 1\8)
	    (rest 1\16)
	    (C4 1\16)
	    (A3 1\16)
	    (f3 1\16)
	    ))

(defconst invention-14-phrase-3-left
	  '((F5 1\8)
	    (F4 1\8)
	    (A4 1\8)
	    (C5 1\8)
	    (F5 1\4)
	    (rest 1\4)
	    ;---
	    (rest 1\8)
	    (F4 1\8)
	    (B4 1\8)
	    (D5 1\8)
	    (F5 1\4)
	    (rest 1\4)
	    ;---
	    (rest 1\8)
	    (G4 1\8)
	    (B4 1\8)
	    (C5 1\8)
	    (E5 1\4)
	    (rest 1\4)
	    ))


(defconst invention-14-phrase-3-right
	  '((rest 1\16)
	    (F3 1\32)
	    (G3 1\32)
	    (A3 1\32)
	    (G3 1\32)
	    (F3 1\16)

	    (C4 1\16)
	    (A3 1\16)
	    (F4 1\16)
	    (C4 1\16)

	    (A3 1\16)
	    (C4 1\32)
	    (B3 1\32)
	    (A3 1\32)
	    (B3 1\32)
	    (C4 1\16)

	    (F3 1\16)
	    (A3 1\16)
	    (C3 1\16)
	    (E3 1\16)

	    (D3 1\16)
	    (B2 1\32)
	    (C3 1\32)
	    (D3 1\32)
	    (C3 1\32)
	    (B2 1\16)

	    (F3 1\16)
	    (D3 1\16)
	    (B3 1\16)
	    (F3 1\16)

	    (D3 1\16)
	    (F3 1\32)
	    (E3 1\32)
	    (D3 1\32)
	    (E3 1\32)
	    (F3 1\16)

	    (B2 1\16)
	    (D3 1\16)
	    (G2 1\16)
	    (B2 1\16)

	    (E2 1\16)
	    (G2 1\32)
	    (A2 1\32)
	    (B2 1\32)
	    (A2 1\32)
	    (G2 1\16)

	    (E3 1\16)
	    (C3 1\16)
	    (G3 1\16)
	    (E3 1\16)

	    (B3 1\16)
	    (C3 1\32)
	    (D3 1\32)
	    (E3 1\32)
	    (D3 1\32)
	    (C3 1\16)

	    (G3 1\16)
	    (E3 1\16)
	    (C4 1\16)
	    (G3 1\16)
	    ))

(defconst invention-14-phrase-4-left
	  '((rest 1\16)
	    (F4 1\32)
	    (G4 1\32)
	    (A4 1\32)
	    (G4 1\32)
	    (F4 1\16)

	    (C5 1\16)
	    (A4 1\16)
	    (F5 1\16)
	    (C5 1\16)

	    (A5 1\16)
	    (E5 1\32)
	    (D5 1\32)
	    (C5 1\32)
	    (D5 1\32)
	    (E5 1\16)

	    (A4 1\16)
	    (C5 1\16)
	    (f4# 1\16)
	    (D5 1\16)
	    ;---
	    (B4 1\8)
	    (D5 1\8)
	    (B4 1\8)
	    (G4 1\8)

	    (A4 1\8)
	    (F5 1\8)
	    (A4 1\8)
	    (F4 1\8)
	    ;---
	    (G4 1\16)
	    (C4 1\32)
	    (D4 1\32)
	    (E4 1\32)
	    (D4 1\32)
	    (C4 1\16)

	    (G4 1\16)
	    (E4 1\16)
	    (C5 1\16)
	    (G4 1\16)

	    (D5 1\16)
	    (A4 1\32)
	    (G4 1\32)
	    (F4 1\32)
	    (G4 1\32)
	    (A4 1\16)

	    (D4 1\16)
	    (F4 1\16)
	    (B3 1\16)
	    (G4 1\16)
	    ))

(defconst invention-14-phrase-4-right
	  '((A3 1\8)
	    (C4 1\8)
	    (A3 1\8)
	    (F3 1\8)

	    (f3# 1\8)
	    (A3 1\8)
	    (f3# 1\8)
	    (D3 1\8)

	    (G3 1\16)
	    (G2 1\32)
	    (A2 1\32)
	    (B2 1\32)
	    (A2 1\32)
	    (G2 1\16)

	    (D3 1\16)
	    (B2 1\16)
	    (G3 1\16)
	    (D3 1\16)

	    (B3 1\16)
	    (A3 1\32)
	    (G3 1\32)
	    (F3 1\32)
	    (G3 1\32)
	    (A3 1\16)

	    (D3 1\16)
	    (F3 1\16)
	    (B2 1\16)
	    (D3 1\16)

	    (E3 1\8)
	    (G3 1\8)
	    (E3 1\8)
	    (C3 1\8)

	    (B2 1\8)
	    (D3 1\8)
	    (B2 1\8)
	    (G2 1\8)))

(defconst invention-14-phrase-5-left
	  '((E4 1\8)
	    (rest 1\8)
	    (rest 1\16)
	    (C4 1\32)
	    (D4 1\32)
	    (E4 1\32)
	    (D4 1\32)
	    (C4 1\16)

	    (C5 3\16)
	    (B4 1\16)
	    (A4 1\16)
	    (F4 1\32)
	    (G4 1\32)
	    (A4 1\32)
	    (G4 1\32)
	    (F4 1\16)

	    (F5 3\16)
	    (e5 1\16)
	    (D5 1\16)
	    (B4 1\32)
	    (C5 1\32)
	    (D5 1\32)
	    (C5 1\32)
	    (B4 1\16)

	    (B5 3\16)
	    (A5 1\16)
	    (G5 1\16)
	    (B5 1\32)
	    (A5 1\32)
	    (G5 1\32)
	    (A5 1\32)
	    (B5 1\16)

	    (E5 1\16)
	    (G5 1\32)
	    (F5 1\32)
	    (E5 1\32)
	    (F5 1\32)
	    (G5 1\16)

	    (C5 1\16)
	    (E5 1\32)
	    (D5 1\32)
	    (C5 1\32)
	    (D5 1\32)
	    (E5 1\16)
	    
	    (A4 1\16)
	    (C5 1\32)
	    (D5 1\32)
	    (E5 1\32)
	    (D5 1\32)
	    (C5 1\16)

	    (F5 1\16)
	    (A4 1\32)
	    (G4 1\32)
	    (F4 1\32)
	    (G4 1\32)
	    (A4 1\16)

	    (G4 1\16)
	    (B4 1\32)
	    (C5 1\32)
	    (D5 1\32)
	    (C5 1\32)
	    (B4 1\16)

	    (E5 1\16)
	    (G4 1\32)
	    (F4 1\32)
	    (E4 1\32)
	    (F4 1\32)
	    (G4 1\16)

	    (F4 1\16)
	    (A4 1\32)
	    (B4 1\32)
	    (C5 1\32)
	    (B4 1\32)
	    (A4 1\16)

	    (D5 1\16)
	    (F4 1\32)
	    (E4 1\32)
	    (D4 1\32)
	    (E4 1\32)
	    (F4 1\16)

	    (E4 1\16)
	    (G4 1\32)
	    (A4 1\32)
	    (B4 1\32)
	    (A4 1\32)
	    (G4 1\16)

	    (C5 1\16)
	    (E4 1\32)
	    (D4 1\32)
	    (C4 1\32)
	    (D4 1\32)
	    (E4 1\16)
	    (D4 1\4)

	    (rest 1\16)
	    (b4 1\32)
	    (c5 1\32)
	    (d5 1\32)
	    (c5 1\32)
	    (b4 1\16)
	    
	    ))

(defconst invention-14-phrase-5-right
	  '((C3 1\16)
	    (C2 1\32)
	    (D2 1\32)
	    (E2 1\32)
	    (D2 1\32)
	    (C2 1\16)

	    (C3 3\16)
	    (B2 1\16)
	    ;---
	    (A2 1\16)
	    (F2 1\32)
	    (G2 1\32)
	    (A2 1\32)
	    (G2 1\32)
	    (F2 1\16)

	    (f3 3\16)
	    (E3 1\16)
	    ;---
	    (D3 1\16)
	    (B2 1\32)
	    (C3 1\32)
	    (D3 1\32)
	    (C3 1\32)
	    (B2 1\16)

	    (B3 3\16)
	    (A3 1\16)

	    (G3 1\16)
	    (E3 1\32)
	    (F3 1\32)
	    (G3 1\32)
	    (F3 1\32)
	    (E3 1\16)

	    (E4 3\16)
	    (D4 1\16)

	    (C4 1\16)
	    (E4 1\32)
	    (D4 1\32)
	    (C4 1\32)
	    (D4 1\32)
	    (E4 1\16)

	    (A3 1\16)
	    (C4 1\32)
	    (B3 1\32)
	    (A3 1\32)
	    (B3 1\32)
	    (C4 1\16)

	    (F3 1\16)
	    (A3 1\32)
	    (B3 1\32)
	    (C4 1\32)
	    (B3 1\32)
	    (A3 1\16)

	    (D4 1\16)
	    (F3 1\32)
	    (E3 1\32)
	    (D3 1\32)
	    (E3 1\32)
	    (F3 1\16)
	    ;---
	    (E3 1\16)
	    (G3 1\32)
	    (A3 1\32)
	    (B3 1\32)
	    (A3 1\32)
	    (G3 1\16)

	    (C4 1\16)
	    (E3 1\32)
	    (D3 1\32)
	    (C3 1\32)
	    (D3 1\32)
	    (E3 1\16)

	    (D3 1\16)
	    (F3 1\32)
	    (G3 1\32)
	    (A3 1\32)
	    (G3 1\32)
	    (F3 1\16)

	    (B3 1\16)
	    (D3 1\32)
	    (C3 1\32)
	    (B2 1\32)
	    (C3 1\32)
	    (D3 1\16)
	    ;---
	    (C3 1\16)
	    (E3 1\32)
	    (F3 1\32)
	    (G3 1\32)
	    (F3 1\32)
	    (E3 1\16)

	    (A3 1\16)
	    (C3 1\32)
	    (B2 1\32)
	    (A2 1\32)
	    (B2 1\32)
	    (C3 1\16)

	    (B2 1\16)
	    (B3 1\32)
	    (C4 1\32)
	    (D4 1\32)
	    (C4 1\32)
	    (B3 1\16)

	    (F4 1\16)
	    (D4 1\16)
	    (B4 1\16)
	    (F4 1\16)))

(defconst invention-14-phrase-6-left
	  '((F5 1\16)
	    (D5 1\16)
	    (B5 1\16)
	    (F5 1\16)

	    (D5 1\16)
	    (F5 1\32)
	    (E5 1\32)
	    (D5 1\32)
	    (E5 1\32)
	    (F5 1\16)
	    ;---
	    (B4 1\16)
	    (E5 1\16)
	    (B4 1\16)
	    (E5 1\16)

	    (G4 1\16)
	    (E4 1\32)
	    (F4 1\32)
	    (G4 1\32)
	    (F4 1\32)
	    (E4 1\16)
	    ;---
	    (B4 1\16)
	    (G4 1\16)
	    (E5 1\16)
	    (B4 1\16)

	    (G4 1\16)
	    (B4 1\32)
	    (A4 1\32)
	    (G4 1\32)
	    (A4 1\32)
	    (B4 1\16)

	    (E4 1\8)

	    (E5 3\16)

	    (E5 1\32)
	    (D5 1\32)
	    (C5 1\32)
	    (D5 1\32)
	    (E5 1\16)
	    ;---
	    (F4 1\8)

	    (E5 3\16)

	    (C5 1\32)
	    (D5 1\32)
	    (E5 1\32)
	    (D5 1\32)
	    (C5 1\16)

	    (F5 1\16)
	    (D5 1\32)
	    (C5 1\32)
	    (B4 1\32)
	    (C5 1\32)
	    (D5 1\16)

	    (F4 1\16)
	    (B4 1\16)
	    (C5 1\16)
	    (A4 1\16)
	    (B4 1)))

(defconst invention-14-phrase-6-right
	  '((B3 1\16)
	    (F4 1\32)
            (E4 1\32)
            (D4 1\32)
            (E4 1\32)
            (F4 1\16)

            (B3 1\16)
            (D4 1\16)
            (F3 1\16)
            (A3 1\16)

            (G3 1\16)
            (E3 1\32)
            (F3 1\32)
            (G3 1\32)
            (F3 1\32)
            (E3 1\16)

            (B3 1\16)
            (G3 1\16)
            (E4 1\16)
            (B3 1\16)

            (G3 1\16)
            (B3 1\32)
            (A3 1\32)
            (G3 1\32)
            (A3 1\32)
            (B3 1\16)

            (E3 1\16)
            (G3 1\16)
            (B2 1\16)
            (D3 1\16)

            (C3 1\16)
            (F2 1\32)
            (G2 1\32)
            (A2 1\32)
            (G2 1\32)
            (F2 1\16)

            (C3 1\16)
            (A2 1\16)
            (E3 1\16)
            (C3 1\16)

            (A2 1\16)
            (C3 1\32)
            (B2 1\32)
            (A2 1\32)
            (B2 1\32)
            (C3 1\16)

            (F2 1\16)
            (A2 1\16)
            (C2 1\16)
            (E2 1\16)

            (D2 1\16)
            (B2 1\32)
            (C3 1\32)
            (D3 1\32)
            (C3 1\32)
            (B2 1\16)

            (F3 1\8)
            (F2 1\8)
            (B2 1)))

(defun write-simple-note-list-to-file (file-name symbol)
  (let ((base 10.)
	(ibase 10.))
    (with-open-file (f file-name :direction :output)
      (format f "~&;;; -*- Mode:Lisp; Package:(MIDI GLOBAL); Base:10 -*-")
      (format f "~2&(defconst ~s '(" symbol)
      (dolist (x (symeval symbol))
	(format f "~&  ~s" x))
      (format f "~&))~&"))))