100 DEFPROC FBEEP(%p,%c)
 110 LOCAL %q
 120 OUT %65533,7: %q=% IN 49149: IF %q&c THEN OUT %49149,%q-c
 130 %c=%c-(c>>2): OUT %65533,%c-1<<1:%q=%n[p+39]: OUT %49149,%q&255: OUT %65533,%c<<1-1: OUT %49149,%q>>8: ENDPROC 
 140   
 150 REM VBEEP FAST VERSIONS - NO ERROR CHECKING
 160 REM Initialise pitch table in arrays N% & O% 
 170 DEFPROC FINIT()
 180 LOCAL tick,Hz,%p
 190 LET tick=3500000/(32*440)
 200 FOR p=-39 TO 127-39
 210   LET h=2^((p-9)/12)
 220   LET %p=p+39
 230   LET %n[p]=tick/h
 240 NEXT p
 250 ayd=49149:ayr=65533:aya=1:ayb=2:ayc=4
 260 ENDPROC 
 270  
 280 REM Fast BEEP on channel (1,2,4) pitch -39..88, no checks
 290 REM Reads N%(),O%() - W suffix waits approx t seconds
 295 REM FBEEPW waits t seconds, uses current channel c volume
 300 DEFPROC FBEEPW(%p,t,%c)
 310 PROC FBEEP(%p,%c)
 320 PROC TRUEPAUSE(t*50)
 325 PROC FMUTE(%c)
 330 ENDPROC 
 340  
 350 DEFPROC FENV(%s,%p)
 360 OUT %65533,13: OUT %49149,%s: OUT %65533,12: OUT %49149,%p>>8: OUT %65533,11: OUT 49149,%p & 255
 370 ENDPROC 
 380  
 390 DEFPROC FNOISE(%p,%c)
 400 LOCAL %s: OUT %65533,6: OUT %49149,%p: OUT %65533,7: LET %s= % IN 49149: LET %s=%s&@11000111: OUT %49149,%s|((7-c)<<3)
 410 ENDPROC 
 420  
 430 REM Mute channel(s) of current AY
 440 DEFPROC FMUTE(%c)
 450 LOCAL %d: OUT %65533,%7: LET %d=% IN 49149: OUT %49149,%c|d
 460 ENDPROC 
 470   
 480 DEFPROC FVOL(%v,%c)
 490 OUT %65533,%c>>1+8: OUT %49149,%v: ENDPROC 
 500   
 510 REM Test only
 520 DEFPROC FSCALE()
 530 PROC FINIT(): PROC FVOL(15,aya)
 540 FOR n=-39 TO 69: PRINT n;" ";: PROC FBEEP(n,%1): PROC TRUEPAUSE(10): NEXT n
 550 PROC FVOL(0,aya): ENDPROC 
 560  
