[bb] music tracker by b32 [ 1+ years ago ]

Started by BlitzBot, June 29, 2017, 00:28:43

Previous topic - Next topic
Print
Go Down Pages1
User actions

BlitzBot

June 29, 2017, 00:28:43
Title : music tracker
Author : b32
Posted : 1+ years ago

Description : Updated: once
This is a basic tracker program in Blitz (3D, but no 3d commands) It needs Ziltch's winmm.decls.
I've had two complaints that it gives no sound. So now I try autodetecting the device.
The midi exporting bug is gone now. I forgot to take in account the empty space before the first note of a track.

Code :
Code (blitzbasic) Select
; ID: 1865
; Author: b32
; Date: 2006-11-18 00:46:30
; Title: music tracker
; Description: tracker style music editor

;-----------------------------------------------------------------------------------------------------
;   Userlib, extracted from winmm.decls by Ziltch
;-----------------------------------------------------------------------------------------------------

; .lib "winmm.dll"
;
; midiOutGetNumDevs%()
; midiOutClose%(hMidiOut%)
; midiOutOpen%(lphMidiOut*,uDeviceID%,dwCallback%,dwInstance%,dwFlags%); nul1*,nul2*,dwFlags%)
; midiOutShortMsg%(hMidiOut%,dwMsg%)
; midiOutGetDevCaps%( uDeviceID%, lpCaps*, uSize%):"midiOutGetDevCapsA"
;

;-----------------------------------------------------------------------------------------------------
; usage: you need this in a .decls file in folder "c:program fileslitzuserlibs" to run
;-----------------------------------------------------------------------------------------------------


;MIDI code by Ziltch
;tracker/saving routine by bram32bit

;-----------------------------------------------------------------------------------------------------
; Globals
;-----------------------------------------------------------------------------------------------------

Const notes$ = "C-C#D-D#E-F-F#G-G#A-A#B-"
Const keyb1$ = "ZSXDCVGBHNJM,L.;/'"
Const keyb2$ = "ZSXDCVGBHNJMQ2W3ER5T6Y7UI9O0P[=]"
Const dumpfile$ = "dump002.dat"

Global device
Global setvolume = 127

Global maxnotes = 63
Global maxchannels = 19

ReadHeader(dumpfile$)

Global fmaxnotes = maxnotes
Global fmaxchannels = maxchannels
Const indexwidth = 35
Const notewidth = 100
Const noteheight = 15
Const ofx = 180
Const ofy = 50
Global vis_maxnotes = 31
Global vis_maxchannels = 3
Global vis_ofx = 0
Global  vis_ofy = 0

If vis_maxnotes > maxnotes Then vis_maxnotes = maxnotes
If vis_maxchannels > maxchannels Then vis_maxchannels = maxchannels

Global patternwidth = notewidth * 4 + indexwidth
Global patternheight = (maxnotes + 1) * noteheight

Global octave = 3
Global curX
Global curY
Global recmode = 1
Global spd# = 125.0
Global btel
Global playing
Global starttime
Global nowtime
Global  oldtimenow

Global MIDI_File
Dim nxt(0)

Dim instrument(maxchannels)
Dim lastnote(maxchannels)
Dim instrumentname$(128)
Dim mute(maxchannels)

Dim Pattern(maxchannels, maxnotes)
Dim Vol(maxchannels, maxnotes)
Dim Sel(maxchannels, maxnotes)

Dim BUF_Pattern(maxchannels, maxnotes)
Dim BUF_Vol(maxchannels, maxnotes)
Dim BUF_Sel(maxchannels, maxnotes)

Dim templen(maxnotes + 1)

Dim button$(10)

ReadData()

;-----------------------------------------------------------------------------------------------------
;   Initialize
;-----------------------------------------------------------------------------------------------------

Graphics 800, 600, 0, 2
SetBuffer BackBuffer()

font = LoadFont("FixedSys")
SetFont font
font2 = LoadFont("Arial", 12)

;if midi device gives trouble, try passing -1 as a parameter
numdevices = midiOutGetNumDevs()
Print numdevices

For i = 0 To numdevices
device = OpenMidiOut(i)
If device <> 0 Then Print "Found device " + i + " .. ": tst = 1: Exit
Print "Not found device " + i
Next
If tst <> 1 Then
Print "Hmm .. no midi devices were found."
Print "Please press any key to exit"
WaitKey()
End
End If

