LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032763. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "MUSE" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "MUSIC-DEMO") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2753214954. :AUTHOR "REL3" :LENGTH-IN-BYTES 14084. :LENGTH-IN-BLOCKS 14. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      ;;; -*- Mode:Common-Lisp; Package:USER; Base:10 -*-;;; Music playing on Explorer(defmacro with-real-time body  `(let ((old-sb-state (si:sb-on)) (priority (send si:current-process :priority)) (min-quantum (si:read-meter 'si:%tv-clock-rate)))     (unwind-protect       (progn (send si:current-process :set-priority 100) (write-meter 'si:%tv-clock-rate 2) (si:sb-on '(:keyboard)) . ,body)       (si:sb-on old-sb-state)       (write-meter 'si:%tv-clock-rate min-quantum)       (send si:current-process :set-priority priority))))(defun Make-Halftone-Freq-Table()  (let ((it (make-array 128 :element-type '(unsigned-byte 16)))(halftone (exp (/ (log 2.0) 12.0)))(a440 50)freq)    (setq freq 440.0)    (loop for note from a440 downto 1 do; (print (list note freq)) (setf (aref it note) (round freq)) (setq freq (/ freq halftone)))    (setq freq 440.0)    (loop for note from a440 below 128 do (setf (aref it note) (round freq)) (setq freq (* freq halftone)))    it))(defparameter HalfTone-Freq-Table (Make-Halftone-Freq-Table))(defun scale()  (tv:sib-sound-bit :on)  (loop for i from 1 below 128 do(tv:do-sound (tv:tone 0 (aref Halftone-Freq-Table i)))(tv:do-sound (tv:volume 0 0) 10))  (tv:sib-sound-bit :off)  )(defparameter VOICES 3); All the current hardware supports.(defun make-tone-table(); Construct a table of pre-compiled tones.  (let ((it (make-array (list VOICES 128))))    (loop for i from 1 below 128 do  (loop for v from 0 below VOICES do(setf (aref it v i)      (tv:tone v (aref Halftone-Freq-Table i)))))    it))(defparameter tone-table (make-tone-table));;; Here is the music structure.(defstruct music  Title  Notes; (array (nvoices size))  Times; (array size)  Size; Size of above array.  Current; Current note in above.  Key; Note offset.  Tempo; Playing speed.  plist  )(defun new-music(&optional (max-size 20000))  (make-music :Size 0      :Current 0      :Key 50      :Tempo 100      :Notes (make-array (list VOICES max-size) :element-type '(unsigned-byte 8))      :Times (make-array max-size :element-type '(unsigned-byte 8))      ))(defvar music (new-music))(defun add-notes(duration &rest notes)  (let ((s (music-size music))(v 0))    (dolist (nn notes)      (setf (aref (music-notes music) v s) nn)      (setq v (+ 1 v)))    (loop for v from v below VOICES do  (setf (aref (music-notes music) v s) 0))    (setf (aref (music-times music) s) duration)    (setf (music-size music) (+ s 1))));;; Read a music data file:(defvar voices-to-read '(0 1 2))(defun word-line(mus word other)  (let ((word (intern (string-upcase word) ""))value)    (if (member word '(:title))(setq value (string-trim #\space other))      (loop with int and i = 0 and j    while (setq i (string-search-not-set '(#\space #\tab) other i))    do (multiple-value-setq (int j) (parse-number other i))    while (and int (> j i))    collect int into result    do (setq i j)    finally (setq value (if (cdr result) result (car result)))));    (format t "~%~10a: ~d" word value)    (IF value(case word    (:title (setf (music-title mus) value))    (:key (setf (music-key mus) value))    (:tempo (setf (music-tempo mus) value))    (otherwise (setf (getf (music-plist mus) word) value)));      (FORMAT t " Ignored")      )))(defun number-line(mus dur right)  (let ((v 0)(realv 0)(i 0))    (loop while (< i (length right)) do  (loop while (or (eql (elt right i) '#\SPACE)  (eql (elt right i) '#\TAB))do (incf i))  (if (and (< i (length right)) (< v VOICES))      (multiple-value-bind (int n)  (parse-number right i)(if (or (null int) (= n i))    (setq i 1000)    (if (<= int 1) (setq int 0))    (when (> int 255.)      (FSIGNAL "Note can't fit in 8 bits - ~d" int)      (setq int 0))    (if (consp voices-to-read)(when (member realv voices-to-read :test #'eq)  (setf (aref (music-notes mus) v (music-size mus)) int)  (INCF v))(when (plusp int)  (loop for l below vwhen (= int (aref (music-notes mus) l (music-size mus)))do (return)finally(setf (aref (music-notes mus) v (music-size mus)) int)(incf v))))    (INCF realv)    (setq i n)))      (setq i (length right)))); force end of string.    (loop while (< v VOICES) do           (setf (aref (music-notes mus) v (music-size mus)) 0)           (INCF v))    (setf (aref (music-times mus) (music-size mus)) dur)    (setf (music-size mus)(+ 1 (music-size mus)))));;; Read a score from file. Optional arguments:;;;   voices: select-voices eg '(0 1 2) to specify the voices (max VOICES);;;     NOT to ignore in input file.(defun RdMusic (filename &optional name &key (select-voices nil))  (let ((voices-to-read (or select-voices voices-to-read))(size (array-dimension (music-times music) 0)) duration)    (setf (music-size music) 0)    (setf (music-key music) 50)    (setf (music-tempo music) 100)    (with-open-file (str filename :direction :input)      (loop while (< (music-size music) size) do    (multiple-value-bind (line eof)(read-line str nil)      (when eof(return))      (multiple-value-bind(colon colonpos) (find '#\: line)(when colon  (let ((right (nsubstring line (+ 1 colonpos))))    (if (setq duration (parse-number line 0 colonpos 10. t))(number-line music duration right)(word-line music (nsubstring line 0 colonpos) right))))))))    (WHEN name      (LET ((new-music (get name 'music))    (new-size (music-size music)))(UNLESS (AND new-music     (>= (array-dimension (music-times new-music) 0) (music-size music)))  (SETQ new-music (new-music (+ 100 new-size))))(SETF (music-title new-music) (music-title music))(SETF (music-size new-music) new-size)(SETF (music-key new-music) (music-key music))(SETF (music-tempo new-music) (music-tempo music))(SETF (music-plist new-music) (music-plist music))(LET ((to (music-notes new-music))      (from (music-notes music)))  (DOTIMES (i voices)    (DOTIMES (j new-size)      (SETF (AREF to i j) (AREF from i j)))))(COPY-ARRAY-PORTION (music-times music) 0 new-size    (music-times new-music) 0 new-size)(SETF (get name 'music) new-music)))    ))(defun dump(m)  (loop for n from 0 below 20 do(format t "~d: ~d ~d ~d ~d~&"(aref (music-times m) n)(aref (music-notes m) 0 n)(aref (music-notes m) 1 n)(aref (music-notes m) 2 n)(aref (music-notes m) 3 n))));(dump music)(defvar cnotes (make-array VOICES))(defvar camps  (make-array VOICES))(defvar cdecay (make-array VOICES))(defvar decay 50)(defvar decay-to 10)(defun pmuse(&optional name &key     (PATHNAME nil)     (select-voices '(0 1 2))     (key-adj 0)     (speed 10)     (no-articulation nil))  (tv:beep-stop-flash)  (LET ((m (IF name (GET name 'music) music)))    (WHEN (AND (not m) pathname)      (rdmusic pathname name :select-voices select-voices))    (SETQ m (GET name 'music))    (UNLESS m (FERROR "~a isn't a music name" name))        (let* ((size (music-size m))   (key (+ key-adj (music-key m)))   (tempo (music-tempo m))   (notes (music-notes m))   (times (music-times m))   (i 0) n realn f vol   (new-note t)   time-start   time   interval   )            (setq speed (* speed tempo))            (loop for v from 0 below VOICES do    (setf (aref cnotes v) nil)    (setf (aref camps v) 15)    (setf (aref cdecay v) 0))            (setq time (setq time-start (logand (si:%fixnum-microsecond-time) #x7FFFFF)))      (tv:with-sound-enabled;with-real-time(loop while (< i size) do            (when new-note(tv:sib-sound-bit :on)(setq time-start (logand #x7FFFFF (+ time-start (* speed (aref times i)))))(setq new-note nil))            (loop for v from 0 below VOICES do    (let ((cnotes-v (aref cnotes v))  (camps-v (aref camps v))  (cdecay-v (aref cdecay v))  )                  (setq n (setq realn (aref notes v i)))      (if (and no-articulation (zerop realn))  (if (null (setq n (aref cnotes v))) (setq n 0)))            (if (zerop n)  (progn (setq vol 15) (setq f (aref tone-table v 1)))(setq f (aref tone-table v (+ n key)))(if (eql n cnotes-v)    (if (<= (setq cdecay-v (- cdecay-v 1)) 0)(progn (if (> (setq vol (+ 1 camps-v)) decay-to)   (setq vol decay-to))       (setq cdecay-v decay)       )      (setq vol camps-v))  (setq vol 0)  (setq cdecay-v decay)  ))      (setf camps-v vol)      (setf cnotes-v realn)      (tv:do-sound (tv:volume v vol))      (tv:do-sound f)            (setf (aref cnotes v) cnotes-v)      (setf (aref camps v) camps-v)      (setf (aref cdecay v) cdecay-v)      ))            ;;; Set interval to positive interval, in microseconds, elapsed since start of note:            (setq interval (logand #x7FFFFF (- (logand (si:%fixnum-microsecond-time) #x7FFFFF) time-start)))      (unless (> interval #x40000)(setq new-note t)(setq i (+ 1 i)))))))); Following are more than 6 voices, and require multiple machines:(tv:def-beep-function stairs      pmuse stairs :key-adj -47 :speed 90 :no-articulation t      :pathname "public:music;stairs.muse" :select-voices (0 1 2));; Play these next two on two machines at once(tv:def-beep-function stairs1      pmuse stairs1 :key-adj -47 :speed 90 :no-articulation t      :pathname "public:music;stairs.muse" :select-voices (1 3 5))(tv:def-beep-function stairs2      pmuse stairs2 :key-adj -47 :speed 90 :no-articulation t      :pathname "public:music;stairs.muse" :select-voices (0 2 4))(tv:def-beep-function haydn88a      pmuse haydn88a :key-adj -10 :speed 150 :no-articulation t      :pathname "public:music;haydn88a.muse")(tv:def-beep-function haydn88b      pmuse haydn88b :key-adj -10 :speed 150 :no-articulation t      :pathname "public:music;haydn88b.muse")(tv:def-beep-function haydn88c      pmuse haydn88c :key-adj -10 :speed 150 :no-articulation t      :pathname "public:music;haydn88c.muse")(tv:def-beep-function bouree      pmuse bouree :key-adj -47 :speed 350 :no-articulation t      :pathname "public:music;bouree.muse");; Play these next two on two machines at once(tv:def-beep-function docs1      pmuse docs1 :key-adj -47 :speed 300 :no-articulation t      :pathname "public:music;docs.muse" :select-voices (0 2 4))(tv:def-beep-function docs2      pmuse docs2 :key-adj -47 :speed 300 :no-articulation t      :pathname "public:music;docs.muse" :select-voices (0 2 4))(tv:def-beep-function bach-little      pmuse bach-little :key-adj -47 :speed 20 :no-articulation t      :pathname "public:music;bach-little.muse")(tv:def-beep-function melon1      pmuse melon1 :key-adj -60 :speed 300 :no-articulation t      :pathname "public:music;melon.muse" :select-voices (0 1 2))(tv:def-beep-function melon2      pmuse melon2 :key-adj -60 :speed 300 :no-articulation t      :pathname "public:music;melon.muse" :select-voices (3 4 5))(tv:def-beep-function bach-prelude1      pmuse bach-prelude1 :key-adj -47 :speed 300 :no-articulation t      :pathname "public:music;bach-prelude1.muse")(tv:def-beep-function bach-prelude6      pmuse bach-prelude6 :key-adj -47 :speed 190 :no-articulation t      :pathname "public:music;bach-prelude6.muse")(tv:def-beep-function prudence      pmuse prudence :key-adj 0 :speed 190 :no-articulation t      :pathname "public:music;prudence.muse.")(tv:def-beep-function jude      pmuse jude :key-adj -47 :speed 28 :no-articulation t      :pathname "public:music;jude.muse")(tv:def-beep-function rulebr      pmuse rulebr :key-adj -47 :speed 200 :no-articulation t      :pathname "public:music;rulebr.muse");; Play these next two on two machines at once(tv:def-beep-function sc282a      pmuse sc282a :key-adj -47 :speed 60 :no-articulation t      :pathname "public:music;sc282.muse"  :select-voices (0 2 4))(tv:def-beep-function sc282b      pmuse sc282b :key-adj -47 :speed 60 :no-articulation t      :pathname "public:music;sc282.muse"  :select-voices (1 2 5));; This would sound great with all 6 parts...(tv:def-beep-function sheba      pmuse sheba :key-adj -47 :speed 180 :no-articulation t      :pathname "public:music;sheba.muse" :select-voices t)(tv:def-beep-function sheila      pmuse sheila :key-adj -47 :speed 220 :no-articulation t      :pathname "public:music;sheila.muse")(tv:def-beep-function sj7      pmuse sj7 :key-adj 0 :speed 100 :no-articulation t      :pathname "public:music;sj7.muse")(tv:def-beep-function super      pmuse super :key-adj -47 :speed 120 :no-articulation t      :pathname "public:music;super.muse" :select-voices t);; Another one that needs more voices(tv:def-beep-function triste      pmuse triste :key-adj -47 :speed 120 :no-articulation t      :pathname "public:music;triste.muse" :select-voices (0 2 4))(tv:def-beep-function tull      pmuse tull :key-adj -20 :speed 50 :no-articulation t      :pathname "public:music;tull.muse" :select-voices (0 2 4))(tv:def-beep-function turca      pmuse turca :key-adj -47 :speed 20 :no-articulation t      :pathname "public:music;turca.muse" :select-voices t)(tv:def-beep-function uryfug      pmuse uryfug :key-adj -47 :speed 200 :no-articulation t      :pathname "public:music;uryfug.muse" :select-voices t)(tv:def-beep-function voy      pmuse voy :key-adj -47 :speed 50 :no-articulation t      :pathname "public:music;voy.muse" :select-voices t);; Gota have more voices;(tv:def-beep-function warm;      pmuse warm :key-adj -47 :speed 10 :no-articulation t;      :pathname "public:music;warm.muse" :select-voices (1 2 5))(tv:def-beep-function yesterday      pmuse yesterday :key-adj -47 :speed 10 :no-articulation t      :pathname "public:music;yesterday.muse" :select-voices t) 26 1 1 112: 1 1 1 1 1 184: 47 47 31 43 38 112: 1 1 1 43 38 172: 52 55 26 43 38 112: 52 55 26 1 1 112: 52 55 1 1 1 160: 50 54 26 48 45 4224: 50 54 26 48 45 4212: 50 54 1 48 45 4272: 50 54 26 48 45 4212: 50 54 26 1 1 112: 50 54 1 1 1 160: 5