(FILECREATED "31-Mar-86 20:44:23" {DSK}<LISPFILES>MUSICKEYBOARD.;5 73162
changes to: (FNS MKEYBOARDFN EDITSECTION MKEYBOARD STARTKEYBOARD RAISEOCTAVE WAITFORWAKEUP)
(VARS MUSICKEYBOARDCOMS)
previous date: "31-Mar-86 09:20:40" {DSK}<LISPFILES>MUSICKEYBOARD.;1)
(* Copyright (c) 1986 by XEROX Corporation. All rights reserved.)
(PRETTYCOMPRINT MUSICKEYBOARDCOMS)
(RPAQQ MUSICKEYBOARDCOMS ((VARS 32ND 64TH ACC BADGE CF CHANGINGBEAT CHANGINGSTYLE
DISTINCTSCORENOTES DOTTEDNOTES DURLIST EIGHTH HALF HALVEDNOTES
MARKER MIDRANGEKEYMAP MYICON OCTAVES QUARTER SIXTEENTH
SLURREDSCORENOTES WHOLE)
(FNS ACCELERATEBYSCORE BUILDFIRSTPLIST BUILDLASTPLIST CHANGEDURATION CHANGESTATE CLEANUPSCORE
CONVERT CREATEKEYBOARDW DRAWKEYBOARDW EDITFROM EDITNOTE EDITSECTION EDITTO
EXPANDKEYBOARD FINDBEAT FINDOCTAVE FINDSTYLE FULLNOTE GETNOTE GETSYMBOL HOWMANY
CREATEPIANOMENU CREATEORGANMENU KILLHEAD KILLKEYBOARD KILLNOTE KILLTAIL LOADTUNE
LOWERKEYBOARD LOWEROCTAVE MAKESCORE MESACON MKEYBOARD MKEYBOARDFN MOUSEDKEY NEAR
ORGANKEYS ORGANMENU ORGANMOUSE PIANOHELP PIANOKEYS PIANOMENU PIANOMOUSE PLAYANDSAVE
PLAYBACK PLAYFIRST PLAYLAST POPANDDROP PRESSEDKEY PRINTFIRST PRINTLAST PRINTSCORE QUIT
RAISEKEYBOARD RAISEOCTAVE REMOVENOTE RESETBEAT RESETOCTAVE RESETSTYLE RESETTITLEBAR
RESETTUNE SAVETUNE SCOREON SHRINKKEYBOARD STARTKEYBOARD STILLMOUSED STILLPRESSED
VALIDTUNE WAITFORWAKEUP WIPEOUT! YES?)))
(RPAQ 32ND (READBITMAP))
(9 20
"@OH@"
"@OH@"
"@L@@"
"@OH@"
"@L@@"
"@OH@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"CL@@"
"GL@@"
"OL@@"
"OH@@"
"OH@@"
"O@@@")
(RPAQ 64TH (READBITMAP))
(9 20
"@OH@"
"@OH@"
"@L@@"
"@OH@"
"@L@@"
"@OH@"
"@L@@"
"@OH@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"CL@@"
"GL@@"
"OL@@"
"OH@@"
"OH@@"
"O@@@")
(RPAQ ACC (READBITMAP))
(12 91
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"OOO@"
"GON@"
"GON@"
"AOH@")
(RPAQ BADGE (READBITMAP))
(26 39
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"N@@@@@D@"
"O@@@@@L@"
"OH@@@AL@"
"OOOOOOL@")
(RPAQ CF (READBITMAP))
(26 130
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"L@@@@@@@"
"N@@@@@D@"
"O@@@@@L@"
"OOOOOOL@")
(RPAQQ CHANGINGBEAT
"Changing the Beat
The current beat may be changed in two ways. You
can choose a particular beat from the BEAT item in
the Piano menu or you can use the 1 and 2 keys to
double/halve the current beat respectively.")
(RPAQQ CHANGINGSTYLE
"Changing the Note Style
The shift lock controls note style. When it is
depressed notes will be played in 'SLURRED' mode.
Otherwise, they will be 'DISTINCT'.
If you don't like this feature, the code for it
may be removed from PRESSEDKEY and code for a
menu item to control STYLE will be found in
CREATEPIANOMENU and PIANOMENU.")
(RPAQQ DISTINCTSCORENOTES ((0 c)
(10 c#)
(1 d)
(11 d#)
(2 e)
(3 f)
(13 f#)
(4 g)
(14 g#)
(5 a)
(15 a#)
(6 b)
(20 r)))
(RPAQQ DOTTEDNOTES
"Dotted Notes
A single-dotted note may be played by holding the
period '.' or comma ',' key down as the note is
played.
A double-dotted note is played by holding both the
comma and period down as the note is played.
KEYBOARD doesn't allow more than two dots.")
(RPAQQ DURLIST [(1 ((53332))
((33336)
(NIL . 19996)))
(2 ((26666))
((16668)
(NIL . 9998)))
(4 ((13333))
((8334)
(NIL . 4999)))
(8 ((6666))
((4167)
(NIL . 2499)))
(16 ((3333))
((2084)
(NIL . 1249)))
(32 ((1666))
((1042)
(NIL . 624)))
(64 ((833))
((521)
(NIL . 312])
(RPAQ EIGHTH (READBITMAP))
(9 20
"@OH@"
"@OH@"
"@OH@"
"@OH@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"CL@@"
"GL@@"
"GL@@"
"OH@@"
"O@@@"
"O@@@")
(RPAQ HALF (READBITMAP))
(9 20
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@O@@"
"CC@@"
"DB@@"
"DF@@"
"HL@@"
"O@@@")
(RPAQQ HALVEDNOTES
"Halved Notes
You can play a note at half the current beat
without changing the beat by holding the dash '-'
key down as you play the note.")
(RPAQ MARKER (READBITMAP))
(9 20
"@OH@"
"@OH@"
"@L@@"
"@L@@"
"@OH@"
"@OH@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"CL@@"
"GL@@"
"OL@@"
"OH@@"
"OH@@"
"O@@@"
"N@@@")
(RPAQQ MIDRANGEKEYMAP [(0 ((262 . 6666)))
(10 ((277 . 6666)))
(1 ((294 . 6666)))
(11 ((311 . 6666)))
(2 ((330 . 6666)))
(3 ((349 . 6666)))
(13 ((370 . 6666)))
(4 ((392 . 6666)))
(14 ((415 . 6666)))
(5 ((440 . 6666)))
(15 ((466 . 6666)))
(6 ((494 . 6666)))
(20 ((NIL . 6666])
(RPAQ MYICON (READBITMAP))
(93 36
"OOOOOOOOOOOOOOOOOOOOOOOH"
"OOOOOOOOOOOOOOOOOOOOOOOH"
"OOOOOOOOOOOOOOOOOOOOOOOH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCLO@HGHOCLBANCLBANGHOAH"
"LCHG@HCHNALB@NCHBALCHNAH"
"LA@B@HA@D@HB@DA@B@HA@DAH"
"LA@B@HA@D@HB@DA@B@HA@DAH"
"LA@B@HA@D@HB@DA@B@HA@DAH"
"LA@B@HA@D@HB@DA@B@HA@DAH"
"LA@B@HA@D@HB@DA@B@HA@DAH"
"LA@B@HA@D@HB@DA@B@HA@DAH"
"LA@B@HA@D@HB@DA@B@HA@DAH"
"LA@B@HA@D@HB@DA@B@HA@DAH"
"LAHGALCHNALG@NCHG@LCHNAH"
"OOOOOOOOOOOOOOOOOOOOOOOH"
"OOOOOOOOOOOOOOOOOOOOOOOH")
(RPAQQ OCTAVES
"Changing Octaves
The left and right shift keys are used to change
octaves. The Left shift lowers the octave and the
Right shift raises it.")
(RPAQ QUARTER (READBITMAP))
(9 20
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@C@@"
"@O@@"
"CO@@"
"GN@@"
"GN@@"
"OL@@"
"O@@@")
(RPAQ SIXTEENTH (READBITMAP))
(9 20
"@OH@"
"@OH@"
"@L@@"
"@OH@"
"@OH@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"@L@@"
"CL@@"
"GL@@"
"OL@@"
"OH@@"
"OH@@"
"O@@@")
(RPAQQ SLURREDSCORENOTES ((0 C)
(10 C#)
(1 D)
(11 D#)
(2 E)
(3 F)
(13 F#)
(4 G)
(14 G#)
(5 A)
(15 A#)
(6 B)
(20 R)))
(RPAQ WHOLE (READBITMAP))
(9 6
"AL@@"
"GO@@"
"LAH@"
"LAH@"
"GO@@"
"AL@@")
(DEFINEQ
(ACCELERATEBYSCORE
[LAMBDA (FASTER) (* edited: "21-Jan-86 18:16")
[if FASTER
then [SETQ SCORE (REVERSE (CONS (QUOTE /)
(REVERSE SCORE]
else (SETQ SCORE (REVERSE (CONS (QUOTE *)
(REVERSE SCORE]
[SETQ NEWTUNE (REVERSE (MESACON (CONCATLIST (REVERSE SCORE]
(MAKESCORE NEWTUNE])
(BUILDFIRSTPLIST
[LAMBDA (TLIST N) (* edited: "30-Jan-86 16:29")
(PROG (PLIST)
[for X to N while TLIST do (if [AND (CDR TLIST)
(NOT (FULLNOTE (CADR TLIST)
(CAR TLIST]
then (SETQ PLIST (CONS (CADR TLIST)
(CONS (CAR TLIST)
PLIST)))
(SETQ TLIST (CDDR TLIST))
else (SETQ PLIST (CONS (CAR TLIST)
PLIST))
(SETQ TLIST (CDR TLIST]
(RETURN PLIST])
(BUILDLASTPLIST
[LAMBDA (TLIST N) (* edited: "30-Jan-86 16:19")
(PROG (PLIST)
[for X to N while TLIST do (if [AND (CDR TLIST)
(NOT (FULLNOTE (CAR TLIST)
(CADR TLIST]
then (SETQ PLIST (CONS (CAR TLIST)
(CONS (CADR
TLIST)
PLIST)))
(SETQ TLIST (CDDR TLIST))
else (SETQ PLIST (CONS (CAR TLIST)
PLIST))
(SETQ TLIST (CDR TLIST]
(RETURN PLIST])
(CHANGEDURATION
[LAMBDA NIL (* edited: "15-Jan-86 18:24")
[PROG (TEMPLATE)
[if (EQ CURRENTSTYLE (QUOTE DISTINCT))
then (SETQ TEMPLATE (CADDR (FASSOC CURRENTBEAT DURLIST)))
else (SETQ TEMPLATE (CADR (FASSOC CURRENTBEAT DURLIST]
(SETQ KEYMAP (for X in KEYMAP collect (LIST (CAR X)
(if (CADR TEMPLATE)
then
(LIST (CONS (CAAADR
X)
(CAAR
TEMPLATE))
(CADR TEMPLATE))
else
(LIST (CONS (CAAADR X)
(CAAR TEMPLATE]
(* edited: "13-Dec-85 17:43")
])
(CHANGESTATE
[LAMBDA (SYM) (* edited: "21-Jan-86 18:48")
(if [AND (EQ CURRENTSTYLE (QUOTE SLURRED))
(MEMB SYM (QUOTE (c d e f g a b r]
then (SETQ CURRENTSTYLE (QUOTE DISTINCT))
(SETQ SCORENOTES DISTINCTSCORENOTES)
(CHANGEDURATION)
elseif [AND (EQ CURRENTSTYLE (QUOTE DISTINCT))
(MEMB SYM (QUOTE (C D E F G A B R]
then (SETQ CURRENTSTYLE (QUOTE SLURRED))
(SETQ SCORENOTES SLURREDSCORENOTES)
(CHANGEDURATION))
(SELECTQ SYM
[< (AND (GREATERP OCTAVET -2)
(RESETOCTAVE (SUB1 OCTAVET)
OCTAVET)
(SETQ OCTAVET (SUB1 OCTAVET]
[> (AND (LESSP OCTAVET 5)
(RESETOCTAVE (ADD1 OCTAVET)
OCTAVET)
(SETQ OCTAVET (ADD1 OCTAVET]
(/ (AND (LESSP CURRENTBEAT 64)
(SETQ CURRENTBEAT (TIMES CURRENTBEAT 2))
(CHANGEDURATION)))
(* (AND (GREATERP CURRENTBEAT 1)
(SETQ CURRENTBEAT (QUOTIENT CURRENTBEAT 2))
(CHANGEDURATION)))
NIL])
(CLEANUPSCORE
[LAMBDA (TSCORE) (* edited: " 8-Jan-86 22:47")
(PROG (NEWSCORE OCTDIFF BEATDIFF)
[while TSCORE do (if (MEMB (CAR TSCORE)
(QUOTE (< > / *)))
then (SETQ OCTDIFF 0)
(SETQ BEATDIFF 0)
(while [AND TSCORE
(MEMB (CAR TSCORE)
(QUOTE (< > / *]
do (SELECTQ (CAR TSCORE)
(> (SETQ OCTDIFF (ADD1 OCTDIFF)))
(< (SETQ OCTDIFF (SUB1 OCTDIFF)))
(/ (SETQ BEATDIFF (ADD1 BEATDIFF)))
(* (SETQ BEATDIFF (SUB1 BEATDIFF)
))
NIL)
(SETQ TSCORE (CDR TSCORE)))
(for X to (ABS OCTDIFF)
do (SETQ NEWSCORE (CONS (if (MINUSP OCTDIFF)
then (QUOTE
<)
else (QUOTE >))
NEWSCORE)))
(for X to (ABS BEATDIFF)
do (SETQ NEWSCORE (CONS (if (MINUSP BEATDIFF)
then (QUOTE
*)
else (QUOTE /))
NEWSCORE)))
else (SETQ NEWSCORE (CONS (CAR TSCORE)
NEWSCORE))
(SETQ TSCORE (CDR TSCORE]
(RETURN (REVERSE NEWSCORE])
(CONVERT
[LAMBDA (STRNG) (* edited: "14-Jan-86 17:52")
(PROG (NEWNAME)
(PRIN1 "Songname? ")
(SETQ NEWNAME (READ))
(AND NEWNAME (SET NEWNAME (MESACON STRNG)))
(RETURN NEWNAME])
(CREATEKEYBOARDW
[LAMBDA NIL (* edited: "25-Mar-86 21:19")
(PROG NIL
(if (OR (NOT (BOUNDP (QUOTE KEYBOARDW)))
(NULL KEYBOARDW))
then (SETQ KEYBOARDW (CREATEW (QUOTE (400 100 552 140))
"Music Keyboard"))
(WINDOWPROP KEYBOARDW (QUOTE REPAINTFN)
(QUOTE DRAWKEYBOARDW))
(WINDOWPROP KEYBOARDW (QUOTE ICON)
MYICON)
(WINDOWPROP KEYBOARDW (QUOTE CLOSEFN)
(QUOTE KILLKEYBOARD))
(WINDOWADDPROP KEYBOARDW (QUOTE SHRINKFN)
(QUOTE SHRINKKEYBOARD))
(WINDOWADDPROP KEYBOARDW (QUOTE EXPANDFN)
(QUOTE EXPANDKEYBOARD))
[SETQ KEYBOARDTTYW (CREATEW (QUOTE (400 240 552 70]
(WINDOWPROP KEYBOARDTTYW (QUOTE PAGEFULLFN)
(QUOTE NILL))
(ATTACHWINDOW KEYBOARDTTYW KEYBOARDW (QUOTE TOP))
else (CLEARW KEYBOARDW)
(CLEARW KEYBOARDTTYW))
(DRAWKEYBOARDW)
(SETQ SCORE NIL)
(RETURN KEYBOARDW])
(DRAWKEYBOARDW
[LAMBDA NIL (* edited: "13-Dec-85 21:24")
(CLEARW KEYBOARDW) (* edited: "13-Dec-85 11:21")
(for OCTAVE from 1 to 3 as CORIGIN in (QUOTE (0 182 364))
do (for X from 0 to 6 as Y in (QUOTE (C D E F G A B))
do (BITBLT (if (MEMB Y (QUOTE (C F)))
then CF
else BADGE)
NIL NIL KEYBOARDW (PLUS CORIGIN (TIMES X 26))
0))
(for X in (QUOTE (21 47 99 125 151)) do (BITBLT ACC NIL NIL KEYBOARDW
(PLUS CORIGIN X)
39])
(EDITFROM
[LAMBDA NIL (* edited: " 4-Feb-86 19:18")
(CLEARW KEYBOARDTTYW)
(CLEARBUF)
(PRIN1 "Starting with what note number? " KEYBOARDTTYW)
(PROG (START LENGTH)
(if (AND (NUMBERP (SETQ START (READ)))
(GREATERP START 0)
(LEQ START NEWTUNELENGTH)
(SETQ LENGTH (HOWMANY))
(if (GREATERP LENGTH (ADD1 (DIFFERENCE NEWTUNELENGTH START)))
then (SETQ LENGTH (ADD1 (DIFFERENCE NEWTUNELENGTH START)))
else T)
(GREATERP LENGTH 0))
then (EDITSECTION START LENGTH])
(EDITNOTE
[LAMBDA NIL (* edited: " 3-Feb-86 14:51")
(CLEARW KEYBOARDTTYW)
(CLEARBUF)
(PRIN1 "What note number? " KEYBOARDTTYW)
(PROG (START)
(if (AND (NUMBERP (SETQ START (READ)))
(GREATERP START 0)
(LEQ START NEWTUNELENGTH))
then (EDITSECTION START 1])
(EDITSECTION
[LAMBDA (START LENGTH) (* edited: "31-Mar-86 19:59")
(PROG (TUNETAIL SECTION)
[for X from 0 to (DIFFERENCE NEWTUNELENGTH (PLUS START LENGTH))
finally (SETQ TUNETAIL (REVERSE TUNETAIL))
do (if (FULLNOTE (CAR NEWTUNE)
(CADR NEWTUNE))
then (SETQ TUNETAIL (CONS (CAR NEWTUNE)
TUNETAIL))
(SETQ NEWTUNE (CDR NEWTUNE))
else (SETQ TUNETAIL (CONS (CADR NEWTUNE)
(CONS (CAR NEWTUNE)
TUNETAIL)))
(SETQ NEWTUNE (CDDR NEWTUNE]
[SETQ SECTION (MKEYBOARDFN (for X to LENGTH finally (RETURN (REVERSE
SECTION))
do (if (FULLNOTE (CAR NEWTUNE)
(CADR NEWTUNE))
then (SETQ SECTION (CONS (CAR NEWTUNE)
SECTION))
(SETQ NEWTUNE (CDR NEWTUNE))
else (SETQ SECTION
(CONS (CADR NEWTUNE)
(CONS (CAR NEWTUNE)
SECTION)))
(SETQ NEWTUNE (CDDR NEWTUNE]
(BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS CURRNOTEYPOS NIL NIL NIL (QUOTE INVERT))
(SETQ INSTRUMENTMODE (QUOTE PIANO))
(SETQ NEWTUNE (APPEND TUNETAIL SECTION NEWTUNE))
(MAKESCORE NEWTUNE)
(RETURN NEWTUNE)
else(CLEARW KEYBOARDTTYW)
(PRIN1 "Okey-dokey"])
(EDITTO
[LAMBDA NIL (* edited: " 3-Feb-86 14:51")
(CLEARW KEYBOARDTTYW)
(CLEARBUF)
(PRIN1 "Ending with what note number? " KEYBOARDTTYW)
(PROG (START LENGTH)
(if [AND (NUMBERP (SETQ START (READ)))
(GREATERP START 0)
(LEQ START NEWTUNELENGTH)
(SETQ LENGTH (HOWMANY))
(if (GREATERP LENGTH START)
then (SETQ LENGTH START)
else T)
(GREATERP LENGTH 0)
(SETQ START (ADD1 (DIFFERENCE START LENGTH]
then (EDITSECTION START LENGTH])
(EXPANDKEYBOARD
[LAMBDA NIL (* ml " 7-Mar-86 11:59")
(if (PROCESSP KEYBOARDPROCESS)
then (WAKE.PROCESS KEYBOARDPROCESS])
(FINDBEAT
[LAMBDA (NOTE) (* edited: "16-Jan-86 09:19")
(PROG (FBEAT)
(if (EQ TEMSTYLE (QUOTE SLURRED))
then [RETURN (for I in DURLIST
do (if (EQ (if (ZEROP DOTS)
then (CAAADR I)
else (FIX (TIMES (CAAADR I)
DOTS)))
(CDR NOTE))
then (RETURN (CAR I]
else (COND
([SETQ FBEAT (for I in DURLIST do (if (EQ (CAAAR (CDDR I))
(CDR NOTE))
then (SETQ DOTS 0)
(RETURN (CAR I]
(RETURN FBEAT))
([SETQ FBEAT (for I in DURLIST
do (if (EQ [FIX (TIMES 1.5 (CAAAR (CDDR I]
(CDR NOTE))
then (SETQ DOTS 1.5)
(RETURN (CAR I]
(RETURN FBEAT))
([SETQ FBEAT (for I in DURLIST
do (if (EQ [FIX (TIMES 1.75 (CAAAR (CDDR
I]
(CDR NOTE))
then (SETQ DOTS 1.75)
(RETURN (CAR I]
(RETURN FBEAT])
(FINDOCTAVE
[LAMBDA (NOTE) (* edited: "27-Jan-86 17:56")
(if (CAR NOTE)
then (for X from 5 to -2 do (if [GEQ (CAR NOTE)
(FIX (TIMES (CAAR (CADAR
MIDRANGEKEYMAP))
(EXPT 2 X]
then (RETURN X])
(FINDSTYLE
[LAMBDA (NOTE) (* edited: "15-Jan-86 23:00")
(SETQ DOTS 0)
(if [OR (for X in DURLIST do (if (EQ (CAAADR X)
(CDR NOTE))
then (RETURN T)))
(for X in DURLIST do (if (EQ (FIX (TIMES 1.5 (CAAADR X)))
(CDR NOTE))
then (SETQ DOTS 1.5)
(RETURN T)))
(for X in DURLIST do (if (EQ (FIX (TIMES 1.75 (CAAADR X)))
(CDR NOTE))
then (SETQ DOTS 1.75)
(RETURN T]
then (QUOTE SLURRED)
else (QUOTE DISTINCT])
(FULLNOTE
[LAMBDA (PAIR PREVPAIR) (* edited: " 4-Feb-86 19:45")
(* * RETURNS TRUE IF PAIR IS A SOUNDING NOTE OR A FULL REST)
(if (CAR PAIR)
then T
else
(* * RETURN T IF PAIR IS NOT FOUND TO BE A POST-NOTE REST. NECESSARY SINCE SOME POST-NOTE RESTS ACTUALLY EQUAL SOME
DOTTED FULL RESTS.)
(NOT (COND
((for X in DURLIST do (if (AND (EQ (CDR PAIR)
(CDADR (CADDR X)))
(EQ (PLUS (CDADR (CADDR X))
(CDR PREVPAIR))
(CAAADR X)))
then (RETURN T)))
T)
((for X in DURLIST
do (if [AND [EQ (CDR PAIR)
(FIX (TIMES 1.5 (CDADR (CADDR X]
(NEAR (PLUS (CDR PAIR)
(CDR PREVPAIR))
(FIX (TIMES 1.5 (CAAADR X]
then (RETURN X)))
T)
((for X in DURLIST
do (if [AND [EQ (CDR PAIR)
(FIX (TIMES 1.75 (CDADR (CADDR X]
(NEAR (PLUS (CDR PAIR)
(CDR PREVPAIR))
(FIX (TIMES 1.75 (CAAADR X]
then (RETURN T)))
T)
NIL])
(GETNOTE
[LAMBDA (SYM) (* edited: "14-Jan-86 18:07")
(PROG (KEYCODE)
[SETQ KEYCODE (for Y in SCORENOTES do (if (EQ (CADR Y)
SYM)
then (RETURN (CAR Y]
(RETURN (CADR (FASSOC KEYCODE KEYMAP])
(GETSYMBOL
[LAMBDA (NOTE) (* edited: "20-Jan-86 15:56")
(PROG (KEYCODE)
[SETQ KEYCODE (for X in MIDRANGEKEYMAP
do (if [OR (NULL (CAAADR X))
(AND (CAR NOTE)
(EQ (CAR NOTE)
(FIX (TIMES (CAAADR X)
(EXPT 2 NEWOCTAVET]
then (RETURN (CAR X]
(RETURN (if (ZEROP DOTS)
then (CADR (FASSOC KEYCODE SCORENOTES))
elseif (FEQP DOTS 1.5)
then (PACK* (CADR (FASSOC KEYCODE SCORENOTES))
(QUOTE +))
else (PACK* (CADR (FASSOC KEYCODE SCORENOTES))
(QUOTE ++])
(HOWMANY
[LAMBDA NIL (* edited: " 9-Jan-86 00:25")
(PROG (N)
(CLEARBUF)
(CLEARW KEYBOARDTTYW)
(PRIN1 "How many notes? " KEYBOARDTTYW)
(SETQ N (READ))
(if (NUMBERP N)
then (RETURN N])
(CREATEPIANOMENU
[LAMBDA NIL (* ml "11-Mar-86 14:30")
(* (QUOTE (STYLE (QUOTE STYLE)
"Changes the style SLURRED <--> Distinct.")))
(create MENU
ITEMS ←(LIST (QUOTE (HELP (QUOTE PIANOHELP)
"Brings up a menu of subjects that might need explaining."))
(QUOTE (BEAT NIL
"The subitems are beats to which you can set the current beat."
(SUBITEMS WHOLE "1/2" "1/4" "1/8" "1/16" "1/32" "1/64")))
[QUOTE ("EDIT" (QUOTE EDITNOTE)
"Allows you to edit one note."
(SUBITEMS ("STARTING WITH..." (QUOTE EDITFROM)
"Allows you to edit a string beginning with note #...")
("ENDING WITH..." (QUOTE EDITTO)
"Allows you to edit a string ending with note #..."]
(QUOTE (RESET (QUOTE RESET)
"Resets the tune (and score) to what it was at the start of the edit session."))
(QUOTE (LOAD (QUOTE LOAD)
"Allows you to load a pre-written tune (a KEYBOARDTOOL notelist or a PLAY package string.)"))
(QUOTE (SAVE (QUOTE SAVE)
"Saves the current tune in a list and attaches it to the name you supply."))
[QUOTE (PLAYBACK (QUOTE PLAYBACK)
"Plays back the entire current tune."
(SUBITEMS (FIRST (QUOTE PLAYFIRST)
NIL
"Plays back the first N notes of the current tune.")
(LAST (QUOTE PLAYLAST)
NIL
"Plays back the last N notes of the current tune."]
[QUOTE (ACCELERATE (QUOTE ACCELERATE)
"Makes the current tune twice as fast."
(SUBITEMS (FASTER (QUOTE FASTER)
"Makes the current tune twice as fast.")
(SLOWER (QUOTE SLOWER)
"Makes the current tune twice as slow."]
[QUOTE (WIPEOUT! (QUOTE WIPEOUT!)
"WIPES OUT THE CURRENT TUNE."
(SUBITEMS (FIRST (QUOTE FIRST)
"WIPES OUT THE FIRST N NOTES OF THE CURRENT TUNE.")
(LAST (QUOTE LAST)
"WIPES OUT THE LAST N NOTES OF THE CURRENT TUNE."]
(QUOTE (ORGAN (QUOTE ORGAN)
"Gets you into organ mode. The current tune is not affected."))
(if (EQ PLAYMODE (QUOTE MOUSE))
then (QUOTE ("KEY MODE" (QUOTE KEYMODE)
"Will let you use the terminal keyboard to select notes."))
else (QUOTE ("MOUSE MODE" (QUOTE MOUSEMODE)
"Will let you use the mouse to select notes.")))
(if SCOREMODE
then (QUOTE ("SCORE OFF" (QUOTE SCOREOFF)
"Will turn the score-manipulating functions off."))
else (QUOTE ("SCORE ON" (QUOTE SCOREON)
"Will turn the score-manipulating functions on.")))
[QUOTE ("PRINT SCORE" (QUOTE PRINTSCORE)
"Will reprint the score for the entire current tune."
(SUBITEMS (FIRST (QUOTE PRINTFIRST)
"Will reprint the score for the first N notes of the current tune.")
(LAST (QUOTE PRINTLAST)
"Will reprint the score for the last N notes of the current tune."]
(QUOTE (PAUSE (QUOTE PAUSE)
"Will make KEYBOARD inactive until you press the left mouse button inside KEYBOARD's window."))
(QUOTE QUIT])
(CREATEORGANMENU
[LAMBDA NIL (* ml " 7-Mar-86 09:32")
(if NIL
then
(* * Get these procedures noticed by MasterScope)
(QUIT)
(RESETTITLEBAR))
(create MENU
ITEMS ←(LIST [QUOTE (PIANO (SETQ INSTRUMENTMODE (QUOTE PIANO]
[if (EQ PLAYMODE (QUOTE KEYS))
then [QUOTE ("MOUSE MODE" (PROGN (SETQ PLAYMODE
(QUOTE MOUSE))
(SETQ MENUFORORGAN
(CREATEORGANMENU))
(RESETTITLEBAR]
else (QUOTE ("KEYS MODE" (PROGN (SETQ PLAYMODE (QUOTE KEYS))
(SETQ MENUFORORGAN (
CREATEORGANMENU))
(RESETTITLEBAR]
(QUOTE (PAUSE (WAITFORWAKEUP)))
(QUOTE (QUIT (QUIT])
(KILLHEAD
[LAMBDA NIL (* edited: "25-Mar-86 18:41")
(PROG ((N (HOWMANY)))
(SETQ NEWTUNE (REVERSE NEWTUNE))
(if N
then (AND SCOREMODE (SETQ SCORE (REVERSE SCORE)))
(for X to N while NEWTUNE
do [if (OR (NULL (CADR NEWTUNE))
(FULLNOTE (CADR NEWTUNE)
(CAR NEWTUNE)))
then (SETQ NEWTUNE (CDR NEWTUNE))
(AND SCOREMODE (SETQ SCORE (REMOVENOTE SCORE)))
else (SETQ NEWTUNE (CDDR NEWTUNE))
(AND SCOREMODE (SETQ SCORE (REMOVENOTE SCORE]
(SETQ NEWTUNELENGTH (SUB1 NEWTUNELENGTH)))
(if SCOREMODE
then (PRINTSCORE (SETQ SCORE (REVERSE SCORE)))
else (RESETTITLEBAR)))
(SETQ NEWTUNE (REVERSE NEWTUNE])
(KILLKEYBOARD
[LAMBDA NIL (* edited: " 3-Feb-86 09:38")
(SETQ INSTRUMENTMODE NIL])
(KILLNOTE
[LAMBDA NIL (* edited: " 5-Feb-86 10:03")
(if (FULLNOTE (CAR NEWTUNE)
(CADR NEWTUNE))
then (SETQ NEWTUNE (CDR NEWTUNE))
else (SETQ NEWTUNE (CDDR NEWTUNE)))
(SETQ NEWTUNELENGTH (SUB1 NEWTUNELENGTH))
(if SCOREMODE
then (PRINTSCORE (SETQ SCORE (REMOVENOTE SCORE)))
else (RESETTITLEBAR))
(while (STILLPRESSED KEYCODE) do])
(KILLTAIL
[LAMBDA NIL (* edited: " 5-Feb-86 10:01")
(PROG ((N (HOWMANY)))
(if N
then (for X to N while NEWTUNE
do [if (FULLNOTE (CAR NEWTUNE)
(CADR NEWTUNE))
then (AND SCOREMODE (SETQ SCORE (REMOVENOTE SCORE)))
(SETQ NEWTUNE (CDR NEWTUNE))
else (SETQ NEWTUNE (CDDR NEWTUNE))
(AND SCOREMODE (SETQ SCORE (REMOVENOTE SCORE]
(SETQ NEWTUNELENGTH (SUB1 NEWTUNELENGTH)))
(if SCOREMODE
then (PRINTSCORE SCORE)
else (RESETTITLEBAR])
(LOADTUNE
[LAMBDA NIL (* edited: "25-Mar-86 21:57")
(PROG (ANS (OLDTUNE NEWTUNE))
(CLEARBUF)
(CLEARW KEYBOARDTTYW)
[SETQ ANS (MENU (create MENU
ITEMS ←(QUOTE (STRING "NOTE LIST"]
(if (EQ ANS (QUOTE STRING))
then (TERPRI)
(PRIN1 "Enter string (Unquoted, with a period at the end): ")
(RESETLST (RESETSAVE (SETSEPR (QUOTE (10 13 32))
0
(GETREADTABLE))
(LIST (QUOTE RESETREADTABLE)
(GETREADTABLE)
(QUOTE ORIG)))
(RESETSAVE (SETBRK (QUOTE (93 91 41 40 34))
0
(GETREADTABLE))
(LIST (QUOTE RESETREADTABLE)
(GETREADTABLE)
(QUOTE ORIG)))
(RESETSAVE (SETSEPR (QUOTE (46))
1
(GETREADTABLE))
(LIST (QUOTE RESETREADTABLE)
(GETREADTABLE)
(QUOTE ORIG)))
(if (SETQ ANS (RSTRING))
then (TERPRI)
(PRIN1 "Parsing the string...")
(SETQ NEWTUNE (APPEND (REVERSE (MESACON ANS))
OLDTUNE))
(PRIN1 "done.")
else (TERPRI)
(PRIN1 "No string supplied.")))
elseif (STREQUAL ANS "NOTE LIST")
then (TERPRI)
(AND (SETQ ANS (PROMPTFORWORD "Enter note list NAME: "))
(if (BOUNDP (MKATOM ANS))
then (SETQ NEWTUNE (APPEND (REVERSE (EVAL (MKATOM
ANS)))
OLDTUNE))
else (PRIN1 "Unbound Atom.")))
else (PRINTSCORE SCORE)
(RETURN))
(CLEARW KEYBOARDTTYW)
(if (NOT (VALIDTUNE))
then (SETQ NEWTUNE OLDTUNE)
(CLEARW KEYBOARDTTYW)
(PRINTOUT KEYBOARDTTYW "Bad Tune. Not loaded." T)
else (MAKESCORE NEWTUNE])
(LOWERKEYBOARD
[LAMBDA NIL (* edited: " 6-Jan-86 21:38")
(AND (GREATERP FIRSTOCTAVE -2)
(SETQ FIRSTOCTAVE (SUB1 FIRSTOCTAVE)))
(while (STILLPRESSED KEYCODE) do])
(LOWEROCTAVE
[LAMBDA (NEWOCTAVET) (* edited: "24-Jan-86 10:19")
(PROG ((OLDOCTAVET OCTAVET))
(AND (GREATERP OCTAVEV 1)
(SETQ OCTAVEV (SUB1 OCTAVEV)))
(if (GREATERP OCTAVET -2)
then (SETQ OCTAVET NEWOCTAVET)
(RESETOCTAVE OCTAVET OLDOCTAVET)
[if (AND SCOREMODE (EQ INSTRUMENTMODE (QUOTE PIANO)))
then (for X to (ABS (DIFFERENCE OCTAVET OLDOCTAVET))
do (PRIN1 (QUOTE <)
KEYBOARDTTYW)
(PRIN1 " " KEYBOARDTTYW)
(SETQ SCORE (CONS (QUOTE <)
SCORE]
(AND (BOUNDP (QUOTE INSTRUMENTMODE))
(RESETTITLEBAR)))
(SETQ OCTPOS (TIMES (SUB1 OCTAVEV)
182))
(while (STILLPRESSED KEYCODE) do])
(MAKESCORE
[LAMBDA (NEWTUNE) (* edited: "25-Mar-86 21:40")
(PROG (TSCORE OLDBEAT OCTDIFF LOCTAVET (TEMSTYLE CURRENTSTYLE)
(NEWBEAT CURRENTBEAT)
(NEWOCTAVET OCTAVET))
(CLEARW KEYBOARDTTYW)
(RESETLST (PRIN1 "Making a new score..." KEYBOARDTTYW)
(RESETSAVE (SETCURSOR WAITINGCURSOR)
(BQUOTE (SETCURSOR , DEFAULTCURSOR)))
(* * N.B. : THIS LOOP GOES THROUGH THE TUNE BACKWARDS!)
(SETQ NEWTUNELENGTH 0)
(while NEWTUNE
do (SETQ NOTE (CAR NEWTUNE))
(if (FULLNOTE NOTE (CADR NEWTUNE))
then (SETQ NEWTUNELENGTH (ADD1 NEWTUNELENGTH))
(if [NOT (EQ TEMSTYLE (SETQ TEMSTYLE (FINDSTYLE
NOTE]
then (if (EQ TEMSTYLE (QUOTE SLURRED))
then (SETQ SCORENOTES SLURREDSCORENOTES)
else (SETQ SCORENOTES DISTINCTSCORENOTES))
)
(SETQ OLDBEAT NEWBEAT)
(OR (SETQ NEWBEAT (FINDBEAT NOTE))
(CLEARW KEYBOARDTTYW)
(NOT (PRINTOUT KEYBOARDTTYW
"Couldn't find the beat of this note:"
, NOTE (QUOTE %.)
T "Aborting Makescore."))
(SETQ SCORE NIL)
(RETURN))
[while (GREATERP OLDBEAT NEWBEAT)
do (SETQ TSCORE (CONS (QUOTE /)
TSCORE)
(SETQ OLDBEAT (QUOTIENT OLDBEAT 2]
[while (GREATERP NEWBEAT OLDBEAT)
do (SETQ TSCORE (CONS (QUOTE *)
TSCORE)
(SETQ OLDBEAT (TIMES OLDBEAT 2]
[if (CAR NOTE)
then (SETQ OLDOCTAVET NEWOCTAVET)
(OR (SETQ NEWOCTAVET (FINDOCTAVE NOTE))
(CLEARW KEYBOARDTTYW)
(NOT (PRINTOUT KEYBOARDTTYW
"Couldn't find the octave of this note:"
, NOTE (QUOTE %.)
T "Aborting Makescore."))
(SETQ SCORE NIL)
(RETURN))
(if (NOT (EQ OLDOCTAVET NEWOCTAVET))
then [while (GREATERP OLDOCTAVET
NEWOCTAVET)
do (SETQ TSCORE
(CONS (QUOTE >)
TSCORE)
(SETQ OLDOCTAVET
(SUB1 OLDOCTAVET]
(while (LESSP OLDOCTAVET
NEWOCTAVET)
do (SETQ TSCORE
(CONS (QUOTE <)
TSCORE)
(SETQ OLDOCTAVET
(ADD1 OLDOCTAVET]
(SETQ TSCORE (CONS (GETSYMBOL NOTE)
TSCORE)))
(SETQ NEWTUNE (CDR NEWTUNE)))
(if (AND NEWBEAT NEWOCTAVET)
then (while (GREATERP NEWBEAT 8)
do (SETQ TSCORE (CONS (QUOTE /)
TSCORE))
(SETQ NEWBEAT (QUOTIENT NEWBEAT 2)))
(while (LESSP NEWBEAT 8)
do (SETQ TSCORE (CONS (QUOTE *)
TSCORE))
(SETQ NEWBEAT (TIMES NEWBEAT 2)))
[while (GREATERP NEWOCTAVET 0) do (SETQ TSCORE
(CONS (QUOTE >)
TSCORE)
(SETQ NEWOCTAVET
(SUB1 NEWOCTAVET]
[while (LESSP NEWOCTAVET 0) do (SETQ TSCORE
(CONS (QUOTE <)
TSCORE)
(SETQ NEWOCTAVET
(ADD1 NEWOCTAVET]
(if (EQ CURRENTSTYLE (QUOTE SLURRED))
then (SETQ SCORENOTES SLURREDSCORENOTES)
else (SETQ SCORENOTES DISTINCTSCORENOTES))
(CHANGEDURATION)
(RESETTITLEBAR)
(PRINTSCORE (SETQ SCORE (REVERSE TSCORE])
(MESACON
[LAMBDA (MESASTRNG) (* edited: "25-Mar-86 20:29")
(PROG (NEWTUNE LASTSYM LASTNOTE TNOTE (DOTS 0)
(LASTDOTS 0)
KEYCODE SCOREMODE (OCTAVET 0)
(CURRENTSTYLE (QUOTE SLURRED))
(SCORENOTES SLURREDSCORENOTES)
(CURRENTBEAT 8))
(SETQ KEYMAP MIDRANGEKEYMAP)
(SETQ MESASTRNG (UNPACK MESASTRNG))
[RESETLST (RESETSAVE (SETCURSOR WAITINGCURSOR)
(BQUOTE (SETCURSOR , DEFAULTCURSOR)))
(for SYM in MESASTRNG
do [if [AND (EQ DOTS 1)
(NOT (EQ SYM (QUOTE +]
then (SETQ NEWTUNE
(APPEND [SETQ LASTNOTE
(for X in LASTNOTE
collect
(CONS (CAR X)
(FIX (TIMES (CDR X)
1.5]
(if (EQ CURRENTSTYLE (QUOTE SLURRED))
then (CDR NEWTUNE)
else (CDDR NEWTUNE]
(CHANGESTATE SYM)
(if (EQ SYM (QUOTE #))
then [SETQ NEWTUNE
(APPEND [SETQ LASTNOTE
(REVERSE (GETNOTE (PACK* LASTSYM
(QUOTE
#]
(if (EQ CURRENTSTYLE (QUOTE SLURRED))
then (CDR NEWTUNE)
else (CDDR NEWTUNE]
elseif (EQ SYM (QUOTE +))
then
(SETQ DOTS (ADD1 DOTS))
[if (EQ DOTS 2)
then (SETQ NEWTUNE
(APPEND
[SETQ LASTNOTE
(for X in LASTNOTE
collect (CONS
(CAR X)
(FIX (TIMES (CDR X)
1.75]
(if (EQ CURRENTSTYLE (QUOTE SLURRED))
then (CDR NEWTUNE)
else (CDDR NEWTUNE]
elseif (AND (EQ SYM (QUOTE -))
(ZEROP DOTS))
then (AND (LESSP CURRENTBEAT 64)
(SETQ CURRENTBEAT (TIMES CURRENTBEAT 2)))
(CHANGEDURATION)
[SETQ NEWTUNE (APPEND (SETQ LASTNOTE
(REVERSE (GETNOTE LASTSYM))
)
(if (EQ CURRENTSTYLE
(QUOTE SLURRED))
then (CDR NEWTUNE)
else (CDDR NEWTUNE]
(SETQ CURRENTBEAT (QUOTIENT CURRENTBEAT 2))
(CHANGEDURATION)
elseif [NOT (MEMB SYM (QUOTE (< > / *]
then (SETQ NEWTUNE (APPEND (SETQ LASTNOTE
(if (SETQ TNOTE
(GETNOTE SYM))
then (SETQ DOTS 0)
(SETQ LASTSYM SYM)
TNOTE
else LASTNOTE))
NEWTUNE]
(RETURN (REVERSE NEWTUNE])
(MKEYBOARD
[LAMBDA (NEWTUNE) (* edited: "31-Mar-86 18:52")
(PROG (KEYCODE NEWNAME DOTS HALVED (NOTENUMBER 0)
(NEWTUNELENGTH 0)
(SCOREMODE T)
(CURRNOTEYPOS 5)
(CURRNOTEXPOS 1000)
(OCTAVEV 1)
(OCTAVET 0)
(OCTPOS 0)
(FIRSTOCTAVE 0)
(CURRENTSTYLE (QUOTE SLURRED))
(SCORENOTES SLURREDSCORENOTES)
(CURRENTBEAT 8)
(MARKER EIGHTH)
(PLAYMODE (QUOTE MOUSE)))
(* * INSTRUMENTMODE WILL BE A SYSTEM-GLOBAL VARIABLE)
(SETQ INSTRUMENTMODE (QUOTE PIANO))
(SETQ MENUFORPIANO (CREATEPIANOMENU))
(SETQ MENUFORORGAN (CREATEORGANMENU))
(CREATEKEYBOARDW)
(SETQ KEYMAP MIDRANGEKEYMAP)
(SETQ NEWTUNE (REVERSE NEWTUNE))
(RESETLST (RESETSAVE (TTYDISPLAYSTREAM KEYBOARDTTYW))
(SETQ NEWTUNE (MKEYBOARDFN NEWTUNE)))
(if (AND NEWTUNE (YES? "Want to save the tune?"))
then (SAVETUNE))
(CLOSEW KEYBOARDTTYW)
(CLOSEW KEYBOARDW)
(SETQ KEYBOARDPROCESS NIL)
(PROCESS.RETURN])
(MKEYBOARDFN
[LAMBDA (NEWTUNE) (* edited: "31-Mar-86 20:43")
(PROG (INITIALTUNE INITIALSCORE (INITIALLENGTH 0))
(RESETTITLEBAR)
(AND NEWTUNE (if (NOT (VALIDTUNE))
then (PRINT "BAD TUNE" KEYBOARDTTYW)
(SETQ NEWTUNE NIL)
else (MAKESCORE NEWTUNE)
(SETQ INITIALTUNE NEWTUNE)
(SETQ INITIALSCORE SCORE)
(SETQ INITIALLENGTH NEWTUNELENGTH)))
[while INSTRUMENTMODE do (if (EQ INSTRUMENTMODE (QUOTE PIANO))
then (if (EQ PLAYMODE (QUOTE KEYS))
then (PIANOKEYS)
else (PIANOMOUSE))
elseif (EQ INSTRUMENTMODE (QUOTE ORGAN))
then (if (EQ PLAYMODE (QUOTE KEYS))
then (ORGANKEYS)
else (ORGANMOUSE]
(RETURN NEWTUNE])
(MOUSEDKEY
[LAMBDA NIL (* edited: "24-Jan-86 10:27")
(PROG (TEMOCTAVEV (OLDOCTAVET OCTAVET)
FOUND
(XPOS (LASTMOUSEX KEYBOARDW))
(YPOS (LASTMOUSEY KEYBOARDW)))
(if (AND (MOUSESTATE LEFT)
(GEQ XPOS 0)
(GEQ YPOS 0)
(LESSP XPOS 544)
(LESSP YPOS 121))
then (SETQ TEMOCTAVEV (if (LESSP XPOS 182)
then 1
elseif (LESSP XPOS 364)
then 2
else 3))
[if (LESSP YPOS 39)
then (SETQ FOUND (QUOTIENT (DIFFERENCE XPOS (TIMES 182
(SUB1
TEMOCTAVEV))
)
26))
else (SETQ FOUND (for X in (QUOTE (10 11 13 14 15)) as Y
in (QUOTE (21 47 99 125 151))
until (AND [GEQ XPOS
(PLUS Y (TIMES
182
(SUB1 TEMOCTAVEV]
[LESSP XPOS
(PLUS 12 Y
(TIMES
182
(SUB1 TEMOCTAVEV]
(SETQ FOUND T))
finally (RETURN (if FOUND
then X]
[if FOUND
then (SETQ KEYCODE FOUND)
(if (LESSP OCTAVET (PLUS FIRSTOCTAVE (SUB1 TEMOCTAVEV)))
then (RAISEOCTAVE (PLUS FIRSTOCTAVE (SUB1 TEMOCTAVEV)))
(SETQ OCTPOS (TIMES (SUB1 TEMOCTAVEV)
182))
(SETQ OCTAVEV TEMOCTAVEV)
elseif (GREATERP OCTAVET (PLUS FIRSTOCTAVE (SUB1
TEMOCTAVEV)))
then (LOWEROCTAVE (PLUS FIRSTOCTAVE (SUB1 TEMOCTAVEV)))
(SETQ OCTPOS (TIMES (SUB1 TEMOCTAVEV)
182))
(SETQ OCTAVEV TEMOCTAVEV))
(if (EQ INSTRUMENTMODE (QUOTE PIANO))
then (SETQ DOTS 0)
(SETQ HALVED NIL)
(AND (KEYDOWNP (QUOTE %.))
(SETQ DOTS (ADD1 DOTS)))
(AND (KEYDOWNP (QUOTE ,))
(SETQ DOTS (ADD1 DOTS)))
[OR (ZEROP DOTS)
(SETQ DOTS (PLUS 1 (TIMES (ADD1 DOTS)
.25]
(AND (KEYDOWNP (QUOTE -))
(LESSP CURRENTBEAT 64)
(SETQ HALVED T]
(RETURN FOUND])
(NEAR
[LAMBDA (A B) (* edited: "16-Jan-86 18:25")
(LEQ (ABS (DIFFERENCE A B))
1])
(ORGANKEYS
[LAMBDA NIL (* edited: "24-Jan-86 10:11")
(RESETTITLEBAR)
(while (AND (EQ INSTRUMENTMODE (QUOTE ORGAN))
(EQ PLAYMODE (QUOTE KEYS)))
do (if (PRESSEDKEY)
then (if (LEQ KEYCODE 15)
then (BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS CURRNOTEYPOS NIL
NIL NIL (QUOTE INVERT))
(if (GEQ KEYCODE 10)
then (SETQ CURRNOTEYPOS 50)
(SETQ CURRNOTEXPOS
(PLUS OCTPOS (DIFFERENCE (TIMES (DIFFERENCE
KEYCODE 9)
26)
4)))
(BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS
CURRNOTEYPOS NIL NIL NIL (QUOTE INVERT))
(BEEPON (CAAADR (FASSOC KEYCODE KEYMAP)))
(while (STILLPRESSED KEYCODE)
finally (RETURN (BEEPOFF)))
else (SETQ CURRNOTEYPOS 10)
(SETQ CURRNOTEXPOS (PLUS OCTPOS (TIMES KEYCODE 26)
13))
(BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS
CURRNOTEYPOS NIL NIL NIL (QUOTE INVERT))
(BEEPON (CAAADR (FASSOC KEYCODE KEYMAP)))
(while (STILLPRESSED KEYCODE) finally
(RETURN (BEEPOFF)))
NIL)
else (SELECTQ KEYCODE
(18 (LOWEROCTAVE (SUB1 OCTAVET)))
(19 (RAISEOCTAVE (ADD1 OCTAVET)))
NIL))
elseif (MOUSESTATE MIDDLE)
then (ORGANMENU)
elseif (MOUSESTATE RIGHT)
then (BLOCK 500])
(ORGANMENU
[LAMBDA NIL (* edited: "16-Jan-86 11:37")
(MENU MENUFORORGAN])
(ORGANMOUSE
[LAMBDA NIL (* edited: "24-Jan-86 10:30")
(RESETTITLEBAR)
(while (AND (EQ INSTRUMENTMODE (QUOTE ORGAN))
(EQ PLAYMODE (QUOTE MOUSE)))
do (if (MOUSEDKEY)
then [if (LEQ KEYCODE 15)
then (BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS CURRNOTEYPOS NIL
NIL NIL (QUOTE INVERT))
(if (GEQ KEYCODE 10)
then (SETQ CURRNOTEYPOS 50)
(SETQ CURRNOTEXPOS
(PLUS OCTPOS (DIFFERENCE (TIMES (DIFFERENCE
KEYCODE 9)
26)
4)))
(BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS
CURRNOTEYPOS NIL NIL NIL (QUOTE INVERT))
(BEEPON (CAAADR (FASSOC KEYCODE KEYMAP)))
(while (STILLMOUSED KEYCODE) finally
(RETURN (BEEPOFF)))
else (SETQ CURRNOTEYPOS 10)
(SETQ CURRNOTEXPOS (PLUS OCTPOS (TIMES KEYCODE 26)
13))
(BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS
CURRNOTEYPOS NIL NIL NIL (QUOTE INVERT))
(BEEPON (CAAADR (FASSOC KEYCODE KEYMAP)))
(while (STILLMOUSED KEYCODE) finally
(RETURN (BEEPOFF]
elseif (PRESSEDKEY)
then (SELECTQ KEYCODE
(18 (AND (EQ OCTAVEV 1)
(LOWERKEYBOARD)))
(19 (AND (EQ OCTAVEV 3)
(RAISEKEYBOARD)))
NIL)
elseif (MOUSESTATE MIDDLE)
then (ORGANMENU)
elseif (MOUSESTATE RIGHT)
then (BLOCK 500])
(PIANOHELP
[LAMBDA NIL (* edited: "25-Mar-86 19:04")
(PROG [SUBJ WIND (KEYBOARDWREGION (WINDOWPROP KEYBOARDW (QUOTE REGION]
[SETQ SUBJ (MENU (create MENU
ITEMS ←(LIST (QUOTE ("Changing the Octave" OCTAVES
"Tells you how to change octaves."))
(QUOTE ("Dotted Notes" DOTTEDNOTES
"Tells you how to play dotted notes."))
(QUOTE ("Halved Notes" HALVEDNOTES
"Tells you how to play halved notes."))
(QUOTE ("Changing the Style"
CHANGINGSTYLE
"Tells you how to change the style of notes played."))
(QUOTE ("Changing the Beat" CHANGINGBEAT
"Tells you how to change the current beat."]
(AND SUBJ (SETQ WIND (CREATEW (LIST (PLUS (fetch LEFT of KEYBOARDWREGION)
(if (LESSP (fetch LEFT
of
KEYBOARDWREGION)
377)
then (fetch WIDTH
of KEYBOARDWREGION)
else (MINUS 376)))
(fetch BOTTOM of KEYBOARDWREGION)
376 150)
"Piano Help Window"))
(PRIN1 (EVAL SUBJ)
WIND])
(PIANOKEYS
[LAMBDA NIL (* edited: "24-Jan-86 10:12")
(RESETTITLEBAR)
(while (AND (EQ INSTRUMENTMODE (QUOTE PIANO))
(EQ PLAYMODE (QUOTE KEYS)))
do (if (PRESSEDKEY)
then (if (LEQ KEYCODE 15)
then (BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS CURRNOTEYPOS NIL
NIL NIL (QUOTE INVERT))
(if (GEQ KEYCODE 10)
then (PLAYANDSAVE KEYCODE)
(SETQ CURRNOTEYPOS 50)
(SETQ CURRNOTEXPOS
(PLUS OCTPOS (DIFFERENCE (TIMES (DIFFERENCE
KEYCODE 9)
26)
4)))
else (PLAYANDSAVE KEYCODE)
(SETQ CURRNOTEYPOS 10)
(SETQ CURRNOTEXPOS (PLUS OCTPOS (TIMES KEYCODE 26)
13))
NIL)
(BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS CURRNOTEYPOS NIL
NIL NIL (QUOTE INVERT))
else (SELECTQ KEYCODE
(18 (LOWEROCTAVE (SUB1 OCTAVET)))
(19 (RAISEOCTAVE (ADD1 OCTAVET)))
(20 (PLAYANDSAVE KEYCODE))
(21 (KILLNOTE))
NIL))
elseif (MOUSESTATE MIDDLE)
then (PIANOMENU)
elseif (MOUSESTATE RIGHT)
then (BLOCK 500])
(PIANOMENU
[LAMBDA NIL (* ml "10-Mar-86 11:00")
(* (STYLE (OR (AND (EQ CURRENTSTYLE
(QUOTE SLURRED)) (RESETSTYLE
(QUOTE DISTINCT))) (RESETSTYLE
(QUOTE SLURRED)))))
(SELECTQ (PACK* (MENU MENUFORPIANO))
(PIANOHELP (PIANOHELP))
(WHOLE (RESETBEAT 1))
(1/2 (RESETBEAT 2))
(1/4 (RESETBEAT 4))
(1/8 (RESETBEAT 8))
(1/16 (RESETBEAT 16))
(1/32 (RESETBEAT 32))
(1/64 (RESETBEAT 64))
(EDITNOTE (EDITNOTE))
(EDITFROM (EDITFROM))
(EDITTO (EDITTO))
(RESET (RESETTUNE))
(LOAD (LOADTUNE))
(SAVE (SAVETUNE))
[PLAYBACK (PROGN (SETQ NOTENUMBER 0)
(PLAYBACK NEWTUNE (REVERSE (SETQ SCORE (CLEANUPSCORE
SCORE]
(PLAYFIRST (PLAYFIRST))
(PLAYLAST (PLAYLAST))
(ACCELERATE (ACCELERATEBYSCORE T))
(FASTER (ACCELERATEBYSCORE T))
(SLOWER (ACCELERATEBYSCORE))
(WIPEOUT! (WIPEOUT!))
(FIRST (KILLHEAD))
(LAST (KILLTAIL))
(ORGAN (SETQ INSTRUMENTMODE (QUOTE ORGAN)))
(KEYMODE (PROGN (SETQ PLAYMODE (QUOTE KEYS))
(SETQ MENUFORPIANO (CREATEPIANOMENU))
(RESETTITLEBAR)))
(MOUSEMODE (PROGN (SETQ PLAYMODE (QUOTE MOUSE))
(SETQ MENUFORPIANO (CREATEPIANOMENU))
(RESETTITLEBAR)))
(SCOREOFF (PROGN (SETQ SCOREMODE NIL)
(SETQ MENUFORPIANO (CREATEPIANOMENU))
(RESETTITLEBAR)))
(SCOREON (SCOREON))
(PRINTSCORE (PRINTSCORE SCORE))
(PRINTFIRST (PRINTFIRST))
(PRINTLAST (PRINTLAST))
(PAUSE (WAITFORWAKEUP))
(QUIT (QUIT))
NIL])
(PIANOMOUSE
[LAMBDA NIL (* edited: " 3-Feb-86 15:50")
(RESETTITLEBAR)
(while (AND (EQ INSTRUMENTMODE (QUOTE PIANO))
(EQ PLAYMODE (QUOTE MOUSE)))
do (if (MOUSEDKEY)
then (if (LEQ KEYCODE 15)
then (BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS CURRNOTEYPOS NIL
NIL NIL (QUOTE INVERT))
(if (GEQ KEYCODE 10)
then (PLAYANDSAVE KEYCODE)
(SETQ CURRNOTEYPOS 50)
(SETQ CURRNOTEXPOS
(PLUS OCTPOS (DIFFERENCE (TIMES (DIFFERENCE
KEYCODE 9)
26)
4)))
else (PLAYANDSAVE KEYCODE)
(SETQ CURRNOTEYPOS 10)
(SETQ CURRNOTEXPOS (PLUS OCTPOS (TIMES KEYCODE 26)
13))
NIL)
(BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS CURRNOTEYPOS NIL
NIL NIL (QUOTE INVERT)))
elseif (PRESSEDKEY)
then (SELECTQ KEYCODE
(18 (LOWERKEYBOARD))
(19 (RAISEKEYBOARD))
(20 (PLAYANDSAVE KEYCODE))
(21 (KILLNOTE))
NIL)
elseif (MOUSESTATE MIDDLE)
then (PIANOMENU)
elseif (MOUSESTATE RIGHT)
then (BLOCK 500])
(PLAYANDSAVE
[LAMBDA (KEYCODE) (* edited: "20-Jan-86 16:54")
(PROG (NOTE)
(AND HALVED (LESSP CURRENTBEAT 64)
(RESETBEAT (TIMES 2 CURRENTBEAT)))
(SETQ NOTE (CADR (FASSOC KEYCODE KEYMAP)))
[OR (ZEROP DOTS)
(SETQ NOTE (for X in NOTE collect (CONS (CAR X)
(FIX (TIMES (CDR X)
DOTS]
(SETQ NEWTUNE (CONS (CAR NOTE)
NEWTUNE))
(if (EQ CURRENTSTYLE (QUOTE DISTINCT))
then (SETQ NEWTUNE (CONS (CADR NOTE)
NEWTUNE)))
(if SCOREMODE
then (SETQ SCORE (CONS (PRIN1 (if (NOT (ZEROP DOTS))
then (PACK* (CADR (FASSOC KEYCODE
SCORENOTES))
(if (FEQP DOTS 1.5)
then (QUOTE +)
else (QUOTE ++)))
else (CADR (FASSOC KEYCODE SCORENOTES)))
KEYBOARDTTYW)
SCORE))
(PRIN1 " " KEYBOARDTTYW))
(PLAYTUNE NOTE)
(SETQ NEWTUNELENGTH (ADD1 NEWTUNELENGTH))
(AND HALVED (RESETBEAT (QUOTIENT CURRENTBEAT 2])
(PLAYBACK
[LAMBDA (TUNE TSCORE) (* edited: "28-Jan-86 15:07")
(PROMPTPRINT "Left mouse key to STOP Playback.")
(if SCOREMODE
then (CLEARW KEYBOARDTTYW))
(for X in (REVERSE TUNE) while (NOT (MOUSESTATE LEFT))
do [if SCOREMODE
then (while [AND TSCORE (MEMB (CAR TSCORE)
(QUOTE (< > / *]
do (PRIN1 (CAR TSCORE)
KEYBOARDTTYW)
(PRIN1 " " KEYBOARDTTYW)
(SETQ TSCORE (CDR TSCORE)))
(if [AND TSCORE (OR (CAR X)
(MEMB (CAR TSCORE)
(QUOTE (R r]
then (PRIN1 (CAR TSCORE)
KEYBOARDTTYW)
(PRIN1 " " KEYBOARDTTYW)
(SETQ TSCORE (CDR TSCORE))
(SETQ NOTENUMBER (ADD1 NOTENUMBER]
(PLAYTUNE (LIST X)))
(RESETTITLEBAR])
(PLAYFIRST
[LAMBDA NIL (* edited: "31-Jan-86 07:50")
(PROG ((N (HOWMANY))
(COUNTER 0)
TSCORE)
(SETQ NOTENUMBER 0)
(if (AND N NEWTUNE)
then (AND (GREATERP N NEWTUNELENGTH)
(SETQ N NEWTUNELENGTH))
(for X in (REVERSE (SETQ SCORE (CLEANUPSCORE SCORE)))
until (EQ COUNTER N)
do (if [NOT (MEMB X (QUOTE (< > / *]
then (SETQ COUNTER (ADD1 COUNTER)))
(SETQ TSCORE (CONS X TSCORE)))
(PLAYBACK (BUILDFIRSTPLIST (REVERSE NEWTUNE)
N)
(REVERSE TSCORE])
(PLAYLAST
[LAMBDA NIL (* edited: "30-Jan-86 16:24")
(PROG ((N (HOWMANY))
(COUNTER 0)
TSCORE)
(if (AND NEWTUNE N)
then (AND (GREATERP N NEWTUNELENGTH)
(SETQ N NEWTUNELENGTH))
(SETQ NOTENUMBER (ADD1 NEWTUNELENGTH))
(for X in (SETQ SCORE (CLEANUPSCORE SCORE)) until (EQ COUNTER N)
do (if [NOT (MEMB X (QUOTE (< > / *]
then (SETQ COUNTER (ADD1 COUNTER))
(SETQ NOTENUMBER (SUB1 NOTENUMBER)))
(SETQ TSCORE (CONS X TSCORE)))
(PLAYBACK (REVERSE (BUILDLASTPLIST NEWTUNE N))
TSCORE])
(POPANDDROP
[LAMBDA (TSCORE) (* edited: " 8-Jan-86 18:44")
(* * Pops off the UPSYMs and DOWNSYMs at the front of the list, drops the note they precede, and pushes them back
(reduced) on the front of the list)
(PROG ((OCTDIFF 0)
(BEATDIFF 0))
(while [AND TSCORE (MEMB (CAR TSCORE)
(QUOTE (< > / *]
do (SELECTQ (CAR TSCORE)
(> (SETQ OCTDIFF (ADD1 OCTDIFF)))
(< (SETQ OCTDIFF (SUB1 OCTDIFF)))
(/ (SETQ BEATDIFF (ADD1 BEATDIFF)))
(* (SETQ BEATDIFF (SUB1 BEATDIFF)))
NIL)
(SETQ TSCORE (CDR TSCORE)))
(SETQ TSCORE (REMOVENOTE TSCORE))
(for X to (ABS OCTDIFF) do (SETQ TSCORE (CONS (if (MINUSP OCTDIFF)
then (QUOTE <)
else (QUOTE >))
TSCORE)))
(for X to (ABS BEATDIFF) do (SETQ TSCORE (CONS (if (MINUSP BEATDIFF)
then (QUOTE *)
else (QUOTE /))
TSCORE)))
(RETURN TSCORE])
(PRESSEDKEY
[LAMBDA NIL (* edited: "23-Jan-86 16:47")
(PROG (BEAT)
(if (EQ INSTRUMENTMODE (QUOTE PIANO))
then (SETQ DOTS 0)
(SETQ HALVED NIL)
(AND (KEYDOWNP (QUOTE %.))
(SETQ DOTS (ADD1 DOTS)))
(AND (KEYDOWNP (QUOTE ,))
(SETQ DOTS (ADD1 DOTS)))
[OR (ZEROP DOTS)
(SETQ DOTS (PLUS 1 (TIMES (ADD1 DOTS)
.25]
(AND (KEYDOWNP (QUOTE -))
(LESSP CURRENTBEAT 64)
(SETQ HALVED T))
[if (KEYDOWNP (QUOTE LOCK))
then (AND (EQ CURRENTSTYLE (QUOTE DISTINCT))
(RESETSTYLE (QUOTE SLURRED)))
else (AND (EQ CURRENTSTYLE (QUOTE SLURRED))
(RESETSTYLE (QUOTE DISTINCT]
(if (COND
[(KEYDOWNP (QUOTE 1))
(AND (GREATERP CURRENTBEAT 1)
(SETQ BEAT (QUOTIENT CURRENTBEAT 2]
[(KEYDOWNP (QUOTE 2))
(AND (LESSP CURRENTBEAT 64)
(SETQ BEAT (TIMES CURRENTBEAT 2]
NIL)
then (RESETBEAT BEAT)))
(RETURN (for X
in (QUOTE (0 1 2 3 4 5 6 10 11 13 14 15 18 19 20 21)) as C
in (QUOTE (Z X C V B N M S D G H J LSHIFT RSHIFT SPACE BS))
do (AND (KEYDOWNP C)
(SETQ KEYCODE X)
(RETURN C])
(PRINTFIRST
[LAMBDA NIL (* edited: " 9-Jan-86 11:07")
(PROG (SCOREHEAD (N (HOWMANY))
(Y 0)
(TSCORE (REVERSE SCORE)))
(if N
then (CLEARW KEYBOARDTTYW)
[for X in TSCORE repeatuntil (EQ Y N)
do (SETQ SCOREHEAD (CONS X SCOREHEAD))
(if [NOT (MEMB X (QUOTE (< > / *]
then (SETQ Y (ADD1 Y]
(PRINTSCORE SCOREHEAD])
(PRINTLAST
[LAMBDA NIL (* edited: " 9-Jan-86 11:07")
(PROG ((N (HOWMANY))
TSCORE
(Y 0))
(if N
then (CLEARW KEYBOARDTTYW)
[for X in SCORE repeatuntil (EQ Y N)
do (SETQ TSCORE (CONS X TSCORE))
(if [NOT (MEMB X (QUOTE (< > / *]
then (SETQ Y (ADD1 Y]
(PRINTSCORE (REVERSE TSCORE])
(PRINTSCORE
[LAMBDA (TSCORE) (* edited: " 5-Feb-86 10:03")
(CLEARW KEYBOARDTTYW)
(RESETTITLEBAR)
(SETQ SCORE (CLEANUPSCORE SCORE))
(for X in (REVERSE (SETQ TSCORE (CLEANUPSCORE TSCORE)))
do (PRIN1 X KEYBOARDTTYW)
(PRIN1 " " KEYBOARDTTYW])
(QUIT
[LAMBDA NIL (* ml " 7-Mar-86 11:02")
(if (YES? "Are you sure you want to Quit?")
then (BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS CURRNOTEYPOS NIL NIL NIL (QUOTE
INVERT))
(SETQ INSTRUMENTMODE NIL)
(RESETTITLEBAR))
(CLEARBUF])
(RAISEKEYBOARD
[LAMBDA NIL (* edited: " 6-Jan-86 21:41")
(AND (LESSP FIRSTOCTAVE 3)
(SETQ FIRSTOCTAVE (ADD1 FIRSTOCTAVE)))
(while (STILLPRESSED KEYCODE) do])
(RAISEOCTAVE
[LAMBDA (NEWOCTAVET) (* edited: "31-Mar-86 18:36")
(PROG ((OLDOCTAVET OCTAVET))
(AND (LESSP OCTAVEV 3)
(SETQ OCTAVEV (ADD1 OCTAVEV)))
(if (LESSP OCTAVET 5)
then (SETQ OCTAVET NEWOCTAVET)
(RESETOCTAVE OCTAVET OLDOCTAVET)
[if (AND SCOREMODE (EQ INSTRUMENTMODE (QUOTE PIANO)))
then (for X to (ABS (DIFFERENCE OCTAVET OLDOCTAVET))
do (PRIN1 (QUOTE >)
KEYBOARDTTYW)
(PRIN1 " " KEYBOARDTTYW)
(SETQ SCORE (CONS (QUOTE >)
SCORE]
(AND (BOUNDP (QUOTE INSTRUMENTMODE))
(RESETTITLEBAR)))
(SETQ OCTPOS (TIMES (SUB1 OCTAVEV)
182))
(while (STILLPRESSED KEYCODE) do])
(REMOVENOTE
[LAMBDA (SCORE) (* edited: "17-Jan-86 20:27")
(if [NOT (MEMB (CAR SCORE)
(QUOTE (< > / * R r]
then (SETQ SCORE (CDR SCORE))
elseif (MEMB (CAR SCORE)
(QUOTE (R r)))
then (SETQ SCORE (CDR SCORE))
else (SETQ SCORE (POPANDDROP SCORE)))
SCORE])
(RESETBEAT
[LAMBDA (BEAT) (* edited: "15-Jan-86 18:31")
(PROG (SYMBOL)
(if (NOT (EQ BEAT CURRENTBEAT))
then (BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS CURRNOTEYPOS NIL NIL NIL
(QUOTE INVERT))
(SELECTQ BEAT
(1 (SETQ MARKER WHOLE))
(2 (SETQ MARKER HALF))
(4 (SETQ MARKER QUARTER))
(8 (SETQ MARKER EIGHTH))
(16 (SETQ MARKER SIXTEENTH))
(32 (SETQ MARKER 32ND))
(64 (SETQ MARKER 64TH))
NIL)
(BITBLT MARKER NIL NIL KEYBOARDW CURRNOTEXPOS CURRNOTEYPOS NIL NIL NIL
(QUOTE INVERT))
(if SCOREMODE
then (while (GREATERP CURRENTBEAT BEAT)
do (SETQ CURRENTBEAT (QUOTIENT CURRENTBEAT 2))
(SETQ SCORE (CONS (QUOTE *)
SCORE))
(PRIN1 (QUOTE *)
KEYBOARDTTYW)
(PRIN1 " " KEYBOARDTTYW))
(while (LESSP CURRENTBEAT BEAT)
do (SETQ CURRENTBEAT (TIMES CURRENTBEAT 2))
(SETQ SCORE (CONS (QUOTE /)
SCORE))
(PRIN1 (QUOTE /)
KEYBOARDTTYW)
(PRIN1 " " KEYBOARDTTYW)))
(CHANGEDURATION)
(RESETTITLEBAR])
(RESETOCTAVE
[LAMBDA (OFACTOR TEMOCTAVET) (* edited: "22-Jan-86 16:40")
[PROG (SYMBOL)
(SETQ KEYMAP (for X in MIDRANGEKEYMAP as Y in KEYMAP
collect
(if (CAAADR X)
then [LIST (CAR X)
(if (CADADR Y)
then
(LIST (CONS (FIX (TIMES (EXPT 2
OFACTOR)
(CAAADR
X)))
(CDAADR Y))
(CADADR Y))
else (LIST (CONS
(FIX (TIMES (EXPT 2
OFACTOR)
(CAAADR X)))
(CDAADR Y]
else Y]
T])
(RESETSTYLE
[LAMBDA (STYLE) (* edited: " 8-Jan-86 20:07")
(if (NOT (EQ STYLE CURRENTSTYLE))
then (SETQ CURRENTSTYLE STYLE)
(CHANGEDURATION)
(if (EQ STYLE (QUOTE DISTINCT))
then (SETQ SCORENOTES DISTINCTSCORENOTES)
else (SETQ SCORENOTES SLURREDSCORENOTES))
(RESETTITLEBAR])
(RESETTITLEBAR
[LAMBDA NIL (* edited: "17-Jan-86 20:13")
(WINDOWPROP KEYBOARDW (QUOTE TITLE)
(if (EQ INSTRUMENTMODE (QUOTE PIANO))
then (CONCAT (QUOTE PIANO)
" Octave: " OCTAVET " Style: " CURRENTSTYLE " Beat: 1/"
CURRENTBEAT " Play Mode: " PLAYMODE " Score: "
(if SCOREMODE
then (QUOTE ON)
else (QUOTE OFF))
" Length: " NEWTUNELENGTH " # " NOTENUMBER)
elseif (EQ INSTRUMENTMODE (QUOTE ORGAN))
then (CONCAT (QUOTE Organ)
" Octave: " OCTAVET " Play Mode: " PLAYMODE)
else (QUOTE Keyboard])
(RESETTUNE
[LAMBDA NIL (* edited: "31-Jan-86 13:24")
(if (YES? "Are you sure you want to reset the tune?")
then (CLEARW KEYBOARDTTYW)
(SETQ NEWTUNE INITIALTUNE)
(SETQ SCORE INITIALSCORE)
(SETQ NEWTUNELENGTH INITIALLENGTH)
(PRINTSCORE SCORE)
(RESETTITLEBAR])
(SAVETUNE
[LAMBDA NIL (* ml " 7-Mar-86 17:26")
(PROG (NEWNAME)
(if NEWTUNE
then (TERPRI)
(CLEARBUF)
(SETQ NEWNAME (PACK* (PROMPTFORWORD "Songname? ")))
(AND NEWNAME (SET NEWNAME (REVERSE NEWTUNE))
(TERPRI)
(PRIN1 NEWNAME)
(PRIN1 " saved."])
(SCOREON
[LAMBDA NIL (* edited: " 3-Feb-86 14:44")
(SETQ SCOREMODE T)
(SETQ MENUFORPIANO (CREATEPIANOMENU))
(RESETTITLEBAR)
(CLEARW KEYBOARDTTYW)
(CLEARBUF)
(PROG (A)
(if (AND NEWTUNE (YES? "Want to rewrite the score?"))
then (CLEARW KEYBOARDTTYW)
(MAKESCORE NEWTUNE)
else (CLEARW KEYBOARDTTYW)
(RESETTITLEBAR])
(SHRINKKEYBOARD
[LAMBDA NIL (* ml " 7-Mar-86 11:56")
(if (PROCESSP KEYBOARDPROCESS)
then (SUSPEND.PROCESS KEYBOARDPROCESS])
(STARTKEYBOARD
[LAMBDA NIL (* edited: "31-Mar-86 18:34")
(SETQ KEYBOARDPROCESS (ADD.PROCESS (QUOTE (MKEYBOARD))
(QUOTE AFTEREXIT)
(QUOTE DELETE])
(STILLMOUSED
[LAMBDA (TKEYCODE) (* edited: " 7-Jan-86 11:48")
(AND (MOUSEDKEY)
(EQ KEYCODE TKEYCODE])
(STILLPRESSED
[LAMBDA (KEYCODE) (* edited: " 3-Jan-86 18:24")
(KEYDOWNP (for X
in (QUOTE (0 1 2 3 4 5 6 10 11 13 14 15 18 19 20 21)) as C
in (QUOTE (Z X C V B N M S D G H J LSHIFT RSHIFT SPACE BS))
until (EQ KEYCODE X) finally (RETURN C])
(VALIDTUNE
[LAMBDA NIL (* edited: "17-Jan-86 20:07")
(if (LISTP NEWTUNE)
then (for X in NEWTUNE finally (RETURN T)
do (if (OR (ATOM X)
(NULL X))
then (RETURN)
else (if [OR [NOT (AND (ATOM (CAR X))
(ATOM (CDR X]
[NOT (OR (NULL (CAR X))
(NUMBERP (CAR X]
(NOT (NUMBERP (CDR X]
then (RETURN])
(WAITFORWAKEUP
[LAMBDA NIL (* edited: "31-Mar-86 09:20")
(if (PROCESSP KEYBOARDPROCESS)
then (CLEARW KEYBOARDTTYW)
(PRINT "Pausing... Left Button in this window to wake me up." KEYBOARDTTYW)
(do (BLOCK 500)
(if (AND (MOUSESTATE LEFT)
(NOT (GETMOUSESTATE))
(OR (INSIDEP (WINDOWPROP KEYBOARDW (QUOTE REGION))
LASTMOUSEX LASTMOUSEY)
(INSIDEP (WINDOWPROP KEYBOARDTTYW (QUOTE REGION))
LASTMOUSEX LASTMOUSEY)))
then (TTYDISPLAYSTREAM KEYBOARDTTYW)
(PRINTOUT T "Good Morning." T)
(RETURN])
(WIPEOUT!
[LAMBDA NIL (* edited: " 5-Feb-86 10:00")
(if NEWTUNE
then (if (YES? "Are you sure you want to wipeout this tune?")
then (if SCOREMODE
then (for X to (COUNT NEWTUNE) do (SETQ SCORE (REMOVENOTE
SCORE)))
(PRINTSCORE SCORE))
(SETQ NEWTUNE NIL)
(SETQ NEWTUNELENGTH 0)
else (PRIN1 "WIPEOUT! cancelled."))
else (PRIN1 "There is no tune to wipe out."])
(YES?
[LAMBDA (STRNG) (* edited: "29-Jan-86 16:47")
(* This function prompts the user with STRNG until a Y or N answer is supplied. Returns T if a Y is supplied, NIL
otherwise. Written by ML.)
(MOUSECONFIRM STRNG NIL KEYBOARDTTYW T])
)
(PUTPROPS MUSICKEYBOARD COPYRIGHT ("XEROX Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (8786 73078 (ACCELERATEBYSCORE 8796 . 9233) (BUILDFIRSTPLIST 9235 . 9841) (
BUILDLASTPLIST 9843 . 10461) (CHANGEDURATION 10463 . 11310) (CHANGESTATE 11312 . 12497) (CLEANUPSCORE
12499 . 13929) (CONVERT 13931 . 14215) (CREATEKEYBOARDW 14217 . 15361) (DRAWKEYBOARDW 15363 . 16077) (
EDITFROM 16079 . 16745) (EDITNOTE 16747 . 17140) (EDITSECTION 17142 . 18707) (EDITTO 18709 . 19346) (
EXPANDKEYBOARD 19348 . 19546) (FINDBEAT 19548 . 20784) (FINDOCTAVE 20786 . 21148) (FINDSTYLE 21150 .
21883) (FULLNOTE 21885 . 23229) (GETNOTE 23231 . 23571) (GETSYMBOL 23573 . 24322) (HOWMANY 24324 .
24634) (CREATEPIANOMENU 24636 . 28366) (CREATEORGANMENU 28368 . 29258) (KILLHEAD 29260 . 30183) (
KILLKEYBOARD 30185 . 30332) (KILLNOTE 30334 . 30845) (KILLTAIL 30847 . 31527) (LOADTUNE 31529 . 33548)
(LOWERKEYBOARD 33550 . 33808) (LOWEROCTAVE 33810 . 34694) (MAKESCORE 34696 . 38539) (MESACON 38541 .
41414) (MKEYBOARD 41416 . 42591) (MKEYBOARDFN 42593 . 43540) (MOUSEDKEY 43542 . 45969) (NEAR 45971 .
46127) (ORGANKEYS 46129 . 47795) (ORGANMENU 47797 . 47935) (ORGANMOUSE 47937 . 49666) (PIANOHELP 49668
. 50952) (PIANOKEYS 50954 . 52313) (PIANOMENU 52315 . 54387) (PIANOMOUSE 54389 . 55738) (PLAYANDSAVE
55740 . 57003) (PLAYBACK 57005 . 57943) (PLAYFIRST 57945 . 58662) (PLAYLAST 58664 . 59413) (POPANDDROP
59415 . 60621) (PRESSEDKEY 60623 . 62152) (PRINTFIRST 62154 . 62670) (PRINTLAST 62672 . 63152) (
PRINTSCORE 63154 . 63520) (QUIT 63522 . 63875) (RAISEKEYBOARD 63877 . 64131) (RAISEOCTAVE 64133 .
65010) (REMOVENOTE 65012 . 65423) (RESETBEAT 65425 . 66744) (RESETOCTAVE 66746 . 67489) (RESETSTYLE
67491 . 67909) (RESETTITLEBAR 67911 . 68664) (RESETTUNE 68666 . 69061) (SAVETUNE 69063 . 69481) (
SCOREON 69483 . 69969) (SHRINKKEYBOARD 69971 . 70172) (STARTKEYBOARD 70174 . 70420) (STILLMOUSED 70422
. 70593) (STILLPRESSED 70595 . 70947) (VALIDTUNE 70949 . 71499) (WAITFORWAKEUP 71501 . 72199) (
WIPEOUT! 72201 . 72755) (YES? 72757 . 73076)))))
STOP