Cls

For i = 0 To maxchannels
SelectInstrument(i, i * 2)
Next

ReadPattern(dumpfile$)

;-----------------------------------------------------------------------------------------------------
; Main Loop
;-----------------------------------------------------------------------------------------------------

Repeat

Cls

nowtime = MilliSecs()

;enter=play
If KeyHit(28) Then StartPlay()

;handle playmode
timenow = (Floor((nowtime - starttime) / spd)) Mod (maxnotes + 1)
If playing Then
;check if a new line is played
If timenow <> oldtimenow Then
;play all notes
For chi = 0 To maxchannels
If pattern(chi, timenow) <> 0 Then PlayNote(chi, pattern(chi, timenow) - 1, vol(chi, timenow))
Next
;store played line
oldtimenow = timenow
End If
;draw red play cursor dot
gnow = timenow - vis_ofy
If gnow >= 0 Then If gnow <= vis_maxnotes Then
Color 255, 0, 0
Oval ofx - noteheight, ofy + noteheight * gnow + noteheight/2, noteheight/2, noteheight/2
End If
End If

;read key from pc keyboard
keynote = ReadNoteFromKeyboard()
;if a key is pressed
If keynote > 0 Then
keynote = keynote + octave * 12
;preview note
playnote( curX, keynote - 1, setvolume )
;store note info
If recmode Then
If curX >= 0 Then If curX <= maxchannels
If curY >= 0 Then If curY <= maxnotes
pattern(curX, curY) = keynote
vol(curX, curY) = setvolume
CurY = CurY + 1
End If
End If
End If
End If

;F3=cut
If KeyHit(61) Then CutFrame()

;F4=copy
If KeyHit(62) Then CopyFrame2()

;F5=paste
If KeyHit(63) Then PasteFrame(curX, curY)

;TAB
If KeyHit(15) Then
If recmode Then
If curX >= 0 Then If curX <= maxchannels
If curY >= 0 Then If curY <= maxnotes
pattern(curX, curY) = -1
vol(curX, curY) = 0
PlayNote(curX, -1, 0)
CurY = CurY + 1
End If
End If
End If
End If

;DEL
tst = False
If KeyDown(211) Then
tst = (nowtime - tms > 350)
Else
tms = nowtime
End If
If KeyHit(211) Or tst Then
If recmode Then
If curX >= 0 Then If curX <= maxchannels
If curY >= 0 Then If curY <= maxnotes
pattern(curX, curY) = 0
vol(curX, curY) = 0
PlayNote(curX, -1, 0)
CurY = CurY + 1
End If
End If
End If
End If

;cursor keys for moving cursor
p = 0
If KeyHit(200) Then TestSel: curY = curY - 1
If KeyHit(208) Then TestSel: curY = curY + 1
If KeyHit(203) Then TestSel: curX = curX - 1
If KeyHit(205) Then TestSel: curX = curX + 1

;pgup/pgdn
If KeyHit(201) Then curY = curY - 16: TestSel(+16)
If KeyHit(209) Then curY = curY + 16: TestSel(-16)
If KeyHit(199) Then curY = 0
If KeyHit(207) Then curY = maxnotes

;limit cursor movement
If curX < 0 Then curX = 0
If curY < 0 Then curY = 0
If curX > maxchannels Then curX = maxchannels
If curY > maxnotes Then curY = maxnotes

;scroll interface
If curX > vis_maxchannels + vis_ofx Then vis_ofx = curX - vis_maxchannels
If curX < vis_ofx Then vis_ofx = curX
If curY < vis_ofy Then vis_ofy = curY
If curY > vis_maxnotes + vis_ofy Then vis_ofy = curY - vis_maxnotes

;draw instrument names
Color 100, 100, 0
SetFont font2
For chi = 0 To vis_maxchannels
If chi + vis_ofx > 4 Then
Text ofx + chi * notewidth + indexwidth, ofy - 15, InstrumentName$(instrument(chi + vis_ofx))
Else
Text ofx + chi * notewidth + indexwidth, ofy - 15, "Drum" + (chi + vis_ofx)
End If
Text ofx + chi * notewidth + indexwidth, ofy + noteheight * (vis_maxnotes + 1), chi + vis_ofx

