'===========================================================================
' Subject: MIDI PLAYER (FOR TYPE 0)          Date: 07-26-98 (18:56)       
' Author:  Luke Erren                        Code: QB, QBasic, PDS        
' Origin:  errenvep@worldonline.nl         Packet: SOUND.ABC
'===========================================================================
' MIDI Player (for type 0)
' (C) Luke Erren 1998
' errenvep@worldonline.nl

DECLARE SUB MIDIPitch (Kanaal%, Bottom%, Top%)
DECLARE SUB MidiNoteOFF (Note%, Volume%, Kanaal%, MidiPoort%)
DECLARE SUB MidiNoot (Noot%, Volume%, Kanaal%, MidiPoort%, Pause%)
DECLARE SUB MIDIInstrument (Kanaal%, MidiPoort%, Instrument%)
DECLARE SUB MidiReset (MidiPoort%)
DECLARE SUB MidiInit (MidiPoort%)
DECLARE SUB MidiNote (Note%, Volume%, Kanaal%, MidiPoort%)
DECLARE FUNCTION Instrumentname$ (Nmbr%)
DECLARE FUNCTION NextNumber! ()
DECLARE FUNCTION Controlname$ (Nmr!)
DECLARE FUNCTION Nibble$ (Cr$, l!)
DECLARE FUNCTION Nibble2Number! (ch$)
DECLARE FUNCTION InstrumentNaam$ (Nummer!)
DECLARE FUNCTION NoteName$ (Nmbr%)
DECLARE FUNCTION LeesTimeSigUitBest$ ()
DECLARE FUNCTION LeesTempoUitBest! ()
DECLARE FUNCTION LeesTekstUitBest$ ()
DECLARE FUNCTION VierByteLengte! ()
DECLARE FUNCTION TweeByteLengte! ()
DECLARE FUNCTION ReadVarLen! ()

DIM SHARED Instrname(127) AS STRING
DIM Header AS STRING * 4
DIM TweeByte AS STRING * 2
DIM VierByte AS STRING * 4
DIM FileType AS STRING * 2
DIM l AS INTEGER
DIM SHARED a AS STRING * 1
Tijd = TIMER: FOR i = 1 TO 100000: NEXT i: Wl = 2 / (TIMER - Tijd)
DIM InLen(16) AS INTEGER

IF LEN(ENVIRON$("BLASTER")) THEN
 FOR Length% = 1 TO LEN(ENVIRON$("BLASTER"))
  IF MID$(ENVIRON$("BLASTER"), Length%, 1) = "P" THEN MidiPoort% = VAL("&H" + MID$(ENVIRON$("BLASTER"), Length% + 1, 3))
 NEXT
END IF

IF NOT MidiPoort% THEN MidiPoort% = &H330

