'===========================================================================
' Subject: SOUND BLASTER PIANO               Date: 08-20-96 (00:00)       
' Author:  Kurt Eckhardt                     Code: QB, QBasic, PDS        
' Origin:  king@shadow.net                 Packet: SOUND.ABC
'===========================================================================
'Coded by Kurt Eckhardt 08/20/96
'The graphics are sketchy, but this program was designed more for example
'that anything else. Try Decay rates of 0-5, they sound best.

'I have a generic sound card and the program seems to work fine.
'However, tested on a friends computer who has a true SBpro, produced mixed
'results (actually it sounded like crap). Sorry if it doesn't work on your
'Cpu, but it is Version 1.0

DEFINT A-Z
DECLARE SUB legal ()
DECLARE SUB info ()
DECLARE SUB pressakey ()
DECLARE SUB Menu ()
DECLARE SUB SBDrum (num%)
DECLARE SUB SBPlay (channel%, n$, Octa%)
DECLARE SUB WriteReg (Reg%, value%)
DECLARE SUB InitCard ()
DECLARE SUB Scale ()
DECLARE SUB pause (secs!)
DECLARE SUB center (text$, row!)
DECLARE FUNCTION offset1% (channel%)
DECLARE FUNCTION offset2% (channel%)
DECLARE FUNCTION DetectCard% ()
DECLARE FUNCTION note% (n$)
CONST StatusP = &H388            'Status port
CONST DataP = &H389              'Data port
CONST TRUE = 1
DIM SHARED tst, vst
DIM SHARED dcay

CLS : CALL info
CALL legal: CLS
IF DetectCard = TRUE THEN
   PRINT "We have a soundcard!"
ELSE
   PRINT "Go buy yourself a soundcard!"
   SYSTEM: END
END IF
PRINT "Initalizing Card...": InitCard
PRINT "Ok"
PRINT "Press any key to continue": pressakey

CALL Menu

'Make sure all registers are cleared before closing
CALL WriteReg(&HB0, 0)
CALL InitCard
SYSTEM: END

DEFSNG A-Z
SUB center (text$, row)
text$ = RTRIM$(text$)
LOCATE row, 40 - LEN(text$) / 2
PRINT text$
END SUB

DEFINT A-Z
FUNCTION DetectCard
CALL WriteReg(&H4, &H60)        'Reset both timers
CALL WriteReg(&H4, &H80)
stat1 = INP(&H388)              'Store result
CALL WriteReg(&H2, &HFF)
CALL WriteReg(&H4, &H21)
pause .08                       'Wait 80msecs
stat2 = INP(&H388)              'Store result
CALL WriteReg(&H4, &H60)        'Reset both timers
CALL WriteReg(&H4, &H80)
IF (stat1 AND &HE0) = &H0 THEN
   IF (stat2 AND &HE0) = &HC0 THEN
      found = TRUE
   END IF
END IF
DetectCard = found
END FUNCTION

SUB info
CLS
PRINT "Coded and Designed by Kurt Eckhardt"
PRINT "Copyrite 1996   All Rights Reserved"
PRINT "V1.0 Completed on 8/20/96"
PRINT "Channels 1 through 3 appear to be working correctly as do the drums (I think)"
PRINT "But channels 4-9 only produce muted/distorted sounds, if any at all."
PRINT "Vibrato and Tremolo are operational, but the effect cannot be heard"
PRINT "If the decay is set too short."
PRINT "Sorry about the sharps, they work, but no keyboard interface yet."
PRINT "You'll have to wait until I put in mouse support."
PRINT "If you find any info in this program useful for your own programming endevours,"
PRINT
PRINT "I would greatly appreciate you sending me 1$ so I can make my way through"
PRINT "college. I bet you can look around right now and find that within 10 feet"
PRINT "of yourself- if not, you are as broke as I am."
PRINT "Any comments or questions, send me some email at <king@shadow.net>"
PRINT "Here's the address for that measly buck: "
PRINT
PRINT "Kurt Eckhardt"
PRINT "1820 West Oak Knoll Circle"
PRINT "Ft. Lauderdale FL 33324"
PRINT
PRINT "Thanks!"
pressakey
END SUB