Next

mx = MouseX()
my = MouseY()
mh = MouseHit(1)

;volumebar
volx = 620
voly = ofy
Color 100, 100, 0
Text volx, voly - 15, "volume"
Rect volx, voly, 50, 100, 0
Color 100, 100, 0
Rect volx, voly + 90 - setvolume * 90 / 127, 50, 10
If MouseDown(1) Then
If RectsOverlap(mx, my, 1, 1, volx, voly - 10, 50, 120) Then
setvolume = ((voly + 90 - MouseY()) * 127 / 90)
If setvolume < 0 Then setvolume = 0
If setvolume > 127 Then setvolume = 127
For i = 0 To maxchannels
For j = 0 To maxnotes
If sel(i, j) Then vol(i, j) = setvolume
Next
Next
End If
End If
SetFont font

;buttons
gui$ = ""
For y = 0 To btel - 1
overlap = RectsOverlap(mx, my, 1, 1, ofx - 80, ofy + y * noteheight * 10 / 4, 60, noteheight * 2)
If mh Then
If overlap Then
gui$ = button$(y)
End If
End If
Color 100, 100, 0
Rect ofx - 80, ofy + y * noteheight * 10 / 4, 60, noteheight * 2, 0
If overlap Then Color 255, 255, 0 Else Color 100, 100, 0
Text ofx - 50, ofy + y * noteheight * 10 / 4 + noteheight, button$(y), True, True
Next

Select gui$

Case "New"

For i = 0 To maxchannels
For j = 0 To maxnotes
pattern(i, j) = 0
vol(i, j) = 0
Next
Next
setvolume = 127

Case "Load"

SetBuffer FrontBuffer()
Cls
Color 255, 255, 255
Locate 0, 0
dir = ReadDir(CurrentDir$())
Repeat
f$ = Lower$(NextFile$(dir))
If Right$(f$, 4) = ".pia" Then Print f$
If f$ = "" Then Exit
Forever
f$ = Lower$(iInput$("please enter filename>"))
If Right$(f$, 4) <> ".pia" Then f$ = f$ + ".pia"
ReadPattern(CurrentDir$() + f$)
SetBuffer BackBuffer()
Cls

Case "Save"

SetBuffer FrontBuffer()
Cls
Color 255, 255, 255
Locate 0, 0
f$ = Lower$(iInput$("please enter filename>"))
If Right$(f$, 4) <> ".pia" Then f$ = f$ + ".pia"
ok = True
If FileType(f$) = 1 Then
Print "file exists!"
ok = Lower$(iInput$("overwrite? (y/n)")) = "y"
If ok Then DeleteFile f$
End If
If ok Then
WritePattern(f$)
Print "file saved!"
Print "press any key"
WaitKey()
End If
SetBuffer BackBuffer()
Cls

Case "Export"

SetBuffer FrontBuffer()
Cls
Color 255, 255, 255
Locate 0, 0
f$ = Lower$(iInput$("please enter filename>"))
If Right$(f$, 4) <> ".mid" Then f$ = f$ + ".mid"
ok = True
If FileType(f$) = 1 Then
Print "file exists!"
ok = Lower$(iInput$("overwrite? (y/n)")) = "y"
If ok Then DeleteFile f$
End If
If ok Then SaveMidi(f$)
SetBuffer BackBuffer()
Cls

Case "Play"

StartPlay()

Case "Stop"

playing = False
button$(4) = "Play"

Case "Speed"

SetSpeed()

Case "All"

For i = 0 To maxchannels
For j = 0 To maxnotes
sel(i, j) = 1
Next
Next

Case "Track"

For i = 0 To maxchannels
For j = 0 To maxnotes
sel(i, j) = (i = curX)
Next
Next

Case "Length"

ChangeLength()

Case "Deselect"

For i = 0 To maxchannels
For j = 0 To maxnotes
sel(i, j) = 0
Next
Next

Case "Help"

Help()

End Select

;loop through visible lines
For lni = 0 To vis_maxnotes
;draw index rectangle
Color 64, 64, 0
Rect ofx, ofy + lni * noteheight, indexwidth + 1, noteheight + 1, 0
;draw line index
col = 90 + ((lni + vis_ofy) Mod 4 = 0) * 45
Color col, col, 0
Text ofx + (indexwidth / 2), ofy + lni * noteheight, lni + vis_ofy, True
;loop through visible channels
For chi = 0 To vis_maxchannels

