mirror of
https://github.com/PDP-10/its.git
synced 2026-02-08 01:11:18 +00:00
343 lines
11 KiB
Plaintext
343 lines
11 KiB
Plaintext
|
||
|
||
;;; LLOGO MUSIC BOX PRIMITIVES
|
||
;;; ; SEE HARDWARE
|
||
;;MEMOS 8 AND 9.
|
||
|
||
;;*SLASHIFY #
|
||
|
||
(DECLARE (OR (STATUS FEATURE DEFINE) (FASLOAD DEFINE FASL DSK LLOGO)))
|
||
|
||
(DECLARE (GENPREFIX MUSIC)
|
||
(SPECIAL :INSTRUMENT :NVOICES :SCALEBASE :VOICE :SAVBUF BUFFERS NEWMUSIC
|
||
MODMUSIC DEFAULTSCALEBASE CBUF1 CBUF2 CBUF3 CBUF4 WBUF1 WBUF2 WBUF3
|
||
WBUF4 CBUF WBUF ERRLIST)
|
||
(*FEXPR QUERY NOTIMP CHORUS4 CHORUS3 CHORUS2 CHORUS)
|
||
(*LEXPR ERRBREAK)
|
||
(*EXPR NEWMUSIC MODMUSIC))
|
||
|
||
;; THIS FILE WILL USE BASE 10 NUMBERS (FOLLOWED BY ".")
|
||
|
||
(SSTATUS FEATURE MUSIC)
|
||
|
||
(COND ((STATUS FEATURE LLOGO)
|
||
(MAPC '(LAMBDA (BOTH-OBARRAY-ATOM) (OBTERN BOTH-OBARRAY-ATOM LOGO-OBARRAY))
|
||
'(N O :INSTRUMENT :MAX :NVOICES :VOICE :SCALEBASE :SAVBUF LEGATO)))
|
||
((DEFPROP MAKE SET EXPR)
|
||
(DEFUN HOMCHECK (USELESS) USELESS)
|
||
(DEFUN OBTERN (IGNORE THIS) IGNORE)
|
||
(DEFUN ERRBREAK ARGS (PRINT (ARG ARGS)) (APPLY (FUNCTION BREAK) (LIST (ARG 1.) T)))
|
||
(DEFUN REQUEST NIL (TERPRI) (PRINC '<) (READ))))
|
||
|
||
[MULTICS (DECLARE (*FEXPR TURN_RAWO_ON TURN_RAWO_OFF))
|
||
(CLINE
|
||
"INITIATE >UDD>AP>LIB>TURN_RAWO_ON TURN_RAWO_ON TURN_RAWO_OFF")
|
||
(PUTPROP 'TURN_RAWO_ON
|
||
(DEFSUBR "TURN_RAWO_ON"
|
||
"TURN_RAWO_ON"
|
||
0.)
|
||
'FSUBR)
|
||
(PUTPROP 'TURN_RAWO_OFF
|
||
(DEFSUBR "TURN_RAWO_OFF"
|
||
"TURN_RAWO_OFF"
|
||
0.)
|
||
'FSUBR)]
|
||
|
||
;;SUBROUTINES FOR TURNING ON AND OFF "RAW" OR IMAGE MODE OUTPUT. THIS OUTPUTS CHARACTERS
|
||
;;LIKE CONTROL CHARACTERS DIRECTLY, RATHER THAN AS ORDINARY CHARACTERS PRECEDED BY
|
||
;;UPARROW [ITS] OR BACKSLASH [MULTICS]. QUITTING MUST BE DISABLED FROM INSIDE THE SYSTEM
|
||
;;CALL.
|
||
|
||
;;THE FOLLOWING LAP FUNCTIONS WILL PROBABLY NEED CHANGING
|
||
;;WHEN NEW I/O SYSTEM EXISTS ON ITS LISP.
|
||
|
||
[ITS (DECLARE (*EXPR TURN_RAWO_ON TURN_RAWO_OFF))
|
||
(LAP TURN_RAWO_ON SUBR)
|
||
(ARGS TURN_RAWO_ON (NIL . 0.))
|
||
(HLLOS 0. NOQUIT)
|
||
(*OPEN 2. (% SIXBIT / / %TTY))
|
||
(*VALUE)
|
||
(HLLZS 0. NOQUIT)
|
||
(POPJ P)
|
||
NIL
|
||
(LAP TURN_RAWO_OFF SUBR)
|
||
(ARGS TURN_RAWO_OFF (NIL . 0.))
|
||
(HLLOS 0. NOQUIT)
|
||
(*OPEN 2. (% SIXBIT / / 1TTY/.LISP/./ OUTPUT))
|
||
(*VALUE)
|
||
(HLLZS 0. NOQUIT)
|
||
(POPJ P)
|
||
NIL
|
||
NIL]
|
||
|
||
(DEFINE INITMUSIC NIL
|
||
;; INITIALIZE . DONT WANT SPURIOUS CR/LF ON PRINC.
|
||
(SSTATUS TERPRI T)
|
||
(SETQ BUFFERS '(WBUF1 WBUF2 WBUF3 WBUF4 CBUF1 CBUF2 CBUF3 CBUF4))
|
||
(TERPRI)
|
||
(PRINC 'YOU/ ARE/ NOW/ USING/ THE/ LLOGO/ MINIMUSIC/ SYSTEM/.)
|
||
(COND ((EQ (QUERY / / / WHICH MUSIC BOX? (N OR O)) 'N) (NEWMUSIC))
|
||
((OLDMUSIC)))
|
||
(SETQ :SAVBUF NIL :INSTRUMENT 'LEGATO DEFAULTSCALEBASE 0.)
|
||
(MODMUSIC NIL)
|
||
(NVOICES 4.))
|
||
|
||
(DEFINE STARTMUSIC (ABB SM) NIL (QUERY TURN ON MUSIC BOX/, THEN TYPE /"OK/"/.) (PERFORM))
|
||
|
||
(DEFINE RESTARTMUSIC NIL (INITMUSIC) (STARTMUSIC))
|
||
|
||
(DEFUN WBUFS MACRO (X) '(LIST WBUF1 WBUF2 WBUF3 WBUF4))
|
||
|
||
(DEFUN CBUFS MACRO (X) '(LIST CBUF1 CBUF2 CBUF3 CBUF4))
|
||
|
||
(DEFUN VNEXT MACRO (X)
|
||
;; THE NEXT THREE DEFS ALLOW SING TO TAKE PERCUSSION NOTES BY NAME; USING DRUM AND
|
||
;;BRUSH IS MORE EFFICIENT.
|
||
(LIST '1+ (LIST 'REMAINDER (CADR X) ':NVOICES)))
|
||
|
||
(DEFINE REST NIL (- -25. :SCALEBASE))
|
||
|
||
(DEFINE BOOM NIL (- -24. :SCALEBASE))
|
||
|
||
(DEFINE GRITCH NIL (- -23. :SCALEBASE))
|
||
|
||
(DEFINE DRUM (DLIST)
|
||
(MAPC (FUNCTION (LAMBDA (D) (PLAY1 '/!) (PLAY '/ (SUB1 D)))) DLIST)
|
||
'?)
|
||
|
||
(DEFINE BRUSH (DLIST)
|
||
(MAPC (FUNCTION (LAMBDA (D) (PLAY1 '/") (PLAY '/ (SUB1 D)))) DLIST)
|
||
'?)
|
||
|
||
(DEFUN BCNT (A B) (+ (* 25. (CAAR A)) (CAAR B)))
|
||
|
||
(DEFINE CHORUS2 (PARSE 2.) FEXPR (X) (APPLY (FUNCTION CHORUS4) X))
|
||
|
||
(DEFINE CHORUS3 (PARSE 3.) FEXPR (X) (APPLY (FUNCTION CHORUS4) X))
|
||
|
||
(DEFINE CHORUS4 (PARSE 4.) FEXPR (X)
|
||
(TERPRI)
|
||
(PRINC '/(TRY/ USING/ CHORUS/ NEXT/ TIME/ YOU/'LL/ LIKE/ IT/))
|
||
(APPLY (FUNCTION CHORUS) X))
|
||
|
||
(DEFINE MBUFINIT NIL (NOTIMP MBUFINIT MBUFCLEAR))
|
||
|
||
(DEFINE MBUFPUT X (NOTIMP MBUFPUT PLAY))
|
||
|
||
(DEFINE MBUFNEXT (N) (NOTIMP MBUFNEXT ?))
|
||
|
||
(DEFINE MLEN (ABB :MAX) NIL (APPLY (FUNCTION MAX)
|
||
;; NUMBER OF NOTES IN LARGEST BUFFER.
|
||
(MAPCAR (FUNCTION BCNT) (WBUFS) (CBUFS))))
|
||
|
||
(DEFINE VLEN (ABB MBUFCOUNT) NIL (BCNT WBUF CBUF))
|
||
|
||
;; NUMBER NOTES IN CURRENT BUFFER.
|
||
|
||
(DEFINE NOMUSIC NIL (NOTIMP NOMUSIC ?))
|
||
|
||
(DEFINE PERFORM (ABB PM) NIL (MBUFOUT) (MBUFCLEAR))
|
||
|
||
(DEFINE NEWMUSIC NIL
|
||
;; ASK WHICH PORT (4 IS TTY).
|
||
(SETQ NEWMUSIC
|
||
(QUERY / / / WHICH PORT IS MUSIC BOX? (1/, 2. OR 3.))
|
||
NEWMUSIC
|
||
(COND ((= NEWMUSIC 1.) 79.)
|
||
;; LETTER O
|
||
((= NEWMUSIC 3.) 69.)
|
||
;;LETTER E
|
||
(74.))
|
||
;; LETTER J
|
||
ERRLIST
|
||
'((TURN_RAWO_ON) (TYO 17.) (TYO 32.) (TURN_RAWO_OFF)))
|
||
;;CNTRL-Q SPACE (RESTORE TTY)
|
||
(AND (BOUNDP ':NVOICES) (= :NVOICES 3.) (NVOICES 4.))
|
||
'?)
|
||
|
||
(DEFINE OLDMUSIC NIL (SETQ NEWMUSIC NIL
|
||
ERRLIST '((TURN_RAWO_ON)
|
||
(MAPC 'TYO
|
||
'(99. 103. 32. 32. 32. 32. 32. 71. 32. 65.
|
||
32. 32. 32. 32. 32. 32. 32. 66.))
|
||
(TURN_RAWO_OFF)))
|
||
'?)
|
||
|
||
(DEFINE MBUFCLEAR (ABB MCLEAR) NIL (MAPC (FUNCTION STARTATTACH) BUFFERS) (VOICE 1.))
|
||
|
||
(DEFINE MODMUSIC (TORNIL) (COND ((SETQ MODMUSIC TORNIL) (SETQ :SCALEBASE -25.))
|
||
((SETQ :SCALEBASE DEFAULTSCALEBASE))))
|
||
|
||
(DEFINE VOICES (N) (NOTIMP VOICES NVOICES))
|
||
|
||
(DEFUN NOTIMP FEXPR (X)
|
||
(ERRBREAK (CAR X)
|
||
(LIST '"NOT IMPLEMENTED IN LLOGO: USE"
|
||
(CADR X))))
|
||
|
||
(DEFINE VOICE (N)
|
||
(SETQ :VOICE N)
|
||
(COND ((AND NEWMUSIC (= N 3.) (< :NVOICES 4.)) (NVOICES 4.))
|
||
((< :NVOICES N) (NVOICES N)))
|
||
(COND ((= N 1.) (SETQ CBUF CBUF1 WBUF WBUF1))
|
||
((= N 2.) (SETQ CBUF CBUF2 WBUF WBUF2))
|
||
((= N 3.) (SETQ CBUF CBUF3 WBUF WBUF3))
|
||
((= N 4.) (SETQ CBUF CBUF4 WBUF WBUF4))
|
||
(MODMUSIC (VOICE (VNEXT (SUB1 N))))
|
||
((ERRBREAK 'VOICE '"NO SUCH VOICE")))
|
||
'?)
|
||
|
||
(DEFINE NVOICES (N)
|
||
(COND ((AND NEWMUSIC (= N 3.))
|
||
(ERRBREAK 'NVOICES
|
||
'"3. VOICES ILLEGAL ON NEW BOX USE 4."))
|
||
((AND (> N 0.) (< N 5.)) (SETQ :NVOICES N))
|
||
(MODMUSIC (NVOICES (1+ (REMAINDER (SUB1 N) 4.))))
|
||
((ERRBREAK 'NVOICES '"NO SUCH VOICE")))
|
||
(MBUFCLEAR))
|
||
|
||
(DEFUN CRUNCH (CBUF WBUF)
|
||
(COND ((CDDR CBUF) (ATTACH1 WBUF (MAKNAM (CDDR CBUF))) (STARTATTACH (CADR CBUF)))
|
||
(CBUF)))
|
||
|
||
(DEFUN PLAY1 (NOTE)
|
||
;; CRUNCHES A CHARACTER LIST INTO A PNAME ATOM AND PUTS IT ON A WORD LIST WHICH IS
|
||
;;ASSOCIATED WITH IT. NOTE THAT (CADR LST) IS THE NAME OF THE LIST, AND (CAR LST)
|
||
;;HAS INTERNAL INFO (COUNT, PTR), SINCE THESE ARE "ATTACH LISTS". NORMALLY ONE
|
||
;;WANTS TO SAY (SETQ CBUF (CRUNCH CBUF WBUF))! JUST THE CHAR PART REINITIALIZE
|
||
;;PUTS NOTE IN THE CURRENT CHAR BUF EVERY 25 CHARS, WE CRUNCH TO CONSERVE FREE
|
||
;;SPACE. (ATTACH1 RETURNS THE NUMBER OF CHARS SO FAR).
|
||
(AND (> (ATTACH1 CBUF NOTE) 24.) (SETQ CBUF (CRUNCH CBUF WBUF))))
|
||
|
||
(DEFUN PLAY (NOTE TIMS) (DO I 1. (1+ I) (> I TIMS) (PLAY1 NOTE)))
|
||
|
||
(DEFINE SING (PITCH DUR)
|
||
(PLAY1 (SETQ PITCH (NOTECH PITCH)))
|
||
;; PUTS THE NOTE CORRESPONDING TO THIS PITCH NUMBER INTO THE CURRENT BUFFER (SEE
|
||
;;PLAY). FILLS THE DURATION WITH NOTES OR BLANKS DEPENDING ON WHETHER LEGATO OR
|
||
;;NOT. IF DURATION AT LEAST 2 WILL LEAVE AT LEAST ONE UNIT REST BETWEEN NOTES.
|
||
(PLAY (COND ((EQ :INSTRUMENT 'LEGATO) PITCH) ('/ )) (- DUR 2.))
|
||
(AND (> DUR 1.) (PLAY1 '/ ))
|
||
'?)
|
||
|
||
(DEFINE SONG (A B) (MAPC (FUNCTION SING) A B) '?)
|
||
|
||
(DEFINE CHORUS (PARSE L) FEXPR (COMS)
|
||
;;CHECK FOR WRONG NUMBER? FOR RECURSION
|
||
(MAPC (FUNCTION (LAMBDA (X) (EVAL X) (VOICE (VNEXT :VOICE)))) COMS)
|
||
'?)
|
||
|
||
(DEFINE NOTE (P D)
|
||
;; NOT QUITE SYNONYM, 11LOGO VARIANT OF SING.
|
||
(COND ((= P -28.) (PLAY '/ D))
|
||
((= P -27.) (DRUM (LIST D)))
|
||
((= P -26.) (BRUSH (LIST D)))
|
||
((= P -25.)
|
||
(ERRBREAK 'NOTE '"NOT A VALID PITCH"))
|
||
((SING (+ P 3.) D))))
|
||
|
||
(DEFUN NOTECH (P)
|
||
;; A MUSIC BOX NOTE IS AN ASCII CHAR IN OCTAL [40, 137] A STD LOGO PITCH IS A
|
||
;;NUMBER IN DECIMAL [-25.,38.] (0 = MIDDLE C) :SCALEBASE SPECIFIES OFFSETS FROM
|
||
;;STD, RELATIVE TO MIDDLEC 0. MODMUSIC NUMBERS FROM 0. TO DECIMAL 63. (IE
|
||
;;:SCALEBASE = -25.) MODMUSIC FEATURES "WRAPAROUND" , IE PITCH 64 = PITCH 0.
|
||
;;"NOTECH" RETURNS ASCII CHARS FOR PITCHS. 140 OCTAL 37 OCTAL OCT 37 IS A NULL
|
||
;;CHAR. IGNORED BY BOX.
|
||
(COND (MODMUSIC (ASCII (+ 32. (REMAINDER P 64.))))
|
||
((AND (< (SETQ P (+ P :SCALEBASE 57.)) 96.) (> P 31.)) (ASCII P))
|
||
((PRINT '"NOTE OUT OF MUSIC BOX RANGE")
|
||
(ASCII 31.))))
|
||
|
||
(DEFUN STARTATTACH (LNAM)
|
||
;; STARTS AN ATTACH LIST OF FORM ((CNT . PTR) LNAM) FOR USE WITH ATTACH, ATTACH1
|
||
;;COUNT IS THE NUMBER OF ELEMENTS IN (CDDR LST) PTR IS A PTR TO THE END OF THE
|
||
;;LST.
|
||
(RPLACA (SET LNAM (LIST NIL LNAM)) (CONS 0. (CDR (EVAL LNAM)))))
|
||
|
||
(DEFUN ATTACH1 (LST EL)
|
||
;; ATTACHES ATOM EL TO LIST LST LIST MUST BE AT LEAST TWO ELEMENTS LONG. THE
|
||
;;FIRST ELEMENT IS ASSUMED TO BE A DOTTED PAIR -- A COUNT OF THE ELEMENTS IN (CDDR
|
||
;;LST) AND A PTR TO THE END. THE SECOND ELEMENT IS THE NAME OF THE LIST ITSELF.
|
||
;;THIS INTERNAL INFO IS UPDATED BY ATTACH. VALUE RETURNED IS THE NEW COUNT. NEW
|
||
;;LISTS SHOULD BE INITIALIZED USING STARTATTACH. (NCONS IS DEFINED AS (CONS EL
|
||
;;NIL)).
|
||
(CAR (RPLACA (RPLACD (CAR LST) (CDR (RPLACD (CDAR LST) (NCONS EL))))
|
||
(1+ (CAAR LST)))))
|
||
|
||
(DEFUN MLTPLX (T1 T2 T3 T4 N)
|
||
;; MLTPLX 1 TO 4 ARGS (N), IGNORE REST .
|
||
(PROG (CBUF WBUF)
|
||
;;; REBIND .
|
||
(COND ((< N 2.) (RETURN T1))
|
||
((< N 3.) (SETQ T3 (SETQ T4 NIL)))
|
||
((< N 4.) (SETQ T4 NIL)))
|
||
(STARTATTACH 'CBUF)
|
||
(STARTATTACH 'WBUF)
|
||
TOP (OR T1 T2 T3 T4 (PROG2 (CRUNCH CBUF WBUF) (RETURN (CDDR WBUF))))
|
||
(SETQ T1 (ZAP T1) T2 (ZAP T2))
|
||
(AND (< N 3.) (GO TOP))
|
||
(SETQ T3 (ZAP T3))
|
||
(AND (> N 3.) (SETQ T4 (ZAP T4)))
|
||
(GO TOP)))
|
||
|
||
(DEFUN ZAP (TB)
|
||
(COND (TB (AND (GETCHAR (CAR TB) 2.)
|
||
(SETQ TB (NCONC (EXPLODEC (CAR TB)) (CDR TB))))
|
||
(PLAY1 (CAR TB))
|
||
(CDR TB))
|
||
((PLAY1 '/ ) NIL)))
|
||
|
||
(DEFINE MBUFOUT NIL (PLYTUN (MAKTUN)))
|
||
|
||
(DEFINE MAKETUNE (TUN) (MAKE TUN (CONS :NVOICES (MAKTUN))) TUN)
|
||
|
||
;; NEED TO KNOW # VOICES.
|
||
|
||
(DEFINE PLAYTUNE (TUN) ((LAMBDA (OLDV) (NVOICES (CAR TUN))
|
||
;;ELSE GARBAGE
|
||
(PLYTUN (CDR TUN))
|
||
;;WINS EVEN IF DIFFERENT M.BOX
|
||
(NVOICES OLDV))
|
||
:NVOICES)
|
||
'?)
|
||
|
||
;; RESTORE PREVIOUS STATE
|
||
|
||
(DEFUN MAKTUN NIL
|
||
(MAPC (FUNCTION CRUNCH) (CBUFS) (WBUFS))
|
||
(MLTPLX (CDDR WBUF1) (CDDR WBUF2) (CDDR WBUF3) (CDDR WBUF4) :NVOICES))
|
||
|
||
(DEFUN PLYTUN (TUN)
|
||
;; TUN IS PRE-MLTPLXED CHAR LIST
|
||
(TURN_RAWO_ON)
|
||
(COND (NEWMUSIC (TYO 17.)
|
||
;; CNTRL-Q (REAL)
|
||
(TYO NEWMUSIC)
|
||
;; PORT SELECTOR
|
||
(PRINC '/#0/ / / / /#)
|
||
(TYO (COND ((= :NVOICES 1.) 83.)
|
||
;; LETTER S
|
||
((= :NVOICES 2.) 34.)
|
||
;; DOUBLE QUOTE
|
||
(48.))))
|
||
;; NUMERAL 0
|
||
((PRINC '/c/g/ / / / / )
|
||
(TYO (+ 99. :NVOICES))
|
||
(PRINC '/ /a/ / / / / / / )))
|
||
(MAPC (FUNCTION PRINC) TUN)
|
||
(COND (NEWMUSIC (TYO 17.) (TYO 32.))
|
||
;; ^Q-SPACE RESTORE PORT 4 (TTY)
|
||
((TYO 98.)))
|
||
(TURN_RAWO_OFF)
|
||
;; LOWER B, RESTORE EXECUPORT PRINTER
|
||
'?)
|
||
|
||
(DEFUN QUERY FEXPR (X)
|
||
(TERPRI)
|
||
(MAPC (FUNCTION (LAMBDA (Y) (PRINC Y) (TYO 32.))) X)
|
||
;;; 32. A SPACE
|
||
(REQUEST))
|
||
|
||
(INITMUSIC)
|
||
|