;;; -*- Mode:LISP; Package:OTF1; Base:10 -*- ;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 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)) (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) (setq base-idx (+ base-idx 4 byte-count 2)) (go top)) (2 (decode-yamaha-64-performance-bulk-data (+ base-idx 4) byte-count) (setq base-idx (+ base-idx 4 byte-count 2)) (go top)) (125 (decode-yamaha-condition-acknowledge (+ base-idx 4) byte-count) (setq base-idx (+ base-idx 4 byte-count 2)) (go top)) (otherwise (ferror nil "I dont know about format ~X" format-number)))))) ;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) ))