SUB InitCard
'Set all 244 registers to 0 to initalize
FOR lp = 1 TO 2
FOR Regis = 1 TO &HF5
CALL WriteReg(Regis, 0)
NEXT Regis
NEXT lp

'Set variables
dcay = 5: vst = 0: tst = 0
END SUB

SUB legal
CLS
center "Legal Stuff", 1
PRINT
PRINT "1. This program may be freely distributed so long as no changes have been made."
PRINT "2. This program, or any part of it, may not be used in another program"
PRINT "   without my written consent."
PRINT "3. I take no responsibilty for any adverse affects that may be caused by"
PRINT "   usage of this program upon your machine."
                     
center "By possessing this program you agree with these terms.", 10
pressakey
END SUB

SUB Menu
SCREEN 12: CLS

COLOR 2: center "One Really Bad Music Machine", 1
center "By: Kurt Eckhardt  V1.0", 2: COLOR 15


LOCATE 5, 1: COLOR 11: PRINT "6: "; : COLOR 3: PRINT "Tremolo: OFF"
LOCATE 6, 1: COLOR 11: PRINT "7: "; : COLOR 3: PRINT "Vibrato: OFF"
LOCATE 5, 66: COLOR 11: PRINT "8: "; : COLOR 3: PRINT "Decay: "; HEX$(dcay)
LOCATE 15, 8: COLOR 11: PRINT "0: "; : COLOR 9: PRINT "Quit"
LOCATE 16, 8: COLOR 11: PRINT "1: "; : COLOR 9: PRINT "Hi Hat"
LOCATE 17, 8: COLOR 11: PRINT "2: "; : COLOR 9: PRINT "Symbol"
LOCATE 18, 8: COLOR 11: PRINT "3: "; : COLOR 9: PRINT "Tom Drum"
LOCATE 19, 8: COLOR 11: PRINT "4: "; : COLOR 9: PRINT "Snare Drum"
LOCATE 20, 8: COLOR 11: PRINT "5: "; : COLOR 9: PRINT "Bass Drum"

COLOR 11
LOCATE 26, 8: PRINT "C  D  E   F  G  A  B"
LOCATE 26, 30: PRINT "C  D  E   F  G  A  B"
LOCATE 26, 52: PRINT "C  D  E   F  G  A  B  C"
LOCATE 22, 8: PRINT "C# D#    F# G#  A#"
LOCATE 22, 30: PRINT "C# D#    F# G#  A#"
LOCATE 22, 52: PRINT "C# D#    F# G#  A#    C#"

COLOR 9
FOR x = 50 TO 575 STEP 25
LINE (x, 330)-(x + 25, 420), , B
NEXT x
LINE (50, 365)-(600, 365)