;get note data
note$ = ConvertNote$(pattern(vis_ofx + chi, vis_ofy + lni) - 1, vol(vis_ofx + chi, vis_ofy + lni))
;check if this is the selected note
selected = ((lni + vis_ofy) = curY) And ((chi + vis_ofx) = curX)

If selected Then
col = 255
If note$ = "" Then note$ = "<-->"
Else
col = 90 + ((lni + vis_ofy) Mod 4 = 0) * 45
End If
;draw pattern grid
If sel(vis_ofx + chi, vis_ofy + lni) Then
Color 45, 45, 0
Rect ofx + indexwidth + (chi * notewidth), ofy + (lni * noteheight), notewidth + 1, noteheight + 1, 1
Else
Color 64, 64, 0
Rect ofx + indexwidth + (chi * notewidth), ofy + (lni * noteheight), notewidth + 1, noteheight + 1, 0
End If
Color col, col, 0
Text ofx + chi * notewidth + indexwidth + (notewidth / 2), ofy + (lni * noteheight), note$, True
Next
Next

;SPACE=change recmode
If KeyHit(57) Then
For i = 0 To maxchannels
PlayNote(i, -1, 0)
Next
recmode = Not(recmode)
End If

If KeyHit(59) Then Help()

;F7/F8
If KeyHit(65) Then If octave > 0 Then octave = octave - 1
If KeyHit(66) Then If octave < 12 Then octave = octave + 1
;F9/F10
If KeyHit(67) Then SelectInstrument(curX, instrument(curX) - 1)
If KeyHit(68) Then SelectInstrument(curX, instrument(curX) + 1)

If MouseDown(1) Or MouseDown(2) Then
If RectsOverlap(mx, my, 1, 1, ofx + indexwidth, ofy, patternwidth, patternheight) Then
xx = (mx - ofx - indexwidth) / notewidth + vis_ofx
yy = (my - ofy) / noteheight + vis_ofy
sel(xx, yy) = MouseDown(1)
End If
End If

;show recmode flag
If recmode Then
Color 255, 0, 0
Text GraphicsWidth() / 2, 10, "RECORD", True
End If

Color 64, 64, 64
Text 0, 0, "Press F1 for help"

Flip
Delay 10

Until KeyHit(1)

WritePattern(dumpfile$)

;-----------------------------------------------------------------------------------------------------
;    Finalize
;-----------------------------------------------------------------------------------------------------

CloseMidiOut device

End

;-----------------------------------------------------------------------------------------------------
; CloseMidiOut()
;-----------------------------------------------------------------------------------------------------
;close MIDI device
Function CloseMidiOut(MidiOutHandle)

  midiOutClose(MidiOutHandle)

End Function

;-----------------------------------------------------------------------------------------------------
; OpenMidiOut()
;-----------------------------------------------------------------------------------------------------
;open MIDI device
Function OpenMidiOut(OutDevID=0)

  OutHandleBank = CreateBank(4)
  ok = midiOutOpen(OutHandleBank,OutDevID,0,0, 0)
  MidiOutHandle = PeekInt(OutHandleBank,0)
  FreeBank OutBankHandle
  Return MidiOutHandle

End Function

;-----------------------------------------------------------------------------------------------------
; SendMidiOut()
;-----------------------------------------------------------------------------------------------------
;send MIDI message
Function SendMidiOut(MidiOutHandle, MidiOutChannel, MidiOutStatus, MidiOutdata1 = 0, MidiOutData2 = 0)

   Return midiOutShortMsg(MidiOutHandle,( (MidiOutdata2 Shl 16) Or (MidiOutdata1 Shl 8 ) Or (MidiOutStatus Shl 4) Or MidiOutChannel))

End Function

;-----------------------------------------------------------------------------------------------------
; SelectInstrument()
;-----------------------------------------------------------------------------------------------------
;select MIDI instrument
Function SelectInstrument( channel, program )

If program < 0 Then Return
If program > 127 Then Return

SendMidiOut(device, ConvertChannel(channel), $C, program, 4)
instrument(channel) = program

End Function

