10 REM ***  PICCOLO  RESONANCE - LOSSLESS-HEADJOINT AND BLOWING CORRECTIONS***
20 REM PROGRAM  BY JOHN W. COLTMAN 11/19/89  * PICCRESO.BAS
30 REM
40 WD=0! : REM  HEADJOINT WITHDRAWAL
50            SD$="####.#       ####.#       ###.#       ###.#"
60 DIM A$(19):KEY OFF
70 DEFINT K,B: DIM B(51,19),Q$(39),T(39),L$(39)
80 PI=3.14159
90 PRINT "READING KEY MATRIX - PLEASE WAIT"
100 FOR K=1 TO 19:READ A$(K):NEXT K
110 GOSUB 350
120 FOR N%=1 TO 51
130 FOR K=1 TO 19
140 READ B(N%,K) :NEXT K: NEXT N%
150 DM=187.8 :REM MOUTH NODE DISTANCE
160  PRINT "DO YOU WANT  (1) PRINTOUT OF ENTIRE SCALE                                                    (2) MANUAL NOTE CHOICE                                                          (3) TRILLS - MANUAL"
170 INPUT "WHICH";GG
180 PRINT 
190 IF GG<>1 AND GG<>2 AND GG<>3 GOTO 160
200 IF GG=1 GOTO 1500
210 INPUT"DO YOU WANT TO REVIEW PARAMETERS (Y OR N)";F$
220 PRINT
230 IF F$="Y" OR F$="YES" THEN GOSUB 1110
240 IF GG=3 GOTO 2090
250 INPUT "NOTE NAME";D$
260 GOSUB 1220
270 DATA TR1,TR2,C#,C,B,C,A#,A,G#1,G#2,G,F#,F,E,D#,D,C#,C,B
280 N%=FL-58
290 PRINT"                             A     G#             D#
300 PRINT"              C#    B     A#          G  F# F  E     D  C# C  B
310 PRINT"       TR1 TR2   C     C        G#"
320 PRINT"       ";
330 FOR K=1 TO 19:PRINT B(N%,K);:NEXT K
340 GOTO 800
350 DIM C(20,3):REM INCLUDES COLUMN 0
360 FOR K=1 TO 19
370 FOR P=0 TO 3
380 READ C(K,P)
390 NEXT P,K
400 RETURN
500 REM ** THESE DATA FOR AMY'S ARMSTRONG PICCOLO AS MODIFIED
510 REM ** 
520 DATA -64.94,29.4,.17,.1  :    'TR #1
530 DATA -56.5,29.4,.17,.1   :    'TR #2
540 DATA -46.1,34.5,.17,.1   :    'C#
550 DATA -32.59,26.7,.2,.11  :    'C - UPPER THUMB
560 DATA -22.5,18,.3,.2      :    'B
570 DATA -22.1,26.7,.2,.11   :    'C - LOWER THUMB
580 DATA -11.18,16.4,.4,.3   :    'A#
590 DATA 0,16.4,.4,.3        :    'A HOLE REFERNCE
600 DATA 10.7,16.4,.4,.3     :    'G# SIDE
610 DATA 11.87,16.4,.4,.3    :    'G# TOP - FIXED TO A KEY
620 DATA 23.97,16.3,.6,.3    :    'G
630 DATA 37.02,16.3,.6,.3    :    'F#
640 DATA 50.79,16.3,.6,.3    :    'F
650 DATA 65.49,16.3,.6,.3    :    'E
660 DATA 82.36,14.2,1,.5     :    'D#
670 DATA 103.9,3.5,0,0       :    'D - END FOR STD PICCOLO
680 DATA 103.9,1E8,0,0       :    'C# DUMMY
690 DATA 103.9,1E8,0,0       :    'C DUMMY
700 DATA 103.9,1E8,0,0       :    'B DUMMY
800 L=LO:RA=0 :    REM STARTS CALCULATION FIRST TIME
810 R=L/4+.001
820 C(20,0)=C(19,0)
830 FOR K= 19 TO 1 STEP-1
840 DR=C(K+1,0)-C(K,0)
850 R1=R+DR/2
860 TF=1: REM NO TEMP FACTOR ON COLUMN
870 R=R+TF*DR
880 IF B(N%,K)=0 THEN GOSUB 920: REM key open
890 IF B(N%,K)=1 THEN GOSUB 940: REM key closed
895 REM PRINT R;
900 NEXT K
910 R=R+DM +C(1,0):GOTO 950
920 S= 1/TAN(2*PI*R/L) + L/2/PI/C(K,1)
930 R =L/2/PI*ATN(1/S) :RETURN
940 R=R + C(K,2)-((C(K,2)+C(K,3))*(COS(2*PI*R/L))^2):RETURN
950 IF R<-L/4 THEN R=R+L/2 :GOTO 950
960 IF R>L/4 THEN R = R-L/2 :GOTO 960
962 REM PRINT L;R
965 IF ABS(R)<.1 GOTO 1010
970 IF RA=0  THEN DE=-.01:RO=R:GOTO 980: REM FIRST TIME ONLY
975 DE=DE*R/(RA-R):REM PRINT:PRINT RA,R:PRINT
980 RA=R : LA=L :REM SAVES PREVIOUS VALUES
990 L=L*(1+DE):GOTO 810
1010 IF GG<>1 GOTO 1030
1020 IF GG=1 AND N%<40 GOTO 1800 ELSE GOTO 2040
1030 PRINT:PRINT
1040 PRINT"  NOTE   FREQUENCY    WAVELENGTH      COLUMN     CENTS"
1050 PRINT"                                      EXCESS     DEVIATION"
1060 IF GG=3 THEN D$=E$
1070 PRINT TAB(4) D$;:PRINT TAB(12) USING SD$;F;LO;RO;1731*LOG(LO/L)
1080 REM
1090 IF GG=3 GOTO 2090
1100 GOTO 250
1110 PRINT TAB(5)"KEY";TAB(13)"POSITION";TAB(25)"H";TAB(33)"A";
1120 PRINT TAB(41)"B":PRINT
1130 FOR K=1 TO 19
1140 PRINT TAB(5) A$(K);
1150 PRINT TAB(15) C(K,0);TAB(23) C(K,1);TAB(31)C(K,2);TAB(39)C(K,3)
1160 NEXT K
1170 REM
1180 REM
1190 REM
1200 PRINT "HEADJOINT WITHDRAWN ";WD;" MM":INPUT"READY";DD$:RETURN
1210 INPUT"NOTE";D$
1220 B$=LEFT$(D$,1)
1230 Q=ASC(B$)
1240 IF Q>71 OR Q<65 GOTO 250
1250 ON (Q-64) GOTO 1260,1270,1280,1290,1300,1310,1320
1260 AN=9:GOTO 1330
1270 AN=11: GOTO 1330
1280 AN=0: GOTO 1330
1290 AN=2: GOTO 1330
1300 AN=4: GOTO 1330
1310 AN=5: GOTO 1330
1320 AN=7: GOTO 1330
1330 IF MID$(D$,2,1)="#" THEN BN=AN +1 ELSE BN=AN
1340 CN$=RIGHT$(D$,1)
1350 CN=VAL(CN$)
1360 FL=12*CN+BN
1370 IF FL<59 OR FL>97 GOTO 250
1380 F=16.3516*2^(FL/12)
1390 IF FL<62 THEN HJ=-2.6
1400 IF FL>61 AND FL<70 THEN HJ=.35*(FL-69):GOTO 1440
1410 IF FL>69 THEN HJ=-1.1-.035*(FL-83)+.0075*(FL-83)^2:GOTO 1440
1440 DM= 187.8+WD+HJ
1450 LO=350403!*(1-.3/F^.5)/F : REM WET WAVELENGTH 85 DEG F
1470 RETURN
1480 PRINT "FREQUENCY=";F;"  TUBE WAVELENGTH=";LO
1490 RETURN
1500 INPUT "PICCOLO NAME";MN$
1510 GOTO 1710
1520 IF B(1,19)=2 THEN PP=2 ELSE PP=1
1530 FOR N%=1 TO 39
1540 FL=N%+58:OC=INT(FL/12):OC$=STR$(OC):N2=FL-OC*12+1
1550 ON N2 GOTO 1590,1600,1610,1620,1630,1640,1650,1660,1670,1560,1570,1580
1560 D$="A":GOTO 1680
1570 D$="A#":GOTO 1680
1580 D$="B":GOTO 1680
1590 D$="C":GOTO 1680
1600 D$="C#":GOTO 1680
1610 D$="D":GOTO 1680
1620 D$="D#":GOTO 1680
1630 D$="E":GOTO 1680
1640 D$="F":GOTO 1680
1650 D$="F#":GOTO 1680
1660 D$="G":GOTO 1680
1670 D$="G#":GOTO 1680
1680 D$=D$+OC$
1690 GOSUB 1380:REM GETS FREQ F AND WAVELENGTH L
1700 GOTO 800
1710 LPRINT CHR$(27)"@";:LPRINT CHR$(27)"N"CHR$(4):LPRINT MN$
1720 LPRINT TAB(5)"KEY";TAB(13)"POSITION";TAB(25)"H";TAB(33)"A";TAB(41)"B":LPRINT
1730 FOR K=1 TO 19
1740 LPRINT TAB(5)A$(K);TAB(15)C(K,0);TAB(23)C(K,1);TAB(31)C(K,2);TAB(39)C(K,3):NEXT K
1750 LPRINT "HEADJOINT WITHDRAWN ";WD; "MM"
1760 LPRINT
1770 LPRINT "   NOTE   FREQUENCY   WAVELENGTH    COLUMN    CENTS"
1780 LPRINT "                                    EXCESS    DEVIATION"
1790 GOTO 1520
1800 REM
1810 T(N%)=1731*LOG(LO/L)
1820 LPRINT TAB(4) D$;:LPRINT TAB(12) USING SD$;F;LO;RO;T(N%)
1830 NEXT N%
1840 LPRINT : LPRINT "TRILLS  -- DATA ARE FOR UPPER NOTE":LPRINT
1850 LPRINT"TRILL             FREQUENCY    WAVELENGTH     COLUMN    CENTS"
1860 LPRINT "                                             EXCESS    DEVIATION"
1870 FOR N%= 40 TO 51
1880 ON (N%-39)  GOTO 1890,1900,1910,1920,1930,1940,1950,1960,1970,1980,1990,2000
1890 E$="C6-D6   (TR2)":FL=74:GOTO 2010
1900 E$="C#6-D6  (TR2)":FL=74:GOTO 2010
1910 E$="B6-C#7  (TR2)":FL=85:GOTO 2010
1920 E$="C#7-D8  (TR2)":FL=86:GOTO 2010
1930 E$="G7-G#7  (TR2)":FL=92:GOTO 2010
1940 E$="G#7-A7  (TR2)":FL=93:GOTO 2010
1950 E$="C#6-D#6 (TR1)":FL=75:GOTO 2010
1960 E$="C7-D7   (TR1)":FL=86:GOTO 2010
1970 E$="D7-D#7  (TR1)":FL=87:GOTO 2010
1980 E$="C#7-D#7 (BOTH)":FL=87: GOTO 2010
1990 E$="G7-A7 (BOTH+G#)":FL=93:GOTO 2010
2000 E$="G#7-A#7 (BOTH)" :FL=94:GOTO 2010
2010 GOSUB 1380
2020 IF GG=3 GOTO 290
2030 GOTO 800
2040 LPRINT E$;:LPRINT TAB(19) USING SD$; F;LO;RO;1731*LOG(LO/L)
2050 REM
2060 NEXT N%
2070 GOTO 5000
2080 END
2090 PRINT:PRINT "TRILL FINGER 1     TRILL FINGER 2       BOTH "
2100 PRINT "(1) C6-D6          (7) C#6-D#6        (10) C#7-D#7 "
2110 PRINT "(2) C#6-D6         (8) C7-D7          (11) G7-A7 +G#"
2120 PRINT "(3) B6-C#7         (9) D7-D#7         (12) G#7-A#7  "
2130 PRINT "(4) C#7-D7 "
2140 PRINT "(5) G7-G#7 "
2150 PRINT"(6) G#7-A7                  ";:INPUT"WHICH";TR
2160 N%=TR+39:GOTO 1880
3000 REM  *** THE FOLLOWING DATA ARE STANDARD FINGERINGS, NOTE SPLIT C
3010 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0: 'B4
3020 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0: 'C5
3030 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0
3040 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0: 'D5
3050 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0
3060 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0: 'E5
3070 DATA 1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0
3080 DATA 1,1,1,1,1,1,1,1,1,1,1,0,0,1,0,0,0,0,0
3090 DATA 1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0: 'G5
3100 DATA 1,1,1,1,1,1,1,1,0,1,0,0,0,0,0,0,0,0,0
3110 DATA 1,1,1,1,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0: 'A5
3120 DATA 1,1,1,1,1,1,0,0,1,0,1,1,0,0,0,0,0,0,0
3130 DATA 1,1,1,1,0,1,0,0,1,0,0,0,0,0,0,0,0,0,0
3140 DATA 1,1,1,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0: 'C6
3150 DATA 1,1,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
3160 DATA 1,1,0,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0: 'D6
3170 DATA 1,1,0,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0
3180 DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0: 'E6
3190 DATA 1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0
3200 DATA 1,1,1,1,1,1,1,1,1,1,1,0,0,1,0,0,0,0,0
3210 DATA 1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0: 'G6
3220 DATA 1,1,1,1,1,1,1,1,0,1,0,0,0,0,0,0,0,0,0
3230 DATA 1,1,1,1,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0: 'A6
3240 DATA 1,1,1,1,1,1,0,0,1,0,1,1,0,0,0,0,0,0,0
3250 DATA 1,1,1,1,0,1,0,0,1,0,0,0,0,0,0,0,0,0,0
3260 DATA 1,1,1,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0: 'C7
3270 DATA 1,1,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
3280 DATA 1,1,0,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0
3290 DATA 1,1,1,1,1,1,1,1,0,1,1,1,1,1,0,0,0,0,0
3300 DATA 1,1,1,1,1,1,1,0,1,0,1,1,1,0,0,0,0,0,0: 'CONVENTIONAL E
3310 DATA 1,1,1,1,1,1,0,1,1,1,1,1,0,0,0,0,0,0,0
3320 DATA 1,1,1,1,0,1,0,1,1,1,1,0,0,1,1,0,0,0,0: 'F#7 WITH D# CLOSED
3330 DATA 1,1,1,0,1,0,1,1,1,1,0,0,0,0,0,0,0,0,0: 'G7
3340 DATA 1,1,0,0,1,0,1,1,0,1,0,0,0,0,0,0,0,0,0
3350 DATA 1,1,0,1,1,1,1,0,1,0,1,1,0,0,0,0,0,0,0: 'A7
3360 DATA 1,0,0,1,1,1,0,0,1,0,1,1,0,0,1,0,0,0,0
3370 DATA 0,1,1,1,0,1,0,1,1,1,0,0,0,0,1,0,0,0,0
3380 DATA 1,1,1,0,1,0,1,1,0,1,1,1,0,0,1,0,0,0,0: 'C8
3390 DATA 1,1,0,0,1,0,1,0,0,0,1,1,0,0,1,0,0,0,0
3400 DATA 1,0,1,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0: 'TRILLS BEGIN - N%=40
3410 DATA 1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
3420 DATA 1,0,1,1,0,1,0,0,1,0,0,0,0,0,0,0,0,0,0
3430 DATA 1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
3440 DATA 1,0,1,0,1,0,1,1,1,1,0,0,0,0,0,0,0,0,0
3450 DATA 1,0,0,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0
3460 DATA 0,1,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
3470 DATA 0,1,1,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
3480 DATA 0,1,0,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0
3490 DATA 0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
3500 DATA 0,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0
3510 DATA 0,0,0,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0
3520 END
5000 FOR I=1 TO 39:READ X :Q$(I)=CHR$(X):NEXT I
5010 LPRINT CHR$(27)"@"
5040 S$=":---------:---------:---------:---------:---------³---------:---------:---------:---------:---------:"
5050 DATA 66,67,32,68,32,69,70,32,71,32,65,32,66,67,32,68,32,69,70,32,71,32,65,32,66,67,32,68,32,69,70,32,71,32,65,32,66,67,32
5060 LPRINT CHR$(27)"U" CHR$(1)
5070 QQ$="-50   -40   -30   -20   -10    0    10    20    30   40    50"
5080 LPRINT TAB(25) "CENTS DEVIATION FROM A440 SCALE"
5090 LPRINT TAB(11) QQ$
5100 FOR I=1 TO 39
5110 GOSUB 5230
5120 LPRINT CHR$(18);
5130 IF ASC(Q$(I))=32 THEN LPRINT TAB(9) Q$(I-1);"#";:GOTO 5150
5140 LPRINT TAB(9) Q$(I);" ";
5150 WIDTH "LPT1:",132 : LPRINT CHR$(15);
5160 IF T(I)=0 THEN LPRINT TAB(15) S$:GOTO 5200
5170 LPRINT TAB(15) S1$;
5180 LPRINT "o";
5190 LPRINT S2$
5200 NEXT I
5210 WIDTH "LPT1:",80 : LPRINT CHR$(27)"@"
5220 END
5230 T(I)=T(I)+50:T(I)=INT(T(I)+.5)
5240 IF T(I)<0 OR T(I)>100 THEN T(I)=0
5250 S1$=LEFT$(S$,T(I))
5260 S2$=RIGHT$(S$,100-T(I))
5270 RETURN