DO
   key$ = UCASE$(INKEY$)
   SELECT CASE key$
   CASE "Z": CALL SBPlay(1, "C", 4): xpos = 8: char$ = "C"
   CASE "X": CALL SBPlay(1, "D", 4): xpos = 11: char$ = "D"
   CASE "C": CALL SBPlay(1, "E", 4): xpos = 14: char$ = "E"
   CASE "V": CALL SBPlay(1, "F", 4): xpos = 18: char$ = "F"
   CASE "B": CALL SBPlay(1, "G", 4): xpos = 21: char$ = "G"
   CASE "N": CALL SBPlay(1, "A", 4): xpos = 24: char$ = "A"
   CASE "M": CALL SBPlay(1, "B", 4): xpos = 27: char$ = "B"
   CASE "A": CALL SBPlay(2, "C", 5): xpos = 30: char$ = "C"
   CASE "S": CALL SBPlay(2, "D", 5): xpos = 33: char$ = "D"
   CASE "D": CALL SBPlay(2, "E", 5): xpos = 36: char$ = "E"
   CASE "F": CALL SBPlay(2, "F", 5): xpos = 40: char$ = "F"
   CASE "G": CALL SBPlay(2, "G", 5): xpos = 43: char$ = "G"
   CASE "H": CALL SBPlay(2, "A", 5): xpos = 46: char$ = "A"
   CASE "J": CALL SBPlay(2, "B", 5): xpos = 49: char$ = "B"
   CASE "Q": CALL SBPlay(3, "C", 6): xpos = 52: char$ = "C"
   CASE "W": CALL SBPlay(3, "D", 6): xpos = 55: char$ = "D"
   CASE "E": CALL SBPlay(3, "E", 6): xpos = 58: char$ = "E"
   CASE "R": CALL SBPlay(3, "F", 6): xpos = 62: char$ = "F"
   CASE "T": CALL SBPlay(3, "G", 6): xpos = 65: char$ = "G"
   CASE "Y": CALL SBPlay(3, "A", 6): xpos = 68: char$ = "A"
   CASE "U": CALL SBPlay(3, "B", 6): xpos = 71: char$ = "B"
   CASE "I": CALL SBPlay(3, "C", 7): xpos = 74: char$ = "C"
   CASE "1": CALL SBDrum(1)
   CASE "2": CALL SBDrum(2)
   CASE "3": CALL SBDrum(3)
   CASE "4": CALL SBDrum(4)
   CASE "5": CALL SBDrum(5)
   CASE "6": tst = tst + 1: IF tst > 1 THEN tst = 0
   CASE "7": vst = vst + 1: IF vst > 1 THEN vst = 0
   CASE "8": dcay = dcay + 1: IF dcay > &HF THEN dcay = 0
   CASE ";": CALL Scale
END SELECT

IF INSTR(" ZXCVBNMASDFGHJQWERTYUI678", key$) > 1 THEN
   COLOR 3
   IF tst = 1 THEN tst$ = "ON " ELSE tst$ = "OFF"
   IF vst = 1 THEN vst$ = "ON " ELSE vst$ = "OFF"
   LOCATE 5, 4: PRINT "Tremolo: "; tst$
   LOCATE 6, 4: PRINT "Vibrato: "; vst$
   LOCATE 5, 69: PRINT "Decay: "; HEX$(dcay)
   IF xold <> 0 THEN LOCATE 26, xold: COLOR 11: PRINT ochar$
   IF xpos <> 0 THEN LOCATE 26, xpos: COLOR 4: PRINT char$
   ochar$ = char$: xold = xpos
END IF
LOOP WHILE key$ <> "0"
COLOR 11
END SUB

FUNCTION note% (n$)
'These appear to be the correct frequency numbers
IF n$ = "C" THEN note% = &H209
IF n$ = "C#" THEN note% = &H219
IF n$ = "D" THEN note% = &H229
IF n$ = "D#" THEN note% = &H23B
IF n$ = "E" THEN note% = &H24E
IF n$ = "F" THEN note% = &H261
IF n$ = "F#" THEN note% = &H277
IF n$ = "G" THEN note% = &H28D
IF n$ = "G#" THEN note% = &H2A4
IF n$ = "A" THEN note% = &H2BD
IF n$ = "A#" THEN note% = &H2D8
IF n$ = "B" THEN note% = &H2F4
END FUNCTION

FUNCTION offset1 (channel)
'These are the offsets for each of the nine channels
'For operator number 1
IF channel = 1 THEN offset1 = &H0
IF channel = 2 THEN offset1 = &H1
IF channel = 3 THEN offset1 = &H2
IF channel = 4 THEN offset1 = &H8
IF channel = 5 THEN offset1 = &H9
IF channel = 6 THEN offset1 = &HA
IF channel = 7 THEN offset1 = &H10
IF channel = 8 THEN offset1 = &H11
IF channel = 9 THEN offset1 = &H12
END FUNCTION


FUNCTION offset2 (channel)
'These are the offsets for each of the nine channels
'For operator number 2
IF channel = 1 THEN offset2 = &H3
IF channel = 2 THEN offset2 = &H4
IF channel = 3 THEN offset2 = &H5
IF channel = 4 THEN offset2 = &HB
IF channel = 5 THEN offset2 = &HC
IF channel = 6 THEN offset2 = &HD
IF channel = 7 THEN offset2 = &H13
IF channel = 8 THEN offset2 = &H14
IF channel = 9 THEN offset2 = &H15
END FUNCTION