;-----------------------------------------------------------------------------------------------------
; ReadNoteFromKeyboard()
;-----------------------------------------------------------------------------------------------------
;convert pc keyboard keypress to MIDI note
Function ReadNoteFromKeyboard()

w = GetKey()
note = Instr(keyb1$, Upper$(Chr$(w)))
If note = 0 Then note = Instr(keyb2$, Upper$(Chr$(w)))

Return note

End Function

Function Two$( num )

r$ = Hex$(num)
Return Right$(r$, 2)

End Function


Function ConvertNote$(index, vol)

If index = -2 Then Return "====="
If index = -1 Then Return ""

nti = index Mod 12
note$ = Mid$(notes$, nti * 2 + 1, 2) + (index / 12) + " " + Two$(vol)

Return note$

End Function
;"C#6 127"

Function PlayNote( channel, playnote, vol )
If channel < 0 Then Return
If channel > maxchannels Then Return
;stop previous note
If lastnote(channel) > -1 Then SendMidiOut(device, ConvertChannel(channel), $8, lastnote(channel), 0)
;play new note
If playnote > -1 Then SendMidiOut(device, ConvertChannel(channel), $9, playnote, vol)
;store this note
lastnote(channel) = playnote
End Function


;-------------------------------------------------------------------------------------------------
; instrument data
;-------------------------------------------------------------------------------------------------

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

Data "New"
Data "Load"
Data "Save"
Data "Export"
Data "Play"
Data "Speed"
;Data "Copy"
;Data "Paste"
;Data "Exit"
Data "All"
Data "Deselect"
Data "Track"
Data "Length"
Data "Help"
Data "STOP"
;-----------------------------------------------------------------------------------------------------
; ReadData()
;-----------------------------------------------------------------------------------------------------
;read instrument names
Function ReadData()
Restore
For i = 0 To 127
Read instrumentname$(i)
Next
btel = 0
Repeat
Read b$
If b$ = "STOP" Then Exit
button$(btel) = b$
btel = btel + 1
Forever
End Function

;-----------------------------------------------------------------------------------------------------
; ConvertChannel()
;-----------------------------------------------------------------------------------------------------
;this makes track 0-4 drumtracks, and shifts the rest
Function ConvertChannel(chn)

If chn > 4 Then
chn = chn - 4
; If chn > 8 Then chn = chn + 1
Else
chn = 9
End If

Return chn

End Function

;-----------------------------------------------------------------------------------------------------
; WritePattern()
;-----------------------------------------------------------------------------------------------------
;dump the pattern to disk
Function WritePattern(f$)

If f$ = "" Then Return

ff = WriteFile(f$)

If ff = 0 Then Return

WriteInt ff, maxchannels
WriteInt ff, maxnotes

For j = 0 To maxchannels
WriteInt ff, instrument(j)
Next

For i = 0 To maxnotes
For j = 0 To maxchannels
WriteInt ff, pattern(j, i)
WriteInt ff, vol(j, i)
Next
Next

WriteInt ff, curX
WriteInt ff, curY

CloseFile ff

End Function

;-----------------------------------------------------------------------------------------------------
; ReadPattern()
;-----------------------------------------------------------------------------------------------------
;read dumped pattern from disk
Function ReadHeader(f$)

If FileType(f$) <> 1 Then Return

ff = ReadFile(f$)

If ff = 0 Then Return

maxchannels = ReadInt(ff)
maxnotes = ReadInt(ff)

CloseFile ff

End Function

;-----------------------------------------------------------------------------------------------------
; ReadPattern()
;-----------------------------------------------------------------------------------------------------
;read dumped pattern from disk
Function ReadPattern(f$)

If FileType(f$) <> 1 Then Return

ff = ReadFile(f$)

imaxchannels = ReadInt(ff)
imaxnotes = ReadInt(ff)

If imaxnotes <> maxnotes Then CloseFile ff: Return
If imaxchannels <> maxchannels Then CloseFile ff: Return

For j = 0 To maxchannels
instrument(j) = ReadInt(ff)
SelectInstrument j, instrument(j)
Next

For i = 0 To maxnotes
For j = 0 To maxchannels
pattern(j, i) = ReadInt(ff)
vol(j, i) = ReadInt(ff)
Next
Next

If Not Eof(ff) Then
curX = ReadInt(ff)
curY = ReadInt(ff)
End If

