Creating MIDI files using the classic basic PLAY command and MML

Source-code only - please, don't post questions here.
angros47
Posts: 1418
Joined: Jun 21, 2005 19:04

Creating MIDI files using the classic basic PLAY command and MML

Postby angros47 » Jun 02, 2018 19:55

This program is a variant of the PLAY routine that, instead of playing the notes, creates a MIDI file with the sequence. It works like the normal QBASIC PLAY command, but it supports more than one track (using the same syntax of GWBasic and MSX Basic, PLAY string1, string2, String3....). Notes can be put between {} to play chords. The routine creates single or multitrack midi files.

Code: Select all

FUNCTION WriteVarLen(Value as integer) as string
 dim a as string

 a=chr(Value AND 127)

  DO WHILE (Value > 127)
   Value = Value shr 7
   a=chr((Value AND 127)or 128)+a
  LOOP
 return a
END FUNCTION

FUNCTION WriteFourBytes(Value as integer) as string
 dim a as string
 a=chr(Value and 255)
 Value shr= 8
 a=chr(Value and 255)+a
 Value shr= 8
 a=chr(Value and 255)+a
 Value shr= 8
 a=chr(Value and 255)+a
 return a
end function




function _fbplay_internal_translateNote(toTranslate as string) as ubyte
   select case toTranslate
   case "c"  : return 0

   case "cs" : return 1
   case "db" : return 1

   case "d"  : return 2

   case "ds" : return 3
   case "eb" : return 3

   case "e"  : return 4
   case "fb" : return 4

   case "f"  : return 5
   case "es" : return 5

   case "fs" : return 6
   case "gb" : return 6

   case "g"  : return 7

   case "gs" : return 8
   case "ab" : return 8

   case "a"  : return 9

   case "as" : return 10
   case "bb" : return 10

   case "b"  : return 11
   case "cb" : return 11
   end select
       
end function



function _fbplay_internal(channel as ubyte, playstr as string) as string
       
   'default tempo is 120 quarter notes per minute
   'default note is a quarter note
   'as default notes play their full length
   'default octave is the 4th
   'default instrument is acoustic grand piano |TODO: Find a instrument closer to QB's PLAY sound.
   'maximum volume is default

   dim Track as string

   dim tempo as uinteger = 120
   dim note_len as ubyte = 4
   dim note_len_mod as double = 1
   dim octave as ubyte = 4
   dim volume as ubyte = 127
   dim note_stack(128) as ubyte

   dim chord as ubyte
   dim next_event as double

       
       
   dim duration as double
   dim idx as ubyte
       
   dim number as string
   dim char as string*1
   dim tChar as string*1
       
   dim toTranslate as string

   dim p as integer=1
       
   do while p < len(playstr)

      char=lcase(mid(playstr, p, 1))
      p+=1

      select case char
      
         'basic playing
         case "n"      'plays note with next-comming number, if 0 then pause
            number=""
            do
               tchar=mid(playstr, p, 1)
               if asc(tchar)>=48 and asc(tchar)<=57 then
                  p+=1
                  number+=tchar
               else
                  exit do
               end if
            loop
            idx=val(number)

            if idx=0 then 'pause
               next_event+=60/tempo*(4/note_len)/60
            else 'note
               duration=60/tempo*(4/note_len)

               Track=Track+WriteVarLen(240*next_event)+chr(&H90 + channel)+chr(idx)+chr(volume)

               next_event=duration*(1-note_len_mod)
               'stop_note(channel)=t+duration*note_len_mod(channel)

               note_stack(0)+=1
               note_stack(note_stack(0))=idx
            end if
             
         
         case "a" to "g"      'plays a to g in current octave         
            duration=60/tempo*(4/note_len)
               
            toTranslate=char

            number=""
            char=mid(playstr, p, 1)
            if char="-" then
               toTranslate+="b"
               p+=1
            elseif char="+" or char="#" then
               toTranslate+="s"
               p+=1
            end if

            do
               char=mid(playstr, p, 1)
               if asc(char)>=48 and asc(char)<=57 then
                  p+=1
                  number+=char
               else
                  exit do
               end if
            loop
            if val(number)<>0 then duration=duration*4/val(number)
            if char="." then duration=duration*1.5

            idx=12*octave+_fbplay_internal_translateNote(toTranslate)

            Track=Track+WriteVarLen(240*next_event)+chr(&H90 + channel)+chr(idx)+chr(volume)

            next_event=duration*(1-note_len_mod)

            note_stack(0)+=1
            note_stack(note_stack(0))=idx


         case "p"      'pauses for next-comming number of quarter notes
            number=""
            do
               char=mid(playstr, p, 1)
               if asc(char)>=48 and asc(char)<=57 then
                  p+=1
                  number+=char
               else
                  exit do
               end if
            loop
            next_event+=60/tempo*4/val(number)
               
         
         'octave handling
         case ">"      'up one octave
            if octave<7 then octave+=1
               
         case "<"      'down one octave
            if octave>1 then octave-=1
               
         case "o"      'changes octave to next-comming number
            number=""
            do
               char=mid(playstr, p, 1)
               if asc(char)>=48 and asc(char)<=57 then
                  p+=1
                  number+=char
               else
                  exit do
               end if
            loop
            octave=val(number)
               
               
         'play control
         case "t"      'changes tempo (quarter notes per minute)
            number=""
            do
               char=mid(playstr, p, 1)
               if asc(char)>=48 and asc(char)<=57 then
                  p+=1
                  number+=char
               else
                  exit do
               end if
            loop
            tempo=val(number)

         case "l"      'changes note length (1=full note, 4=quarter note, 8 eigth(?) note aso)
            number=""
            do
               char=mid(playstr, p, 1)
               if asc(char)>=48 and asc(char)<=57 then
                  p+=1
                  number+=char
               else
                  exit do
               end if
            loop
            note_len=val(number)
           
         case "m"      'MS makes note last 3/4, MN is 7/8 and ML sets to normal length
            char=lcase(mid(playstr, p, 1))
            p+=1
            if char="s" then note_len_mod=3/4
            if char="n" then note_len_mod=7/8
            if char="l" then note_len_mod=1
           
           
         'new midi fucntions
         case "i"
            number=""
            do
                 
               char=mid(playstr, p, 1)
               if asc(char)>=48 and asc(char)<=57 then
                  p+=1
                  number+=char
               else
                  exit do
               end if
            loop
            Track=Track+WriteVarLen(0)+chr(&HC0 + channel)+chr(val(number))
           
         case "v"
            number=""
            do
               char=mid(playstr, p, 1)
               if asc(char)>=48 and asc(char)<=57 then
                  p+=1
                  number+=char
               else
                  exit do
               end if
            loop
            volume=val(number)
         Case "{"      'enable chords (notes play simultaneously)
            chord=1
         Case "}"      'disable chords (notes play simultaneously)
            chord=0

         case else
      end select


      if chord then
         if chord=2 then next_event=0 else chord=2
      else
         'Stop current note, if still playing
         for i as integer=1 to note_stack(0)
            Track=Track+WriteVarLen(240*duration*note_len_mod)+chr(&H80 + channel)+chr(note_stack(i))+chr(0)
            duration=0
         next
         note_stack(0)=0
      end if

   loop

   return Track
       