MidiInit (MidiPoort%)
MidiReset (MidiPoort%)
CLS
PRINT "   MIDI Player for type 0    "
PRINT "    (C) 1998 Luke Erren      "
PRINT
PRINT "Adjust speed with '-' and '+'"
PRINT
FOR i = 0 TO 127: READ Instrname(i): NEXT i
LINE INPUT "Midi file : "; File$: IF File$ = "" THEN STOP
IF INSTR(File$, ".") = 0 THEN File$ = File$ + ".MID"
WIDTH 80, 50: CLS
OPEN File$ FOR BINARY AS #1
 GET 1, , Header
 PRINT File$
 IF Header <> "MThd" THEN PRINT "Not a valid MIDI file": STOP
 GET 1, , VierByte
 GET 1, , FileType
 IF ASC(RIGHT$(FileType, 1)) = 0 THEN
   PRINT "Single trax"
  ELSE
   PRINT "Multy trax, this file type is not supported"
 END IF
 Ttrx = TweeByteLengte: PRINT "Aantal trax ="; Ttrx
 PRINT "Tempo = "; TweeByteLengte
 Tempo = 120
  FOR i = 1 TO Ttrx
   GET 1, , Header
   PRINT Header
   IF Header = "MTrk" THEN
    TrkLengte = VierByteLengte + LOC(1)
    WHILE (LOC(1) < TrkLengte) AND Stoppen = 0
     x$ = INKEY$: IF x$ = CHR$(27) THEN Stoppen = 1
     IF x$ = "-" THEN Wl = Wl + .5
     IF x$ = "=" OR x$ = "+" THEN Wl = Wl - .5
     t = ReadVarLen
     FOR Wacht = 1 TO t * (1.5 / Tempo) * 10000 * Wl: NEXT Wacht: REM Timer
     TotalTime! = TotalTime! + t
     LOCATE 40, 1: PRINT USING "Song pointer : ###,###,###"; TotalTime!
     GET 1, , a
     IF a = CHR$(255) THEN
       GET #1, , a
       SELECT CASE ASC(a)
	CASE 0:  PRINT "Sequence Number : "; LeesTekstUitBest$
	CASE 1:  PRINT "Text event      : "; LeesTekstUitBest$
	CASE 2:  PRINT "Copyright       : "; LeesTekstUitBest$
	CASE 3:  PRINT "Track name      : "; LeesTekstUitBest$
	CASE 4:  PRINT "Instrument name : "; LeesTekstUitBest$
	CASE 5:  PRINT "Lyric           : "; LeesTekstUitBest$
	CASE 6:  PRINT "Marker          : "; LeesTekstUitBest$
	CASE 7:  PRINT "Cue point       : "; LeesTekstUitBest$
	CASE 8:  PRINT "Unknown text  8 : "; LeesTekstUitBest$
	CASE 9:  PRINT "Unknown text  9 : "; LeesTekstUitBest$
	CASE 10: PRINT "Unknown text 10 : "; LeesTekstUitBest$
	CASE 11: PRINT "Unknown text 11 : "; LeesTekstUitBest$
	CASE 12: PRINT "Unknown text 12 : "; LeesTekstUitBest$
	CASE 13: PRINT "Unknown text 13 : "; LeesTekstUitBest$
	CASE 14: PRINT "Unknown text 14 : "; LeesTekstUitBest$
	CASE 15: PRINT "Unknown text 15 : "; LeesTekstUitBest$
	CASE 32: PRINT "MIDI ch. Prefix.. ": a$ = LeesTekstUitBest$: REM <====== What is this ?
	CASE 47: PRINT "End of track      ":  GET #1, , a
	CASE 81: Tempo = (60000000 / LeesTempoUitBest): PRINT USING "Set tempo       : #### BPM"; Tempo
	CASE 84: PRINT "SMPTE Offset    : "; : t$ = LeesTekstUitBest$: PRINT ASC(LEFT$(t$, 1)); " "; ASC(MID$(t$, 2, 1))
	CASE 88: PRINT "Time signature    "; LeesTimeSigUitBest$
	CASE 89: PRINT "Key signature"; LeesTekstUitBest$
	CASE 127: PRINT "Sequencer-specific Meta Event"; LeesTekstUitBest$
	CASE ELSE: PRINT "Unknown command "; ASC(a): t$ = LeesTekstUitBest$
       END SELECT
      ELSE
      
       IF HEX$(ASC(a)) = "F0" OR HEX$(ASC(a)) = "F7" THEN
	t$ = LeesTekstUitBest
       ELSE
      
       IF Nibble$(a, 1) = "8" THEN
	Kanaal% = Nibble2Number(Nibble$(a, 0))
	Note% = NextNumber
	Volume% = NextNumber
'        PRINT "Note off Chn.:"; Kanaal%; NoteName(Note%), "  Velocent : "; Volume%
	CALL MidiNoteOFF(Note%, Volume%, Kanaal%, MidiPoort%)
	LOCATE Kanaal% + 20, 28: PRINT "     "
	InLen(Kanaal%) = 0
       END IF
      
       IF Nibble$(a, 1) = "9" THEN
	Kanaal% = Nibble2Number(Nibble$(a, 0))
	Note% = NextNumber
	Volume% = NextNumber