CloseFile ff

End Function

;-----------------------------------------------------------------------------------------------------
; SaveMidi()
;-----------------------------------------------------------------------------------------------------
;save MIDI file
Function SaveMidi(name$)

expand = 1 + 3 * (maxnotes < 16)
notelength = 96 * expand;$60

SetBuffer FrontBuffer()
Color 255, 255, 255
Cls
Locate 0, 0

Print "Saving MIDI file '" + name$ + "' .. "

;set drum instruments
For i = 0 To 4
Instrument(i) = 0
Next

;general tempo
;BPM# = 15000 / spd

;-------------------------------------------------------------------------------------------------
;     calculate tempo
;-------------------------------------------------------------------------------------------------

tt = 4000 / expand * spd ;15000/BPM
t1 = (tt Shr 16)
t2 = (tt Shr 8) Mod 256
t3 = (tt Mod 256)

;opens file
MIDI_File = WriteFile(name$)

If MIDI_File = 0 Then Return

;-------------------------------------------------------------------------------------------------
;   write MIDI header
;-------------------------------------------------------------------------------------------------

;[4] standard header
MIDI_WriteLine "MThd"

;[4] size header = 6 bytes
MIDI_WriteLine Chr$(0) + Chr$(0) + Chr$(0) + Chr$(6)

;[2] midi type 2
MIDI_WriteLine Chr$(0) + Chr$(2)

;[2] number of tracks
MIDI_WriteLine Chr$(0) + Chr$(maxchannels + 1)

;[2] time base
MIDI_WriteLine Chr$($01) + Chr$($80)

;-------------------------------------------------------------------------------------------------
; tempo track
;-------------------------------------------------------------------------------------------------

;[4] track header
MIDI_WriteLine "MTrk"

;[4] track length in bytes = 10 bytes
MIDI_WriteLine Chr$(0) + Chr$(0) + Chr$(0) + Chr$($0A)

;[8] tempo in microseconds pro quarter note
MIDI_WriteLine Chr$(0) + Chr$(255) + Chr$(81) + Chr$(3) + Chr$(t1) + Chr$(t2) + Chr$(t3) + Chr$(0)

;[3] end of track
MIDI_WriteLine Chr$(255) + Chr$(47) + Chr$(0)

Dim nxt(maxnotes)

For iCurTrack = 0 To maxchannels

For i = 0 To maxnotes
If pattern(iCurTrack, i) > 0 Then Exit
If i Mod 8 = 0 Then
pattern(iCurTrack, i) = 3000
vol(iCurTrack, i) = 01
End If
Next
;If pattern(iCurtrack, 0) = 0 Then pattern(iCurtrack, 0) = 13: vol(iCurTRack, 0) = 1

CurTrack = ConvertChannel(iCurTrack)

;-------------------------------------------------------------------------------------------------
;    track CurTrack
;-------------------------------------------------------------------------------------------------

;[4] track header
MIDI_WriteLine "MTrk"

For i = 0 To maxnotes
templen(i) = 0
Next

t = 0: prev = -1
For i = 0 To maxnotes
note = pattern(iCurTrack, i) - 1
If note > 0 Then
t = t + 1
If prev > -1 Then
templen(prev) = i - prev
End If
prev = i
If i = maxnotes Then templen(i) = 1
End If
Next
If prev > -1 Then templen(prev) = (maxnotes + 1) - prev

p = 0
For i = 0 To maxnotes
If pattern(iCurTrack, i) > 0 Then p = p + writevarlen(templen(i) * notelength, 0)
Next

;519
t = t * 7 + p + 7
t1 = t Shr 8
t2 = t Mod 256

;[4] track length in bytes
MIDI_WriteLine Chr$(0) + Chr$(0) + Chr$(t1) + Chr$(t2)


;[4] Channel: Program Change
MIDI_WriteLine Chr$(0) + Chr$($C0 + CurTrack) + Chr$(Instrument(iCurTrack)) + Chr$(0)

;-------------------------------------------------------------------------------------------------
; write notes
;-------------------------------------------------------------------------------------------------