end function
 


sub play (playstr as string, playstr1 as string="", playstr2 as string="", playstr3 as string="", _
   playstr4 as string="", playstr5 as string="", playstr6 as string="", playstr7 as string="", _
   playstr8 as string="", playstr9 as string="", playstr10 as string="", playstr11 as string="", _
   playstr12 as string="", playstr13 as string="", playstr14 as string="", playstr15 as string="")

   'if lcase(left(_fbplay_internal_playstr(0),2))="mb" then    'supposed to play in foreground

   dim Tracks as integer

   dim midi as string
   dim Track as string
   Track=_fbplay_internal (0,playstr)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (1,playstr1)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (2,playstr2)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (3,playstr3)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (4,playstr4)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (5,playstr5)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (6,playstr6)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (7,playstr7)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (8,playstr8)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (9,playstr9)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (10,playstr10)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (11,playstr11)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (12,playstr12)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (13,playstr13)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (14,playstr14)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if
   Track=_fbplay_internal (15,playstr15)
   if len(Track)>0 then
      Midi=Midi +"MTrk"+WriteFourBytes(len(Track)+4)+Track+chr(0)+chr(255)+chr(47)+chr(0)
      Tracks+=1
   end if

   open "output.mid" for output as #2
   ?#2,"MThd"+chr(0)+chr(0)+chr(0)+chr(6)+chr(0)+chr(iif(Tracks>1,1,0))+chr(0)+chr(Tracks)+chr(0)+chr(120)+Midi;
   close   
end sub


PLAY " i48 t200l4mneel2el4eel2el4egl3cl8dl1el4ffl3fl8fl4fel2el8eel4eddel2dgl4eel2el4eel2el4egl3cl8dl1el4ffl3fl8fl4fel2el8efl4ggfdl2cl8"
dodicat
Posts: 5015
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Creating MIDI files using the classic basic PLAY command and MML

Postby dodicat » Jun 03, 2018 10:33

I tested with various downloaded play strings (qb64 and others).
It works really well.(Windows media player, Win 10)
For such short code and many options this is a real gem.
Roland Chastain
Posts: 837
Joined: Nov 24, 2011 19:49
Location: Dakar, Senegal
Contact:

Re: Creating MIDI files using the classic basic PLAY command and MML

Postby Roland Chastain » Jun 08, 2018 21:45

Great.

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 1 guest