SUB pause (secs!)
start! = TIMER
DO: LOOP WHILE TIMER - start! < secs!
END SUB

SUB pressakey
DO: LOOP WHILE INKEY$ = ""
END SUB

SUB SBDrum (num%)
IF num% = 1 THEN CALL WriteReg(&HBD, &H21) 'HHat
IF num% = 2 THEN CALL WriteReg(&HBD, &H22) 'Cymb
IF num% = 3 THEN CALL WriteReg(&HBD, &H24) 'TomT
IF num% = 4 THEN CALL WriteReg(&HBD, &H28) 'Snre
IF num% = 5 THEN CALL WriteReg(&HBD, &H30) 'Bass
CALL WriteReg(&HBD, &H0)
END SUB

SUB SBPlay (channel%, n$, Octa%)
IF Octa% = 1 THEN octave = &H21                  'These are the octave bits
IF Octa% = 2 THEN octave = &H25
IF Octa% = 3 THEN octave = &H29
IF Octa% = 4 THEN octave = &H2D
IF Octa% = 5 THEN octave = &H31
IF Octa% = 6 THEN octave = &H35
IF Octa% = 7 THEN octave = &H39
offs1 = offset1(channel)                         'Get offsets depending
offs2 = offset2(channel)                         'on channel
IF tst = 1 THEN trem = &H80 ELSE trem = &H0
IF vst = 1 THEN vibr = &H40 ELSE vibr = &H0

CALL WriteReg(&HB0 + offs1, &H0)              'Clear previous note
CALL WriteReg(&H20 + offs1, &H0 + trem + vibr)   'Amp/Vib/EG/KSR/Octave(0-F)
CALL WriteReg(&H40 + offs1, &HA)                 'Scale Lev/Volume(0-3F)
CALL WriteReg(&H60 + offs1, &HF0 + dcay)         'Attack/Decay
CALL WriteReg(&H80 + offs1, &H1A)                'Sustain/Release
CALL WriteReg(&HA0 + offs1, note(n$))            'Note
CALL WriteReg(&HE0 + offs1, &H0)                 'Waveform (00-03) Default 00

CALL WriteReg(&H20 + offs2, &H0 + trem + vibr)   'Amp/Vib/EG/KSR/Octave(0-F)
CALL WriteReg(&H40 + offs2, &HA)                 'Scale Lev/Volume(0-3F)
CALL WriteReg(&H60 + offs2, &HF0 + dcay)         'Attack/Decay
CALL WriteReg(&H80 + offs2, &H1A)                'Sustain/Release
CALL WriteReg(&HB0 + offs1, octave)              'Octave(21-39)
CALL WriteReg(&HE0 + offs2, &H0)                 'Waveform (00-03) Default 00
END SUB

SUB Scale
FOR octave = 1 TO 7
CALL SBPlay(3, "C", octave): pause .1
CALL SBPlay(1, "C#", octave): pause .1
CALL SBPlay(2, "D", octave): pause .1
CALL SBPlay(3, "D#", octave): pause .1
CALL SBPlay(1, "E", octave): pause .1
CALL SBPlay(2, "F", octave): pause .1
CALL SBPlay(3, "F#", octave): pause .1
CALL SBPlay(1, "G", octave): pause .1
CALL SBPlay(2, "G#", octave): pause .1
CALL SBPlay(3, "A", octave): pause .1
CALL SBPlay(1, "A#", octave): pause .1
CALL SBPlay(2, "B", octave): pause .1
NEXT octave
END SUB

DEFSNG A-Z
SUB WriteReg (Reg%, value%)
OUT StatusP, Reg%           'Register to write at port &H388
FOR lp = 1 TO 6             'Wait 3.3 msec
wat = INP(&H388)
NEXT lp
OUT DataP, value%           'Now write data to port &H389
FOR lp = 1 TO 35            'Now wait 23 msec
wat = INP(&H389)
NEXT lp
END SUB