LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032767. :SYSTEM-TYPE :LOGICAL :VERSION 17. :TYPE "LISP" :NAME "ORGAN" :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 2754062380. :AUTHOR "REL3" :LENGTH-IN-BYTES 8858. :LENGTH-IN-BLOCKS 9. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      ;; -*- Mode:Common-Lisp; Package:DEMO; Base:10 -*-;; Originally written by ACW, modified by CWH;; Modified again by DLA.;; Modified again by LGO.(defvar *scale* nil)(defvar *key* 0)(defvar *initial-speed* 100);Normal speed(defvar *speed* *initial-speed*);Current speed(defvar *organ-initial-speed*);Speed when ORGAN was last called(defvar *organ-input-buffer* (make-array 300 ':type 'art-string ':leader-length 1))(defvar *organ-speed-stack* (make-array 300 ':leader-length 1))(defvar *organ-initial-right*);Variables for rubout handling(defvar *organ-initial-down*);; This is the origional CADR scale code;(defun piano (n);  (floor (* .5878590257 (piano-1 (- n *key*)))));A = 440 4 Jan 1981;(defun piano-1 (n);  (if (zerop n);      1.0;      (let ((s (piano-1 (lsh n -1))));(* s s (if (oddp n);   1.059463095;   1.0)))));(DEFPARAMETER *scale*;  (let ((arr (make-array 177 ':type 'art-16b)));    (aset (piano 230) arr #\z);    (aset (piano 227) arr #\Z);    (aset (piano 226) arr #\x);    (aset (piano 225) arr #\X);    (aset (piano 224) arr #\c);    (aset (piano 223) arr #\C) ; Cv;    (aset (piano 223) arr #\v);    (aset (piano 222) arr #\V);    (aset (piano 221) arr #\b);    (aset (piano 220) arr #\B);    (aset (piano 217) arr #\n);    (aset (piano 216) arr #\N);    (aset (piano 215) arr #\m);    (aset (piano 214) arr #\M) ; Ma;    (aset (piano 214) arr #\a);    (aset (piano 213) arr #\A);    (aset (piano 212) arr #\s);    (aset (piano 211) arr #\S);    (aset (piano 210) arr #\d);    (aset (piano 207) arr #\D) ; Df;    (aset (piano 207) arr #\f);    (aset (piano 206) arr #\F);    (aset (piano 205) arr #\g);    (aset (piano 204) arr #\G);    (aset (piano 203) arr #\h);    (aset (piano 202) arr #\H);    (aset (piano 201) arr #\j);    (aset (piano 200) arr #\J) ; Jq;    (aset (piano 200) arr #\q);    (aset (piano 177) arr #\Q);    (aset (piano 176) arr #\w);    (aset (piano 175) arr #\W);    (aset (piano 174) arr #\e);    (aset (piano 173) arr #\E);    (aset (piano 173) arr #\r);    (aset (piano 172) arr #\R);    (aset (piano 171) arr #\t);    (aset (piano 170) arr #\T);    (aset (piano 167) arr #\y);    (aset (piano 166) arr #\Y);    (aset (piano 165) arr #\u);    (aset (piano 164) arr #\U);    (aset (piano 164) arr #\k);    (aset (piano 163) arr #\K);    (aset (piano 162) arr #\l);    (aset (piano 161) arr #\L);    (aset (piano 160) arr #\i);    (aset (piano 157) arr #\I);    (aset (piano 157) arr #\o);    (aset (piano 156) arr #\O);    (aset (piano 155) arr #\p);    (aset (piano 154) arr #\P) arr));; On the old CADR keyboards, the default was uppercase, and SHIFT made lower-case characters.;; That is why the upper-case characters give you the normal scale, and lower-case gives you sharps and flats(DEFPARAMETER *note-keys* "zZxXcCvVbBnNmMaAsSdDfFgGhHjJqQwWeErRtTyYuUkKlLiIoOpP")(DEFUN make-scale (FIRST)  (LET ((notes 'tv:(c c# d- d e- e f g- g g# a- a b- b)) ;; D- d# f# g# a#(*scale (MAKE-ARRAY 85)))    (LOOP for octave from 1 to 6  with indx = 0          do (LOOP for note in notes                   for freq = (tv:convert-to-frequency (tv:parse-nominal-note-and-octave note octave))                   for scale-entry = (LIST note freq)                   (SETF (AREF *scale indx) freq);;                   (FORMAT t "~% ~d ~s ~s ~s" indx note octave  freq)                   (INCF indx)))        (LOOP for indx below (LENGTH *note-keys*);;      for character = (AREF *note-keys* (- 51 indx))  for character = (AREF *note-keys* indx)  with scale = (make-array #o177 ':type 'art-16b)  do (SETF (AREF scale (CHAR-INT character)) (AREF *scale (+ first indx)))  finally (RETURN scale))))(DEFPARAMETER *scale* (make-scale 24))#+comment(DEFUN print-scale ()  (LOOP for n being the array-elements of *note-keys*do (format t "~% ~:C ~d" n (AREF *scale* n))))  ;; We need the entire processor here, so turn off :CLOCK and :CHAOS interrupts.;; Change when new version of PROCES installed.    (defun play-string (str)  (tv:with-real-time    (prog (where char ii (repeat (= (aref str 0) #\:)))       R (setq where -1)       L (setq where (1+ where))  (if (= where (length str))      (if (and repeat       (not (send *terminal-io* ':tyi-no-hang)))  (go R)  (return nil)))  (setq char (aref str where))  (and (> char 177) (go L))  (case char    (#\')    (#\/)    (#\ )    (#\:)    (#\CR)    (#\@ (setq *speed* *initial-speed*))    (#\< (setq *speed* (truncate *speed* 3)))    (#\> (setq *speed* (* *speed* 3)))    (#\[ (setq *speed* (lsh *speed* -1)))    (#\] (setq *speed* (lsh *speed* 1)))    (#\- (tv:do-sound nil *speed*));rest    (t (go ON)))  (go L)       ON (setq ii (do ((i where (1+ i)))       ((or (= i (length str))    (not (= (aref str i) char))) i)))  (WHEN (PLUSP (aref *scale* char))    (tv:simple-beep (aref *scale* char) (* *speed* (- ii where))))  (setq where (1- ii))  (go L))))(defun play (thing)  (cond ((stringp thing) (play-string thing))((symbolp thing) (play (symbol-value thing)))((listp thing) (mapc #'play thing))((integerp thing) (tv:simple-beep (aref *scale* thing) *speed*))))(defun organ (&aux (buffer *organ-input-buffer*)   (speed-stack *organ-speed-stack*)           (stream *standard-input*)   (temp-array (make-array 1 ':type 'art-string)) ch)  (organ-note-initial-cursorpos stream)  (store-array-leader 0 buffer 0);Flush buffer contents  (store-array-leader 0 speed-stack 0)  (do ((char (READ-CHAR ch stream) (READ-CHAR ch stream)))      ((= char #\.)       (return-array temp-array)       (string-append buffer))    (case char      (#\rubout (organ-do-rubout buffer speed-stack stream))      ((#\return #\tab)       (WRITE-CHAR char stream)       (vector-push-extend char buffer))      ((#\form 554 514)       (send stream ':clear-screen)       (organ-note-initial-cursorpos stream)       (princ buffer))      (#\escape (play-string buffer))      ((#\? #\help)       (send stream ':clear-screen)       (princ "Welcome to the ORGAN.  The keyboard is now an organ.  Most of the keys playnotes, but the following have special meanings.  The most notable of these arethe following::       If this is the first character in the string, the string will        repeat when played.@       Resets speed to the initial speed.<       Speeds you up by a factor of 3.>       Slows you down by a factor of 3.[       Speeds you up ba a factor of 2.]       Slows you down by a factor of 2.-       Plays a rest.RUBOUT  Allows you to erase your mistakes.ESCAPE  Plays the string you've typed in so far.       Stops.  ORGAN returns a string which is your tune.  This tune can        be played with the PLAY function.")   (organ-note-initial-cursorpos stream)   (princ buffer))      (otherwise       (cond ((< char 200)      (WRITE-CHAR char stream)      (and (member char '(#\< #\> #\[ #\] #\@) :test #'eq)   (vector-push-extend *speed* speed-stack))              (SETF (AREF temp-array 0) char)      (OR (CHAR-EQUAL CHAR #\:);This would play forever...  (play-string temp-array))      (vector-push-extend char buffer))     (t (tv:beep)))))))(defun organ-do-rubout (buffer speed-stack stream &aux r d char)  (cond ((plusp (array-leader buffer 0)) (setq char (vector-pop buffer)) (multiple-value-setq (r d)   (send stream ':read-cursorpos));in PIXEL!! (cond ((or (zerop r)    (= char #\tab))(send stream ':set-cursorpos *organ-initial-right* *organ-initial-down*)(send stream ':string-out buffer))       (t (send stream ':set-cursorpos   (- r (send stream ':character-width char))   d)  (send stream ':clear-eol))) (and (member char '(#\< #\> #\[ #\] #\@) :test #'eq)      (setq *speed* (vector-pop speed-stack))))(t (tv:beep))));Is this the right thing??(defun organ-note-initial-speed ()  (setq *organ-initial-speed* *speed*))(defun organ-figure-out-speed (buffer temp-array)  (setq *speed* *organ-initial-speed*)  (dotimes (x (length buffer))    (and (member (aref buffer x) '(#\< #\> #\[ #\] #\@) :test #'= )         (PROGN (SETF (AREF temp-array 0) (AREF buffer x)); (progn (aset (aref buffer x) temp-array 0)(play-string temp-array)))))(defun organ-note-initial-cursorpos (stream)  (MULTIPLE-VALUE-SETQ  (*organ-initial-right* *organ-initial-down*)    (send stream ':read-cursorpos)))(DEFUN INS (SEXP)    (PRIN1 SEXP ZWEI:(INTERVAL-STREAM (POINT) (POINT) T)))(zwei:defcom com-play-region "Plays the region with the ORGAN program." ()   (zwei:region (a b)      (play (zwei:string-interval a b)))   zwei:dis-none); Star trek theme;(Play-String ":<@]Bbfffds[AM]mmmm-NBBGGGDS[AM]mmm-mNNNMAS[DFD]GGGjjjHGG]NNMA[[SDF]]G---")  ((b  2) 2)    (c# 2) (d# 2) ((e  2) 2)    (d  2) (c  2)   ((b  2) 2)    (a  2) (g  1) ((f# 1) 2)    (g  1) (a  2)   (b  2) (a  2) (g  1) (f# 1) ((e  1) 2)    (e  2) (f# 2)   ((g  2) 2)    (f# 2) (e  2) ((d# 2) 2)    (e  2) (f# 2)   ((b  2) 2)    (c# 2) (d# 2) ((e  2) 2)    (d  2) (c  2)   ((b  2) 2)    (a  2) (g  1) ((f# 1) 3)           (g  1)