bb = 7
For i = 0 To maxnotes
note = pattern(iCurTrack, i) - 1
vou = vol(iCurTrack, i)
If note = 2999 Then note = 13: pattern(iCurTrack, i) = 0
If note > 0 Then
;[4] notes [status] [byte1] [byte2] [delta]
;     on                  note    volume       time
Send $90 + CurTrack: Send note: Send vou: bb = bb + 3 + WriteVarLen(notelength * templen(i))
;    off                  note    volume       time
Send $80 + CurTrack: Send note: Send $00: Send $00: bb = bb + 4
End If
Next

;-------------------------------------------------------------------------------------------------
; end of track
;-------------------------------------------------------------------------------------------------
;[3] end of track
MIDI_WriteLine Chr$(255) + Chr$(47) + Chr$(0)

Next

;closes file
CloseFile MIDI_File

Dim nxt(0)

Print "Done."
Print "Opening file.."
;playback midi file
chn = PlayMusic(name$)
If chn = 0 Then
Print "Hmm, the channel returns an empty handle .. the file is probably not saved"
Else
Print "Playing file .. press any key To Exit"
End If
FlushKeys()
WaitKey()
FlushKeys()

StopChannel chn

SetBuffer BackBuffer()
Cls

End Function


;--------------
;MIDI_WRITELINE
;--------------

;sends a string to the file

Function MIDI_WriteLine( t$ )
For i = 1 To Len( t$ )
WriteByte MIDI_File, Asc(Mid$(t$, i, 1))
Next
End Function


;-----
;SEND
;-----

;sends a byte to the file

Function Send( p )
WriteByte MIDI_File, p
End Function


;-------------------------------------------------------------------------------------------------
; WriteVarLen()
;-------------------------------------------------------------------------------------------------
;write strange midi formatted number
Function WriteVarLen(value, send = 1)

buffer = value And $7F

Repeat

value = value Shr 7
If Not value Then Exit

buffer = buffer Shl 8
buffer = buffer Or (value And $7F) Or $80

Forever

t = 0
Repeat

If send Then Send (buffer And $FF)
t = t + 1
If buffer < $80 Then Exit
buffer = buffer Shr 8

Forever

Return t

End Function

;-------------------------------------------------------------------------------------------------
; TestSel()
;-------------------------------------------------------------------------------------------------
Function TestSel(i = 0)
;shift+move=select
If curX < 0 Then Return
If curY < 0 Then Return
If curX > maxchannels Then Return
If curY > maxnotes Then Return
If KeyDown(42) Then
sel(curX, curY) = Not(sel(curX, curY))
If i <> 0 Then
For t = 0 To Abs(i)
tt = t * Sgn(i) + curY
If tt >= 0 Then If tt <= maxnotes Then
sel(curX, tt) = Not(sel(curX, tt))
End If
Next
End If
End If

End Function

;-------------------------------------------------------------------------------------------------
; StartPlay()
;-------------------------------------------------------------------------------------------------
Function StartPlay()
playing = Not(playing)
If playing Then
button$(4) = "Stop"
Else
button$(4) = "Play"
End If
starttime = nowtime
oldtimenow = -1000
For i = 0 To maxchannels
PlayNote(i, -1, 0)
Next
End Function

;-------------------------------------------------------------------------------------------------
; iInput()
;-------------------------------------------------------------------------------------------------
Function iInput$(r$)
FlushKeys()
r$ = Input$(r$)
FlushKeys()
Return r$
End Function

;-------------------------------------------------------------------------------------------------
; SetSpeed()
;-------------------------------------------------------------------------------------------------
Function SetSpeed()
Cls
Color 255, 255, 255
Locate 0, 0
SetBuffer FrontBuffer()
Print "Current speed is: " + spd + "  (" + 15000 / spd + " BPM)"
spd = iInput ("new speed>")
If spd = 0 Then spd = 1
SetBuffer BackBuffer()
End Function

;-------------------------------------------------------------------------------------------------
; Help
;-------------------------------------------------------------------------------------------------
Function Help()
Cls
Color 64, 64, 64
Locate 0, 0
Print "Use cursor keys to move around"
Print
Print "Q2W3E..etc for playing sounds"
Print "ZSXDC..etc for lower octave"
Print
Print "Change octave using F7/F8"
Print
Print "Change (non-drumtrack) instrument: F9/F10"
Print
Print "Enter to play"
Print "Space toggle recmode"
Print
Print "Esc to dump file and exit"
Print
Print "Del remove note"
Print "TAB make mark"
Print
Print
Print "F3-Cut"
Print "F4-Copy"
Print "F5-Paste"
Print
Print "Press any key to continue"
Flip
FlushKeys()
Repeat
r = GetKey()
Until r Or MouseHit(1)
FlushKeys()
End Function