'        PRINT "Note on  Chn.:"; Kanaal%; NoteName(Note%), "  Velocent : "; Volume%
	LOCATE Kanaal% + 20, 28: PRINT NoteName(Note%); " "
	CALL MidiNote(Note%, Volume%, Kanaal%, MidiPoort%)
	InLen(Kanaal%) = 40
       END IF

      IF Nibble$(a, 1) = "A" THEN PRINT "Key after-touch    "; Nibble2Number(Nibble$(a, 0)); NoteName(NextNumber); "  Velocent : "; NextNumber
      
      IF Nibble$(a, 1) = "B" THEN
       Kanaal% = Nibble2Number(Nibble$(a, 0))
       Instrument% = NextNumber
       NewVal% = NextNumber
'       PRINT "Control change     "; Kanaal%; Controlname(Instrument%); "  New Value"; NextNumber
      END IF

      IF Nibble$(a, 1) = "C" THEN
       Kanaal% = Nibble2Number(Nibble$(a, 0))
       Instrument% = NextNumber
'       PRINT "Program change     "; Kanaal%; " New program number :"; Instrname(Instrument%)
       LOCATE Kanaal% + 20, 1: PRINT Kanaal% + 1; Instrname(Instrument%)
       MIDIInstrument Kanaal%, MidiPoort%, Instrument%
      END IF
       
      IF Nibble$(a, 1) = "D" THEN PRINT "Channel after-touch"; Nibble2Number(Nibble$(a, 0)); " Channel : "; NextNumber

      IF Nibble$(a, 1) = "E" THEN
       Kanaal% = Nibble2Number(Nibble$(a, 0))
       Bottom% = NextNumber
       Top% = NextNumber
  '    PRINT "Pitch wheel change "; Kanaal%; " Bottom : "; Bottom%; "  Top : "; Top%
       MIDIPitch Kanaal%, Bottom%, Top%
      END IF
     END IF
    END IF

    FOR i = 0 TO 15
     IF InLen(i) = 0 THEN InLen(i) = 1
     Bar$ = STRING$(INT(InLen(i)), 22) + STRING$(40 - INT(InLen(i)), 32)
     LOCATE i + 20, 33: COLOR 2
     PRINT MID$(Bar$, 2, 29); : COLOR 4
     PRINT RIGHT$(Bar$, 10);
     COLOR 7
     InLen(i) = InLen(i) - 1
    NEXT i

   WEND
  END IF
 NEXT i
CLOSE #1

MidiReset MidiPoort%
FOR i% = 0 TO 15
 FOR J% = 0 TO 120
  MidiNoteOFF J%, 0, i%, MidiPoort%
 NEXT J%
NEXT i%