1000 REM VBEEP 1.7 by Simon N Goodwin, June 2020..January 2024
1010 REM For NextBASIC 2.07+
1020 LAYER 1,2: REM Hires gives clearer reports
1030 LET ayd=49149
1040 LET ayr=65533
1050 LET aya=1: REM Channel masks
1060 LET ayb=2
1070 LET ayc=4
1080 PROC AYSELECT(0): PROC SH(): REM Chip select, 0..2
1090 PROC AYNOISE(0,0): PROC AYEXTRAS(): PROC FINIT()
1100 PROC AYSTATUS(): GO TO 5000
1101 REM A few Unit Tests 
1102 PROC AYBEEPW(-22,1,15,1): STOP 
1105 PROC FINIT(): PROC FBEEP(-22,1): PROC FVOL(15,1): PAUSE 0: PROC FVOL(0,1): STOP 
1107 PROC fvol(15,1): PROC FBEEPW(22,1,1): STOP 
1110 PROC AYVOLUMES(15,7): PROC AYBEEP(1,aya): PAUSE 50
1120 PROC AYMUTE(aya): PROC AYSTATUS(): PROC AYVOLUMES(0,7)
1130 REPEAT 
1140   INPUT '"Noise pitch (1..31, 0 to quit) ";p 
1150   WHILE p
1160   PROC AYNOISE(p,aya): PROC AYVOLUME(15,aya)
1170 REPEAT UNTIL 0
1180 PROC AYNOISE(0,0): PRINT : PROC AYSTATUS()
1190 STOP 
1200  
1210 DEFPROC AYBEEPW(p,t,%v,%c)
1220 IF %v>16 THEN LIST 1210
1230 PROC AYBEEP(p,%c): PROC FVOL(%v,%c)
1240 PROC TRUEPAUSE(t*50): PROC FVOL(0,%c)
1250 ENDPROC 
1260   
1270 REM Toggle channel(s) to produce noise at period 1..31
1280 REM Uses global variables ayr and ayd to address soundchip
1290 DEFPROC AYNOISE(%p,%c)
1310 IF %p>31 OR (c>7) THEN LIST %1290: STOP 
1330 LOCAL %s: OUT ayr,6: OUT ayd,%p: OUT ayr,7
1360 %s= IN ayd:%s=%s & @11000111: OUT ayd,%s|((7-c)<<3)
1390 ENDPROC 
1400   
1410 REM Mute channel(s) of current AY
1420 DEFPROC AYMUTE(%c)
1430 LOCAL %d
1440 IF %c>7 THEN LIST %1420
1450 OUT ayr,7:%d= IN ayd: OUT ayd,%c|d
1480 ENDPROC 
1490  
1500 REM Set multiple channels to the same volume
1510 REM mute=0, loudest=15; 16 follows envelope 
1520 REM Add channel numbers aya, ayb, ayc to set several
1530 DEFPROC AYVOLUMES(%v,%c)
1540 IF %c>7  THEN LIST %1530: STOP 
1550 IF %v>16 THEN LIST %1530: STOP 
1560 IF %c & 1 THEN OUT ayr,8: OUT ayd,%v
1570 IF %c & 2 THEN OUT ayr,9: OUT ayd,%v
1580 IF %c & 4 THEN OUT ayr,10: OUT ayd,%v
1590 ENDPROC 
1600  
1610 REM Single channel (0 or 1=A) fade 0..15
1620 DEFPROC AYVOLUME(%v,%c)
1630 IF %(c=3) | (c>4) | (v>16) THEN LIST %1620: STOP 
1640 OUT ayr,%c>>1+8: OUT ayd,%v: ENDPROC 
1650  
1660 REM Mute all channels, turn off envelope, noise and tones
1670 REM Uses globals aya, ayb, ayc, ayd and ayr to address chip
1680 DEFPROC SH()
1690 PROC AYVOLUMES(aya+ayb+ayc,0)
1700 OUT ayr,7: OUT ayd,255
1705 PROC AYENVELOPE(0,0)
1710 ENDPROC 
1720   
1730 REM Set one channel's pitch, converting p to AY period
1740 REM p may be a decimal and is rounded to the closest pitch
1750 DEFPROC AYBEEP(p,%c)
1760 IF p<-39 THEN PRINT "AY bass limit=-39, 27.5 Hz": STOP 
1770 IF p>105 THEN PRINT "AY top note=105, 110 kHz!": STOP 
1780 LOCAL %d,%p,tick,Hz
1790 IF %c=0 | (c>4) | (c=3) THEN LIST %1750: STOP 
1800 REM A above middle C is 440 Hz, semitone 9
1810 Hz=2^((p-9)/12)*440
1820 REM PRINT "Semitone ";p;" is ";Hz;" Hertz ";
1830 tick=32/3500000
1850 REM PRINT "Maximum frequency ";1/tick;" Hertz"
1860 REM PRINT "Period step is ";tick*1e6;" us"
1870 REM PRINT "Note period is ";1e6/Hz;" us"
1880 %p=1/Hz/tick
1890 REM PRINT "Ideal period ";1/Hz/tick;", nearest ";%p
1900 OUT ayr,7:%d= IN ayd
1920 IF %d & c THEN OUT ayd,%d-c
1930 %c=%c-(c=4)
1940 OUT ayr,%c-1<<1: OUT ayd,%p&255
1960 OUT ayr,%c<<1-1: OUT ayd,%p>>8
1980 ENDPROC 
1990  
2000 DEFPROC AYSTATUS()
2010 LOCAL %s,%c,%v,%p
2012 PROC AYREG() TO %p
2014 PROC AYSELECTED() TO %s
2016 PRINT "AY Unit ";%p;" selected","Last register set ";%s
2020 OUT ayr,7: LET %s= IN ayd
2040 PRINT "8 bit 8912 port A set for ";
2050 IF %s & 64  THEN PRINT "OUTPUT": ELSE PRINT "INPUT"
2060 PRINT "8 bit 8910 port B set for ";
2070 IF %s & 128 THEN PRINT "OUTPUT": ELSE PRINT "INPUT"
2080 FOR %c=0 TO 2
2090   LET c=%c: PRINT "Channel "; CHR$ (c+65);" Tone ";
2100   IF %1<<c & s THEN PRINT "off";: ELSE PRINT "ON ";
2110   PROC GETVOL(%c=2+c+1) TO %v: PRINT " Volume ";%v; 
2120   PROC GETPERIOD(%c=2+c+1) TO %v: PRINT " Period ";%v; 
2130   PRINT " Noise ";
2140   IF %8<<c & s THEN PRINT "off": ELSE PRINT "ON"
2150 NEXT %c
2160 OUT ayr,12:%c= IN ayd
2170 OUT ayr,11:%s= IN ayd
2180 OUT ayr,13: PRINT "Envelope shape "; IN ayd;
2190 PRINT " Period ";%c<<8+s;
2200 OUT ayr,6 
2210 PRINT "  Noise generator Period "; IN ayd 
2220 ENDPROC 
2225  
2230 DEFPROC AYEXTRAS()
2235 LOCAL %b,%c,%i
2240 %b=% REG 6 & 3
2245 PRINT "Next ";
2250 IF %b=0 THEN PRINT "YM";: ELSE IF %b=1 THEN PRINT "AY";
2255 PRINT " sound-chip configuration"
2260 %b=% REG 8:%c=%b&2+1
2270 PRINT "Number of chips synthesised ";%c
2275 FOR %i=1 TO %c
2280   PRINT "Sound chip ";%i;" outputs in ";
2285   IF % REG 9&(1<<(4+i)) THEN PRINT "mono": ELSE PRINT "stereo"
2290 NEXT %i 
2295 PRINT "Channels left to right are ";
2300 IF %b&32 THEN PRINT "A-B-C": ELSE PRINT "A-C-B"
2305 ENDPROC 
2310   
2320 REM Select one of the three AY chips, 0, 1 or 2  
2330 DEFPROC AYSELECT(%a)
2340 IF %a>2 THEN PRINT "AY chips are numbered 0..2": STOP 
2350 OUT ayr,%255-a
2355 ENDPROC 
2357  
2358 REM Return currently selected AY (core 3.01.09+)
2360 DEFPROC AYSELECTED()
2365 ENDPROC =%3-( IN 49141>>6)
2370  
2372 DEFPROC AYREG()
2375 ENDPROC =% IN 49141&31
2380  
2385 REM Silence all three AY sound generators
2390 DEFPROC SH3()
2400 FOR %i=0 TO 2: PROC AYSELECT(%i): PROC SH(): NEXT %i
2410 ENDPROC 
2420   
2430 DEFPROC TSCALE()
2440 PROC VOLUMES(16,7): PROC ENVELOPE(8,1000)
2450 REM BEEP semitones -60 to +69, AY -39.507..+105ish
2460 FOR i=-22 TO 69: PROC TBEEP(.2,i): NEXT i
2470 PROC VOLUMES(0,7)
2480 ENDPROC 
2490  
2500 REM Set volume envelope shape 0..15 and period 0..65355
2510 DEFPROC AYENVELOPE(%s,%p)
2520 IF %s>15 THEN LIST %2510
2530 OUT ayr,13: OUT ayd,%s
2540 OUT ayr,12: OUT ayd,%p>>8
2550 OUT ayr,11: OUT ayd,%p&255
2560 ENDPROC 
2570  
2580 REM return volume 0..16 of channel aya, ayb, ayc (1,2,4) 
2590 DEFPROC GETVOL(%c)
2600 IF %c<1 OR c=3 OR c>4 THEN LIST %2590: STOP 
2610 OUT ayr,%c+7-(c=4)
2620 ENDPROC = IN ayd
2630  
2640 REM return period 0..4095 for channel mask 1, 2 or 4
2650 DEFPROC GETPERIOD(%c)
2660 IF %c<1 OR c=3 OR c>4 THEN LIST %2650: STOP 
2670 LOCAL %h:%c=%c-1-(c=4)<<1
2690 OUT ayr,%c+1:%h= IN ayd 
2710 OUT ayr,%c:%c= IN ayd
2730 ENDPROC =%h<<8+c
2732  
2734 DEFPROC GETENV()
2736 OUT ayr,13: ENDPROC = IN ayd
2738  
2740 DEFPROC GETRATE()  
2742 LOCAL %h,%l: OUT ayr,12:%h= IN ayd
2744 OUT ayr,11:%l= IN ayd: ENDPROC =%h<<8+l
3400   
3410 REM Mahler BEEPs from the Sinclair manual
3420 DEFPROC MAHLER()
3430 RUN AT 0: RESTORE 3500
3440 REPEAT 
3450   READ d,t: WHILE d
3460   BEEP d*.25,t
3470 REPEAT UNTIL CODE INKEY$ 
3475 IF d AND t<>0 THEN RESTORE t: GO TO 3440 
3480 ENDPROC 
3490  
3500 DATA 4,0,4,2,2,3,2,2,4,0,4,0,4,2,2,3,2,2,4,0,4,3,4,5,8,7,4,3,4,5
3510 DATA 8,7,3,7,1,8,2,7,2,5,2,3,2,2,4,0, 3,7,1,8,2,7,2,5,2,3,2,2
3518 DATA 4,0,4,0,4,-5,8,0,4,0,4,-5,8,0,0,3500: REM Ends with 0,line to restore
3520  
3530 REM Equivalent notes from the AY, played as chords 
3540 DEFPROC MAHLER2()
3541 PROC AYPLAYDATA(3500)
3542 ENDPROC 
3543   
3544 DEFPROC AYPLAYDATA(L)
3545 LOCAL d,t: SPRITE CLEAR : SPRITE PRINT 0 
3550 RUN AT 3: PROC AYNOISE(0,0): PROC AYvolumes(15,ayA+ayB+ayC): RESTORE L
3551 REPEAT 
3552   READ d,t: WHILE d
3553   PROC TBEEP(d*.25,t)
3554 REPEAT UNTIL CODE INKEY$ 
3555 IF d=0 AND t<>0 THEN RESTORE t: GO TO 3551 
3556 PROC SH(): ENDPROC 
3560  
3570 REM BEEP a triad chord up to note n for d seconds
3575 DEFPROC TBEEP(d,n)
3580 IF n<=99 THEN PROC fBEEP(n,ayA): PROC fBEEP(n-5,ayC): PROC fBEEP(n-17,ayB): ELSE PROC AYMUTE(7): REM sustained bass voice
3585 PROC TRUEPAUSE(d*50-1): PROC AYmute(5): ENDPROC 
3590  
3600 DATA 5,4,5,5,5,6,5,5,0,3620
3610 DATA 4,12,4,13,4,14,4,13,0,3640
3620 DATA 4,4,4,5,4,6,4,5,0,3610
3630 DATA 3,4,3,5,3,6,3,5,3,4,6,-8,3,999,0,3500
3640 DATA 3,12,3,13,3,14,3,13,0,3630
3990  
4000 PROC GETFPS()
4010 PRINT fps;" FPS at 50 Hz"'"PAUSE 1 takes ";1000/fps;" ms"
4015 PRINT fps*1.2;" FPS at 60 Hz"'"PAUSE 1 lasts ";833.33/fps;" ms"
4020 PRINT "Effective CPU clock ";fps/50*3.5;" MHz" 
4025 REM Return Frames Per Second for 50
4030  
4035 REM Returns actual frame rate at "50 Hertz" setting
4040 DEFPROC GETCLOCKFACTOR() 
4080 LOCAL %v,fps:%v=% REG 17&7
4090 REM PRINT "VGA ";%v
4100 IF %v<2 THEN fps=%50+v: ENDPROC =fps
4110 IF %v=7 THEN fps=48.2: ENDPROC =fps
4120 IF %v<4 THEN fps=%v:fps=fps+50.6: ENDPROC =fps 
4130 IF %v=4 THEN fps=55.4
4140 IF %v=5 THEN fps=57.1
4150 IF %v=6 THEN fps=59
4160 ENDPROC =fps 
4190   
4195 REM Returns actual CPU clock rate
4200 DEFPROC GETMHz()
4210 LOCAL f,r
4220 PROC GETCLOCKFACTOR() TO f
4225 PROC GETCLOCKRATIO() TO r
4230 ENDPROC =f/50*r*3500000
4240  
4245 REM Returns how many actual milliseconds PAUSE 1 waits
4250 DEFPROC GETmsPERFRAME()
4260 LOCAL f
4270 PROC GETCLOCKFACTOR() TO f
4280 IF % REG 5&4 THEN f=f*1.2: REM 60 Hz 
4290 ENDPROC =1000/f
4300  
4305 REM Return clock ratio, 1=3.5MHz, 2=7MHz, 4=14, 8=28
4310 DEFPROC GETCLOCKRATIO()
4320 LOCAL t:t=% REG 7&3
4330 IF t<2 THEN ENDPROC =t+1
4340 ENDPROC =4*(t-1)
4350  
4400 REM Waits f * 20 ms, f must be at least 1
4410 REM ignores keypress, adjusts for screen mode
4460 DEFPROC TRUEPAUSE(f)
4465 IF f<1 THEN LIST 4460: STOP 
4470 LOCAL %f,m,%n
4480 DPOKE 23672,0:f=f*20: REM ms required
4490 PROC GETmsPERFRAME() TO m:%f=f/m
4495 REM PRINT %f;" actual frames"
4500 REPEAT :%n=% DPEEK 23672: REPEAT UNTIL %n>=f
4510 ENDPROC 
4520 :
5000 REM NextBASIC QIX creatures - this is old demo hacks not production quality
5001 RUN AT 3: SPRITE CLEAR : SPRITE PRINT 0: LAYER CLEAR : LAYER 0
5002 INPUT "Number of QIX Patterns (1 to 3)?";n: IF n<1 OR n<> INT n OR n>3 THEN GO TO 5002
5004 REM Each QIX requires 2 of N position and delta pairs
5005 n=n*2: DIM x(n): DIM y(n): DIM h(n): DIM v(n)
5006 PROC fmute(7): PROC FINIT(): PROC AYenvelope(10,400): PROC AYVOLUMES(12,0): PROC FVOL(15,2): PROC FNOISE(0,4): PROC fBEEP(0,1): PROC fBEEP(0,4): PROC fBEEP(0,2)
5007 REM Each QIX requires 2 of N position and delta pairs
5008 FOR i=1 TO n
5010   x(i)=% RND 256
5020   y(i)=% RND 183
5030   h(i)=2- INT ( RND *5): IF h(i)=0 THEN GO TO 5030
5040   v(i)=1+ 2* INT (3* RND ) 
5042 NEXT i
5044 LAYER 1,0: CLS : FOR %i=0 TO 31:c= INT ( RND *256):x= INT ( RND *128): PLOT INK c,x,%i: PLOT INK c,x,%i+32 : PLOT INK c,x,%i+64: NEXT %i
5052 LAYER 2,1: LAYER OVER 0
5055 LAYER PALETTE 0: LAYER PALETTE 0,0,0
5056 LAYER PALETTE 0,1,511-7: REM Yellow
5057 LAYER PALETTE 0,3,56: REM Green
5058 LAYER PALETTE 0,5,384: REM Red
5059 LAYER PALETTE 0,0,0: REM Black
5080 BORDER 0: PAPER 0: INK 7: OVER 1
5086 PRINT AT 23,0; INK 7; PAPER 1;" NextBASIC QIX audiovisual demo ";
5087 PRINT AT 0,0;:%h=0
5090 %v=64:%u=%64-v:%w=%u: REM v is Qix length, 1 to 64
5092 RESTORE 3500: READ %r,t: PROC vbeep(t,2)
5095 IF n=2 THEN GO TO 6000: REM 1-Qix version includes vbeeps
5100 REPEAT 
5102 FOR i=1 TO n
5110   x=x(i):x=x+h(i): IF x<0 OR x>255 THEN h(i)=( SGN x)* (- INT (1+ RND *6)):x=x(i)
5116   y=y(i):y=y+v(i): IF y<0 OR y>182 THEN y=y(i):v(i)=-v(i) 
5117   y(i)=y:x(i)=x
5118 NEXT i:%w=%u: PROC FNOISE(%w & 15<<1,4)
5119 REG 51,%h:%h=%h+3&63: REG 50,%h<<2
5120 FOR %i=1 TO n STEP 2
5130   %u=%u+2 & 63
5135   INK 0: OVER 0
5140   PLOT %u(u),%v(u):%v=%u+1:x=%256+u(v)-u(u):y=%256+v(v)-v(u): DRAW x-256,y-256
5150 NEXT %i
5155 %u=%w
5160 FOR i=1 TO n STEP 2
5170   %u(u)=x(i):%v(u)=y(i): INK i: OVER 1: PLOT %u(u),%v(u):%v=%u+1
5175   OUT %65533,i-1: OUT %49149,%u(u)
5180   t=i+1:%u(v)=x(t):%v(v)=y(t): DRAW x(t)-x(i),y(t)-y(i)
5185   %u=%u+2 & 63
5190 NEXT i
5210 REPEAT UNTIL LEN INKEY$ 
5220 OVER 0: PROC SH(): PROC AYENVELOPE(0,0)
5230 STOP 
5240  
5990 REM QIX loop for 1 pattern, 2 tones and a backing choon
6000 FOR %i=0 TO 63:%u(i)=0:%v(i)=0: NEXT %i: REM clear history
6100 INK 5: OVER 1: REPEAT : REM BORDER 0: PAUSE 1: BORDER 2
6102 FOR i=1 TO n
6110   x=x(i):x=x+h(i): IF x<0 OR x>255 THEN h(i)=( SGN x)* (- INT (1+ RND *6)):x=x(i)
6116   y=y(i):y=y+v(i): IF y<0 OR y>182 THEN y=y(i):v(i)=-v(i) 
6117   y(i)=y:x(i)=x
6118 NEXT i:%w=%u
6119 REG 51,%h:%h=%h+3&63: REG 50,%h<<2
6130 %u=%u+2 & 63
6140 PLOT %u(u),%v(u):%v=%u+1:x=%256+u(v)-u(u):y=%256+v(v)-v(u): DRAW x-256,y-256
6155 %u=%w
6170 %u(u)=x(1):%v(u)=y(1): PLOT x(1),%v(u):%v=%u+1
6175 OUT %65533,0: OUT %49149,%u(u)
6177 OUT %65533,4: OUT %49149,%v(u)
6180 %u(v)=x(2):%v(v)=y(2): DRAW x(2)-x(1),y(2)-y(1)
6185 %u=%u+2 & 63
6195 IF %r THEN %r=%r-1: GO TO 6210: REM PRINT AT 0,0; OVER 0; INK 3;%r;"  ";: GO TO 6210
6199   PROC FVOL(0,2)
6200   READ %r,t:%r=%r<<2
6202   IF %r>0 THEN PROC FBEEP(t,2): PROC FVOL (15,2): GO TO 6210
6205   IF t=0 THEN %r=65535: ELSE RESTORE t: GO TO 6200
6210 REPEAT UNTIL LEN INKEY$ 
6220 OVER 0: PROC SH(): PROC ENVELOPE(0,0)
6230 STOP 
9999 SAVE "VBEEP1-8.BAS" LINE 1000