;-------------------------------------------------------------------------------------------------
; CopyFrame()
;-------------------------------------------------------------------------------------------------
Function CopyFrame()
fmaxchannels = maxchannels
fmaxnotes = maxnotes

For i = 0 To maxchannels
For j = 0 To maxnotes
BUF_Sel(i, j) = Sel(i, j)
BUF_Pattern(i, j) = Pattern(i, j)
BUF_Vol(i, j) = Vol(i, j)
Next
Next

End Function

;-------------------------------------------------------------------------------------------------
; CopyFrame()
;-------------------------------------------------------------------------------------------------
Function CutFrame(del=0)

If Not del Then CopyFrame()
For i = 0 To maxchannels
For j = 0 To maxnotes
If del Or sel(i, j) Then
Pattern(i, j) = 0
Vol(i, j) = 0
Sel(i, j) = 0
End If
Next
Next

End Function

;-------------------------------------------------------------------------------------------------
; PasteFrame()
;-------------------------------------------------------------------------------------------------
Function CopyFrame2()

cx = 0
cy = 0
For j = 0 To maxnotes
For i = 0 To maxchannels
If sel(i, j) Then
cx = i
cy = j
Exit
End If
Next
If sel(i, j) Then Exit
Next

For i = 0 To maxchannels
For j = 0 To maxnotes
ii = i - cx
jj = j - cy
If ii <= maxchannels Then
If ii >= 0 Then
If jj <= maxnotes Then
If jj >= 0 Then
BUF_Pattern(ii, jj) = Pattern(i, j)
BUF_Vol(ii, jj) = Vol(i, j)
BUF_Sel(ii, jj) = Sel(i, j)
End If
End If
End If
End If
Next
Next

End Function


;-------------------------------------------------------------------------------------------------
; PasteFrame()
;-------------------------------------------------------------------------------------------------
Function PasteFrame(cx, cy, seld = 0)

For i = 0 To fmaxchannels
For j = 0 To fmaxnotes
ii = i + cx
If ii <= maxchannels Then
If ii >= 0 Then
jj = j + cy
If jj <= maxnotes Then
If jj >= 0 Then
If seld Or BUF_sel(i, j) Then
Pattern(ii, jj) = BUF_Pattern(i, j)
Vol(ii, jj) = BUF_Vol(i, j)
If seld Then Sel(ii, jj) = Buf_Sel(i, j)
End If
End If
End If
End If
End If
Next
Next

End Function

;-------------------------------------------------------------------------------------------------
; ChangeLength()
;-------------------------------------------------------------------------------------------------
Function ChangeLength(newlength = -1)

If newlength = -1 Then
Cls
Color 255, 255, 255
Locate 0, 0
SetBuffer FrontBuffer()
Print "Current length is: " + (maxnotes+1)
Print "Exporting MIDI is now only supported for 16/32/64"
newlength = iInput ("new length>")
SetBuffer BackBuffer()
If newlength = 0 Then Return
newlength = Abs(newlength) - 1
End If

CopyFrame()

maxnotes = newlength

Dim Pattern(maxchannels, maxnotes)
Dim Vol(maxchannels, maxnotes)
Dim Sel(maxchannels, maxnotes)

;delete
CutFrame(1)

PasteFrame(0, 0, 1)

Dim BUF_Vol(maxchannels, maxnotes)
Dim BUF_Pattern(maxchannels, maxnotes)
Dim BUF_Sel(maxchannels, maxnotes)

vis_maxnotes = 31
vis_maxchannels = 3
If vis_maxnotes > maxnotes Then vis_maxnotes = maxnotes
If vis_maxchannels > maxchannels Then vis_maxchannels = maxchannels

CurX = 0
CurY = 0

End Function

Comments :


Damien Sturdy(Posted 1+ years ago)

 Not a bad bit of code!Great work :)


Panno(Posted 1+ years ago)

 cool


Subirenihil(Posted 1+ years ago)

 nice :)
Print
Go Up Pages1
User actions