Instrumentname:
DATA "Acoustic Grand","Bright Acoustic","Electric Grand"
DATA "Honky-Tonk","Electric Piano 1","Electric Piano 2"
DATA "Harpsichord","Clav","Celesta"
DATA "Glockenspiel","Music Box","Vibraphone"
DATA "Marimba","Xylophone","Tubular Bells"
DATA "Dulcimer","Drawbar Organ","Percussive Organ"
DATA "Rock Organ","Church Organ","Reed Organ"
DATA "Accoridan","Harmonica","Tango Accordian"
DATA "Acoustic Guitar(nylon)","Acoustic Guitar(steel)","Electric Guitar(jazz)"
DATA "Electric Guitar(clean)","Electric Guitar(muted)","Overdriven Guitar"
DATA "Distortion Guitar","Guitar Harmonics","Acoustic Bass"
DATA "Electric Bass(finger)","Electric Bass(pick)","Fretless Bass"
DATA "Slap Bass 1","Slap Bass 2","Synth Bass 1"
DATA "Synth Bass 2","Violin","Viola"
DATA "Cello","Contrabass","Tremolo Strings"
DATA "Pizzicato Strings","Orchestral Strings","Timpani"
DATA "String Ensemble 1","String Ensemble 2","SynthStrings 1"
DATA "SynthStrings 2","Choir Aahs","Voice Oohs"
DATA "Synth Voice","Orchestra Hit","Trumpet"
DATA "Trombone","Tuba","Muted Trumpet"
DATA "French Horn","Brass Section","SynthBrass 1"
DATA "SynthBrass 2","Soprano Sax","Alto Sax"
DATA "Tenor Sax","Baritone Sax","Oboe"
DATA "English Horn","Bassoon","Clarinet"
DATA "Piccolo","Flute","Recorder"
DATA "Pan Flute","Blown Bottle","Skakuhachi"
DATA "Whistle","Ocarina","Lead 1 (square)"
DATA "Lead 2 (sawtooth)","Lead 3 (calliope)","Lead 4 (chiff)"
DATA "Lead 5 (charang)","Lead 6 (voice)","Lead 7 (fifths)"
DATA "Lead 8 (bass+lead)","Pad 1 (new age)","Pad 2 (warm)"
DATA "Pad 3 (polysynth)","Pad 4 (choir)","Pad 5 (bowed)"
DATA "Pad 6 (metallic)","Pad 7 (halo)","Pad 8 (sweep)"
DATA "FX 1 (rain)","FX 2 (soundtrack)","FX 3 (crystal)"
DATA "FX 4 (atmosphere)","FX 5 (brightness)","FX 6 (goblins)"
DATA "FX 7 (echoes)","FX 8 (sci-fi)","Sitar"
DATA "Banjo","Shamisen","Koto"
DATA "Kalimba","Bagpipe","Fiddle"
DATA "Shanai","Tinkle Bell","Agogo"
DATA "Steel Drums","Woodblock","Taiko Drum"
DATA "Melodic Tom","Synth Drum","Reverse Cymbal"
DATA "Guitar Fret Noise","Breath Noise","Seashore"
DATA "Bird Tweet","Telephone Ring","Helicopter"
DATA "Applause","Gunshot","Unknown instrument"

FUNCTION Controlname$ (Nmr)
 SELECT CASE Nmr
  CASE 1: Controlname$ = "Modulation"
  CASE 7: Controlname$ = "Main volume"
  CASE 10: Controlname$ = "Pan"
  CASE 11: Controlname$ = "Expression"
  CASE 64: Controlname$ = "Sustain"
  CASE 121: Controlname$ = "Reset all controllers"
  CASE 123: Controlname$ = "All notes off"
  CASE ELSE: Controlname$ = "Unknown " + STR$(Nmr)
 END SELECT
END FUNCTION

FUNCTION LeesTekstUitBest$
 Lengte = ReadVarLen
 FOR tt = 1 TO Lengte
  GET #1, , a
  Temp$ = Temp$ + a
 NEXT tt
 LeesTekstUitBest$ = Temp$
END FUNCTION

FUNCTION LeesTempoUitBest
 DIM Temp AS LONG
 GET #1, , a
 IF a = CHR$(3) THEN
  FOR i = 1 TO 3
   GET #1, , a
   Temp = (Temp * 256) + ASC(a)
  NEXT i
 END IF
 LeesTempoUitBest = Temp
END FUNCTION

FUNCTION LeesTimeSigUitBest$
' Temp$ = LeesTekstUitBest$
 GET 1, , a
 GET 1, , a: T1 = ASC(a)
 GET 1, , a: T2 = ASC(a)
 GET 1, , a
 GET 1, , a

 LeesTimeSigUitBest$ = STR$(T1) + " /" + STR$(2 ^ T2)

END FUNCTION

SUB MidiInit (MidiPoort%)
 FOR Temp = 255 TO 0 STEP -1
  OUT MidiPoort% + 1, Temp + 2
 NEXT Temp
END SUB

SUB MIDIInstrument (Kanaal%, MidiPoort%, Instrument%)
 OUT MidiPoort%, &HC0 + Kanaal%
 OUT MidiPoort%, Instrument%
END SUB

SUB MidiNoot (Noot%, Volume%, Kanaal%, MidiPoort%, Pause%)
 OUT MidiPoort%, &H90 + Kanaal%
 OUT MidiPoort%, Noot%
 OUT MidiPoort%, Volume%
  FOR Temp = 1 TO Pause%: NEXT Temp
 OUT MidiPoort%, &H90 + Kanaal%
 OUT MidiPoort%, Noot%
 OUT MidiPoort%, 0
END SUB

SUB MidiNote (Note%, Volume%, Kanaal%, MidiPoort%)
 OUT MidiPoort%, &H90 + Kanaal%
 OUT MidiPoort%, Note%
 OUT MidiPoort%, Volume%
END SUB

SUB MidiNoteOFF (Note%, Volume%, Kanaal%, MidiPoort%)
 OUT MidiPoort%, &H80 + Kanaal%
 OUT MidiPoort%, Note%
 OUT MidiPoort%, Volume%
END SUB

SUB MIDIPitch (Kanaal%, Bottom%, Top%)
 OUT MidiPoort%, &HE0 + Kanaal%
 OUT MidiPoort%, Bottom%
 OUT MidiPoort%, Top%
END SUB

SUB MidiReset (MidiPoort%)
 OUT (MidiPoort%), &HFF
END SUB

FUNCTION NextNumber
 GET #1, , a
 NextNumber = ASC(a)
END FUNCTION

FUNCTION Nibble$ (Cr$, l)
 IF l = 1 THEN
    Nibble$ = LEFT$(HEX$(ASC(Cr$) AND 240), 1)
  ELSE
   Nibble$ = RIGHT$(HEX$(ASC(Cr$) AND 15), 1)
 END IF
END FUNCTION

FUNCTION Nibble2Number (ch$)
 SELECT CASE ch$
   CASE "0": Nibble2Number = 0
   CASE "1": Nibble2Number = 1
   CASE "2": Nibble2Number = 2
   CASE "3": Nibble2Number = 3
   CASE "4": Nibble2Number = 4
   CASE "5": Nibble2Number = 5
   CASE "6": Nibble2Number = 6
   CASE "7": Nibble2Number = 7
   CASE "8": Nibble2Number = 8
   CASE "9": Nibble2Number = 9
   CASE "A": Nibble2Number = 10
   CASE "B": Nibble2Number = 11
   CASE "C": Nibble2Number = 12
   CASE "D": Nibble2Number = 13
   CASE "E": Nibble2Number = 14
   CASE "F": Nibble2Number = 15
 END SELECT
END FUNCTION

FUNCTION NoteName$ (Nmbr%)
 Note = Nmbr% MOD 12
 SELECT CASE Note
  CASE 0: Temp$ = "C"
  CASE 1: Temp$ = "C#"
  CASE 2: Temp$ = "D"
  CASE 3: Temp$ = "D#"
  CASE 4: Temp$ = "E"
  CASE 5: Temp$ = "F"
  CASE 6: Temp$ = "F#"
  CASE 7: Temp$ = "G"
  CASE 8: Temp$ = "G#"
  CASE 9: Temp$ = "A"
  CASE 10: Temp$ = "A#"
  CASE 11: Temp$ = "B"
 END SELECT
 Octave = (Nmbr% - Note) / 12
 NoteName$ = Temp$ + STR$(Octave)
END FUNCTION

FUNCTION ReadVarLen
 GET #1, , a
 Value = ASC(a)
 IF (Value AND 128) THEN
  Value = (Value AND 127)
  DO
   GET #1, , a
   Value2 = ASC(a)
   Value = (Value * (2 ^ 7)) + (Value2 AND 127)
  LOOP WHILE (Value2 AND 128)
 END IF
 ReadVarLen = Value
END FUNCTION

FUNCTION TweeByteLengte
 GET #1, , a
 t = ASC(a) * 2 ^ 8
 GET #1, , a
 TweeByteLengte = t + ASC(a)
END FUNCTION

FUNCTION VierByteLengte
 GET #1, , a
 t = ASC(a) * 2 ^ 8
 GET #1, , a
 t = (ASC(a) + t) * 2 ^ 8
 GET #1, , a
 t = (ASC(a) + t) * 2 ^ 8
 GET #1, , a
 VierByteLengte = t + ASC(a)
END FUNCTION