' *********************************************** ' * ' * midi functions library for g_lib.dll * ' *********************************************** ' declarations for this module are in g_lib.bi ' declaration for the not exported procs. in g_lib.bas ' work on multiple midi in port by kl 07.2004-16.07.2004 ' hMidiI() and hMidiO() now only in this dll. GMT uses an array dimmed at the same adres. ' consequenty, the array size can no longer change now at runtime. 'metacompile debugger flag for midiplayer functions - writes log files.. with this flag enabled you can play only one file! '%midiplayerdebug = 1 ' adapt. pbwin8.00 gwr 05.03.2005 ' 27.06.2005: M&M automat sysex support added. ' 23.01.2006: minor updates and debug of MM_Midiplayer after last concert ' most problems we had with "wrong" controllers were caused by controllers not shown in the event list by Sonar ' (ctrl 7 and 10, which can be set in the GUI in the track view) ' 30.12.2006: Bako added in player ' 08.10.1007: start adding support for HY1 sensor. gwr. ' 14.10.2007: HY1 support finalized, after 3 days of measurements and math... gwr. ' 16.10.2007: HY1 firmware upgrade. PBWin 8.04 ' 27.10.2007: AXE3 implemention finalized. ' 17.11.2007: PIR2 implementation added. ' 30.12.2007: HANDY1 implementation added. ' 09.08.2007: Bomi added to player ' 20.06.2011: works on playalong callback function for the player to pass current harmony of the midi file to namuda.. to be checked ' 09.01.2012: Fractional midi note play subs added for robots. ' 12.11.2012: QInstrumPlay now also supports the monophonic wind instruments ' 28.02.2016: bug fixes in midifiltering in player - now should give exactly the same result as playing the file in sonar.. ' 25.04.2020: this is not true as yet... ' 02.05.2021: Why is mPlay k,n, 0 behaving differently than Noteoff k, n ??? ' 04.05.2021: upgraded for Roro. %midiplayer_wordy = 1 'metacompilation constant - create huge log files! SUB GetMidiOutPorts (mp() AS STRING) EXPORT ' this procedure returns the names of the midi output ports found in the computer as an array of strings. LOCAL aantalmidiOUTdevices AS LONG LOCAL Caps AS MIDIOUTCAPS LOCAL uSize AS LONG LOCAL n AS LONG aantalmidiOUTdevices = midiOutGetNumDevs () IF aantalmidiOUTdevices <= %False THEN EXIT SUB REDIM mp(aantalmidiOUTdevices-1) AS STRING uSize = SIZEOF (Caps) n = %False DO midiOutGetDevCaps BYVAL n, Caps, uSize mp(n)= Caps.szPName INCR n LOOP UNTIL n = aantalmidiOUTdevices END SUB SUB GetMidiInPorts (mp() AS STRING) EXPORT LOCAL aantalmidiINdevices AS LONG LOCAL Caps AS MIDIINCAPS LOCAL uSize AS LONG LOCAL n AS LONG aantalmidiINdevices = midiInGetNumDevs () IF aantalmidiINdevices <= %False THEN EXIT SUB REDIM mp(aantalmidiINdevices-1) AS STRING uSize = SIZEOF (Caps) n = %False DO midiInGetDevCaps BYVAL n, Caps, uSize mp(n)= Caps.szPName INCR n LOOP UNTIL n = aantalmidiINdevices n = ReadMidiFlagsFromFile (IniFileName) ' InifileName is function in g_indep.dll) ' reads the flags for sysex reception END SUB SUB QuitSysExThread (BYVAL n AS BYTE) EXPORT ' changed 15.01.2002 for multiport use. ' improved 08.06.2002 LOCAL retval AS DWORD 'IF hMidiI(n) THEN IF SxThread.h THEN SxThread.flags = &H0FFFFFFFF ' forces sysex thread to exit, if on. 'retval = midiInUnPrepareHeader (hMidiI(n), MidiSXHdr0, SIZEOF(MidiSXHdr0)) retval = midiInUnPrepareHeader (SxThread.h, MidiSXHdr0, SIZEOF(MidiSXHdr0)) END IF END SUB SUB ReportMidiError (BYVAL ID AS LONG) EXPORT ' used for midi I/O functions LOCAL szTitelbox AS ASCIIZ * 40 LOCAL m AS STRING 'ASCIIZ * 200 szTitelBox = " Midi I/O error:" SELECT CASE ID CASE %MMSYSERR_NOERROR EXIT SUB CASE %MMSYSERR_INVALHANDLE 'The specified device HANDLE is invalid. [unlikely...) m = "Invalid device handle for SysEx" + CHR$(13) CASE %MMSYSERR_INVALPARAM 'The specified address is invalid. [almost impossible] m = "Invalid SYX buffer address" + CHR$(13) m = m + "or, MidiInOpen with invalid pointer or structure" + CHR$(13) CASE %MMSYSERR_NOMEM 'The system is unable TO allocate OR LOCK memory m = "Midi Input device started, but... " + CHR$(13) m = m + "No memory for SysEx receive buffer." + CHR$(13) m = m + "or, unable to allocate memory for midi-input." + CHR$(13) CASE %MMSYSERR_BADDEVICEID m = "MidiOpen with out of range device ID" + CHR$(13) CASE %MMSYSERR_INVALFLAG m = "MidiOpen with invalid flags..." + CHR$(13) END SELECT Warning m, 10000 END SUB SUB InstrumAllNotesOff (BYREF instrument AS musician) EXPORT LOCAL i? LOCAL ShortMessage AS LONG, b? LOCAL h AS DWORD h = Instrument.channel SHIFT RIGHT h,8 ' retrieve portnumber h = hMidiO(h) IF ISFALSE h THEN Warning "Note off command without valid midi handle in " + FUNCNAME$, 10000 EXIT SUB END IF SELECT CASE TRIM$(UCASE$(instrument.naam)) CASE "HARMA" , "HARMO", "SPIRO" , "SO", "FA", "TRUMP", "PIPEROLA", "BOURDONOLA", "SYNCHROCHORD" ModeMess Instrument.channel, &H7B, %False Instrument.Har(1).vel = NUL$(128) EXIT SUB CASE "OB", "KORN", "HELI", "BOMI", "BONO", "AUTOSAX", "RODO", "ASA" Controller Instrument.channel, 123, %False Instrument.Har(1).vel = NUL$(128) EXIT SUB CASE "QT", "QTQ", "BAKO", "KRUM", "TUBO" Controller Instrument.channel, 123, %False Instrument.Har(1).vel = NUL$(128) EXIT SUB END SELECT SELECT CASE LEFT$(UCASE$(instrument.naam),4) CASE "PUFF" NoteOff Instrument.channel, 104 ' orange light NoteOff Instrument.channel, 105 NoteOff Instrument.channel, 54 ' eyes NoteOff Instrument.channel, 53 CASE "TROM" ' added 21.04.2004 NoteOff Instrument.channel, 18 ' bass light NoteOff Instrument.channel, 19 ' tenor drum light NoteOff Instrument.channel, 20 ' snare light NoteOff Instrument.channel, 21 ' damper off ' CASE "SO","SO ", "FA", "FA " ' 'So_AllOff instrument ' Controller Instrument.channel, 123, %False CASE "VIBI","KLUN","SPRI","THUN","DRIP","HURD" , "HUMA", "SNAR", "SYNC" ' hurdy added 12.07.2004 ' humanola added 06.12.2005: implemented on PIC level ' harma 06.12.2005: implemented on PIC level ' harma and harmo cannot be distinguished here! ModeMess Instrument.channel, &H7B, %False ' implemented in their listen tasks 11.02.2002 'CASE "BAKO","KRUM","QT","QTQ " ' ModeMess Instrument.channel, &H7B, %False CASE "PLAY","AUTO","GORG" FOR i? = instrument.lowtes TO instrument.hightes ShortMessage = i? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &H80 OR (instrument.channel AND &H000F) midiOutShortMsg h, ShortMessage instrument.Har(0).vel = NUL$(128) ' for pacing with slow processor board on automats. instrument.Har(1).vel = NUL$(128) NEXT i? CASE "AKE", "AKE " ' should also have ctrl 123 = &H7F - to be checked. FOR i? = instrument.lowtes TO instrument.lowtes + 24 ShortMessage = i? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &H80 OR (instrument.channel AND &H000F) midiOutShortMsg h, ShortMessage NEXT i? FOR i? = 49 TO instrument.hightes ShortMessage = i? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &H80 OR (instrument.channel AND &H000F) midiOutShortMsg h, ShortMessage NEXT i? CASE ELSE FOR i? = instrument.lowtes TO instrument.hightes ShortMessage = i? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &H80 OR (instrument.channel AND &H000F) midiOutShortMsg h, ShortMessage NEXT i? END SELECT Instrument.Dur(0) = timeGetTime - Instrument.Dur(1) Instrument.Dur(1) = timeGetTime Instrument.Har(1).vel = NUL$(128) instrument.Har(0).vel = NUL$(128) END SUB SUB InstrumPlay (BYREF instrument AS musician) EXPORT ' this procedure plays all different notes found in instrument.Har(1).vel (the notes to play/change) ' using instrument.Har(0).vel as comparison base (previous chord/notes). ' When done, it moves the played notes and thus the sounding situation to instrument.Har(0).vel, ' returning a blank instrument.Har(1).vel. ' The procedure also fills the Dur(0), Dur(1) fields . ' Dur(0) will contain the time in ms. that the Har(0) passed on input has been sounding. (absolute duration, not clocktime) ' Dur(1) will contain the clocktime in ms. when Har(1)passed on input was switched on. ' If the Har() string was identical to the previous one, the values will not change, as no output ' has to take place. ' rewritten 11.02.2002 ' bug killed 17.01.2006 - see below for comments ' 2007.03.23 kl adaptation: before the h(0).vel also contained out of range notes that weren't played. now those are omitted LOCAL i AS BYTE LOCAL ib? LOCAL ob? LOCAL flag AS DWORD LOCAL ShortMessage AS LONG LOCAL h AS DWORD LOCAL lh AS harmtype 'here we keep the notes fromh(1).vel that are actually played (in range etc..) h = instrument.channel SHIFT RIGHT h, 8 h = hMidiO(h) IF ISFALSE h THEN EXIT SUB FOR i = Instrument.lowtes + 1 TO Instrument.hightes + 1 ib? = ASC(MID$(Instrument.Har(1).vel, i, 1)) ' new note ob? = ASC(MID$(Instrument.Har(0).vel, i, 1)) ' old note IF ISFALSE ib? THEN IF ob? THEN 'NoteOff ShortMessage = i - 1 SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &H080 OR (instrument.channel AND &H000F) midiOutShortMsg h, ShortMessage BIT SET flag, 0 END IF ELSE IF ob? <> ib? THEN IF ob? THEN 'NoteOff ShortMessage = i - 1 SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &H080 OR (instrument.channel AND &H000F) midiOutShortMsg h, ShortMessage END IF 'NoteOn ShortMessage = ib? SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR (i -1) SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR 144 OR (instrument.channel AND &H000F) midiOutShortMsg h, ShortMessage BIT SET flag, 0 END IF MID$(lh, i, 1) = CHR$(ib) END IF NEXT i IF BIT (flag, 0) THEN Instrument.Dur(0) = timeGetTime - Instrument.Dur(1) 'GetTickCount - Instrument.Dur(1) Instrument.Dur(1) = timeGetTime 'GetTickCount Instrument.Har(0).vel = lh.vel 'Instrument.Har(1).vel changed 2007.03.23 END IF 'the following line is added by kl 20060118 'not resetting har(1).vel caused errors in situations like ' AddNote2Har piano.har(1), 60, 40 2 ' InstrumPlay Piano ' ... ' AddNote2Har piano.har(1), 60, 40 ' ' --> here the user relies on the fact that sending exactly the same velocity won't trigger the note again ' (imagine a situation where some notes should keep sounding and a new note is added) ' but, if har(1).vel wasn't reset and you use addnote2har with a note just played (twice), the velocities is summed with the old velocity!! 'we found this bug while trying to find out why we had sticking notes, and this did solve the sticking notes, but we don't see how.. Instrument.Har(1).vel = NUL$(128) END SUB FUNCTION Sire_Play (BYVAL noot AS SINGLE, BYVAL velo AS BYTE, OPT BYVAL nr AS DWORD, OPT BYVAL MODE AS LONG) EXPORT AS LONG 'sire player met pitch mapping 'als nr ingevuld is wordt deze sirene gebruikt 'anders wordt de volgende vrije gekozen - merk op dat deze modus niet echt bruikbaar is, 'aangezien een sirene vanuit stilstand meer dan 1" nodig heeft om op toon te komen. voor een legato melodie blijf je dus beter op dezelfde sirene 'merk op: in de huidige implementatie is de enige functie van velo hier AAN/AF! 'BIT 0 in mode: 0 = break off, 1 = break on ' te doen: ' automatische beveiliging tegen teveel hoog draaiende sirenes binnen 1 module. ' velo info gebruiken voor proportioneel inschakelen van meerdere sirenes bij lage noten. ' kl: of alleen al om de volumes wat gelijk te krijgen, noot 84 is heel luid, 80 al een heel stuk stiller, 60 is zo goed als niets meer ' nog een groter probleem: bij lage tonen duurt het meer dan een seconde voor de sirene uit stilstand op toon is.. ' antwoord gwr: we kunnen velo gebruiken om het aantal sirenes dat we wensen te kiezen. 'kl: kunnen we het verdubbelen dan niet beter vanuit de midi file doen? ' een track kopieren en de hoge noten eruit gooien lijkt me makkelijker dan de velocities individueel aanpassen.. DIM Sirens(23) AS STATIC LONG DIM current(2) AS STATIC SINGLE ' current monitoring LOCAL i AS DWORD LOCAL cnt AS LONG STATIC j AS DWORD STATIC HighNotes AS DWORD 'for protection against too much simultaneous high notes LOCAL nv AS WORD LOCAL doubling AS DWORD IF ISFALSE sire.channel THEN 'instruments are not initialized automatically here GetinstrumentPArams Sire, %IDM_SIRE SetRobotPort Sire, "", hMidiO() END IF 'beveiliging tegen teveel simultane hoge noten: 'kl: wat is de precieze limit? IF noot > 76 THEN IF velo > 1 THEN INCR HighNotes IF HighNotes > 10 THEN Warning "Too many high notes on Sire - note skipped!" EXIT FUNCTION END IF ELSE DECR HighNotes END IF END IF IF ISFALSE velo THEN IF nr THEN mPLAY Sire.channel, Sire.lowtes-1 + nr, ((NOT MODE) AND &b01) '%False Sirens(nr - 1) = %False FUNCTION = %True ELSE ' zoek de sirene die de noot speelt en schakel haar uit: nv = Sire_MidiNoot2Velo (noot) i = 0 DO IF Sirens(i) = noot THEN 'nv THEN mPLAY Sire.channel, Sire.lowtes + i, ((NOT MODE) AND &b01) '%False ' met breaking function Sirens(i) = %False FUNCTION = %True END IF INCR i LOOP UNTIL i > 23 END IF EXIT FUNCTION END IF i = %False nv = Sire_MidiNoot2Velo (noot, Sire.LowTes + nr) SELECT CASE nr CASE %False '050428: kl: EXPERIMENT: doubling of low notes: up to 8 sirens for lowest notes ' quick and dirty formula based on what we hear - we should be able to come up with something better based on measured data.. doubling = MIN(8, MAX(1, 8 - ( (noot - 48) / 4 ))) DO IF ISFALSE Sirens(j) THEN mPlay Sire.channel,Sire.lowtes + j, HIBYT(nv) Controller Sire.channel, Sire.lowtes + j, LOBYT(nv) Sirens(j) = noot 'nv FUNCTION = %True 'question: should we return %true as soon as we can play it on one siren,or only if we can double it the way we wich 'alternative: return the nr of doublings DECR doubling IF ISFALSE doubling THEN EXIT FUNCTION 'loop END IF INCR j IF j > 23 THEN j = 0 INCR i LOOP UNTIL i > 23 CASE 1 TO 24 ' warning "sire noot:" + str$(hibyt(nv)) mPlay Sire.channel, Sire.lowtes - 1 + nr, HIBYT(nv) Controller Sire.channel, Sire.lowtes -1 + nr, LOBYT(nv) Sirens(nr -1) = noot 'nv FUNCTION = %True END SELECT END FUNCTION FUNCTION Sire_Velo2MidiNoot (BYVAL velo AS INTEGER, OPT BYVAL sirennr AS BYTE) EXPORT AS SINGLE LOCAL frq AS SINGLE ' transfer function calculated with Gausfit. gwr.20.04.2005 'if no sirennr is given the old, general approximation is used 'if sirennr is given, a more precise, siren-specific result is returned ' IF velo < 6 THEN FUNCTION = %False : EXIT FUNCTION velo = MIN(velo,127) SELECT CASE sirennr CASE 0 ' eerste versie met 5 meetpunten, via Gausfit: 'FUNCTION = 41.12872 + (1.560877 * velo) - (1.880568E-02 * (velo^2!)) + (7.231988E-05 * (velo^3!)) ' 3e graads vergelijking op grond van 15 meetpunten: [29.04.2005] FUNCTION = 44.44099 + (1.31992 * velo) - (1.604728E-02 * (velo^2!)) + (6.405674E-05 * (velo^3!)) EXIT FUNCTION CASE 48: frq = 1.128746E-3 * velo ^ 3 +-.2726631 * velo ^ 2 + 25.32561 * velo + -20.90851 CASE 49: frq = 1.096185E-3 * velo ^ 3 +-.2703165 * velo ^ 2 + 25.51878 * velo + -84.64728 CASE 50: frq = 1.438367E-3 * velo ^ 3 +-.340337 * velo ^ 2 + 29.53804 * velo + -87.40405 CASE 51: frq = 8.046628E-4 * velo ^ 3 +-.2112235 * velo ^ 2 + 21.95724 * velo + -1.812073 CASE 52: frq = 8.018589E-4 * velo ^ 3 +-.2106524 * velo ^ 2 + 22.11712 * velo + -4.770996 CASE 53: frq = 1.035053E-3 * velo ^ 3 +-.2603055 * velo ^ 2 + 25.0695 * velo + -53.22162 CASE 54: frq = 1.368806E-3 * velo ^ 3 +-.3207721 * velo ^ 2 + 27.59199 * velo + -37.08344 CASE 55: frq = 1.106716E-3 * velo ^ 3 +-.2749459 * velo ^ 2 + 25.68056 * velo + -39.4024 CASE 56: frq = 1.194353E-3 * velo ^ 3 +-.2882408 * velo ^ 2 + 26.11708 * velo + -34.86035 CASE 57: frq = 1.583504E-3 * velo ^ 3 +-.3336676 * velo ^ 2 + 27.16224 * velo + -55.146 CASE 58: frq = 1.137692E-3 * velo ^ 3 +-.2858365 * velo ^ 2 + 26.43642 * velo + -48.70654 CASE 59: frq = 1.198863E-3 * velo ^ 3 +-.2930566 * velo ^ 2 + 25.26101 * velo + 44.15656 CASE 60: frq = 1.238183E-3 * velo ^ 3 +-.3013299 * velo ^ 2 + 25.70898 * velo + 39.95502 CASE 61: frq = 8.913073E-4 * velo ^ 3 +-.2353962 * velo ^ 2 + 23.44074 * velo + -17.97858 CASE 62: frq = 9.522797E-4 * velo ^ 3 +-.2457782 * velo ^ 2 + 23.97548 * velo + -14.65326 CASE 63: frq = 9.436719E-4 * velo ^ 3 +-.245761 * velo ^ 2 + 24.10331 * velo + -27.96692 CASE 64: frq = 1.344162E-3 * velo ^ 3 +-.3371081 * velo ^ 2 + 30.0036 * velo + -131.4896 CASE 65: frq = 9.663361E-4 * velo ^ 3 +-.2542917 * velo ^ 2 + 24.96048 * velo + -52.94025 CASE 66: frq = 4.022287E-4 * velo ^ 3 +-.1251819 * velo ^ 2 + 16.31614 * velo + 130.0679 CASE 67: frq = 8.20812E-4 * velo ^ 3 +-.2230131 * velo ^ 2 + 23.1468 * velo + -40.78522 CASE 68: frq = 1.001001E-3 * velo ^ 3 +-.2560369 * velo ^ 2 + 24.42712 * velo + -12.69305 CASE 69: frq = 8.405571E-4 * velo ^ 3 +-.223105 * velo ^ 2 + 22.49756 * velo + 7.531738 CASE 70: frq = 9.016883E-4 * velo ^ 3 +-.2360961 * velo ^ 2 + 23.28981 * velo + -14.08301 CASE 71: frq = 1.317252E-3 * velo ^ 3 +-.3120989 * velo ^ 2 + 27.19199 * velo + -57.34601 END SELECT FUNCTION = f2nf(frq) END FUNCTION FUNCTION Sire_MidiNoot2Velo (BYVAL noot AS SINGLE, OPT BYVAL sirennr AS BYTE) EXPORT AS WORD ' will return the 7-bit velo value to send in HIBYT(velo) and the 7-bit LSB in LOBYT(velo) 'if noot > 84 then exit function 'if no sirennr is given, the old general approximation is used 'if sirennr is given, a more precise, siren-specific result is returned LOCAL velo AS SINGLE LOCAL retval AS WORD LOCAL f AS SINGLE LOCAL lsb AS WORD LOCAL frq AS SINGLE STATIC init AS DWORD STATIC nv() AS DWORD STATIC n AS DWORD LOCAL i AS LONG, j AS LONG IF noot < 60 THEN FUNCTION = %False :EXIT FUNCTION IF noot > 84 THEN FUNCTION = %False: EXIT FUNCTION sirennr = sirennr - sire.lowtes IF sirennr > 23 THEN warning "invalid siren nr:" + STR$(Sirennr + sire.lowtes) + " @ " + FUNCNAME$ EXIT FUNCTION END IF IF ISFALSE sirennr THEN ' eerste opmeting met 4 meetpunten: ' velo = -1170.342 + (61.77662 * noot) - (1.077227 * (noot ^2)) + (6.265741E-03 * (noot^3)) ' 3e graads vergelijking op grond van 15 meetpunten: [29.04.2005] velo = -1678.095 + (85.66193 * noot) - (1.443499 * (noot ^2)) + (8.094788E-03 * (noot^3)) retval = FIX(velo) ' must have a bug... f = FRAC(velo) * 128 ' now 0-127 SHIFT LEFT retval, 8 lsb = FIX(f) FUNCTION = retval OR lsb EXIT FUNCTION END IF 'new computation 2009: now we have a lot of sample points and linear interpolation between them.. IF ISFALSE init THEN DIM nv(23, 60 TO 84) FOR i = 0 TO 23 FOR j = 60 TO 84 INCR n nv(i, j) = VAL(READ$(n)) ' logfile "read" + STR$(i) + STR$(j) + STR$(nv(i,j)) NEXT NEXT init = 1 END IF IF noot = 84 THEN FUNCTION = nv(sirennr, 84): EXIT FUNCTION ' logfile FUNCNAME$ + STR$(noot) + STR$(sirennr) + STR$(INT(nv(sirennr, INT(noot)) * (1-FRAC(noot)) + nv(sirennr, INT(noot) + 1) * FRAC(noot))) FUNCTION = INT(nv(sirennr, INT(noot)) * (1-FRAC(noot)) + nv(sirennr, INT(noot) + 1) * FRAC(noot)) 'this is the old code from 2004' it appeared that the pitches of the siren are not stable over a long time, so now we automated the measuring process and we use a table lookup in stead #IF %DEF(%sire_old_code) frq = NF2F(noot) SELECT CASE sirennr CASE 48: velo = 1.338627E-7 * frq ^ 3 +-7.763604E-5 * frq ^ 2 + 6.021343E-2 * frq + .2900238 CASE 49: velo =-2.503275E-8 * frq ^ 3 + 2.013901E-4 * frq ^ 2 +-7.456291E-2 * frq + 22.80358 CASE 50: velo = 1.916251E-7 * frq ^ 3 +-1.672173E-4 * frq ^ 2 + 9.699092E-2 * frq + -3.297226 CASE 51: velo = 1.095482E-7 * frq ^ 3 +-3.40558E-5 * frq ^ 2 + 4.725789E-2 * frq + 1.978928 CASE 52: velo = 1.266446E-7 * frq ^ 3 +-7.175756E-5 * frq ^ 2 + .0676482 * frq + -1.12709 CASE 53: velo = 1.082624E-7 * frq ^ 3 +-2.778984E-5 * frq ^ 2 + 3.692396E-2 * frq + 5.2938 CASE 54: velo = 1.253145E-7 * frq ^ 3 +-4.284218E-5 * frq ^ 2 + 3.283006E-2 * frq + 5.117798 CASE 55: velo = 1.495847E-7 * frq ^ 3 +-9.094972E-5 * frq ^ 2 + 6.344934E-2 * frq + .8565063 CASE 56: velo = 1.198522E-7 * frq ^ 3 +-4.091515E-5 * frq ^ 2 + 3.759064E-2 * frq + 4.349892 CASE 57: velo = 1.455441E-7 * frq ^ 3 +-6.487829E-5 * frq ^ 2 + 5.090202E-2 * frq + 2.513779 CASE 58: velo = 1.944539E-7 * frq ^ 3 +-1.5768E-4 * frq ^ 2 + 9.250464E-2 * frq + -2.983765 CASE 59: velo = 2.276979E-7 * frq ^ 3 +-1.805052E-4 * frq ^ 2 + 9.079982E-2 * frq + -5.320236 CASE 60: velo = 2.339494E-7 * frq ^ 3 +-1.89529E-4 * frq ^ 2 + 9.391801E-2 * frq + -5.60289 CASE 61: velo = 1.590462E-7 * frq ^ 3 +-9.56368E-5 * frq ^ 2 + 6.791692E-2 * frq + -5.769348E-2 CASE 62: velo = 1.720991E-7 * frq ^ 3 +-1.246866E-4 * frq ^ 2 + 8.241827E-2 * frq + -2.651459 CASE 63: velo = 1.551002E-7 * frq ^ 3 +-9.161852E-5 * frq ^ 2 + 6.500762E-2 * frq + .6826019 CASE 64: velo = 1.601635E-7 * frq ^ 3 +-8.003559E-5 * frq ^ 2 + .0426185 * frq + 7.838226 CASE 65: velo = 1.799911E-7 * frq ^ 3 +-1.322584E-4 * frq ^ 2 + .0837289 * frq + -1.133286 CASE 66: velo = 2.064074E-7 * frq ^ 3 +-2.083409E-4 * frq ^ 2 + .1477906 * frq + -19.70808 CASE 67: velo = 1.392443E-7 * frq ^ 3 +-6.570487E-5 * frq ^ 2 + .0556488 * frq + 2.694473 CASE 68: velo = 1.681701E-7 * frq ^ 3 +-1.09184E-4 * frq ^ 2 + 7.021956E-2 * frq + -.9130859 CASE 69: velo = 1.594407E-7 * frq ^ 3 +-9.509333E-5 * frq ^ 2 + 6.807113E-2 * frq + -1.185654 CASE 70: velo = 9.535194E-8 * frq ^ 3 + 2.139811E-5 * frq ^ 2 + 6.071553E-3 * frq + 9.002342 CASE 71: velo =-7.312811E-8 * frq ^ 3 + 3.166891E-4 * frq ^ 2 +-.1538038 * frq + 33.81197 CASE ELSE: Warning "invalid siren nr in" + FUNCNAME$ + ":"+STR$(sirennr) END SELECT ' msgbox str$(f) +" - " + str$(fv) retval = FIX(velo) lsb = FIX(FRAC(velo) * 128) SHIFT LEFT retval, 8 FUNCTION = retval OR lsb #ENDIF 'the following is based on incomplete data.. priority now is to get Phill's piece ready, afterwards we can fill in the rest.. DATA 0, 0, 0, 0, 0, 0, 0, 0, 2919, 3102, 3314, 3616, 4011, 4195, 4645, 5205, 5905, 6605, 7500, 8610, 9900, 11410, 13195, 15325, 0 DATA 0, 3610, 3790, 4027, 4265, 4450, 5650, 0, 0, 5765, 6805, 7170, 7600, 8240, 8875, 9895, 10745, 11860, 12710, 14640, 16295, 0, 0, 0, 0 DATA 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3855, 4050, 4320, 4570, 4945, 5477, 6010, 6720, 7617, 8515, 9805, 11345, 13140, 15255, 0 DATA 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3970, 4220, 4550, 4802, 5212, 5795, 6405, 7180, 8135, 9090, 10520, 11950, 13755, 0, 0 DATA 0, 0, 0, 0, 0, 2572, 2732, 2982, 3192, 3402, 3672, 4140, 4513, 4886, 5260, 5785, 6420, 7125, 7950, 8995, 10275, 11820, 13445, 0, 0 DATA 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3669, 3974, 4451, 5163, 5586, 5976, 6783, 7515, 8485, 9525, 10725, 12180, 13865, 0, 0 DATA 0, 1802, 1902, 2072, 2182, 2329, 2477, 2669, 2862, 3067, 3312, 3484, 4020, 4285, 4745, 5245, 5745, 6455, 7380, 8305, 9510, 11015, 0, 0, 0 DATA 1842, 1937, 2037, 2147, 2282, 2455, 2627, 2802, 2992, 3227, 3492, 3844, 4197, 4657, 5010, 5410, 6150, 6890, 7765, 8725, 9955, 11580, 13970, 0, 0 DATA 1867, 1982, 2097, 2207, 2322, 2442, 2599, 2757, 2947, 3172, 3487, 3697, 4122, 4480, 4885, 5395, 6140, 6885, 7780, 8940, 10370, 11800, 13520, 0, 0 DATA 0, 1932, 2122, 3418, 2357, 2507, 2692, 2902, 4813, 3362, 3647, 4170, 4590, 5010, 5430, 6025, 6635, 7525, 8415, 9610, 10915, 12600, 14320, 0, 0 DATA 0, 2022, 2112, 2197, 2312, 2437, 2604, 2772, 2982, 3237, 3472, 3707, 3982, 4477, 4915, 5410, 6015, 6810, 7747, 8685, 9990, 11735, 13740, 0, 0 DATA 0, 0, 0, 0, 0, 0, 1852, 1972, 2142, 2302, 2457, 2692, 3007, 3342, 3732, 4160, 4695, 5390, 6210, 7295, 8625, 10245, 12325, 0, 0 DATA 0, 0, 0, 0, 0, 0, 1852, 1992, 2127, 2382, 2515, 2727, 2987, 3382, 3777, 4210, 4755, 5440, 6420, 7400, 8745, 10507, 12270, 0, 0 DATA 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4355, 4700, 5190, 5610, 6290, 6950, 7685, 8540, 9545, 10820, 12305, 0, 0, 0 DATA 1847, 1990, 2067, 2137, 2257, 2437, 2642, 2827, 3027, 3304, 3582, 3907, 4355, 4725, 5125, 5680, 6450, 7175, 7970, 9145, 10615, 12280, 14345, 0, 0 DATA 1862, 1959, 2057, 2157, 2257, 2347, 2517, 2722, 2922, 3127, 3372, 3930, 4105, 4390, 4867, 5345, 5960, 6705, 7615, 8775, 10045, 11680, 13580, 0, 0 DATA 1927, 2057, 2157, 2262, 64, 2572, 2757, 2967, 3177, 3402, 3732, 4027, 4455, 4900, 5325, 5895, 6585, 7290, 8140, 9160, 10465, 12105, 14085, 0, 0 DATA 2097, 2197, 2297, 2397, 2537, 2667, 2822, 3029, 3237, 3905, 4160, 4355, 4625, 5071, 5517, 5965, 6665, 7500, 8335, 9375, 10775, 12655, 13920, 0, 0 DATA 0, 2227, 2412, 2527, 2687, 2777, 2937, 3097, 3317, 3667, 3659, 4295, 4620, 4940, 5280, 5775, 6405, 7120, 8005, 9150, 10350, 12015, 13760, 0, 0 DATA 2042, 2137, 2232, 2327, 2447, 2607, 2767, 2992, 3162, 3462, 3975, 4260, 4595, 4980, 5470, 6025, 6645, 7440, 8305, 9505, 11010, 12815, 14990, 0, 0 DATA 0, 0, 2027, 2137, 2227, 2342, 2472, 2602, 2792, 3007, 3232, 3507, 4040, 4370, 4825, 5290, 6015, 6730, 7545, 8585, 9855, 11500, 13400, 0, 0 DATA 1907, 2032, 2144, 2256, 2367, 2487, 2697, 2857, 3047, 3277, 3572, 3912, 4362, 4837, 5347, 5957, 6642, 7527, 8427, 9582, 10997, 12837, 15237, 0, 0 DATA 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 DATA 0, 2112, 2227, 2317, 2447, 2602, 2732, 2907, 3072, 3307, 3577, 3842, 4187, 4542, 5082, 5592, 6252, 7007, 7887, 9002, 10337, 0, 0, 0, 0 END FUNCTION FUNCTION PlayLlor (BYVAL n AS SINGLE, BYVAL v AS DWORD, BYVAL dev AS SINGLE, OPT BYVAL silent AS LONG) EXPORT AS DWORD ' returns the midi note command for Llor if the note could be played, if not, returns False ' dev is the amount of allowable deviation in cents. ' we have a similar function for Vacca since 17.07.2005 'debugged kl 20050914: added + 35 and + 47 in the play instruction and for belly and vitello since 10.08.2006 (Residing in g_mm.inc) LOCAL i AS DWORD LOCAL j AS DWORD LOCAL note1 AS INTEGER LOCAL dif AS SINGLE LOCAL mindif AS SINGLE STATIC tog AS DWORD STATIC LlorSpec() AS LlorSpectype IF ISFALSE Llor.channel THEN 'we're not sure here whether llor has been initialised allready.. GetInstrumentParams Llor, %IDM_LLOR SetRobotPort Llor, "", hMidiO() END IF IF ISFALSE tog THEN DIM LlorSpec(12) AS STATIC Llorspectype FOR i = 1 TO 12 LlorSpec(i).midi = 35 + i LlorSpec(i).splitpoint = 30 ' mag nooit nul zijn, noch 127 ! NEXT i ' data for the 12 bells: LlorSpec(1).Spek(0) = 64.43 LlorSpec(1).Spek(1) = 54.19 LlorSpec(1).Spek(2) = 70.97 LlorSpec(1).Spek(3) = 75.81 LlorSpec(1).Spek(4) = 79.78 LlorSpec(2).Spek(0) = 53.72 LlorSpec(2).Spek(1) = 70.61 LlorSpec(2).Spek(2) = 63.65 LlorSpec(2).Spek(3) = 75.99 LlorSpec(2).Spek(4) = 36.42 LlorSpec(3).Spek(0) = 59.96 LlorSpec(3).Spek(1) = 70.29 LlorSpec(3).Spek(2) = 41.33 LlorSpec(3).Spek(3) = 60.02 LlorSpec(3).Spek(4) = 60.16 LlorSpec(4).Spek(0) = 64.99 LlorSpec(4).Spek(1) = 65.09 LlorSpec(4).Spek(2) = 47.76 LlorSpec(4).Spek(3) = 80.62 LlorSpec(4).Spek(4) = 74.60 LlorSpec(5).Spek(0) = 44.68 ' 40 LlorSpec(5).Spek(1) = 72.25 LlorSpec(5).Spek(2) = 78.76 LlorSpec(5).Spek(3) = 74.40 LlorSpec(5).Spek(4) = 0 LlorSpec(6).Spek(0) = 68.80 ' 41 LlorSpec(6).Spek(1) = 51.91 LlorSpec(6).Spek(2) = 79.02 LlorSpec(6).Spek(3) = 0 LlorSpec(6).Spek(4) = 0 LlorSpec(7).Spek(0) = 52.84 ' 42 LlorSpec(7).Spek(1) = 70.40 LlorSpec(7).Spek(2) = 75.83 LlorSpec(7).Spek(3) = 64.79 LlorSpec(7).Spek(4) = 0 LlorSpec(8).Spek(0) = 58.22 ' 43 LlorSpec(8).Spek(1) = 76.31 LlorSpec(8).Spek(2) = 0 LlorSpec(8).Spek(3) = 0 LlorSpec(8).Spek(4) = 0 LlorSpec(9).Spek(0) = 64.02 ' 44 LlorSpec(9).Spek(1) = 82.01 LlorSpec(9).Spek(2) = 48.93 LlorSpec(9).Spek(3) = 68.24 LlorSpec(9).Spek(4) = 92.59 LlorSpec(10).Spek(0) = 70.07 ' 45 LlorSpec(10).Spek(1) = 87.85 LlorSpec(10).Spek(2) = 0 LlorSpec(10).Spek(3) = 0 LlorSpec(10).Spek(4) = 0 LlorSpec(11).Spek(0) = 72.86 ' 46 LlorSpec(11).Spek(1) = 79.02 LlorSpec(11).Spek(2) = 0 LlorSpec(11).Spek(3) = 0 LlorSpec(11).Spek(4) = 0 LlorSpec(12).Spek(0) = 79.11 ' 47 LlorSpec(12).Spek(1) = 0 LlorSpec(12).Spek(2) = 0 LlorSpec(12).Spek(3) = 0 LlorSpec(12).Spek(4) = 0 tog = %True END IF dev = dev /100! ' make dev. fractional ' first we scan for the best match, we scan the strongest spectral components of each bell: i = 1 mindif= 10000.0 DO j = 0 DO dif = ABS(n-LlorSpec(i).Spek(j)) IF dif < mindif THEN mindif = dif : note1 = i INCR j LOOP UNTIL j > 4 INCR i LOOP UNTIL i > 12 ' check this against the tollerance: IF mindif =< dev THEN IF (v>0) AND (v < LlorSpec(note1).Splitpoint) THEN IF ISFALSE silent THEN mPlay Llor.channel, note1 + 47, v * (127.0/ LlorSpec(note1).Splitpoint) FUNCTION = note1 + 47 ELSE IF ISFALSE silent THEN mPlay Llor.channel, note1 + 35, v ' also needs rescaling. FUNCTION = note1 + 35 END IF ELSE FUNCTION = %False END IF END FUNCTION 'SUB MiRobotPlay (BYREF Robot AS musician) EXPORT ' ' 05.06.2011: This procedure is now obsolete and can be removed from the library. ' ' 29.06.2003 ' ' uses non-standard midi, in combination with our special purpose hardware [UART-2003]. ' ' We need Robot.channel ' ' We will need a select case structure here to implement the different midi-controlled robots ' ' we might build. ' STATIC tog AS DWORD ' we need a tog for each robot... ' STATIC ShortMessage AS DWORD ' STATIC h AS DWORD ' LOCAL i AS DWORD ' LOCAL j AS DWORD ' LOCAL ib AS BYTE ' LOCAL vb AS BYTE ' velobyte - used as databus ' LOCAL nb AS BYTE ' notebyte - used as adresbus ' STATIC sb AS BYTE ' status byte ' DIM latch(15) AS LOCAL BYTE ' LOCAL p AS DWORD ' STATIC wind AS BYTE ' only for , stores oldvalue of So.ctrl(1) ' ' IF ISFALSE tog THEN ' DIM olatch(15) AS STATIC BYTE ' previous contents of the latches ' h = robot.channel ' SHIFT RIGHT h, 8 ' h = hMidiO(h) ' IF ISFALSE h THEN EXIT SUB ' no midi handle, so we cannot proceed. ' sb = 144 OR (robot.channel AND &H000F) ' set with the dip-switches on the hardware. (UART board) ' tog = %True ' END IF ' ' SELECT CASE LCASE$(TRIM$(robot.naam)) '' CASE "so" '' ' this code allows multiphonics to be played. '' ' settings for valves are to be passed by the user in the Har(1).vel string '' p = 1 '' ' note: we could use the lowest latch to send a pincode to the hardware. '' latch(7) = %False ' power DAC latch '' FOR i = 1 TO 5 '7 ' we limit this to the actual range used. '' ' has only 8 latches '' ' only the lower 5 bytes (latches 1 to 5) are used for notes. '' ' latch 6 is used for the foot, latch 7 steers the power DAC and '' ' latch 8 the valves in the three lowest bits. '' ' i=8 (latch 8) points to the valve positions corresponding to the '' ' highest note to be played according to the har-string passed. '' FOR j = 0 TO 7 ' bit counter for each latch '' ib = ASC(MID$(Robot.Har(1).vel, p, 1)) ' new harmony string ` '' IF ib > %False THEN '' latch(7) = MAX(latch(7),ib) ' volume for DAC steered by latch 7 '' ' note that we use only 7 bits here, although '' ' we can use 8 bits. '' BIT SET latch(i), j ' this sends the correct frequency to the power-AND '' ' here we do not to set the required pattern for the valves in bits latch(8),0 ,latch(8),1, latch(8),2 '' ' latch(8) = Sot(p-1).ventiel ' is incompatible with polyphonic notes... '' ' requested volume is in ib now. '' ELSE '' BIT RESET latch(i), j '' END IF '' INCR p ' counts 1 - 128 '' NEXT j '' '' ' translate to our non-standard midi format: '' IF latch(i) <> olatch(i) THEN '' nb = i ' uses the lowest 4 bits (0,1,2,3) '' ' for the higher registers we have to use bits 4 and 5. '' ' bit 6 is used as 8th bit for the databus. [cfr hardware DEMUX board] '' vb = latch(i) '' IF BIT (vb,7) THEN '' BIT RESET vb,7 ' so we stick to the required 7-bit length in midi. '' BIT SET nb, 6 ' we pack the 8th bit in the highest possible bit of the second byte '' ' the decoding and reassembling is done in the hardware of our boards. '' ELSE '' BIT RESET nb, 6 '' END IF '' ' now we have a new byte available, so we can send it (max. 8 notes at the same time!) '' ' note that the midi-drivers expects the bits as lsb - msb - status, so 24 bits, big endian. '' ShortMessage = vb '' SHIFT LEFT ShortMessage ,8 '' ShortMessage = ShortMessage OR nb '' SHIFT LEFT ShortMessage , 8 '' ShortMessage = %MEVT_F_SHORT OR ShortMessage OR sb '' midiOutShortMsg h, ShortMessage '' olatch(i) = latch(i) '' ELSE '' ' niks. '' END IF '' NEXT i '' ' all note latches are set and output now. '' '' ' and now send the foot command: '' ' connected to note 48 '' IF IsNoteInHar (Robot.Har(1), 48) THEN BIT SET latch(6),0 ELSE BIT RESET latch(6),0 '' IF latch(6) <> olatch(6) THEN '' ShortMessage = latch(6) '' SHIFT LEFT ShortMessage, 8 '' ShortMessage = Shortmessage OR 6 '' SHIFT LEFT ShortMessage, 8 '' ShortMessage = %MEVT_F_SHORT OR ShortMessage OR sb '' midiOutShortMsg h, ShortMessage '' olatch(6) = latch(6) '' END IF '' '' ' set the bits for the valves '' IF IsNoteInHar (Robot.Har(1), 64) THEN BIT SET latch(8),0 ELSE BIT RESET latch(8),0 '' IF IsNoteInHar (Robot.Har(1), 65) THEN BIT SET latch(8),1 ELSE BIT RESET latch(8),1 '' IF IsNoteInHar (Robot.Har(1), 66) THEN BIT SET latch(8),2 ELSE BIT RESET latch(8),2 '' IF latch(8) <> olatch(8) THEN '' ' for the pistons alone, no bit swapping required since we use only the 3 lowest bits here '' ShortMessage = latch(8) '' SHIFT LEFT ShortMessage, 8 '' ShortMessage = Shortmessage OR 8 '' SHIFT LEFT ShortMessage, 8 '' ShortMessage = %MEVT_F_SHORT OR ShortMessage OR sb '' midiOutShortMsg h, ShortMessage '' olatch(8) = latch(8) '' END IF '' '' ' to finish, we add the commands for wind pressure and driver amplitude as well... '' IF latch(7) <> olatch(7) THEN '' ' this latch holds the volume for the moving coil driver '' nb = 7 '' vb = latch(7) 'here we can also use all 8 bits... '' IF BIT (vb,7) THEN '' BIT RESET vb, 7 '' BIT SET nb, 6 '' ELSE '' BIT RESET nb, 6 '' END IF '' ShortMessage = vb '' SHIFT LEFT ShortMessage, 8 '' ShortMessage = Shortmessage OR nb '' SHIFT LEFT ShortMessage, 8 '' ShortMessage = %MEVT_F_SHORT OR ShortMessage OR sb '' midiOutShortMsg h, ShortMessage '' olatch(7) = latch(7) '' END IF '' '' ' if we need a strobe to trigger the 74154's on the board, we send: '' '' ' shortmessage = 6 'nb 'bits 0,1,2,3 adress the 74154 outputs '' ' 'bits 4,5 select the 75154 '' ' ' to strobe, we adres a dummy to the second 74154 : '' ' BIT SET shortmessage, 4 '' ' SHIFT LEFT ShortMessage, 8 '' ' ShortMessage = %MEVT_F_SHORT OR ShortMessage OR sb '' ' midiOutShortMsg h, ShortMessage '' '' '' Robot.Har(0).vel = Robot.Har(1).vel '' Robot.Har(1).vel = NUL$(128) '' '' ' last but not least, we send the wind controller: '' IF Robot.Ctrl(1) <> wind THEN '' wind = Robot.ctrl(1) '' AfterTouch Robot.channel, wind '' END IF ' CASE ELSE ' ' generic polyphonic code ' MSGBOX "Not implemented yet!",, FUNCNAME$ ' p = 1 ' FOR i = 0 TO 15 ' we can limit this to the actual range used. ' FOR j = 0 TO 7 ' ib = ASC(MID$(Robot.Har(1).vel, p, 1)) ' new harmony string ' IF ib THEN ' BIT SET latch(i), j ' ELSE ' BIT RESET latch(i), j ' END IF ' INCR p ' counts 1 - 128 ' NEXT j ' IF latch(i) <> olatch(i) THEN ' nb = i ' uses the lowest 4 bits (0,1,2,3) ' ' for the higher registers we have to use bits 4 and 5. ' ' bit 6 is used as 8th bit for the databus. ' vb = latch(i) ' IF BIT (vb,7) THEN ' BIT RESET vb,7 ' so we stick to the required 7-bit length in midi. ' BIT SET nb, 6 ' we pack the 8th bit in the highest possible bit of the second byte ' ' the decoding and reassembling is done in the hardware of our boards. ' ELSE ' BIT RESET nb, 6 ' END IF ' ' now we have a new byte available, so we can send it (max. 8 notes at the same time!) ' ' note that the midi-drivers expects the bits as lsb - msb - status, so 24 bits, big endian. ' ShortMessage = vb ' SHIFT LEFT ShortMessage ,8 ' ShortMessage = ShortMessage OR nb ' SHIFT LEFT ShortMessage , 8 ' ShortMessage = %MEVT_F_SHORT OR ShortMessage OR sb ' midiOutShortMsg h, ShortMessage ' olatch(i) = latch(i) ' ELSE ' ' niks. ' END IF ' NEXT i ' Robot.Har(0).vel = Robot.Har(1).vel ' Robot.Har(1).vel = NUL$(128) ' END SELECT 'END SUB SUB StartSysExThread (BYREF SxThread AS GMT_SYSEX_THREAD) EXPORT ' this works fine, but it may cause increased jitter in GMT. STATIC tog AS DWORD 'SxThread AS GMT_SYSEX_THREAD is a global in G_LIB.dll. 23.10.1999/13.12.99 STATIC pTid AS LONG LOCAL retval AS LONG IF ISFALSE tog THEN IF SxThread.h THEN ' IF ISFALSE SxThread.h THEN SxThread.h = hMidiI(0)' midi input handle - should be set in OpenMidiIn SxThread.cnt = %False ' BIT SET SxThread.flags, %SYSEX_TO_FILE ' done by reading flags from ini-file. ' BIT SET SxThread.flags, %SYSEX_TO_SXB ' idem. REDIM SxB(0) AS GLOBAL STRING * %SysExBuffer ' to receive the sysex strings. pTid = VARPTR(SxThread) THREAD CREATE SxIn(pTid) TO SxThread.id ' SxThread.id contains the thread handle on return. IF SxThread.id THEN tog = %True SetThreadPriority SxThread.id, %THREAD_PRIORITY_BELOW_NORMAL 'THREAD SUSPEND SxThread.id TO retval ELSE Warning "Cannot create midi sysex thread in " + FUNCNAME$, 10000 END IF ELSE Warning "Cannot start midi sysex receiver without midi handle in " + FUNCNAME$, 10000 EXIT SUB END IF END IF END SUB THREAD FUNCTION SxIn (BYVAL x AS LONG) AS LONG ' no export! ' thread function for midi sysex reception. ' We use x to pass a pointer (BYVAL!!!) to a thread specific data structure, defined as GMT_SYSEX_THREAD ' This pointer serves at the same time as unique ID for the thread. ' Under no circomstances users should call this function directly! It will create an endless loop. Only reset will ' help you out then. ' The only way of calling the procedure is with CREATE THREAD SxIn (VARPTR(SxThread)) TO SxThread.id STATIC fnr AS LONG STATIC tog AS DWORD STATIC COUNT AS DWORD LOCAL gt AS GMT_SYSEX_THREAD PTR LOCAL SX AS STRING LOCAL i AS LONG LOCAL MidiSXHdr AS MIDIHDR LOCAL retval AS LONG gt = x ' this pointer should of course not change during execution! IF @gt.flags = %SYSEX_STOP THEN EXIT FUNCTION IF BIT (@gt.flags, %SYSEX_TO_FILE) THEN fnr = FREEFILE OPEN $SXFILE FOR APPEND LOCK SHARED AS #fnr END IF SX = CHR$(0) ' we check @gt.cnt, the counter for sysex strings incremented in de callback. DO 'IF @gt.flags = %SYSEX_STOP THEN EXIT LOOP ' this stops the thread. ' changed to: IF BIT (@gt.flags, %SYSEX_BLOCK) THEN EXIT LOOP ' note that, once stopped, the same thread cannot be restarted! IF @gt.cnt > COUNT THEN tog = %True SX = PEEK$(@gt.pSXBuf, @gt.length) IF BIT(@gt.flags, %SYSEX_TO_SXB) THEN REDIM PRESERVE SxB(@gt.cnt) AS GLOBAL STRING * %SysExBuffer SxB(@gt.cnt) = SX END IF IF fnr THEN IF SX <> "" THEN IF LEFT$(SX,1) = CHR$(&HF0) THEN IF BIT(@gt.flags,%SYSEX_TO_FILE) THEN ' write to file: FOR i = 1 TO @gt.length - 1 PRINT #fnr, HEX$(ASC(MID$(SX,i,1)));","; NEXT i PRINT #fnr, HEX$(ASC(MID$(SX,i,1))) END IF END IF END IF END IF COUNT = @gt.cnt ELSE SLEEP 0 ' makes the thread release its timeslice. END IF LOOP UNTIL @gt.flags = %SYSEX_STOP IF fnr THEN CLOSE #fnr DeleteIfEmpty $SXFILE END IF END FUNCTION FUNCTION GetSysEx (BYVAL devicenr AS WORD, BYVAL flags AS INTEGER) EXPORT AS STRING '(BYREF SxThread AS GMT_SYSEX_THREAD, BYVAL flags AS INTEGER) EXPORT AS STRING LOCAL i AS LONG LOCAL tmp AS STRING ' This function reads received sysex messages from the array buffer in the DLL. FUNCTION = "" IF SxThread.cnt <= %False THEN EXIT FUNCTION IF ISFALSE hMidiI(devicenr) THEN EXIT FUNCTION SELECT CASE SGN(flags) CASE -1 ' oldest msg's returned first i = %False DO tmp = SxB(i) IF LEFT$(tmp,1) = CHR$(&HF0) THEN IF INSTR(tmp, CHR$(&HF7)) THEN 'was istrue bug FUNCTION = EXTRACT$(tmp,CHR$(&HF7)) & CHR$(&HF7) IF BIT(flags,1) THEN 'was istrue bug ' remove the string data from the array so that we do not return it again. SxB(i) = STRING$(%SysExBuffer,CHR$(0)) END IF EXIT LOOP END IF END IF INCR i LOOP UNTIL i > UBOUND(SxB) CASE 0 ' illegal Warning "GetSysEx called with invalid flags", 10000 CASE 1 ' most recent msg's returned first i = UBOUND(SxB) DO tmp = SxB(i) IF LEFT$(tmp,1) = CHR$(&HF0) THEN IF INSTR(tmp, CHR$(&HF7)) THEN ' was istrue bug FUNCTION = EXTRACT$(tmp,CHR$(&HF7)) & CHR$(&HF7) IF BIT(flags,1) THEN ' was istrue bug ' remove the string data from the array so that we do not return it again. SxB(i) = STRING$(%SysExBuffer,CHR$(0)) END IF EXIT LOOP END IF END IF DECR i LOOP UNTIL i < %False END SELECT END FUNCTION SUB BlockSysExReception (BYVAL hmi AS DWORD) EXPORT LOCAL retval AS LONG BIT SET SxThread.flags,%SYSEX_BLOCK IF SxThread.id THEN THREAD STATUS SxThread.id TO retval IF retval = &H103 THEN THREAD SUSPEND SxThread.id TO retval END IF END IF END SUB SUB SysEx (BYVAL hMidiOut AS DWORD, Sx$) EXPORT LOCAL i AS WORD ' max.64k- this limit is set by the Win32api. Blame Bill Gates... LOCAL retval AS DWORD LOCAL SysExBuf AS MIDIHDR DIM Dta(LEN(Sx$)-1) AS LOCAL BYTE FOR i = 0 TO UBOUND(Dta) Dta(i)= ASC(MID$(Sx$,i+1,1)) NEXT i SysExBuf.lpData = VARPTR(Dta(0)) SysExBuf.dwBufferLength = LEN(Sx$) SysExBuf.dwFlags = %Null retval = MidiOutPrepareHeader (hMidiOut, SysExBuf, SIZEOF(SysExBuf)) SELECT CASE retval CASE %MMSYSERR_NOERROR ' everything works fine... so we send the buffer: MidiOutLongMsg hMidiOut, SysExBuf, SIZEOF(SysExBuf) CASE %MMSYSERR_INVALHANDLE Warning "SYSEX-error: Cannot send a sysex if midi-port is not opened", 10000 CASE %MMSYSERR_INVALPARAM Warning "SYSEX-error: wrong bufferpointer or size exceeds 64k", 10000 CASE %MMSYSERR_NOMEM Warning "SYSEX-error: unable to allocate memory", 10000 END SELECT END SUB 'most recent version of this function is FUNCTION MM_Sysx() in mrobots.inc! remmed kl @ 20050811 'SUB SysEx_MM (BYVAL hMidiOut AS DWORD, BYREF Robot AS musician ,Sx$) EXPORT ' ' specific version for M&M robots with programmable velo-lookup tables (piano, casta, vacca...) ' ' to be done... ' ' hMidiOut has to become the port to which the automat is connected! ' ' Vacca: time unit = 19.2 microseconds, bij 14 bit dus max. 314 ms. ' LOCAL h AS DWORD ' IF LEFT$(Sx$, 5) <> CHR$(&HF0,&H7D,&H4A,&H54,LOBYT(Robot.channel)) THEN ' Warning "SysEx_MM error", 10000 ' END IF ' h = robot.channel ' SHIFT RIGHT h, 8 ' h = hMidiO(h) ' convert port to midi handle ' IF ISFALSE h THEN EXIT SUB ' ' format: F0 7D 4A 54 ' 4A 54 vormen een pinkode ' ' LOBYT(Robot.channel), prognr (1-8) ' note : prog.0 , de default, is niet programmeerbaar. ' ' note ' ' velo 1 msb, velo 1 lsb ' ' velo 2 msb, velo 2 lsb ' ' ... ' ' velo 127 msb, velo 127 lsb ' ' F7 ' ' voor elke noot moeten dus 127 velo's gestuurd worden. ' ' dan moet 200ms gewacht worden. 'END SUB FUNCTION OpenMidiOutputDevice (BYVAL devicenumber AS LONG) EXPORT AS DWORD ' We can use the function to open all available devices and ports. ' since we have the midiouthandles in a DLL-global array, all midi-out procedures ' are in this DLL. LOCAL retval AS DWORD LOCAL hmo AS DWORD STATIC init AS DWORD STATIC nrOpenMidiOutPorts AS WORD IF ISFALSE init THEN nrOpenMidiOutPorts = %False init = %True END IF tryagain: retval = midiOutOpen (hmo, devicenumber, %Null, %Null, %Null) SELECT CASE retval CASE %MMSYSERR_NOERROR INCR nrOpenMidiOutPorts ' IF UBOUND(hMidiO) < nrOpenMidiOutPorts -1 THEN remmed 23.07.2004 ' REDIM PRESERVE hMidiO(nrOpenMidiOutPorts -1) AS GLOBAL DWORD ' END IF hMidiO(nrOpenMidiOutPorts -1) = hmo FUNCTION = hmo ' communicate with caller... CASE %MMSYSERR_ALLOCATED IF hmo THEN retval = midiOutClose (hmo) '04.12.2000 GOTO tryagain ELSE ReportMidiError retval FUNCTION = %False END IF CASE ELSE ReportMidiError retval FUNCTION = %False END SELECT END FUNCTION 'SUB PrepareMidiIOmenu (BYREF hMidiO() AS DWORD , byref hMidiI() AS DWORD) EXPORT ' new 26.06.2002 SUB PrepareMidiIOmenu (BYREF hO AS DWORD, BYREF h AS DWORD) EXPORT ' changed 22.07.2004 LOCAL i AS LONG LOCAL hPop AS LONG LOCAL Lb AS STRING LOCAL mp() AS STRING LOCAL m AS ASCIIZ * 40 LOCAL hmo AS DWORD LOCAL hMenu AS LONG LOCAL hSubMenu AS LONG hMenu = GetMenu(@pgh.setup) hSubMenu = GetSubMenu(hMenu, 4) SELECT CASE midiOutGetNumDevs ' dll CASE 0 EnableMenuItem hMenu, %IDM_MIDI_OUTPUT_DEVS, %MF_GRAYED ' CASE 1 ' no choice, just open it... ' ' REDIM hMidiO(0) AS GLOBAL DWORD ' for multiport support - remmed 23.07.2004 ' hmo = OpenMidiOutputDevice (0) ' dll function. ' IF hmo THEN ' CheckMenuItem hMenu, %IDM_MIDI_OUTPUT_DEVS, %MF_CHECKED ' EnableMenuItem hMenu, %IDM_MIDI_OUTPUT_DEVS, %MF_GRAYED ' hMidiO(0)= hmo ' ELSE ' Warning "Failure to open midi-out device in " + FUNCNAME$, 10000 ' END IF CASE ELSE ' REDIM hMidiO(midiOutGetNumDevs -1) AS GLOBAL DWORD - remmed 23.07.2004 Lb = "MIDI-OUT PORTS" MENU NEW POPUP TO hPop MENU ADD POPUP, hSubMenu, Lb, hPop, %MF_ENABLED , AT BYCMD %IDM_MIDI_OUTPUT_DEVS ' MENU DELETE hMenu, BYCMD %IDM_MIDI_OUTPUT_DEVS MENU DELETE hSubMenu, 3 'BYCMD %IDM_MIDI_OUTPUT_DEVS DIM mp(0) AS LOCAL STRING GetMidiOutPorts mp() ' dll call FOR i = 0 TO midiOutGetNumDevs -1 MENU ADD STRING, hPop,STR$(i) + " = " + TRIM$(mp(i)),%IDM_MIDI_OUTPUT_PORTS + i,%MF_ENABLED, AT BYCMD %IDM_MIDI_OUTPUT_DEVS NEXT i MENU DRAW BAR @pgh.setup END SELECT hO = VARPTR(hMidiO(0)) ' pointer for use in a dim at statement in gmt! hSubMenu = GetSubMenu(hMenu, 3) SELECT CASE midiINGetNumDevs ' dll CASE 0 EnableMenuItem hMenu, %IDM_MIDI_INPUT_DEVS, %MF_GRAYED ' CASE 1 ' ' no choice, just open it... '' REDIM hMidiI(0) AS GLOBAL DWORD ' for multiport support ' i = OpenMidiInputDevice (0) ' IF i THEN ' CheckMenuItem hMenu, %IDM_MIDI_INPUT_DEVS, %MF_CHECKED ' EnableMenuItem hMenu, %IDM_MIDI_INPUT_DEVS, %MF_GRAYED ' hMidiI(0)= i ' ELSE ' Warning "Failure to open midi-in device in " + FUNCNAME$, 10000 ' ' we should check the error returned... ' END IF CASE ELSE ' REDIM hMidiI(midiInGetNumDevs -1) AS GLOBAL DWORD ' first redim, later redimmed on selections. ' change 22.07.2004: dim. stays. Check handles ' instead of ubound hMidiI(). !!! gwr. Lb = "MIDI-IN PORTS" MENU NEW POPUP TO hPop MENU ADD POPUP, hSubMenu, Lb, hPop, %MF_ENABLED , AT BYCMD %IDM_MIDI_INPUT_DEVS ' MENU DELETE hMenu, BYCMD %IDM_MIDI_INPUT_DEVS MENU DELETE hSubMenu, 3 'BYCMD %IDM_MIDI_INPUT_DEVS DIM mp(0) AS LOCAL STRING GetMidiInPorts mp() ' dll call FOR i = 0 TO midiInGetNumDevs -1 IF LEFT$(TRIM$(mp(i)),11) <> "TTS Virtual" THEN MENU ADD STRING, hPop,STR$(i) + " = " + TRIM$(mp(i)),%IDM_MIDI_INPUT_PORTS + i,%MF_ENABLED, AT BYCMD %IDM_MIDI_INPUT_DEVS ELSE ' ? print it grayed? - we decided not to display it. END IF NEXT i MENU DRAW BAR @pgh.setup END SELECT h = VARPTR(hMidiI(0)) END SUB ' midi-out procedures: SUB mPlay (BYVAL kanaal AS WORD, BYVAL noot?, BYVAL velo?) EXPORT ' changed 23.11.2002 for UDP/IP support ' low nibble of low byte kanaal = kanaal ' low nibble of high byte kanaal = port ' highest bit of high byte = UDP/IP LOCAL ShortMessage AS LONG LOCAL hm AS DWORD IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = velo? SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR noot? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR 144 OR (kanaal AND &H000F) midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 - problems with combi g_h and g_nih - we try to eliminate all g_net dependencies here hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() SHIFT RIGHT hm,12 ' 0-15 pc number, note that 0 sends to itself! g_net_send CHR$(144 OR (kanaal AND &H000F)) & CHR$(noot?) & CHR$(velo?),hm '[\DEBUG] #ENDIF END IF END SUB SUB PlayDur (BYVAL kanaal AS WORD, BYVAL noot?, BYVAL velo?, BYVAL duur AS DWORD) EXPORT ' added in gmt 09.10.2003 ' seems to have bug since version 8.00... ' bug discovered 23.07.2004: kanaal was dword. MUST BE WORD!!! ' updated 28.7.2008: now uses the timerqueue timers... ' redimensioning the tiev array caused crashes (Because the callback still remembered the old pointer, which could change) ' -> we just make it bigger than needed from the start LOCAL ShortMessage AS LONG LOCAL hm AS DWORD LOCAL n AS LONG LOCAL i AS LONG 'if we're the first to use the tiev array we dimension it IF UBOUND(tiev) <=0 THEN REDIM tiev(1000) 'more then we'll (probably) ever need ' we need a dynamic global array of TiEv's here n = -1 DO INCR n IF n > UBOUND (TiEv) THEN MSGBOX "Max nr of timers reached (Currently" + STR$(UBOUND(tiev)) + ") in " + FUNCNAME$ ' REDIM PRESERVE TiEv(n) AS GLOBAL TimedEvent -> '' 'debug...' ' for i = lbound(tiev) to ubound(tiev) ' logfile str$(i) + str$(Tiev(i).cptr) + str$(tiev(i).time) + str$(tiev(i).param1) + str$(tiev(i).param2) ' next END IF 'IF ISFALSE TiEV(n).tID THEN EXIT LOOP LOOP UNTIL ISFALSE TiEv(n).tID TiEv(n).cptr = CODEPTR(PlayDur_CB) TiEv(n).time = duur TiEv(n).param1 = kanaal ' param1 is dword TiEv(n).param2 = noot? ' param2 is dword IF ISFALSE (kanaal AND &H0F000) THEN ' no UDP's hm = hMidiO(HIBYT(kanaal)) ShortMessage = velo? SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR noot? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR 144 OR (kanaal AND &H000F) midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() SHIFT RIGHT hm,12 ' 0-15 pc number, note that 0 sends to itself! g_net_send CHR$(144 OR (kanaal AND &H000F)) & CHR$(noot?) & CHR$(velo?),hm #ENDIF END IF i = QScheduleEvent (TiEv(n)) ' replacement for the old ScheduleEvent with the new winapi functions. In g_main.inc. END SUB SUB PlayDur_CB (BYVAL pev AS DWORD) '20080731 now we pass and use the pointer of the specific event in stead of searching through the array for the event to execute ' this means that in priniciple we can use this function together with other ones that use the timed events without problems ' (As long as they don't use ' more then 1000 at the same time ' mind that timing get's very inaccurate when using a lot of these timers though.. LOCAL pe AS TimedEvent POINTER pe = pev NoteOff @pe.param1, @pe.param2 @pe.param1 = %False ' reset het event, zodat we het opnieuw kunnen gebruiken @pe.param2 = %False END SUB 'type Glisstype ' van as currency ' tot as currency ' duur as dword 'ms ' velo as byte 'although we probably better fix velo 127 if we want a propper gliss ' 'for internal use ONLY ' startt as dword 'ms ' endtt as dword ' lastval as currency ' lastnote as byte ' lastbend as byte ' busy as dword ' cb as dword 'user callback for when gliss finished 'end type FUNCTION gliss(BYVAL pM AS musician PTR, BYVAL van AS CURRENCY, BYVAL tot AS CURRENCY, BYVAL duur AS SINGLE, BYVAL velo AS BYTE, OPT BYVAL cb AS DWORD, OPT BYVAL surpressfingerings AS LONG) EXPORT AS LONG 'gliss on musician over a certain period - monophonic per instrument, but can happen on several intruments at the same time (Atual lkmit not yet checked) 'for monophonic wind instruments, only velo 127 will work well. use controllers for the volume.. 'it's the responsibility of the user not to start a new gliss on the same instrument before the other one finished 'returns -1 if process started, false if conditions not met (instrument out of range, ...) 'optional flag to surpress fingerings - for gliss over long range this prevents key clicking. for gliss over short range it will be better to stick to the right fingering ' >does not work for autosax.. use ctl 65 there in stead 'cb is the pointer to an optional function that gets called at the end of the gliss. it should take one dword param, which will contain the musician pointer.. '31/10/2011 doesn't work yet. although the timer is created if we can believe the returnvalues, the callback nver gets called.. LOCAL n AS LONG LOCAL i AS LONG LOCAL note AS BYTE LOCAL bnd AS BYTE STATIC init AS DWORD STATIC gl() AS glisstype IF ISFALSE init THEN DIM gl(1000) 'as glisstype 'should be plenty.. init = 1 END IF ' logfile FUNCNAME$ + " " + @pm.Naam + STR$(van) + STR$(tot) + STR$(duur) + STR$(velo) 'check conditions IF (van < @pM.LowTes) OR (van > @pM.HighTes) THEN EXIT FUNCTION IF (tot < @pM.LowTes) OR (tot > @pM.HighTes) THEN EXIT FUNCTION IF duur <= 0 THEN EXIT FUNCTION n = -1 'store values in static array DO INCR n IF n > UBOUND(gl) THEN MSGBOX "Max nr of glissandi reached in " + FUNCNAME$ EXIT FUNCTION END IF LOOP UNTIL ISFALSE gl(n).busy gl(n).van = van gl(n).tot = tot gl(n).duur = duur gl(n).velo = velo gl(n).startt = timegettime gl(n).endt = gl(n).startt + duur gl(n).lastval = van gl(n).busy = 1 gl(n).cb = cb gl(n).sf = surpressfingerings ' logfile "Schedule gliss from" + STR$(van) + " to" + STR$(tot) + " time" + STR$(duur) 'start playing SELECT CASE @pM.naam CASE "SO", "HELI", "BONO", "OB", "AUTOSAX", "FA", "KORN" note = INT(van + .5) gl(n).lastnote = note bnd = 64 + 127 * (van - INT(van + .5)) gl(n).lastbend = bnd mPlay @pM.channel, note, velo Bend @pM.channel, 0, bnd CASE "QT", "XY", "TUBI" gl(n).lastnote = INT(2 * van + .5)/2 AddNote2QHar @pM.QHar(1), gl(n).lastnote, gl(n).velo QInstrumPlay @pM CASE ELSE gl(n).lastnote = INT(van + .5) AddNote2Har @pM.Har(1), gl(n).lastnote, gl(n).velo InstrumPlay @pM 'instrumpaly only plays when notes have changed, so this should be ok.. END SELECT 'schedule timer.. 'we use the timed events like in playdur, but this time with repeat. 'if we're the first to use the tiev array we dimension it IF UBOUND(tiev) <=0 THEN REDIM tiev(1000) 'more then we'll (probably) ever need ' we need a dynamic global array of TiEv's here n = -1 DO INCR n IF n > UBOUND (TiEv) THEN MSGBOX "Max nr of timers reached (Currently" + STR$(UBOUND(tiev)) + ") in " + FUNCNAME$ EXIT FUNCTION END IF LOOP UNTIL ISFALSE TiEv(n).tID ' logfile "timer" +STR$(n) TiEv(n).cptr = CODEPTR(Gliss_CB) TiEv(n).time = 15 'duur voor timer eerste keer terugkomt TiEv(n).param1 = pM 'dword TiEv(n).param2 = VARPTR(gl(n)) ' param2 is dword Tiev(n).repeat = 15 'ms - experimental i = QScheduleEvent (TiEv(n)) ' replacement for the old ScheduleEvent with the new winapi functions. In g_main.inc. ' i = ScheduleEvent (TiEv(n)) ' replacement for the old ScheduleEvent with the new winapi functions. In g_main.inc. ' logfile "res:" + STR$(i) + STR$(Tiev(n).tid) FUNCTION = -1 END FUNCTION SUB Gliss_cb(BYVAL pev AS DWORD) '100/s for now, always calculates new value, but only send what makes a difference midiwise.. (with big short glisses this might cause troubles..) ' Flut to be added! LOCAL pe AS TimedEvent POINTER LOCAL pM AS Musician POINTER LOCAL pgl AS glisstype POINTER LOCAL fn AS CURRENCY LOCAL note AS BYTE LOCAL qnote AS CURRENCY LOCAL bnd AS BYTE pe = pev pM = @pe.param1 pgl = @pe.param2 IF @pgl.endt <= timegettime THEN ' logfile "endtime reached!!" 'note af, bend reset SELECT CASE UCASE$(TRIM$(@pM.naam)) CASE "QT", "XY", "TUBI" QInstrumPlay @pM CASE "SO", "HELI", "BONO", "OB", "AUTOSAX", "FA", "KORN" MPlay @pM.channel, @pgl.LastNote, 0 Bend @pM.channel, 0, 64 CASE ELSE InstrumPlay @pM END SELECT 'release timer @pe.repeat = 0 'call cb IF @pgl.cb THEN CALL DWORD @pgl.cb USING cbgl(pM) @pgl.busy = 0 EXIT SUB END IF 'check current value and calculat3e midi note and bend - only send the last two if they changed.. fn = @pgl.van + (@pgl.tot - @pgl.van) * ((timegettime - @pgl.startt) / (@pgl.endt - @pgl.startt)) note = INT(fn + .5) 'handling for specific instruments 'QT SELECT CASE UCASE$(TRIM$(@pM.naam)) CASE "QT", "XY", "TUBI" @pgl.lastnote = INT(2 * fn + .5)/2 ' logfile @pM.naam + STR$(@pgl.lastnote) AddNote2QHar @pM.QHar(1), @pgl.lastnote, @pgl.velo QInstrumPlay @pM CASE "SO", "HELI", "BONO", "OB", "AUTOSAX", "FA", "KORN" 'general handling for monophonic wind instrumtns with pitch bend support IF note <> @pgl.lastnote THEN @pgl.lastnote = note ' logfile "new note:" + STR$(note) + STR$(timegettime) 'nb, we can control fingerings for fa too, but as the valves make few sounds, we ommit that here.. mPlay @pM.channel, note, @pgl.velo IF @pgl.sf THEN SELECT CASE UCASE$(TRIM$(@pM.naam)) CASE "KORN" controller Korn.channel, 13, &B111100 'lowest bits should be 0 apparently.. CASE "SO", "HELI" ', "KORN" 'for now we close all valves.. as the lowest note shoud work with a lot of higher notes.. 'using the fingering of the starting note is also an option, but becomes quite arbitrary with a gliss spanning several semitones.. Controller @pM.channel, 13, 60 CASE "BONO" 'inconsistent with other instruments that use ctl 13!! controller @pM.channel, 13, 15 ' case "AUTOSAX" ' Keypress @pM.channel, 127, 127 'moet werken volgens de picspecs, maar doet niets ' 'ctl 65 is de oplossing CASE "OB" KeyPress @pM.channel, 127, 63 'alles dicht END SELECT END IF END IF bnd = 64 + 127 * (fn - INT(fn + .5)) IF bnd <> @pGl.lastbend THEN @pgl.lastbend = bnd ' logfile "new bend:" + STR$(bnd) + STR$(timegettime) Bend @pM.channel, 0, bnd END IF CASE ELSE @pgl.lastnote = note AddNote2Har @pM.Har(1), note, @pgl.velo InstrumPlay @pM 'instrumpaly only plays when notes have changed, so this should be ok.. END SELECT END SUB 'dummy as callback prototype SUB cbgl(BYVAL d AS DWORD) END SUB SUB PlayHarDur (BYVAL kanaal AS WORD, BYVAL ht AS Harmtype, BYVAL duur AS DWORD) EXPORT 'important: not to be mixed with PlayDur! - either use one or the other (as they use the same Tiev array) 'maybe we want to change this later on.. playing chords with this function combied with a melody with PlayDur kindof makes sense.. 'if both callbacks use pointers in stead of running through the whole tiev array we're there.. STATIC h() AS harmtype LOCAL n AS LONG LOCAL i AS LONG ' logfile FUNCNAME$ + STR$(kanaal) + STR$(duur) IF UBOUND(tiev) <= 0 THEN REDIM tiev(1000) '<=, as an undimensioned aray returns ubound -1 IF UBOUND(h) <= 0 THEN REDIM h(UBOUND(tiev)) n = -1 DO INCR n IF n > UBOUND (TiEv) THEN MSGBOX "Max nr of timers reached (Currently" + STR$(UBOUND(tiev)) + ") in " + FUNCNAME$ ' REDIM PRESERVE TiEv(n) AS GLOBAL TimedEvent -> '' 'debug...' ' for i = lbound(tiev) to ubound(tiev) ' logfile str$(i) + str$(Tiev(i).cptr) + str$(tiev(i).time) + str$(tiev(i).param1) + str$(tiev(i).param2) ' next END IF 'IF ISFALSE TiEV(n).tID THEN EXIT LOOP LOOP UNTIL ISFALSE TiEv(n).tID ' logfile "har nr:" + STR$(n) ' logfile "har ptr:" + STR$(VARPTR(h(n))) TiEv(n).cptr = CODEPTR(PlayHarDur_CB) TiEv(n).time = duur h(n) = ht TiEv(n).param1 = kanaal ' param1 is dword TiEv(n).param2 = VARPTR(h(n)) ' param1 is dword PlayHar h(n), kanaal QScheduleEvent(tiev(n)) ' logfile STR$(timegettime) + "ev descr:" + STR$(Tiev(n).cptr) + STR$(Tiev(n).tid) + STR$(tiev(n).time) + STR$(tiev(n).param1) + STR$(tiev(n).param2) END SUB SUB PlayHarDur_CB(BYVAL pev AS DWORD) 'the byval should be there!! LOCAL pe AS TimedEvent POINTER LOCAL ph AS HarmType POINTER LOCAL i AS LONG ' logfile FUNCNAME$ + STR$(pev) pe = pev ' logfile STR$(timegettime) + "ev check:" + STR$(@pe.cptr) + STR$(@pe.tid) + STR$(@pe.time) + STR$(@pe.param1) + STR$(@pe.param2) ph = @pe.param2 ' logfile "phar:" + STR$(ph) FOR i = 1 TO 127 IF ASC(@ph.vel, i) THEN mPlay @pe.param1, i-1, 0 NEXT @pe.param1 = 0 @pe.param2 = 0 ' logfile FUNCNAME$ + " exit" END SUB SUB PlayHar (H AS HarmType, BYVAL k AS WORD) EXPORT ' nrports * 16 channels polyphonic midi output procedure STATIC tog? LOCAL i AS LONG LOCAL ib? LOCAL ob? LOCAL vox AS WORD STATIC OldHar() AS HarmType IF ISFALSE (k AND &H0F000) THEN ' case midi I/O IF tog? = %False THEN i = 16 * (UBOUND(hMidiO) + 1) ' nr of available/possible channels , 16 for each port DIM OldHar(i-1) AS STATIC HarmType ' uitgebreid naar multiport support 12.12.99 tog? = %True FOR i= 0 TO UBOUND(OldHar) OldHar(i).vel = NUL$(128) NEXT i END IF vox = HIBYT(k) AND &H0F ' isolate portnumber SHIFT LEFT vox, 4 ' make it a channel multiplier vox = vox OR (k AND &H000F) ' return as usable voice pointer '---- FOR i = 1 TO 128 ib? = ASC(MID$(H.vel, i, 1)) 'ob? = ASC(MID$(OldHar(k AND &H000F).vel, i, 1)) ob? = ASC(MID$(OldHar(vox).vel, i, 1)) IF ib? = %False THEN IF ob? THEN 'NoteOff k, i -1 mPlay k, i-1, 0 ' changed 09.12.2019 for robots that have release implemented. END IF ELSE IF ob? <> ib? THEN IF ob? THEN 'NoteOff k, i - 1 mPlay k, i-1, 0 END IF mPlay k, i - 1, ib? END IF END IF NEXT i OldHar(vox).vel = H.vel ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 ' UDP/IP case ' note that we misuse the sysex format here to send a long string command. i = k ' i is used here as an index to the PC in the array g_net.IP() SHIFT RIGHT i,12 g_net_send CHR$(240 OR (k AND &H000F)) & "H" & H.vel , i '[/DEBUG] #ENDIF END IF END SUB SUB QInstrumPlay (BYREF M AS musician) EXPORT ' added gwr 26.09.2006 - to be tested. ' only works for real quartertone instruments: ' ' ' ' ' , together ' optional: we can implement it for Vacca, Vitello, Llor... ' nrports * 16 channels polyphonic midi output procedure ' changed 23.03.2007 by KL: ' Qhar(1).vel field added to the musician type, so this function can behave similarly to InstrumPlay ' Qhar(1).vel is cleared and the currently sounding notes are put in Qhar(0).vel. notes that where out of range and ' that thus are not played are not added to Qhar(0).vel ' 12.04.2007 Xy added ' 12.01.2012 support for monophonic wind instrumetns added ' 13.07.2013 extended for Klar, Asa, Horny STATIC tog? LOCAL lqh AS QHarmType 'here we store the notes that are played, to put them in Qharm(0).vel afterwards. '(we don't just copy qhar(1).vel, as then out of range notes are also copied.. LOCAL i AS LONG LOCAL ib? LOCAL ob? LOCAL vox AS WORD ' logfile FUNCNAME$ + " " + M.naam + " " + M.QHar(1).vel IF ISFALSE (M.channel AND &H0F000) THEN ' case midi I/O IF tog? = %False THEN i = 16 * (UBOUND(hMidiO) + 1) ' nr of available/possible channels , 16 for each port DIM OldQHar(i-1) AS STATIC QHarmType ' uitgebreid naar multiport support 12.12.99 tog? = %True FOR i= 0 TO UBOUND(OldQHar) OldQHar(i).vel = NUL$(256) NEXT i END IF IF TRIM$(LCASE$(M.naam)) = "qtq" THEN Warning "please use in stead of with " + FUNCNAME$: EXIT SUB IF TRIM$(LCASE$(M.naam)) = "xyq" THEN Warning "please use in stead of with " + FUNCNAME$: EXIT SUB vox = HIBYT(M.channel) AND &H0F ' isolate portnumber SHIFT LEFT vox, 4 ' make it a channel multiplier vox = vox OR (M.channel AND &H000F) ' return as usable voice pointer 'waar moet deze voor dienen? wordt niet gebruikt.. xof 20080211 '---- FOR i = (M.lowtes * 2) + 1 TO (M.hightes * 2) + 2 'sic +2: = bovenste kwarttoon ' 1 TO 256 ib? = ASC(MID$(M.QHar(1).vel, i, 1)) ob? = ASC(MID$(M.QHar(0).vel, i, 1)) IF ib? = %False THEN IF ob? THEN SELECT CASE LCASE$(TRIM$(M.naam)) CASE "qt" ', "qtq" IF (i-1) MOD 2 THEN ' in this case we have a quartertone NoteOff M.channel +1, INT((i-1)/2) ' logfile "Off-q"+ STR$(i) + STR$(INT((i-1)/2)) ELSE NoteOff M.channel, (i-1)/2 ' logfile "Off" + STR$(i) + STR$((i-1)/2) END IF CASE "xy" ', "xyq" 'niks CASE "tubi" ' niks CASE "puff" ' niks CASE "so", "heli", "bono", "fa", "autosax", "korn", "ob","klar","horny","asa" NoteFOff M, (i-1)/2 END SELECT END IF ELSE IF ob? <> ib? THEN IF ob? THEN SELECT CASE LCASE$(TRIM$(M.naam)) CASE "qt" ', "qtq" IF (i-1) MOD 2 THEN ' in this case we have a quartertone NoteOff M.channel+1, INT((i-1)/2) ' logfile "Off-q"+ STR$(i) + STR$(INT(i-1)/2) ELSE NoteOff M.channel, (i-1)/2 ' logfile "Off" + STR$(i) + STR$((i-1)/2) END IF END SELECT END IF SELECT CASE LCASE$(TRIM$(M.naam)) CASE "qt" ', "qtq" IF (INT((i-1)/2) < M.lowtes) OR (INT((i-1)/2) > M.hightes) THEN ITERATE FOR MID$(lqh.vel, i, 1) = CHR$(ib?) IF (i-1) MOD 2 THEN ' in this case we have a quartertone mPlay M.channel+1, INT((i-1)/2), ib? ' logfile "On-q" + STR$(i) + STR$(INT((i-1)/2)) ELSE mPlay M.channel, (i-1)/2, ib? ' logfile "On" + STR$(i) + STR$((i-1)/2) END IF CASE "xy" ', "xyq" IF (INT((i-1)/2) < M.lowtes) OR (INT((i-1)/2) > M.hightes) THEN ITERATE FOR MID$(lqh.vel, i, 1) = CHR$(ib?) IF ((i-1) MOD 2) THEN ' in this case we have a quartertone mPlay M.channel+1, INT((i-1)/2), ib? ' logfile funcname$ + " xy" + str$(M.channel + 1) + str$(INT((i-1)/2)) + str$(ib?) ELSE mPlay M.channel, (i-1)/2, ib? ' logfile FUNCNAME$ + " xy" + STR$(M.channel) + STR$((i-1)/2) + STR$(ib?) END IF CASE "tubi" 'logfile " q-tubi with note"+ STR$(i) IF (INT((i-1)/2) <72) OR (INT((i-1)/2) > 108) THEN ITERATE FOR 'limiteer tessituur MID$(lqh.vel, i, 1) = CHR$(ib?) IF ((i-1) MOD 2) THEN ' in this case we have a quartertone 'logfile " q-tubi"+ STR$(INT((i-1)/2)) + STR$(ib) mPlay M.channel, INT(((i-1)/2)) - 48, ib? 'was bug - the INT is necessary here!! ELSE 'logfile " q-tubi"+ STR$((i-1)/2) + STR$(ib) mPlay M.channel, (i-1)/2, ib? END IF CASE "puff" IF (INT((i-1)/2) < 55) OR (INT((i-1)/2) > 96) THEN ITERATE FOR 'limiteer tessituur MID$(lqh.vel, i, 1) = CHR$(ib?) IF ((i-1) MOD 2) THEN ' in this case we have a quartertone mPlay M.channel, INT(((i-1)/2)) - 48, ib? 'was bug - the INT is necessary here!! ELSE mPlay M.channel, (i-1)/2, ib? END IF CASE "so", "heli", "bono", "fa", "autosax", "korn", "ob" ,"klar","asa","horny" NoteFOn M, (i-1)/2, ib? CASE ELSE ' niks Warning TRIM$(M.naam) + " is not (yet) supported by the function " + FUNCNAME$ END SELECT ELSE MID$(lqh.vel, i, 1) = CHR$(ib?) END IF END IF NEXT i M.Qhar(0).vel = lqh.vel RESET M.Qhar(1).vel ELSE END IF END SUB SUB NoteOff (BYVAL kanaal AS WORD, BYVAL noot?) EXPORT LOCAL ShortMessage AS LONG LOCAL hm AS DWORD IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = noot? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &H80 OR (kanaal AND &H000F) midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll SHIFT RIGHT hm,12 g_net_send CHR$(128 OR (kanaal AND &H000F)) & CHR$(noot?) & CHR$(0),hm '[/DEBUG] #ENDIF END IF END SUB SUB Release (BYVAL kanaal AS WORD, BYVAL noot?, BYVAL r?) EXPORT ' added 12.12.2004 for Llor: here we use note-off with a release value. ' since than, used in a lot of our robots. LOCAL Shortmessage AS LONG LOCAL hm AS DWORD IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = r? SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR noot? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &H80 OR (kanaal AND &H000F) '128 midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 ' ' bug to be solved...: we do not send release value... ' hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll ' SHIFT RIGHT hm,12 ' g_net_send CHR$(&H80 OR (kanaal AND &H000F)) & CHR$(noot?) & CHR$(r?),hm '[/DEBUG] #ENDIF END IF END SUB SUB KeyPress (BYVAL kanaal AS WORD, BYVAL noot?, BYVAL value?) EXPORT 'this is the polyphonic key aftertouch command LOCAL Shortmessage AS LONG LOCAL hm AS DWORD IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = value? SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR noot? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &HA0 OR (kanaal AND &H000F) '160 midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll SHIFT RIGHT hm,12 g_net_send CHR$(&HA0 OR (kanaal AND &H000F)) & CHR$(noot?) & CHR$(value?),hm '[/DEBUG] #ENDIF END IF END SUB SUB ModeMess (BYVAL kanaal AS WORD,BYVAL ctrl?, BYVAL value?) EXPORT ' this is identical to controller change LOCAL ShortMessage AS LONG LOCAL hm AS DWORD IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = value? SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR ctrl? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR 176 OR (kanaal AND &H000F) '&HB0 midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll SHIFT RIGHT hm,12 g_net_send CHR$(176 OR (kanaal AND &H000F)) & CHR$(ctrl?) & CHR$(value?),hm '[/DEBUG] #ENDIF END IF END SUB SUB Controller (BYVAL kanaal AS WORD,BYVAL ctrl?, BYVAL value?) EXPORT ' this is identical to ModeMess LOCAL ShortMessage AS LONG LOCAL hm AS DWORD IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = value? SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR ctrl? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR 176 OR (kanaal AND &H000F) '&HB0 midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll SHIFT RIGHT hm,12 g_net_send CHR$(176 OR (kanaal AND &H000F)) & CHR$(ctrl?) & CHR$(value?),hm '[/DEBUG] #ENDIF END IF END SUB SUB SetMidiChannel (BYVAL kanaal AS WORD, BYVAL newchannel?) EXPORT ' 25.01.2005 ' implemented on some PIC-controlled M&M music robots. ' uses controller 127 LOCAL ShortMessage AS LONG LOCAL hm AS DWORD ' always first send an all notes off: Controller kanaal, 123, %False ' then change the receive channel: IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = newchannel? SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR 127 SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR 176 OR (kanaal AND &H000F) '&HB0 midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll SHIFT RIGHT hm,12 g_net_send CHR$(176 OR (kanaal AND &H000F)) & CHR$(127) & CHR$(newchannel?),hm '[/DEBUG] #ENDIF END IF END SUB SUB ResetRobot (BYVAL kanaal AS WORD) EXPORT ' 25.01.2005 ' does all notes off ' resets all controllers ' resets the PIC controller so that after a reset, the robot will listen again to its default midi channel, ' either encoded in the firmware or else set by dip switches on the PIC board. LOCAL ShortMessage AS LONG LOCAL hm AS DWORD ' always first send an all notes off: Controller kanaal, 123, %False ' then send the reset command: IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = %False SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR 121 ' 121 = reset SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR 176 OR (kanaal AND &H000F) '&HB0 midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll SHIFT RIGHT hm,12 g_net_send CHR$(176 OR (kanaal AND &H000F)) & CHR$(121) & CHR$(0),hm '[/DEBUG] #ENDIF END IF END SUB SUB Bend (BYVAL kanaal AS WORD,BYVAL lsb?, BYVAL msb?) EXPORT ' &HE0 pitchbend LOCAL ShortMessage AS LONG LOCAL hm AS DWORD IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = msb? SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR lsb? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR 224 OR (kanaal AND &H000F) ' &HE0 midiOutShortMsg hm, ShortMessage ' note that the order of the msg. is status, lsb, msb !!! ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll SHIFT RIGHT hm,12 g_net_send CHR$(224 OR (kanaal AND &H000F)) & CHR$(lsb?) & CHR$(msb?),hm '[/DEBUG] #ENDIF END IF END SUB SUB ProgChange(BYVAL kanaal AS WORD,BYVAL value?) EXPORT ' &HC0 program change '192 LOCAL ShortMessage AS LONG LOCAL hm AS DWORD IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = ShortMessage OR value? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR 192 OR (kanaal AND &H000F) midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll SHIFT RIGHT hm,12 g_net_send CHR$(192 OR (kanaal AND &H000F)) & CHR$(value?),hm '[/DEBUG] #ENDIF END IF END SUB SUB ProgChangeEx(BYVAL kanaal AS WORD, BYVAL msblsb AS WORD, BYVAL value?) EXPORT ' bank & program change ' not yet implemented for UDP/IP use... LOCAL ShortMessage AS LONG LOCAL hm AS DWORD IF ISFALSE (kanaal AND &H0F000) THEN ModeMess kanaal,0, (HIBYT(msblsb) AND &H7F) ' bank msb ModeMess kanaal,32, (LOBYT(msblsb) AND &H7F) ' bank lsb hm = hMidiO(HIBYT(kanaal)) ShortMessage = ShortMessage OR value? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &HC0 OR (kanaal AND &H000F) midiOutShortMsg hm, ShortMessage ELSE Warning "ProgChangeEx not implemented under UDP/IP yet... in " + FUNCNAME$, 10000 END IF END SUB SUB AfterTouch (BYVAL kanaal AS WORD, BYVAL value?) EXPORT ' &HD0 channel aftertouch or channel pressure ' this is NOT individual note aftertouch!!! LOCAL ShortMessage AS LONG LOCAL hm AS DWORD IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = ShortMessage OR value? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &HD0 OR (kanaal AND &H000F) midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll SHIFT RIGHT hm,12 g_net_send CHR$(&H0D0 OR (kanaal AND &H000F)) & CHR$(value?), hm '[/DEBUG] #ENDIF END IF END SUB '---------------------------- SUB AllNotesOff (BYVAL k AS WORD) EXPORT LOCAL ShortMessage AS LONG LOCAL hm AS DWORD IF ISFALSE (k AND &H0F000) THEN hm = hMidiO(HIBYT(k)) ShortMessage = &H7B SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &HB0 OR (k AND &H000F) midiOutShortMsg hm, ShortMessage ShortMessage = &H79 SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &HB0 OR (k AND &H000F) midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 hm = k ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll SHIFT RIGHT hm,12 g_net_send CHR$(&HB0 OR (k AND &H000F)) & CHR$(&H7B), hm g_net_send CHR$(&HB0 OR (k AND &H000F)) & CHR$(&H79), hm '[/DEBUG] remmed 20060621 #ENDIF END IF END SUB ' ---------------------------------------- SUB NoteCentOn (BYVAL kanaal AS WORD, BYVAL noot!, BYVAL velo?) EXPORT ' note + microtonal correction ' This presupposes that the equipment is set up for a bendrange of +/- 1 semitone. ' to be checked 08.02.2012!!! we may need a specific function for the robots. LOCAL n? , c%,lsb?,msb? LOCAL Shortmessage AS LONG LOCAL hm AS DWORD n? = ABS(FIX(noot!)) ' the integer part is the note c% = FIX(FRAC(noot!) * 100) ' isolate the cent correction, preserve the sign, so we have -100 to +100 now c% = %d13 + (c% * (%d13 /100)) ' multiply by %d14/100 (range)) ' shift to positive only - 14bit number lsb? = c% AND &H007F SHIFT RIGHT c%, 7 msb? = c% AND &H007F IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = velo? SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR n? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &H90 OR (kanaal AND &H000F) midiOutShortMsg hm, ShortMessage ShortMessage = msb? SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR lsb? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &H0E0 OR (kanaal AND &H000F) midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll SHIFT RIGHT hm,12 g_net_send CHR$(&H90 OR (kanaal AND &H000F)) & CHR$(n?) & CHR$(velo?), hm g_net_send CHR$(&HE0 OR (kanaal AND &H000F)) & CHR$(msb?) & CHR$(lsb?), hm ' check this '[/DEBUG] remmed 20060621 #ENDIF END IF END SUB SUB NoteCentOff (BYVAL kanaal AS WORD,BYVAL noot!) EXPORT LOCAL n?, Shortmessage AS LONG, lsb?, msb? LOCAL hm AS DWORD n? = ABS(FIX(noot!)) lsb? = %False msb? = &H40 IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ShortMessage = n? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &H090 OR (kanaal AND &H000F) midiOutShortMsg hm, ShortMessage ShortMessage = msb? SHIFT LEFT ShortMessage ,8 ShortMessage = ShortMessage OR lsb? SHIFT LEFT ShortMessage , 8 ShortMessage = %MEVT_F_SHORT OR ShortMessage OR &H0E0 OR (kanaal AND &H000F) midiOutShortMsg hm, ShortMessage ELSE #IF %DEF(%UDP) '[DEBUG] remmed 20060621 hm = kanaal ' hm is used here as an index to the PC in the array g_net.IP() in g_net.dll SHIFT RIGHT hm,12 g_net_send CHR$(&H90 OR (kanaal AND &H000F)) & CHR$(n?) & CHR$(0), hm g_net_send CHR$(&HE0 OR (kanaal AND &H000F)) & CHR$(msb?) & CHR$(lsb?), hm ' check this '[/DEBUG] remmed 20060621 #ENDIF END IF END SUB SUB NoteFOn(BYVAL m AS musician, BYVAL note AS CURRENCY, BYVAL velo AS BYTE) EXPORT 'fractional note on for the robots (bend range +- quartertone) 'KL 09.01.2012 - to be tested 'if we have scaling differences between robots, we need a select case here. 'Note: only to be used with instruments that do have pitch bend implemented. IF INT(note + 0.5) <= m.hightes THEN ' condition added by gwr 08.02.2013 mPlay m.channel, INT(note + .5), velo Bend m.channel, 0, MAX(MIN(64 + 127 * (note - INT(note + .5)), 127),0) ' lsb, msb! ELSE Controller m.channel, 123, %False END IF END SUB SUB NoteFOff(BYVAL m AS musician, BYVAL note AS CURRENCY) EXPORT IF INT(note + 0.5) <= m.hightes THEN mPlay m.channel, INT(note + .5), 0 ' condition added by gwr 08.02.2013 ELSE Controller m.channel, 123, %False END IF Bend m.channel, 0, 64 END SUB SUB SetPitchBendRange (Mq AS MidiEquipment, BYVAL kanaal AS WORD, BYVAL bereik AS BYTE) EXPORT LOCAL param AS WORD LOCAL value AS WORD LOCAL hm AS DWORD LOCAL i AS DWORD IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) ' range = nr. of semitones Up/Down ' the channel is quite irrelevant for proteus synths, but we need it to retrieve the midiport & handle SELECT CASE UCASE$(TRIM$(Mq.naam)) CASE "PROTEUS2","PROTEUS3","PROTEUS2XR","PROTEUS3XR","PROTEUS1","PROTEUS1XR" param = 262 value = bereik SysEx hm, CHR$(&HF0,&H18,4,Mq.id,3,param MOD 128,param \128,value MOD 128, value \ 128,&HF7) CASE "PROTEUS2000" IF bereik > 12 THEN bereik = 12 SysEx hm, CHR$(&HF0,&H18,&H0F,Mq.id,&H55,264 MOD 128, 264 \ 128,bereik,0, &HF7) CASE "FB01" FOR i = 0 TO 15 SysEx hm, CHR$(&HF0,&H43,16+i,&H15,&H0C,bereik,&HF7) NEXT i END SELECT ELSE Warning FUNCNAME$ + " not implemented for UDP/IP", 10000 END IF END SUB SUB Proteuspatch (Mq AS MidiEquipment, BYVAL kanaal AS WORD, BYVAL patchnumber AS WORD) EXPORT ' changed to allow more EMU synths. ' Mq should be passed as one element from the global Meq() array. ' Now we have support for multiple EMU synths, using individual ID's. LOCAL msb AS BYTE, lsb AS BYTE LOCAL hm AS DWORD IF ISFALSE (kanaal AND &H0F000) THEN hm = hMidiO(HIBYT(kanaal)) SELECT CASE UCASE$(TRIM$(Mq.naam)) CASE "PROTEUS2","PROTEUS3","PROTEUS2XR","PROTEUS3XR","PROTEUS1","PROTEUS1XR" IF patchnumber < 128 THEN ProgChange kanaal, patchnumber ELSE ' 1. set channel SysEx hm, CHR$(&HF0,&H18,4,Mq.id,3,0,2,LOBYT(kanaal),0,&HF7) ' 256 midi basic channel ' enable channel: SysEx hm, CHR$(&HF0,&H18,4,Mq.id,3,0,3,LOBYT(kanaal),0,&HF7) ' lsb param = 0, msb param = 3 ==> 384 ' lsb data = kanaal? , msb data = 0 ' 2. set patch: msb = patchnumber \ 128 lsb = patchnumber MOD 128 SysEx hm, CHR$(&HF0,&H18,4,Mq.id,3,3,2,lsb,msb,&HF7) ' param-value command lsb=3, msb=2 ==> 259, current preset END IF CASE "PROTEUS2000" ' uses CC0/CC32 for bank selection ModeMess kanaal,0,4 'use CMPSR - rom sets, no user sets (then param should be 0) ModeMess kanaal,32,patchnumber \ 128 ' selects the bank ProgChange kanaal,patchnumber MOD 128 ' &H0F is the id. for the Proteus2000 'multimode channel select ' SysEx hm, CHR$(&HF0,&H18,&H0F,Mq.id,&H55,129 MOD 128,129 \ 128,LOBYT(kanaal),0, &HF7) 'lsbparam,msbparam, ' ' multimode channel enable: ' SysEx hm, CHR$(&HF0,&H18,&H0F,Mq.id,&H55,135 MOD 128, 135 \ 128,1,0, &HF7) ' ' set patch: ' SysEx hm, CHR$(&HF0,&H18,&H0F,Mq.id,&H55,130 MOD 128, 130 \ 128,patchnumber MOD 128, patchnumber \ 128, &HF7) CASE "PROCUSSION" IF patchnumber < 128 THEN ProgChange kanaal, patchnumber ELSE ' &H06 is the id. for the Procussion ' set channel SysEx hm, CHR$(&HF0,&H18,&H06,Mq.id,9,0,&B110000,LOBYT(kanaal),0,&HF7) ' enable channel: SysEx hm, CHR$(&HF0,&H18,&H06,Mq.id,9,69,&B1100000 OR LOBYT(kanaal),0, 1, 0, &HF7) ' select kit: SysEx hm, CHR$(&HF0,&H18,&H06,Mq.id,9,64,&B1100000 OR LOBYT(kanaal), patchnumber MOD 128, patchnumber \ 128, &HF7) END IF END SELECT ELSE Warning FUNCNAME$ + " not implemented under UDP/IP", 10000 END IF END SUB SUB ProtOFF (Mq AS MidiEquipment, BYVAL k AS WORD) EXPORT LOCAL msb%, lsb% LOCAL hm AS DWORD IF ISFALSE (k AND &H0F000) THEN hm = hMidiO(HIBYT(k)) SELECT CASE UCASE$(TRIM$(Mq.naam)) CASE "PROTEUS2","PROTEUS3","PROTEUS2XR","PROTEUS3XR" msb% = (384 + LOBYT(k)) \128 lsb% = (384 + LOBYT(k)) MOD 128 SysEx hm, CHR$(&HF0,&H18,4,Mq.id,3,lsb%,msb%,0,0,&HF7) CASE "PROTEUS2000" SysEx hm, CHR$(&HF0,&H18,&H0F,Mq.id,&H55,129 MOD 128,129 \ 128,LOBYT(k),0, &HF7) ' multimode channel enable: SysEx hm, CHR$(&HF0,&H18,&H0F,Mq.id,&H55,135 MOD 128, 135 \ 128,0,0, &HF7) CASE "PROCUSSION" ' disable channel: SysEx hm, CHR$(&HF0,&H18,&H06,Mq.id,9,69,&B1100000 OR LOBYT(k),0, 0, 0, &HF7) END SELECT ELSE Warning FUNCNAME$ + " not implemented under UDP/IP", 10000 END IF END SUB SUB ProtON (Mq AS MidiEquipment, BYVAL k AS WORD) EXPORT LOCAL msb%,lsb% LOCAL hm AS DWORD IF ISFALSE (k AND &H0F000) THEN hm = hMidiO(HIBYT(k)) SELECT CASE UCASE$(TRIM$(Mq.naam)) CASE "PROTEUS2","PROTEUS3","PROTEUS2XR","PROTEUS3XR" msb% = (384 + LOBYT(k)) \128 lsb% = (384 + LOBYT(k)) MOD 128 SysEx hm, CHR$(&HF0,&H18,4,Mq.id,3,lsb%,msb%,1,0,&HF7) CASE "PROTEUS2000" ' multimode channel select: SysEx hm, CHR$(&HF0,&H18,&H0F,Mq.id,&H55,129 MOD 128,129 \ 128,LOBYT(k),0, &HF7) ' multimode channel enable: SysEx hm, CHR$(&HF0,&H18,&H0F,Mq.id,&H55,135 MOD 128, 135 \ 128,1,0, &HF7) CASE "PROCUSSION" ' enable channel SysEx hm, CHR$(&HF0,&H18,&H06,Mq.id,9,69,&B1100000 OR LOBYT(k),0, 1, 0, &HF7) END SELECT ELSE Warning FUNCNAME$ + " not implemented under UDP/IP", 10000 END IF END SUB SUB ProteusTuning (Mq AS MidiEquipment, BYVAL k AS WORD, BYVAL patch AS WORD, BYVAL tuningnumber AS BYTE) EXPORT LOCAL hm AS DWORD IF ISFALSE (k AND &H0F000) THEN hm = hMidiO(HIBYT(k)) k = LOBYT(k) SELECT CASE UCASE$(TRIM$(Mq.naam)) CASE "PROTEUS2","PROTEUS3","PROTEUS2XR","PROTEUS3XR" ' set basic basic channel: ' parameter = 256 of lsb=0 & msb=2 lsb msb lsb msb SysEx hm, CHR$(&HF0,&H18,4,Mq.id,3,0,2,k,0,&HF7) ' parameter = 259 = current preset = lsb=3 msb=2 SysEx hm, CHR$(&HF0,&H18,4,Mq.id,3,3,2,patch MOD 128,patch \ 128,&HF7) ' set tuning in this preset: ' parameter (127) + value sysex for proteus SysEx hm, CHR$(&HF0,&H18,4,Mq.id,3,&H7F,0,tuningnumber,0,&HF7) CASE "PROTEUS2000" ' this is to be tested!!! ' multimode channel select: SysEx hm, CHR$(&HF0,&H18,&H0F,Mq.id,&H55,129 MOD 128,129 \ 128,k,0, &HF7) ' multimode preset: SysEx hm, CHR$(&HF0,&H18,&H0F,Mq.id,&H55,130 MOD 128, 130 \ 128,patch MOD 128, patch \ 128, &HF7) ' set tuning in this preset: SysEx hm, CHR$(&HF0,&H18,&H0F,Mq.id,&H55,923 MOD 128, 923 \ 128,tuningnumber,0, &HF7) CASE "PROCUSSION" ' not implemented by EMU END SELECT ELSE Warning FUNCNAME$ + " not implemented under UDP/IP", 10000 END IF END SUB SUB BypassTSR24 (BYVAL k AS WORD) EXPORT ' switches TSR24 to bypass. It is a toggle-function! LOCAL hm AS DWORD IF ISFALSE (k AND &H0F000) THEN hm = hMidiO(HIBYT(k)) SysEx hm, CHR$(&HF0, 0, 0, &H10, LOBYT(k), &H40, &H54, &H54, &HF7) ELSE Warning FUNCNAME$ + " not implemented under UDP/IP", 10000 END IF END SUB SUB InitP2M (Pitch2Midi$, BYVAL k AS WORD) EXPORT ' this procedure should initialize the pitch to midi converter. ' Used in and GMT -compositions LOCAL Checksum% LOCAL Sx$ LOCAL hm AS DWORD IF ISFALSE (k AND &H0F000) THEN hm = hMidiO(HIBYT(k)) SELECT CASE UCASE$(Pitch2Midi$) CASE "GI10","ROLAND GI10" ' initialize Roland Pitch to Midi Converter ' set midi-channel: Checksum% = &H80 - ((0 + 0 + 0 + LOBYT(k)) MOD &H80) Sx$ = CHR$(&HF0,&H41,&H10,&H70,&H12,0,0,0,LOBYT(k),Checksum%,&HF7) SysEx hm, Sx$ SetMidiListenChannel BYVAL(k), %True ' new 05.04.2003... ' set bend-range: (set to 1 octave) Checksum% = &H80 - ((0 + 0 + 1 + 2) MOD &H80) Sx$ = CHR$(&HF0,&H41,&H10,&H70,&H12,0,0,1,2,Checksum%,&HF7) SysEx hm, Sx$ ' set poly/mono (set to Mono) Checksum% = &H80 - ((0 + 0 + 2 + 0) MOD &H80) Sx$ = CHR$(&HF0,&H41,&H10,&H70,&H12,0,0,2,0,Checksum%,&HF7) SysEx hm, Sx$ ' set octave shift: (set to normal) Checksum% = &H80 - ((0 + 0 + 3 + &H40) MOD &H80) Sx$ = CHR$(&HF0,&H41,&H10,&H70,&H12,0,0,3,&H40,Checksum%,&HF7) SysEx hm, Sx$ ' set bend Date Thin (ON= reduce data flow) Checksum% = &H80 - ((0 + 0 + 4 + 2) MOD &H80) Sx$ = CHR$(&HF0,&H41,&H10,&H70,&H12,0,0,4,2,Checksum%,&HF7) SysEx hm, Sx$ ' set attack noise filter: (set to ON) Checksum% = &H80 - ((0 + 0 + 5 + 0) MOD &H80) Sx$ = CHR$(&HF0,&H41,&H10,&H70,&H12,0,0,5,0,Checksum%,&HF7) SysEx hm, Sx$ ' set pedal assignment: - not used ' set Touch sensitivity: - set to Fi (most sensitive dynamics) Checksum% = &H80 - ((0 + 0 + 7 + 0) MOD &H80) Sx$ = CHR$(&HF0, &H41,&H10,&H70,&H12,0,0,7,0,Checksum%,&HF7) SysEx hm, Sx$ ' set pick-up sensitivity: - not used (applies only to guitar-input) ' set Master Tune: (set to 440Hz) Checksum% = &H80 - ((0 + 0 + &HE + 0) MOD &H80) Sx$ = CHR$(&HF0,&H41,&H10,&H70,&H12,0,0,&HE,0,Checksum%,&HF7) SysEx hm, Sx$ CASE "CQT2" ' new 30.01.2002 Warning "Change code: use Create_CQT_Control_Task instead in " + FUNCNAME$, 10000 modemess k,33,75 '64 note: must be channel 0 !!! modemess k,34,85 '64 modemess k,35,64 modemess k,36,64 modemess k,37,64 modemess k,38,64 modemess k,39,64 modemess k,40,0 modemess k,41,93 '102 '127 modemess k,42,32 '12 '0 CASE ELSE EXIT SUB END SELECT ELSE SELECT CASE UCASE$(Pitch2Midi$) CASE "GI10","ROLAND GI10" Warning FUNCNAME$ + " not implemented under UDP/IP for this device", 10000 CASE "CQT2" ' new 30.01.2002 Warning "Change code: use Create_CQT_Control_Task instead @" + FUNCNAME$, 10000 modemess k,33,75 '64 note: must be channel 0 !!! modemess k,34,85 '64 modemess k,35,64 modemess k,36,64 modemess k,37,64 modemess k,38,64 modemess k,39,64 modemess k,40,0 modemess k,41,93 '102 '127 modemess k,42,32 '12 '0 CASE ELSE EXIT SUB END SELECT END IF END SUB ' delay procedures: added 02.01.2000: SUB ClearDelayArrays EXPORT REDIM DelayTimeArray (0) AS GLOBAL DWORD ' mapped on push button REDIM DelayNoteArray (0) AS GLOBAL WORD ' word is enough END SUB SUB WriteDelayLine (BYVAL noot AS BYTE, BYVAL velo AS BYTE) EXPORT ' this procedure receives note information and stores it in a delay line with millisecond time values. ' it can be retrieved using the function ReadDelayLine ' DelayTimeArray() AS DWORD, DelayNoteArray() AS WORD these are and have to be global in the dll. STATIC oldtim AS DWORD STATIC init AS BYTE LOCAL nt AS WORD LOCAL Pt AS DWORD LOCAL tim AS DWORD IF ISFALSE noot THEN EXIT SUB ' should'nt happen IF ISFALSE init THEN ClearDelayArrays init = %True END IF Pt = UBOUND(DelayNoteArray) + 1 ' note that we start recording at position 1, not 0 REDIM PRESERVE DelayTimeArray(Pt) AS GLOBAL DWORD ' these are global - max.256kByte each REDIM PRESERVE DelayNoteArray(Pt) AS GLOBAL WORD ' note that these arrays grow forever...make sure you have enough memory installed! ' it's a wise idea to erase the arrays from memory if the program does no longer require them. ' A simple call to ClearDelayArrays does the job. nt = nt OR noot SHIFT LEFT nt, 8 nt = nt OR velo tim = timeGetTime ' in ms. IF tim <= oldtim THEN DO INCR tim LOOP UNTIL tim > oldtim END IF DelayNoteArray(Pt)= nt DelayTimeArray(Pt)= tim oldtim = tim END SUB FUNCTION ReadDelayLine (BYVAL ins AS BYTE, BYVAL delaytime AS DWORD, BYVAL speed!) EXPORT AS INTEGER ' [documented in gmt-manual.html] LOCAL i AS LONG LOCAL SizeAr AS WORD LOCAL maxval AS DWORD LOCAL minval AS DWORD LOCAL deltat AS SINGLE LOCAL timenow AS DWORD LOCAL timeuppervalue AS DWORD LOCAL nv?? LOCAL j& STATIC lastpointer() AS WORD STATIC olddelaytime() AS DWORD STATIC timeref() AS SINGLE STATIC init AS DWORD IF ISFALSE init THEN DIM lastpointer(255) AS STATIC WORD ' remember last place read DIM olddelaytime(255) AS STATIC DWORD ' remember delaytime DIM timeref(255) AS STATIC SINGLE init = %True END IF SizeAr = UBOUND(DelayTimeArray) ' its a dynamic array, so this changes... IF SizeAr < 1 THEN FUNCTION = %NotFalse : EXIT FUNCTION ' for debug: 'STATIC oldsize AS WORD 'IF SizeAr <> oldsize THEN MSGBOX STR$(SizeAr): oldsize = SizeAr ' o.k. maxval = DelayTimeArray(SizeAr) ' store limits of the available timeframe minval = DelayTimeArray(1) ' time for first note recorded. ' was (0) - must have been bug before 03.01.2000 timenow = timeGetTime 'GetTickCount() ' store time now in ms. - must be dword, was single ' the recorded timeframe is now : maxval - minval, in milliseconds. IF (delaytime = 0) OR (speed!=0!) THEN ' reset static variables for this instance lastpointer(ins) = %False olddelaytime(ins) = %False timeref(ins) = %False FUNCTION = %False EXIT FUNCTION END IF IF delaytime <> olddelaytime(ins) THEN ' a new value for the delaytime causes a restart of the read-out procedure at the ' delaytime given as a parameter. The timefactor (speed!), if different from 1, ' will only be applied from any further reads on. timeuppervalue = timenow - delaytime ' this is the point where reads should stop. ' make sure we do not attempt to read before the delay line ' contains information older than the requested delay time... IF timeuppervalue < minval THEN IF speed! > 0 THEN FUNCTION = %NotFalse EXIT FUNCTION ELSE ' if we do a backwards read, we can set the delaytime to the first recorded value ' automatically: timeuppervalue = minval delaytime = timenow - minval END IF END IF IF speed! >= 0! THEN ' normal forwards reading ARRAY SCAN DelayTimeArray(), > timeuppervalue, TO i ' note that i is always index + 1 timeref(ins) = timenow IF i <= 2 THEN FUNCTION = %NotFalse EXIT FUNCTION ' else we risk a system crash!!! ELSE lastpointer(ins) = i ' this is where a next read should start DECR i ' this is where we have a note to return now olddelaytime(ins) = delaytime ' next time we do not have to scan the entire array FUNCTION = DelayNoteArray(i) EXIT FUNCTION END IF ELSE ' for backwards reading, the first call always starts now. i = SizeAr timeref(ins) = timenow lastpointer(ins)= SizeAr - 1 olddelaytime(ins) = delaytime ' we have to find the first note-off from now on: DO nv?? = DelayNoteArray(i) DECR i IF i < 0 THEN FUNCTION = %NotFalse : EXIT FUNCTION LOOP UNTIL LOBYT (nv??) = %False ' (nv?? AND &H007F) = %False ' was bug: we had LOWRD !!! lastpointer(ins) = i ' now we have to invert note-on and note offs... ' ingeval er een note off staat, gaan we kijken op vroegere ' plekken of er binnen het trajekt beperkt door delaytime ' een overeenkomstige note on was. ' Is dit het geval dan gebruiken we de erbij horen velocity ' als note ON velo waarde in lsb j& = i :' -1 ? DO IF (DelayNoteArray(j&) AND &H7F00)= (nv?? AND &H7F00) THEN nv?? = (nv?? AND &H7F00) OR (DelayNoteArray(j&) AND &H007F) FUNCTION = nv?? EXIT FUNCTION 'EXIT DO END IF DECR j& LOOP UNTIL j& = 0 FUNCTION = %NotFalse EXIT FUNCTION END IF ELSE ' in this case the function will return all values not yet read as found in the delay line. ' For playback speed modulation we apply the time factor (speed!) here. SELECT CASE speed! CASE < -1! ' in this case we read backwards, starting from now, but at a faster speed. ' the reads stop when the delaypoint is reached. ' The function then returns -3 deltat = (timenow - timeref(ins)) ' this counts backwards timeuppervalue = timenow - (deltat + deltat*(ABS(speed!))) IF timeuppervalue < timeref(ins) - delaytime THEN ' end reached. FUNCTION = -3 EXIT FUNCTION END IF FOR i = lastpointer(ins) TO %False STEP -1 IF DelayTimeArray(i) > timeuppervalue THEN lastpointer(ins)= i -1 nv?? = DelayNoteArray(i) ' now we have to invert note-on and note offs... SELECT CASE nv?? AND &H007F CASE %False ' ingeval er een note off staat, gaan we kijken op vroegere ' plekken of er binnen het trajekt beperkt door delaytime ' een overeenkomstige note on was. ' Is dit het geval dan gebruiken we de erbij horen velocity ' als note ON velo waarde in lsb j& = i -1 DO IF (DelayNoteArray(j&) AND &H7F00)= (nv?? AND &H7F00) THEN nv?? = (nv?? AND &H7F00) OR (DelayNoteArray(j&) AND &H007F) FUNCTION = nv?? EXIT FUNCTION EXIT DO END IF DECR j& LOOP UNTIL j& = 0 CASE ELSE ' wanneer we een note-on kommando krijgen, moeten we nu een ' note off uitsturen. In principe moeten we nagaan, of die noot ' binnen deze procedure ook wel ooit werd aangezet. Aangezien ' een overbodige note-off echter niet erg schadelijk is (???) ' bezuiningen we hier wat op de rekentijd, en zoeken we niks op... nv?? = nv?? AND &H7F00 FUNCTION = nv?? EXIT FUNCTION END SELECT FUNCTION = %NotFalse EXIT FUNCTION ELSE lastpointer(ins) = i FUNCTION = %NotFalse EXIT FUNCTION END IF NEXT i CASE -1! ' in this case we read backwards, starting from now ' the reads stops when the delaypoint is reached. ' The function then returns -3 deltat = timenow - timeref(ins) timeuppervalue = timenow - (2 * deltat) :' dit telt achteruit IF timeuppervalue < timeref(ins) - delaytime THEN ' end reached. FUNCTION = -3 EXIT FUNCTION END IF FOR i = lastpointer(ins) TO %False STEP -1 IF DelayTimeArray(i) > timeuppervalue THEN lastpointer(ins)= i -1 nv?? = DelayNoteArray(i) ' now we have to invert note-on and note offs... SELECT CASE nv?? AND &H007F CASE %False ' ingeval er een note off staat, gaan we kijken op vroegere ' plekken of er binnen het trajekt beperkt door delaytime ' een overeenkomstige note on was. ' Is dit het geval dan gebruiken we de erbij horen velocity ' als note ON velo waarde in lsb j& = i -1 DO IF (DelayNoteArray(j&) AND &H7F00)= (nv?? AND &H7F00) THEN nv?? = (nv?? AND &H7F00) OR (DelayNoteArray(j&) AND &H007F) FUNCTION = nv?? EXIT FUNCTION EXIT DO END IF DECR j& LOOP UNTIL j& = 0 CASE ELSE ' wanneer we een note-on kommando krijgen, moeten we nu een ' note off uitsturen. In principe moeten we nagaan, of die noot ' binnen deze procedure ook wel ooit werd aangezet. Aangezien ' een overbodige note-off echter niet erg schadelijk is (???) ' bezuiningen we hier wat op de rekentijd, en zoeken we niks op... nv?? = nv?? AND &H7F00 FUNCTION = nv?? EXIT FUNCTION END SELECT FUNCTION = %NotFalse EXIT FUNCTION ELSE lastpointer(ins) = i FUNCTION = %NotFalse EXIT FUNCTION END IF NEXT i CASE < 0! ' in this case we read backwards, starting from now, but at a slower speed. ' the reads stop when the delaypoint is reached.( if ever...) ' The function then returns -3 deltat = (timenow - (timeref(ins))) timeuppervalue = timenow - (deltat + (deltat * (ABS(speed!)))) :' dit telt achteruit IF timeuppervalue < timeref(ins) - delaytime THEN ' end reached. FUNCTION = -3 EXIT FUNCTION END IF FOR i = lastpointer(ins) TO %False STEP -1 IF DelayTimeArray(i) > timeuppervalue THEN lastpointer(ins)= i -1 nv?? = DelayNoteArray(i) SELECT CASE nv?? AND &H007F CASE %False j& = i -1 DO IF (DelayNoteArray(j&) AND &H7F00)= (nv?? AND &H7F00) THEN nv?? = (nv?? AND &H7F00) OR (DelayNoteArray(j&) AND &H007F) FUNCTION = nv?? EXIT FUNCTION EXIT DO END IF DECR j& LOOP UNTIL j& = 0 CASE ELSE nv?? = nv?? AND &HFF00 FUNCTION = nv?? EXIT FUNCTION END SELECT FUNCTION = %NotFalse EXIT FUNCTION ELSE lastpointer(ins) = i FUNCTION = %NotFalse EXIT FUNCTION END IF NEXT i CASE 0! timeref(ins) = timenow CASE < 1! 'deltat = timenow - timeref(instance) :'objective time since first call timeuppervalue = timenow - delaytime FOR i = lastpointer(ins) TO SizeAr IF DelayTimeArray(i)+ ((DelayTimeArray(i) - timeref(ins))*speed!) < timeuppervalue THEN lastpointer(ins) = i + 1 FUNCTION = DelayNoteArray(i) EXIT FUNCTION ELSE lastpointer(ins) = i FUNCTION = %NotFalse :' end of timelimit is reached... EXIT FUNCTION END IF NEXT i CASE 1! ' first calculate the timevalue where reading should stop timeuppervalue = timenow - delaytime ' following check should not be necessary now... IF timeuppervalue < minval THEN FUNCTION = %NotFalse: EXIT FUNCTION ' then, find the pointer... FOR i = lastpointer(ins) TO SizeAr IF DelayTimeArray(i) < timeuppervalue THEN lastpointer(ins) = i + 1 FUNCTION = DelayNoteArray(i) ELSE lastpointer(ins) = i FUNCTION = %NotFalse :' end of timelimit is reached... END IF EXIT FUNCTION NEXT i CASE > 1! 'deltat = timenow - timeref(ins) :'objective time since first call timeuppervalue = timenow - delaytime FOR i = lastpointer(ins) TO SizeAr SELECT CASE DelayTimeArray(i)- ((DelayTimeArray(i) - timeref(ins))*(speed!-1!)) CASE < DelayTimeArray(lastpointer(ins)), > maxval ' we cannot go faster than real-time..., so we should stop the delay-read ' we should reset the delay line! olddelaytime(ins) = %False timeref(ins) =timenow - delaytime ' this causes autorestarting ' unless the calling procedure uses the -2 value returned by ' the function, to reset the delayline. FUNCTION = -2 EXIT FUNCTION CASE < timeuppervalue lastpointer(ins) = i + 1 FUNCTION = DelayNoteArray(i) EXIT FUNCTION CASE ELSE lastpointer(ins) = i FUNCTION = %NotFalse ' end of timelimit for reading is reached... EXIT FUNCTION END SELECT NEXT i END SELECT END IF END FUNCTION ' midi-in procedures:--------------------------------------------------------- FUNCTION OpenMidiInputDevice (BYVAL devicenumber AS LONG) EXPORT AS DWORD ' opens an existing device and returns a handle ' redimensions also the required input buffers. ' bugs removed 21.07.2004 ! LOCAL retval AS DWORD LOCAL hM AS DWORD ' handle for opened midi device STATIC nrOpenMidiInPorts AS WORD STATIC Init AS DWORD IF ISFALSE Init THEN 'REDIM hMidiI(0) AS GLOBAL DWORD 'MSGBOX "redim mibuf " + STR$(UBOUND(hMidiI)) 'REDIM MiBuf(UBOUND(hMidiI)) AS GLOBAL STRING * %MidiBuffer ' removed 23.07.2004 ' we now have as many buffers dimmed as we have midi ports on the pc. nrOpenMidiInPorts = %False Init = %True END IF FUNCTION = %False ' sofar we support midi-sysex reception only for a single midiport.... ' even if no sysex is required we prepare the pointers to avoid nul-pointer at closing ' or staring up the application [07.02.2002] ' IF ISFALSE SxThread.pSXbuf THEN IF ISFALSE SxThread.h THEN ' now first prepare buffers and header before starting midi-in! ' this took us a long time to figure out... ' without doing this, its impossible to receive sysex's. ' prepare double buffers: SxB0 = STRING$(%SysExBuffer, 0) ' 29.10.99 SxB1 = STRING$(%SysExBuffer, 0) ' 29.10.99 ' also make sure we prepare the thread structure: SxThread.pSXbuf = VARPTR(SxB1) ' set to secondary buffer MidiSXHdr0.lpdata = VARPTR(SxB0) MidiSXHdr0.dwBufferlength = LEN(SxB0) MidiSXHdr0.dwFlags = %False MidiSXHdr0.dwUser = %False END IF INCR nrOpenMidiInPorts tryagain: retval = midiInOpen (hM, devicenumber, CODEPTR(MidiProc),nrOpenMidiInPorts, %CALLBACK_FUNCTION OR %MIDI_IO_STATUS) ' we display possible error codes in this case: SELECT CASE retval CASE %MMSYSERR_NOERROR ' the flags in SxThread.flags are read from the ini-file IF ISFALSE BIT(SxThread.flags,%SYSEX_BLOCK) THEN retval = MSGBOX("Enable sysex reception for this port ?",%MB_YESNO OR %MB_ICONQUESTION OR %MB_DEFBUTTON2 OR %MB_APPLMODAL,"-Midi proc") SELECT CASE retval CASE %IDYES ' here we check whether a thread is not already running... IF ISFALSE SxThread.h THEN retval = midiInPrepareHeader (hM, MidiSXHdr0,SIZEOF(MidiSXHdr0)) IF retval <> %MMSYSERR_NOERROR THEN ReportMidiError retval EXIT FUNCTION ELSE retval = midiInAddBuffer (hM, MidiSXHdr0, SIZEOF(MidiSXHdr0)) retval = midiInStart (hM) IF retval <> %MMSYSERR_NOERROR THEN ReportMidiError retval DECR nrOpenMidiInPorts ' check this!!! EXIT FUNCTION ELSE ' ???? here we had a very stupid bug,... ' how come it ever worked ??? (bug killed 21.07.2004-gwr) 'REDIM PRESERVE hMidiI(nrOpenMidiInPorts -1) AS GLOBAL STRING * %MidiBuffer '22.07 REDIM PRESERVE hMidiI(nrOpenMidiInPorts -1) AS GLOBAL DWORD 'GLOBAL STRING * %MidiBuffer '23.07 MSGBOX STR$(nropenmidiinports - 1),,FUNCNAME$ + ".0" '23.07 REDIM PRESERVE MiBuf(nrOpenMidiInPorts -1) AS GLOBAL STRING * %MidiBuffer ClearMiBuf nrOpenMidiInPorts - 1 ' should clear buffer 0 SxThread.h = hM '05.10.2006 removed StartSysexThread here ' we left all peparations, so the function can be called from within a user application ' without bothering the ser with buffer preparation etc.. ' StartSysExThread SxThread ' procedure in DLL hMidiI(nrOpenMidiInPorts -1) = hM FUNCTION = hM EXIT FUNCTION END IF END IF ELSE Warning "SysEx thread already running in" + FUNCNAME$, 10000 ' start midi-in with existing sysex reception thread. ' the midiproc. will send all sysex from all ports to the buffers. retval = midiInStart (hM) IF retval <> %MMSYSERR_NOERROR THEN ReportMidiError retval DECR nrOpenMidiInPorts EXIT FUNCTION ELSE ' MSGBOX STR$(nropenmidiinports - 1),,FUNCNAME$ + ".1" '22.07 REDIM PRESERVE hMidiI(nrOpenMidiInPorts -1) AS GLOBAL DWORD 'STRING * %MidiBuffer '23.07 REDIM PRESERVE MiBuf(nrOpenMidiInPorts -1) AS GLOBAL STRING * %MidiBuffer ClearMiBuf nrOpenMidiInPorts -1 hMidiI(nrOpenMidiInPorts -1) = hM FUNCTION = hM END IF END IF CASE %IDNO ' ' MSGBOX "open new midiport",,FUNCNAME$ ' ' start midi-in without sysex reception. retval = midiInStart (hM) IF retval <> %MMSYSERR_NOERROR THEN ReportMidiError retval DECR nrOpenMidiInPorts EXIT FUNCTION ELSE ' MSGBOX STR$(nropenmidiinports - 1),,FUNCNAME$ + ".2" '22.07 REDIM PRESERVE hMidiI(nrOpenMidiInPorts -1) AS GLOBAL DWORD 'STRING * %MidiBuffer '23.07 REDIM PRESERVE MiBuf(nrOpenMidiInPorts -1) AS GLOBAL STRING * %MidiBuffer ClearMiBuf nrOpenMidiInPorts -1 hMidiI(nrOpenMidiInPorts -1) = hM FUNCTION = hM END IF ' ' MSGBOX "nr of open ports:" + STR$(UBOUND(hMidiI)),,FUNCNAME$ ' END SELECT ELSE ' start midi-in without sysex reception. retval = midiInStart (hM) IF retval <> %MMSYSERR_NOERROR THEN ReportMidiError retval DECR nrOpenMidiInPorts EXIT FUNCTION ELSE '23.07 REDIM PRESERVE MiBuf(nrOpenMidiInPorts -1) AS GLOBAL STRING * %MidiBuffer '22.07 ' REDIM PRESERVE hMidiI(nrOpenMidiInPorts -1) AS GLOBAL DWORD ' added 21.07.2004 ClearMiBuf nrOpenMidiInPorts -1 hMidiI(nrOpenMidiInPorts -1) = hM FUNCTION = hM END IF END IF CASE %MMSYSERR_ALLOCATED IF hM THEN retval = MidiInClose (hM) GOTO Tryagain ' we risk an endless loop here... ELSE ReportMidiError retval DECR nrOpenMidiInPorts EXIT FUNCTION END IF CASE ELSE ReportMidiError retval ' dll procedure DECR nrOpenMidiInPorts EXIT FUNCTION END SELECT END FUNCTION FUNCTION MidiProc (BYVAL h AS DWORD, BYVAL wMsg AS LONG, BYVAL dwI AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS DWORD) EXPORT AS LONG 'midi input callback function... called on reception of midi interrupts. 'dwI wordt doorgegeven zoals bepaald bij de opening van de MidiIn callback, in dit geval, 0. ' dwI contains the portnumber. 'Dit kunnen we gebruiken voor de afhandeling van systemen met meerdere midi-in poorten. In dat geval kunnen ' we meerdere instanties van de callback gebruiken. ' Wordt dwI echter wel elke keer doorgegeven ??? 'wMsg bevat de message konstante 'wParam bevat de 2 of 3 midi databytes 'lParam bevat de tijdsinformatie... ' Up to 20.12.2002 we recorded all information from all midi channels. To improve speed, ' we implemented selective listening. ' The midi channels to be recorded (added to MiBuf) have to be set in the new global ListenMask (DWORD) ' bit 0 = channel 0 ' bit 1 = channel 1 etc... ' since 2005, we can support 16 midi ports, thus 256 midi channels. LOCAL StatusByte? LOCAL lpMiHdr AS MIDIHDR PTR ' required for sysex reception LOCAL retval AS LONG LOCAL prt AS LONG ' was DWORD LOCAL k AS DWORD ' midi kanaal ' find the port that sends the message: prt = dwI -1 IF prt < %False THEN EXIT FUNCTION ' ' STATIC INSDBG AS LONG ' IF ISFALSE insdbg THEN ' insdbg = kl_debug 0, "midiproc" ' kl_debug %kl_dbg_logfile, STR$(insdbg) +", midi.log" ' END IF ' FUNCTION = %False SELECT CASE wMsg CASE %MIM_OPEN '&H3C1 FUNCTION = %True CASE %MIM_CLOSE '&H3C2 hMidiI(prt)= %False MiBuf(prt) = STRING$(%MidiBuffer, 255) ' clear midi input data for this port FUNCTION = %True CASE %MIM_DATA ,%MIM_MOREDATA '&H3C3 ' in geval een Moredata message komt, is de tijdsparameter lparam niet ingevuld. StatusByte? = (LOBYT(LOWRD(wParam))) IF StatusByte? < 241 THEN ' the midi channel is now Statusbyte? AND &H0F k = wParam AND &H0F END IF SELECT CASE StatusByte? CASE < 128 ' error condition - this cannot happen... ? running status ??? CASE < 143 ' note off messages are translated into note-on's with velocity %False IF BIT (ListenMask, (k + 16 * prt)) THEN BIT SET StatusByte?, 4 ' 12.12.99 Mibuf(prt) = CHR$(0,HIBYT(LOWRD(wParam)),StatusByte?) + Mibuf(prt) END IF CASE < 192 ' two bytes should follow: note off/ note on / poly aftertouch/ control change ' status &H80, &H90, &HA0, &HB0 IF BIT (ListenMask, (k + 16 * prt)) THEN ' kl_debug insdbg, STR$(prt) + hex$(LOBYT(HIWRD(wParam))) + hex$(LOWRD(wParam)) + STR$(statusbyte) Mibuf(prt) = CHR$(LOBYT(HIWRD(wParam)),HIBYT(LOWRD(wParam)),StatusByte?) + Mibuf(prt) ' warning "pass noot v:" + chr$(LOBYT(HIWRD(wParam))) + " n:" + chr$(HIBYT(LOWRD(wParam))) + " port" + HEX$(prt) ELSE ' warning "skip noot " + chr$(LOBYT(HIWRD(wParam))) + " " + chr$(HIBYT(LOWRD(wParam))) + " port" + HEX$(prt) END IF CASE < 224 ' range 192-207: program change &HC0 ' range 208-223: channel pressure &HD0 ' single byte should follow IF BIT (ListenMask, (k + 16 * prt)) THEN Mibuf(prt) = CHR$(HIBYT(LOWRD(wParam)),StatusByte?) + Mibuf(prt) END IF CASE < 240 ' range 224-239: pitch bend &HE0 IF BIT (ListenMask, (k + 16 * prt)) THEN Mibuf(prt) = CHR$(LOBYT(HIWRD(wParam)),HIBYT(LOWRD(wParam)),StatusByte?) + Mibuf(prt) END IF CASE 241 ' undefined byte MidiStopStartCont prt,%G_SSC_SET,%MIDI_UD241_RECEIVED CASE 242 ' implemented 15.09.2000 ' song position - 2 bytes follow ' we do not store this in the buffer, but update the songposition pointer ' by calling the procedure: retval = LOBYT(HIWRD(wParam)) SHIFT LEFT retval, 7 retval = retval OR HIBYT(LOWRD(wParam)) ' to be checked... SongpositionPointer prt,%G_SPP_SET,retval CASE 243 ' song number - 1 byte follows (selected song after official protocol) ' added 15.09.2000 Mibuf(prt) = CHR$(HIBYT(LOWRD(wParam)),StatusByte?) + Mibuf(prt) CASE 244 MidiStopStartCont prt,%G_SSC_SET,%MIDI_UD244_RECEIVED CASE 245 MidiStopStartCont prt,%G_SSC_SET,%MIDI_UD245_RECEIVED CASE 246 ' tune request MidiStopStartCont prt,%G_SSC_SET,%MIDI_TRQ_RECEIVED ' 247 = EOX cannot happen here ' CASE 248 ' system real time msg. ' following cases added for WSB 15.09.2000 CASE 249 MidiStopStartCont prt,%G_SSC_SET,%MIDI_UD249_RECEIVED CASE 250 MidiStopStartCont prt,%G_SSC_SET,%MIDI_START_RECEIVED CASE 251 MidiStopStartCont prt,%G_SSC_SET,%MIDI_CONT_RECEIVED CASE 252 MidiStopStartCont prt,%G_SSC_SET,%MIDI_STOP_RECEIVED ' MiBuf(prt) = CHR$(StatusByte?) + Mibuf(prt) ' 250 = midi start ' 251 = midi cont ' 252 = midi stop ' no need to store this in the buffer... CASE 253 MidiStopStartCont prt,%G_SSC_SET,%MIDI_UD253_RECEIVED ' CASE 254 ' midi clock - disregard! CASE 255 ' system reset - added 20.12.2002 ' this clears the secondary midi input buffer. ClearMiBuf prt ' CASE ELSE 'BEEP END SELECT FUNCTION = %True CASE %MIM_LONGDATA, %MM_MIM_LONGDATA ' we receive all sysex in the same thread regardless the port they originate from... IF BIT(SxThread.flags,%SYSEX_BLOCK) THEN EXIT FUNCTION ' here sysex reception is handled. ' Use our function GetSysEx, to retrieve the data. ' We use a thread to check the data. THREAD STATUS SxThread.id TO retval IF retval = &H103 THEN THREAD SUSPEND SxThread.id TO retval ' IF retval = -1 THEN MSGBOX "Error with SX thread" END IF lpMiHdr = wParam 'pointer to the midiSysex buffer just filled. INCR SxThread.cnt 'lparam = dwTimeStamp, in milliseconds since midiInStart. - not used here. ' o.k: SetDlgItemText hCockpit, %GMT_TEXT0_ID + 11, STR$(lparam) & STR$(@lpMiHdr.dwbytesrecorded) ' SetDlgItemText hCockpit, %GMT_TEXT0_ID + 11, GetSysEx(hmi,@lpMiHdr) & CHR$(0) ' double buffer code using SxB0 and SxB1 ' first we set the pointers so that the SxThread can retrieve the data: SxThread.length = @lpMiHdr.dwBytesRecorded 'copy the data to the secondary buffer: SxB1 = PEEK$(@lpMiHdr.lpdata, @lpMiHdr.dwBytesRecorded) SxThread.pSXbuf = VARPTR(SxB1) ' constant, so we do not have to do this... IF SxThread.id THEN THREAD RESUME SxThread.id TO retval ' the copy of the received buffer to SxB happens in the thread code. END IF ' this buffer could be unprepared in the thread. ' try doing it here: [ this maybe what causes the crashes... ] @lpMiHdr.dwflags = %False ' following changed 08.06.2002: 'retval = midiInUnprepareheader (hMidiI(dwI),@lpMiHdr, SIZEOF(MidiSXHdr0)) 'retval = midiInPrepareHeader (hMidiI(dwI), @lpMiHdr, SIZEOF(MidiSXHdr0)) 'retval = midiInAddBuffer (hMidiI(dwI), @lpMiHdr, SIZEOF(MidiSXHdr0)) ' new: retval = midiInUnprepareheader (SxThread.h,@lpMiHdr, SIZEOF(MidiSXHdr0)) retval = midiInPrepareHeader (SxThread.h, @lpMiHdr, SIZEOF(MidiSXHdr0)) retval = midiInAddBuffer (SxThread.h, @lpMiHdr, SIZEOF(MidiSXHdr0)) EXIT FUNCTION CASE %MIM_ERROR '&H3C5 ' MSGBOX "%MIM_ERROR" ' SLEEP 20000 FUNCTION = %True CASE %MIM_LONGERROR ' MSGBOX "%MIM_LONGERROR" ' SLEEP 20000 FUNCTION = %True 'CASE ELSE ' MSGBOX "Strange midi message received in callback" & STR$(wMsg) & STR$(lparam) & STR$(wparam) ' SLEEP 20000 END SELECT ' ' kl_debug dbgins, "exit " + FUNCNAME$ ' END FUNCTION SUB ClearMiBuf (BYVAL mport AS WORD) EXPORT IF mport > UBOUND(hMidiI) THEN EXIT SUB IF mport > UBOUND(MiBuf) THEN EXIT SUB ' added 22.07.2004 - no longer required 23.07.2004 MiBuf(mport) = STRING$(%MidiBuffer, 255) ' clear midi input data for this port IF ISFALSE mport THEN SxB0 = STRING$(%SysExBuffer,0) ' clear sysex receive buffers. SxB1 = STRING$(%SysExBuffer,0) END IF END SUB SUB Clear_MidiListenTask () EXPORT ' this procedure is normally called by its code pointer placed in TaskEx.StopCptr for tasks ' defined as midi listentask. ' We cannot pass a parameter and thus we have to limit ourselves to the ' %ppListenTask here... LOCAL prt AS WORD prt = HIBYT(@pTask(%ppListen).channel) ClearMiBuf prt END SUB '---------------------------- Midi real time input functions ---------------------------------- FUNCTION GetProgChange (BYVAL k AS WORD, BYVAL flags AS INTEGER) EXPORT AS INTEGER ' to support multiport midi-in, we use k to contain the port in the hibyt and channel ' in the lobyt. LOCAL buf$ LOCAL Msb??, Lsb? LOCAL pt% LOCAL lbuf AS WORD FUNCTION = %NotFalse buf$ = EXTRACT$(Mibuf(HIBYT(k)),CHR$(255)) ' returns the part of the buffer before the CHR$(255) delimiter. lbuf = LEN(buf$) IF lbuf <2 THEN EXIT FUNCTION pt% = INSTR(SGN(flags),buf$,CHR$(192 OR LOBYT(k))) ' looks forward or backward... IF pt% < 2 THEN EXIT FUNCTION FUNCTION = ASC(MID$(buf$,pt%-1,1)) IF ISFALSE BIT(Flags,1) THEN EXIT FUNCTION ELSE Mibuf(HIBYT(k)) = LEFT$(buf$,pt% -3) + RIGHT$(buf$,lbuf - pt%)+ CHR$(255) END IF END FUNCTION '------------------------------------------------------------- FUNCTION GetController (BYVAL k AS WORD, BYVAL c?,BYVAL flags AS INTEGER) EXPORT AS INTEGER ' this must have a bug, in that it does not return -1 !!! LOCAL buf$ LOCAL Msb??, Lsb? LOCAL pt% LOCAL lbuf AS WORD FUNCTION = %NotFalse buf$ = EXTRACT$(Mibuf(HIBYT(k)),CHR$(255)) ' returns the part of the buffer before the CHR$(255) delimiter. lbuf = LEN(buf$) IF lbuf < 3 THEN EXIT FUNCTION pt% = INSTR(SGN(flags),buf$,CHR$(c?,176 OR LOBYT(k))) ' looks forwards or backwards ' STATIC INSDBG AS LONG ' IF ISFALSE insdbg THEN ' insdbg = kl_debug 0, funcname$ ' kl_debug %kl_dbg_logfile, STR$(insdbg) +", midi.log" ' END IF IF SGN(flags) = %Newest THEN IF pt% < 2 THEN EXIT FUNCTION ' kl_debug insdbg, "ch: " + hex$(k) + " val:" + str$(asc(mid$(buf$, pt%-1,1))) FUNCTION = ASC(MID$(buf$,pt%-1,1)) ' note that pointer points to c? !!! IF ISFALSE BIT(flags,1) THEN EXIT FUNCTION ELSE Mibuf(HIBYT(k)) = LEFT$(buf$,pt% -2) + RIGHT$(buf$,lbuf - pt%)+ CHR$(255) END IF ELSE ' oldest case... IF pt% < 3 THEN EXIT FUNCTION ' kl_debug insdbg, "ch: " + HEX$(k) + " val:" + STR$(ASC(MID$(buf$, pt%-1,1))) FUNCTION = ASC(MID$(buf$,pt%-1,1)) ' -1 would return c? !!! IF ISFALSE BIT(flags,1) THEN EXIT FUNCTION ELSE 'was bug - corrected 040805 kl Mibuf(HIBYT(k)) = REMOVE$(Mibuf(HIBYT(k)), CHR$(MID$(buf$,pt%-1,1),c?,176 OR LOBYT(k))) '& CHR$(255) END IF END IF END FUNCTION '---------------------------------------------------------- FUNCTION GetAfterTouch (BYVAL k AS WORD, BYVAL flags AS INTEGER) EXPORT AS INTEGER LOCAL buf$ LOCAL Msb??, Lsb? LOCAL pt% LOCAL lbuf AS WORD FUNCTION = %NotFalse buf$ = EXTRACT$(Mibuf(HIBYT(k)),CHR$(255)) ' returns the part of the buffer before the CHR$(255) delimiter. lbuf = LEN(buf$) IF lbuf <2 THEN EXIT FUNCTION pt% = INSTR(SGN(flags),buf$,CHR$(208 OR LOBYT(k))) ' looks forwards! IF pt% < 2 THEN EXIT FUNCTION Lsb? = ASC(MID$(buf$,pt%-1,1)) FUNCTION = Lsb? IF ISFALSE BIT(flags,1) THEN EXIT FUNCTION ELSE Mibuf(HIBYT(k)) = LEFT$(buf$,pt% -2) + RIGHT$(buf$,lbuf - pt%)+ CHR$(255) END IF END FUNCTION FUNCTION SongPositionPointer (BYVAL mprt AS WORD,BYVAL flags AS WORD,BYVAL value AS WORD) EXPORT AS WORD ' new 15.09.2000 - html manual updated! -used in wsb-server ' to set/reset the songpositionpointer call the function as a sub: ' SongPositionPointer midiportnr, %G_SPP_SET, value ' if you want to set it to a new value and retrieve the old value: ' oldvalue = SongPositionPointer (midiportnr,%G_SPP_SET,newvalue) ' To retrieve the latest pointer value code as: ' value = SongPositionPointer (midiportnr, %G_SPP_GET, %False) ' The songpositionpointervalues are set from within the midi-in callback, but ' can be reset/set by the user. STATIC tog AS LONG STATIC Spp() AS WORD IF ISFALSE tog THEN DIM Spp(15) AS STATIC WORD tog = %True END IF SELECT CASE flags CASE %G_SPP_SET ' = %False FUNCTION = Spp(mprt) ' so the function returns the old value Spp(mprt)= value ' save the new value EXIT FUNCTION CASE %G_SPP_GET ' = %True FUNCTION = Spp(mprt) END SELECT END FUNCTION FUNCTION MidiStopStartCont (BYVAL mprt AS WORD, BYVAL flags AS WORD,BYVAL value AS WORD) EXPORT AS WORD ' new 15.09.2000 - html manual updated! ' flags can only be: ' %G_SSC_SET or %G_SSC_GET ' value must be one of the declared constants: (bit positions!) ' %MIDI_STOP_RECEIVED = bit 0 ' %MIDI_START_RECEIVED = bit 1 ' %MIDI_CONT_RECEIVED = bit 2 ' %False ' as well as: ' %MIDI_UD241_RECEIVED these are undefined in the midi standard. ' %MIDI_UD244_RECEIVED ' %MIDI_UD245_RECEIVED ' %MIDI_UD249_RECEIVED ' %MIDI_UD253_RECEIVED STATIC tog AS LONG STATIC Ssc() AS WORD IF ISFALSE tog THEN DIM Ssc(15) AS STATIC WORD tog = %True END IF SELECT CASE flags CASE %G_SSC_SET ' = %False FUNCTION = Ssc(mprt) ' so the function returns the old/previous value SELECT CASE value CASE %False ' resets all flags Ssc(mprt) = %False CASE %MIDI_STOP_RECEIVED ' these toggle each other, preserving other flags BIT SET Ssc(mprt),0 BIT RESET Ssc(mprt),1 BIT RESET Ssc(mprt),2 CASE %MIDI_START_RECEIVED BIT RESET Ssc(mprt),0 BIT SET Ssc(mprt),1 BIT RESET Ssc(mprt),2 CASE %MIDI_CONT_RECEIVED BIT RESET Ssc(mprt),0 BIT RESET Ssc(mprt),1 BIT SET Ssc(mprt),2 CASE %MIDI_TRQ_RECEIVED BIT SET Ssc(mprt),3 ' these flags can only be individually reset by your application. CASE %MIDI_UD241_RECEIVED BIT SET Ssc(mprt),4 CASE %MIDI_UD244_RECEIVED BIT SET Ssc(mprt),5 CASE %MIDI_UD245_RECEIVED BIT SET Ssc(mprt),6 CASE %MIDI_UD249_RECEIVED BIT SET Ssc(mprt),7 CASE %MIDI_UD253_RECEIVED BIT SET Ssc(mprt),8 END SELECT EXIT FUNCTION CASE %G_SSC_GET ' = %True FUNCTION = Ssc(mprt) CASE %G_SSC_GETANDRESET ' = %Remove ' you have to pass the flag to reset via the value parameter FUNCTION = Ssc(mprt) SELECT CASE value CASE %False ' resets all flags Ssc(mprt) = %False CASE %MIDI_STOP_RECEIVED BIT RESET Ssc(mprt),0 CASE %MIDI_START_RECEIVED BIT RESET Ssc(mprt),1 CASE %MIDI_CONT_RECEIVED BIT RESET Ssc(mprt),2 CASE %MIDI_TRQ_RECEIVED BIT RESET Ssc(mprt),3 CASE %MIDI_UD241_RECEIVED BIT RESET Ssc(mprt),4 CASE %MIDI_UD244_RECEIVED BIT RESET Ssc(mprt),5 CASE %MIDI_UD245_RECEIVED BIT RESET Ssc(mprt),6 CASE %MIDI_UD249_RECEIVED BIT RESET Ssc(mprt),7 CASE %MIDI_UD253_RECEIVED BIT RESET Ssc(mprt),8 END SELECT END SELECT END FUNCTION FUNCTION GetSongSelect (BYVAL mprt AS WORD, BYVAL flags AS INTEGER) EXPORT AS INTEGER ' 15.09.2000 - no channel info! - so no packing of port number required. ' msg is 243 followed with a single 7-bit byte. LOCAL buf$ LOCAL Msb??, Lsb? LOCAL pt% LOCAL lbuf AS WORD FUNCTION = %NotFalse buf$ = EXTRACT$(Mibuf(mprt),CHR$(255)) ' returns the part of the buffer before the CHR$(255) delimiter. lbuf = LEN(buf$) IF lbuf <2 THEN EXIT FUNCTION pt% = INSTR(SGN(flags),buf$,CHR$(243)) ' looks forwards! IF pt% < 2 THEN EXIT FUNCTION Lsb? = ASC(MID$(buf$,pt%-1,1)) FUNCTION = Lsb? IF ISFALSE BIT(flags,1) THEN EXIT FUNCTION ELSE Mibuf(mprt) = LEFT$(buf$,pt% -2) + RIGHT$(buf$,lbuf - pt%)+ CHR$(255) END IF END FUNCTION FUNCTION GetPressure (BYVAL k AS WORD, BYVAL flags AS INTEGER) EXPORT AS INTEGER ' 3 byte message ! LOCAL buf$ LOCAL Msb??, Lsb? LOCAL pt% LOCAL lbuf AS WORD FUNCTION = %NotFalse buf$ = EXTRACT$(Mibuf(HIBYT(k)),CHR$(255)) ' returns the part of the buffer before the CHR$(255) delimiter. lbuf = LEN(buf$) IF lbuf <3 THEN EXIT FUNCTION pt% = INSTR(SGN(flags),buf$,CHR$(160 OR LOBYT(k))) ' looks forwards or backwards IF pt% < 3 THEN EXIT FUNCTION Msb?? = ASC(MID$(buf$,pt%-1,1)) Lsb? = ASC(MID$(buf$,pt%-2,1)) SHIFT LEFT Msb??,8 FUNCTION = Msb?? OR Lsb? IF ISFALSE BIT(flags,1) THEN EXIT FUNCTION ELSE Mibuf(HIBYT(k)) = LEFT$(buf$,pt% -3) + RIGHT$(buf$,lbuf - pt%)+ CHR$(255) END IF END FUNCTION '---------------------------------------------------------- FUNCTION GetMidiNote (BYVAL k AS WORD, BYVAL flags AS INTEGER) EXPORT AS INTEGER LOCAL buf$ LOCAL Msb??, Lsb? LOCAL pt% LOCAL lbuf AS WORD FUNCTION = %NotFalse buf$ = EXTRACT$(Mibuf(HIBYT(k)),CHR$(255)) ' returns the part of the buffer before the CHR$(255) delimiter. lbuf = LEN(buf$) IF lbuf <3 THEN EXIT FUNCTION pt% = INSTR(SGN(flags),buf$,CHR$(144 OR LOBYT(k))) ' looks forwards or backwards IF pt% < 3 THEN EXIT FUNCTION Msb?? = ASC(MID$(buf$,pt%-1,1)) Lsb? = ASC(MID$(buf$,pt%-2,1)) SHIFT LEFT Msb??,8 FUNCTION = Msb?? OR Lsb? IF ISFALSE BIT(flags,1) THEN EXIT FUNCTION ELSE ' here there is a potential bug, in that the midi callback may overwrite the ' buffer whilst we are rewriting it! Mibuf(HIBYT(k)) = LEFT$(buf$,pt% -3) + RIGHT$(buf$,lbuf - pt%)+ CHR$(255) END IF END FUNCTION FUNCTION GetNoteOff (BYVAL k AS WORD, BYVAL flags AS INTEGER) EXPORT AS INTEGER LOCAL buf$ LOCAL Msb??, Lsb? LOCAL pt% LOCAL lbuf AS WORD FUNCTION = %NotFalse buf$ = EXTRACT$(Mibuf(HIBYT(k)),CHR$(255)) ' returns the part of the buffer before the CHR$(255) delimiter. lbuf = LEN(buf$) IF lbuf <3 THEN EXIT FUNCTION pt% = INSTR(SGN(flags),buf$,CHR$(128 OR LOBYT(k))) ' looks forwards or backwards IF pt% < 3 THEN EXIT FUNCTION Msb?? = ASC(MID$(buf$,pt%-1,1)) Lsb? = ASC(MID$(buf$,pt%-2,1)) SHIFT LEFT Msb??,8 FUNCTION = Msb?? OR Lsb? IF ISFALSE BIT(flags,1) THEN EXIT FUNCTION ELSE ' here there is a potential bug, in that the midi callback may overwrite the ' buffer whilst we are rewriting it! Mibuf(HIBYT(k)) = LEFT$(buf$,pt% -3) + RIGHT$(buf$,lbuf - pt%)+ CHR$(255) END IF END FUNCTION FUNCTION GetControllers (BYVAL k AS WORD, BYVAL flags AS INTEGER) EXPORT AS INTEGER LOCAL buf$ LOCAL Msb??, Lsb? LOCAL pt% LOCAL lbuf AS WORD FUNCTION = %NotFalse buf$ = EXTRACT$(Mibuf(HIBYT(k)),CHR$(255)) ' returns the part of the buffer before the CHR$(255) delimiter. lbuf = LEN(buf$) IF lbuf <3 THEN EXIT FUNCTION pt% = INSTR(SGN(flags),buf$,CHR$(176 OR LOBYT(k))) ' looks forwards or backwards IF pt% < 3 THEN EXIT FUNCTION Msb?? = ASC(MID$(buf$,pt%-1,1)) ' controller number Lsb? = ASC(MID$(buf$,pt%-2,1)) ' controller value SHIFT LEFT Msb??,8 FUNCTION = Msb?? OR Lsb? IF ISFALSE BIT(flags,1) THEN EXIT FUNCTION ELSE Mibuf(HIBYT(k)) = LEFT$(buf$,pt% -3) + RIGHT$(buf$,lbuf - pt%)+ CHR$(255) END IF END FUNCTION '------------------------------------------------------------------ FUNCTION GetPitchBend (BYVAL k AS WORD, BYVAL flags AS INTEGER) EXPORT AS INTEGER ' this returns pitchbendinformation in Cents!!! LOCAL buf$ LOCAL Msb??, Lsb? LOCAL pt% LOCAL lbuf AS WORD LOCAL bendvalue AS INTEGER LOCAL bv AS SINGLE FUNCTION = %NotFalse ' problem!: -1 is a possible value here!!! (09.05.2004) buf$ = EXTRACT$(Mibuf(HIBYT(k)),CHR$(255)) ' returns the part of the buffer before the CHR$(255) delimiter. lbuf = LEN(buf$) IF lbuf <3 THEN EXIT FUNCTION pt% = INSTR(SGN(flags),buf$,CHR$(224 OR LOBYT(k))) ' looks forwards or backwards IF pt% < 3 THEN EXIT FUNCTION 'bug fixed kl 000725 (msb & lsb were swapped before ... 'positive vaues are right now, but we don't get any negative ones... Msb?? = ASC(MID$(buf$,pt%-2,1)) Lsb? = ASC(MID$(buf$,pt%-1,1)) SHIFT LEFT Msb??,8 bendvalue = (Msb?? OR Lsb?) - %d14 ' bipolar 14 bits number bv = %Bendrange * ((100! * bendvalue%) / %d14) FUNCTION = INT(bv) IF ISFALSE BIT(Flags,1) THEN EXIT FUNCTION ELSE Mibuf(HIBYT(k)) = LEFT$(buf$,pt% -3) + RIGHT$(buf$,lbuf - pt%)+ CHR$(255) END IF END FUNCTION FUNCTION GetPitchBendRaw (BYVAL k AS WORD, BYVAL flags AS INTEGER) EXPORT AS INTEGER ' this returns pitchbendinformation in 14bit msb-lsb packed in the return value. LOCAL buf$ LOCAL Msb??, Lsb? LOCAL pt% LOCAL lbuf AS WORD LOCAL bendvalue AS INTEGER LOCAL bv AS SINGLE FUNCTION = %NotFalse buf$ = EXTRACT$(Mibuf(HIBYT(k)),CHR$(255)) ' returns the part of the buffer before the CHR$(255) delimiter. lbuf = LEN(buf$) IF lbuf <3 THEN EXIT FUNCTION pt% = INSTR(SGN(Flags),buf$,CHR$(224 OR LOBYT(k))) ' looks forwards or backwards IF pt% < 3 THEN EXIT FUNCTION Msb?? = ASC(MID$(buf$,pt%-2,1)) ' 7 bits Lsb? = ASC(MID$(buf$,pt%-1,1)) ' 7 bits SHIFT LEFT Msb??,7 ' was bug (8) up to 09.05.2004 FUNCTION = Msb?? OR Lsb? IF ISFALSE BIT(flags,1) THEN EXIT FUNCTION ELSE Mibuf(HIBYT(k)) = LEFT$(buf$,pt% -3) + RIGHT$(buf$,lbuf - pt%)+ CHR$(255) END IF END FUNCTION FUNCTION RecognizeNoteDur (BYVAL nv%, BYVAL duration AS DWORD, BYVAL tokennote?,BYVAL tolerance?)EXPORT AS INTEGER ' dit is een patroonherkenningsfunktie. ' Om een reeks noten te herkennen, moet de funktie voor elke noot van de te ' herkennen sekwens aanroepen worden. De sekwens is dan herkend als voor alle opgegeven ' noten, de funktie %True heeft geretourneerd. ' The tolerance parameter works on the duration and should be expressed in %, ' thus 10 means that notes with durations between duration - (duration * (10/100)) and ' duration + (duration * (10/100)) will return recognition. ' Do not set tolerance? to zero, because chances are extremely small, a note will ever have ' an exact duration. Even so, the jitter on the multitasker would make recognition ' impossible. ' Since tolerance is set as a byte variable, its maximum value is 255%. ' Duration must be expressed in milliseconds. STATIC starttime AS DWORD STATIC stoptime AS DWORD STATIC oldnote? STATIC tog AS DWORD STATIC NootAanDuur() AS DWORD 'SINGLE LOCAL verschil AS LONG ' STATIC NootUitDuur() AS SINGLE - not yet implemented. LOCAL note?, velo? IF tog = %False THEN DIM NootAanDuur(127) AS STATIC DWORD 'SINGLE ' remember durations ' DIM NootUitDuur(0 TO 127) AS STATIC SINGLE ' remember rests tog = %True END IF IF tokennote? <> oldnote? THEN starttime = %False stoptime = %False oldnote? = tokennote? END IF FUNCTION = %False ' default velo? = LOBYT (nv%) note? = HIBYT (nv%) ' recognizes tokens from midi-input. ' The function returns %True if the token was recognized, for the duration passed and expressed in ms. ' First check whether the note conforms: IF note? = tokennote? THEN IF velo? THEN ' note-ON case starttime = timeGetTime stoptime = %False ELSE ' note-OFF geval stoptime = timeGetTime IF starttime THEN NootAanDuur(note?) = stoptime - starttime ' in dit geval hebben we een noot + duur kunnen bepalen. ' Nu laten we een afwijking toe van + of - tolerance op de duur. verschil = NootAanDuur(note?) - duration 'IF ABS(NootAanDuur(note?) - duration) =< ((duration * tolerance?) / 100!) THEN IF ABS(verschil) <= ((duration * tolerance?) / 100!) THEN starttime = %False stoptime = %False oldnote? = 255 ' reset FUNCTION = %True EXIT FUNCTION ELSE ' note is O.K. but duration is wrong... oldnote? = 255 ' reset starttime = %False stoptime = %False EXIT FUNCTION END IF ELSE ' note-off without prior note on... we disregard this condition. END IF END IF ELSE ' in dit geval hebben we een nieuwe noot. ' ingeval deze noot heel erg kort is, is het wellicht een fout, dus moeten we ' de duur meten... IF velo? THEN NootAanDuur(note?)= timeGettime ELSE ' note off case... IF NootAanDuur(note?) THEN NootAanDuur(note?)= (timeGetTime) - NootAanDuur(note?) ELSE NootAanDuur(note?)= %False END IF END IF END IF END FUNCTION SUB Midi_Listen_UDP (BYVAL b AS STRING) EXPORT ' called from g_net.dll on reception of midi input via UDP/IP ' this procedure is called directly from within the UDP/IP callback thread and ' does not require a task. First sketch, 23.11.2002 LOCAL stat AS BYTE LOCAL l AS DWORD LOCAL n AS BYTE LOCAL v AS BYTE STATIC Har AS HarmType l = LEN(b) IF l < 2 THEN EXIT SUB ' this procedure is called either from the g_net thread or the UDP callback when instructions are received ' using UDP/IP ' We use the standard midi commands, with extensions for playing complete harmstrings. ' progchange has only 2 bytes ' noteon/off has 3 bytes ' controller change has 3 bytes stat = ASC(LEFT$(b,1)) SELECT CASE (stat AND &H0F0) ' high nibble CASE 128 n = ASC(MID$(b,2,1)) NoteOff stat AND &H0F, n CASE 144 n = ASC(MID$(b,2,1)) v = ASC(MID$(b,3,1)) mPlay stat AND &H0F, n, v CASE 160 n = ASC(MID$(b,2,1)) v = ASC(MID$(b,3,1)) Keypress stat AND &H0F, n, v '160 note pressure CASE 176 'controllers n = ASC(MID$(b,2,1)) v = ASC(MID$(b,3,1)) ModeMess stat AND &H0F, n, v CASE 192 ' prog.change - this is a 2-byte command only n = ASC(MID$(b,2,1)) ProgChange stat AND &H0F, n CASE 208 ' aftertouch n = ASC(MID$(b,2,1)) Aftertouch stat AND &H0F, n CASE 224 ' pitch bend n = ASC(MID$(b,2,1)) v = ASC(MID$(b,3,1)) Bend stat AND &H0F, n, v CASE 240 ' sysex ' special case using Harma_PlayHar (harmstring) ' so we implement 240+k, "H", Har.vel and optional 247 delimiter. IF l >= 130 THEN IF MID$(b,2,1) = "H" THEN Har.vel = MID$(b,3,128) PlayHar Har, stat AND &H0F END IF END IF CASE ELSE EXIT SUB END SELECT END SUB FUNCTION SetMidiListenChannel (BYVAL k AS WORD, BYVAL onoff AS LONG) EXPORT AS DWORD ' new 20.12.2002 - note that Listenmask is a global quad in this library. ' changed 10.01.2005: now we have 256 bits reserved for the listenmask. (4-quads) ' the lowbyte of k has the midichannel, ' the lownibble of the highbyte of k has the port. ' UDP not implemented yet. STATIC init AS LONG LOCAL prt AS DWORD FUNCTION = %False prt = HIBYT(k) IF prt > 15 THEN Warning "UDP midiports are not implemented yet in" + FUNCNAME$, 10000 EXIT FUNCTION END IF prt = prt AND &H0F IF ISFALSE init THEN ' on the first call we reset the listenmask completely. ' As a default and for compatibility reasons with older code, all lowest 16 channels are enabled on ' startup. RESET listenmask init = %True END IF IF prt > UBOUND(hMidiI) THEN MSGBOX "hMidiI array error!!!",, FUNCNAME$ IF ISFALSE hMidiI(prt) THEN Warning "You cannot set midi listen channels without opening a midiinputport in " + FUNCNAME$, 10000 END IF 'IF prt > 3 THEN ' Warning "No more than 4 midi listen ports implemented in GMT",10000 ' changed 10.01.2005 to: IF prt > 15 THEN Warning "No more than 16 midi listen ports implemented in GMT",10000 EXIT FUNCTION END IF k = LOBYT(k) AND &H0F IF ISFALSE onoff THEN BIT RESET listenmask, (prt * 16) OR (k AND &H0F) ELSE BIT SET listenmask, (prt * 16) OR (k AND &H0F) END IF FUNCTION = VARPTR(Listenmask) ' return pointer to the 4xquad (64 bit) integer. END FUNCTION '------------------------------------------------------------- 'Procedures for reading and playing midi files '------------------------------------------------------------- 'use like this: ' Task(App.MidiPlayerTasknr).naam = "PlayMid" ' Task(App.MidiPlayerTasknr).cptr = CODEPTR(MidiPlayer) ' Task(App.MidiPlayerTasknr).freq = 500 ' TaskEX(App.MidiPlayerScoreTasknr).stopcptr = CODEPTR(MidiPlayerStop) SUB MidiPlayer(OPT BYVAL resetplayer AS LONG, OPT BYVAL susp AS LONG) EXPORT 'task App.MidiPlayerTasknr 'task.rit.minduur misused for tempo scaling in interactive implementations! 'the MM_Notemap also uses task.rit.maxduur for global velo scaling (superimposed on per instrument velo scaling) 'prompts for filename and plays it 'filtering allready done for channel (chmap) ' filter gets opportunity to process entire msg, and then is supposed to return -1, otherwise the filter function returns the channel to which the message is to be sent ' a pointer to an alternative mapping funct can be passed to chmap. chmap wil return the return val of that funct 'second event type specific filtering mechanism receives event and is supposed to do midioutput itself ' - - probably second filter can completely replace first in the end (in the works..) 'tempo controll added .2 to 5 * original tempo, scaled log 'further filters for note/velo/ctrl needed '20051007: as we experienced glitches in some heavy files we made some changes ' - function chmap was eliminated. we loose some flexibility, but we have a function call less fo each note ' - IsMMFile flag ' - MMChmap is only used for initialisation of instruments anymore! STATIC stat AS LONG STATIC md() AS ParsedMidiType STATIC mevents AS DWORD 'event counter - changed var.name to mevents gwr, compiler 9.0 STATIC maxevents AS DWORD STATIC starttime AS DWORD STATIC info$ STATIC trackinfo$ STATIC hProg AS LONG 'progressbar handle STATIC hTrack AS LONG 'tempo slider STATIC LastScale AS SINGLE STATIC pause AS LONG '0 = spelen, 1 = gepauseerd vanuit interaktieve applicate (getoggeld via de susp flag, ' -1 = gepauseerd omwille van marker in file - wacht op manuele userinput STATIC tpause AS LONG STATIC lastpauseevent AS LONG LOCAL fn AS STRING 'filename LOCAL ch AS LONG LOCAL i AS DWORD LOCAL b$ STATIC progress AS DWORD STATIC hDlgStart AS LONG IF resetplayer THEN IF stat THEN 'stoptask calls function with reset flag also, for the case task is stopped by user 'only stop task once or we create an infinite loop here! stat = %false maxevents = %false pause = 0 StopTask @pApp.MidiPlayerTasknr '%mplay 'clear filters ' chmap md(0), 0, 1 ' END IF IF hDlgStart THEN DIALOG END hDlgStart: hDlgStart = 0 EXIT SUB END IF IF stat = -1 THEN EXIT SUB IF ISFALSE stat THEN 'we're not playing anything right now.. IF susp THEN susp = 0: EXIT SUB 'we getting a pause on/off message, but should ignore it here stat = -1 StopTask @pApp.MidiPlayerTasknr Starttime = %false @pTask(@pApp.MidiPlayerTaskNr).rit.minduur = 1 'we misuse rit.minduur for tempo scaling! LastScale = 1 info$ = "": trackinfo$ = "" ERASE md() REDIM md(1000) AS STATIC ParsedMidiType DIALOG DOEVENTS fn = MidiPlayer_GetFilename 'MidiPlayer_FileOpenName IF TRIM$(fn) = "" THEN EXIT SUB 'create control window IF ISFALSE hDlgStart THEN DIALOG NEW 0, FUNCNAME$, 200, 1 , 300, 60, %WS_POPUP OR %WS_CAPTION TO hDlgStart CONTROL ADD LABEL, hDlgStart, 1, "Reading file " + fn, 1, 1, 298, 12 CONTROL ADD "msctls_progress32", hDlgStart, 1000, "Progress", 1, 15, 298, 10, _ %WS_CHILD OR %WS_VISIBLE OR %WS_BORDER OR %WS_DISABLED OR %PBS_SMOOTH , 0 CONTROL ADD LABEL, hDlgStart, 2000, "Speed: 01.00", 1, 30, 45, 12 CONTROL ADD "msctls_trackbar32", hDlgStart, 2001, "Speed", 50, 30, 248, 12, %WS_CHILD OR %WS_VISIBLE OR _ %TBS_HORZ OR %TBS_NOTICKS ' CONTROL ADD BUTTON, hDlgStart, 100, "&start", 1, 45, 98, 11, %BS_FLAT OR %WS_DISABLED OR %WS_TABSTOP CONTROL ADD BUTTON, hDlgStart, 101, "&cancel", 101, 45, 98, 11, %BS_FLAT OR %WS_DISABLED OR %WS_TABSTOP CONTROL ADD BUTTON, hDlgStart, 102, "&wait for interaction", 201, 45, 98, 11, %BS_FLAT OR %WS_DISABLED OR %WS_TABSTOP CONTROL HANDLE hDlgStart, 1000 TO hProg SendMessage hProg, %PBM_SETRANGE, 0, MAKLNG(0,1000) CONTROL HANDLE hDlgStart, 2001 TO hTrack SendMessage hTrack, %TBM_SETRANGE,%TRUE, MAKLNG(0, 1000) SendMessage hTrack, %TBM_SETpagesize, 0, 5 'means shift by 5 if usr clicks next 2 current position/presses pgup DIALOG SHOW MODELESS hDlgStart CALL procMidiPlayerStartWin END IF SendMessage(hTrack, %TBM_SETPOS,%TRUE, 408) 'set current pos. 408 = tempo 1 (log scaling..) FOR i = 0 TO 20: DIALOG DOEVENTS: NEXT 'otherwise dialog doesn't get drawn before the file is parsed maxevents = ParseMidiFile(BYVAL fn, BYREF md(), BYREF info$, BYREF trackinfo$) CONTROL SET TEXT @pgh.cockpit, %GMT_MSG1, "Events in file:" + STR$(maxevents) IF ISFALSE LEN(info$) THEN info$ = "-" IF ISFALSE LEN(trackinfo$) THEN trackinfo$ = "-" IF ISFALSE maxevents THEN Warning "Couldn't read file: " + fn + FUNCNAME$ + "@g_tools", 10000 MidiPlayer 1 EXIT SUB END IF 'prepare filters IF INSTR(UCASE$(REMOVE$(info$, " ")), "") THEN Warning "Use the dedicated player for M&M files!!" END IF ' REDIM markers(UBOUND(md)) ' IF CreateMarkerList(md(), markers()) THEN ' MSGBOX "Here we should give the option to ffw to a certain marker..",,FUNCNAME$ ' END IF 'next '?? 'the following is only for the M&M player ' mevents = MidiPlayer_SkipDlg(BYREF md()) 'als er ctrl(51) voorkomen in de file (die per 2 een pauze/continue koppel vormen), ' 'krijgt user hier de gelegenheid om naar een vd continues te skippen.. CONTROL ENABLE hDlgStart, 100 CONTROL ENABLE hDlgStart, 101 CONTROL ENABLE hDlgStart, 102 CONTROL ENABLE hDlgStart, 1000 CONTROL SET TEXT hDlgStart, 1, "Ready to play " + fn pause = 0: stat = 1 EXIT SUB END IF IF ISFALSE starttime THEN IF mevents THEN starttime = timegettime - md(mevents).time 'als we naar ee bepaalde ctrl(51) geskipped zijn van het begin ELSE starttime = timegettime END IF END IF IF ISFALSE(@ptask(@pApp.MidiPlayerTaskNr).tog) THEN @ptask(@pApp.MidiPlayerTaskNr).tog=1 'susp wordt doorgegeven vanuit interaktieve taken om de player te starten / stoppen.. IF susp = 1 THEN ' msgbox "pause" pause = 1 CONTROL GET TEXT hDlgStart, 1 TO b$ REPLACE "Playing" WITH "Paused" IN b$ CONTROL SET TEXT hDlgStart, 1, b$ tpause = timegettime END IF IF pause = 1THEN IF susp = -1 THEN ' msgbox "pause off" pause = 0 CONTROL GET TEXT hDlgStart, 1 TO b$ REPLACE "Paused" WITH "Playing" IN b$ CONTROL SET TEXT hDlgStart, 1, b$ starttime = starttime + (timegettime - tpause) ELSE EXIT SUB END IF END IF 'einde van de pauze in reaktie op de SKIP marker 'we seeken de volgende NEXT, maar sturen wel note off / controllers etc die tussen de SKIP en NEXT komen 'we beginnen bij het eerste event na de next!!! '!!!! als je in sonar een note en marker op hetzelfde tijdstip zet weet je niet wat eerst komt in de midifile!! IF pause = -1 THEN IF susp = -1 THEN pause = 0 i = mevents ' logfile "------ skip through from" + str$(Events) DO UNTIL ((md(mevents).bstat AND &H0B0) = &H0B0) AND (md(mevents).bdat1 = 51) AND (md(mevents).bdat2 = 0) INCR mevents 'we should send controllers and noteoffs here!! IF mevents > UBOUND(md) THEN warning "Ctl 51 (for skipping) doesn't match!" EXIT LOOP END IF LOOP INCR mevents ' starttime = starttime + (timegettime - tpause) - (md(events).time - md(i).time) starttime = timegettime - md(mevents).time ' logfile "now:" + str$(timegettime) + " - next:" + str$(md(Events).time + starttime) ' logflag = 1 EXIT SUB ELSE DIALOG DOEVENTS EXIT SUB END IF END IF 'afspeeltempo veranderd - herebereken de timings.. IF LastScale <> @ptask(@pApp.MidiPlayerTasknr).rit.minduur THEN FOR i = mevents TO maxevents md(i).time = md(mevents).time + (md(i).time - md(mevents).time) * LastScale / @ptask(@pApp.MidiPlayerTasknr).rit.minduur NEXT LastScale = @ptask(@pApp.MidiPlayerTasknr).rit.minduur END IF 'check en speel events i = 0 DO WHILE (md(mevents).time <= (timegettime - starttime)) INCR i 'check if the following safety check is a good thing to have.. IF i > 10 THEN starttime = starttime + ABS(timegettime - (starttime + md(mevents).time)) EXIT LOOP 'safety - max 10 notes at a time END IF SELECT CASE md(mevents).bStat CASE &H090 TO &H09F 'note on ch = md(mevents).bStat AND &H0F mPlay BYVAL ch, md(mevents).bDat1, md(mevents).bDat2 '-1 if filter proc has played the note itself.. CASE &H080 TO &H08F 'note off - we ignore the velocity val ch = md(mevents).bStat AND &H0F ' must be changed !!! Vibi has release!!! mPlay BYVAL ch, md(mevents).bDat1, 0 CASE &H0A0 TO &H0AF 'key aftertouch ch = md(mevents).bStat AND &H0F KeyPress BYVAL ch, md(mevents).bDat1, md(mevents).bDat2 CASE &H0B0 TO &H0BF 'control change ch = md(mevents).bStat AND &H0f ModeMess BYVAL ch, md(mevents).bDat1, md(mevents).bDat2 CASE &H0C0 TO &H0CF 'progchange ch = md(mevents).bStat AND &H0F ProgChange BYVAL ch, md(mevents).bDat1 CASE &H0D0 TO &H0DF 'channel aftertouch - implemented on Bako ch = md(mevents).bStat AND &H0F AfterTouch BYVAL ch, md(mevents).bDat1 CASE &H0E0 TO &H0EF 'pitch bend ch = md(mevents).bStat AND &H0F Bend BYVAL ch, md(mevents).bDat1, md(mevents).bDat2 'markers would be the most elegant solution for PAUSE/CONTINUE points, but cakepro messes up their timing! CASE &H0FF 'marker CASE 0 'do nothing CASE ELSE Warning "invalid Statusbyte " + HEX$(md(mevents).bStat) + " " + FUNCNAME$ + "(" + fn + ")@g_midi", 10000 END SELECT INCR mevents IF mevents > maxevents THEN 'was >= 040420 - bug? midiplayer 1 IF hDlgStart THEN DIALOG END hDlgStart: hDlgstart = 0 EXIT SUB END IF LOOP IF INT(1000 * md(mevents).time / md(maxevents - 1).time) <> progress THEN '<> as we can go back when tempo is slowed down!! progress = INT(1000 * md(mevents).time / md(maxevents - 1).time) SendMessage hProg, %PBM_SETPOS, progress, 0 END IF END SUB '%midiplayer_wordy = 1 SUB MM_MidiPlayer(OPT BYVAL resetplayer AS LONG, OPT BYVAL susp AS LONG, OPT BYVAL startplay AS LONG, OPT BYVAL playfilename$) EXPORT 'task App.MidiPlayerTasknr 'task.rit.minduur misused for tempo scaling in interactive implementations! 'the MM_Notemap also uses task.rit.maxduur for global velo scaling (superimposed on per instrument velo scaling) 'prompts for filename and plays it 'filtering allready done for channel (chmap) ' filter gets opportunity to process entire msg, and then is supposed to return -1, otherwise the filter function returns the channel to which the message is to be sent ' a pointer to an alternative mapping funct can be passed to chmap. chmap wil return the return val of that funct 'second event type specific filtering mechanism receives event and is supposed to do midioutput itself ' - - probably second filter can completely replace first in the end (in the works..) 'tempo controll added .2 to 5 * original tempo, scaled log '20051007: as we experienced glitches in some heavy files we mad some changes ' - function chmap was eliminated. we loose some flexibility, but we have a function call less for each note ' - IsMMFile flag ' - MMChmap eliminated ' --> glitches verdwijnen kompleet als de applikatie die deze taak gebruikt de DAQ aanzet!! ' 20060718 op Xi niet meer nodig '20070613 play along task voorzien: pointer in task.hparam, USING MM_PlayAlong MMTrack(), mevents, maxevents '2010.12.23: added horizontal scrollbar, so we can scroll to tracks that would be under the screen.. '2013.04.02 playfilename$ option added. if filled in, it will get ready for playing that file without showing the file selection dialog after you start the task- experimental!! ' use like this: ' MM_Midiplayer 0,0,0, "c:\midifiles\20130321_MM_spring\3_SB_Krakers_(Temblo).mid" ' StartTask App.MidiPlayerTasknr '2016.06.22 tag no longer required STATIC stat AS LONG STATIC md() AS ParsedMidiType STATIC mevents AS DWORD 'event counter STATIC maxevents AS DWORD STATIC starttime AS DWORD STATIC info$ STATIC trackinfo$ STATIC hProg AS LONG 'progressbar handle STATIC hTrack AS LONG 'tempo slider STATIC LastScale AS SINGLE STATIC pause AS LONG '0 = spelen, 1 = gepauseerd vanuit interaktieve applicate (getoggeld via de susp flag, ' -1 = gepauseerd omwille van marker in file - wacht op manuele userinput STATIC tpause AS LONG STATIC lastpauseevent AS LONG STATIC cpstop AS DWORD STATIC skip AS LONG STATIC noplay AS LONG 'flag that is set between start of task and the moemnt the user presses start in the interface after a file has been loaded.. STATIC ddcnt AS DWORD STATIC busyflag AS DWORD STATIC nextfile$ LOCAL fn AS STRING 'filename LOCAL ch AS LONG LOCAL i AS DWORD LOCAL b$ LOCAL ttt AS DWORD STATIC progress AS DWORD STATIC hDlgStart AS DWORD ' logfile FUNCNAME$ + STR$(timegettime) IF LEN(playfilename$) THEN Nextfile$ = playfilename$ EXIT SUB END IF IF startplay THEN ' logfile FUNCNAME$ + " reset noplay" @pTask(@pApp.MidiPlayerTasknr).freq = 200 '250 '1000 noplay = 0 END IF IF skip THEN busyflag = 0 EXIT SUB 'only for when MidiPlayerTasknr is not filled in END IF ttt = timegettime IF ISFALSE @pApp.MidiPlayerTasknr THEN MSGBOX "App.MidiPlayerTasknr should be set to the tasknr of the MM_MidiPlayer for it to function!",,FUNCNAME$ skip = 1 END IF ' IF susp THEN logfile FUNCNAME$ + " called with susp " + STR$(susp) IF resetplayer THEN IF stat THEN 'stoptask calls function with reset flag also, for the case task is stopped by user 'only stop task once or we create an infinite loop here! stat = %false maxevents = %false pause = 0 susp = 0 noplay = 0 MM_Reset_Pitchbend mmTrack() @ptask(@pApp.MidiPlayerTasknr).@px.hIcon = 0 StopTask @pApp.MidiPlayerTasknr '%mplay END IF IF hDlgStart THEN DIALOG END hDlgStart: hDlgStart = 0 busyflag = 0 EXIT SUB END IF IF noplay THEN DIALOG DOEVENTS: EXIT SUB 'initialisation still busy.. IF stat = -1 THEN EXIT SUB IF ISFALSE stat THEN 'we're not playing anything right now.. IF susp THEN susp = 0: busyflag = 0: EXIT SUB 'we getting a pause on/off message, but should ignore it here @ptask(@pApp.MidiPlayerTasknr).@px.hIcon = 0 stat = -1 noplay = 1 ' @pTask(@pApp.MidiPlayerTasknr).freq = 1 'test: rely on stat -1 and don't stop the task.. does it work this way with the new timers? ' cpstop = @pTaskEx(@pApp.MidiPlayerTasknr).Stopcptr ' @pTaskEx(@pApp.MidiPlayerTasknr).Stopcptr = 0 'we don't want the stopcptr to be called here, but put it back for when the piece is finished or gets interrupted ' StopTask @pApp.MidiPlayerTasknr ' @pTaskEx(@pApp.MidiPlayerTasknr).stopcptr = cpstop Starttime = %false @pTask(@pApp.MidiPlayerTasknr).rit.minduur = 1 'we misuse rit.minduur for tempo scaling! LastScale = 1 info$ = "": trackinfo$ = "" ERASE md() REDIM md(1000) AS STATIC ParsedMidiType DIALOG DOEVENTS 0 IF LEN (nextfile$) THEN fn = nextfile$ nextfile$ = "" ELSE fn = MidiPlayer_GetFilename 'MidiPlayer_FileOpenName ' logfile fn END IF IF TRIM$(fn) = "" THEN MM_MidiPlayer 1 'new 20101217 - should solve bug where task stayed on after not selecting anything busyflag = 0 EXIT SUB END IF MidiLogFile "READ " + fn, TRIM$(fn) + ".log" 'create control window IF ISFALSE hDlgStart THEN DIALOG NEW 0, FUNCNAME$, 200, 1, 330, 60, %WS_POPUP OR %WS_CAPTION TO hDlgStart ',%WS_EX_RIGHTSCROLLBAR TO hDlgStart '%ws_ex_rightscrollbar TO hDlgStart CONTROL ADD LABEL, hDlgStart, 1, "Reading file " + fn, 1, 1, 298, 24 CONTROL ADD "msctls_progress32", hDlgStart, 1000, "Progress", 1, 27, 298, 10, _ %WS_CHILD OR %WS_VISIBLE OR %WS_BORDER OR %WS_DISABLED OR %PBS_SMOOTH , 0 CONTROL ADD LABEL, hDlgStart, 2000, "Speed: 01.00", 1, 42, 45, 12 CONTROL ADD "msctls_trackbar32", hDlgStart, 2001, "Speed", 50, 42, 248, 12, %WS_CHILD OR %WS_VISIBLE OR _ %TBS_HORZ OR %TBS_NOTICKS CONTROL ADD BUTTON, hDlgStart, 100, "&start", 1, 57, 98, 11, %BS_FLAT OR %WS_DISABLED OR %WS_TABSTOP CONTROL ADD BUTTON, hDlgStart, 101, "&cancel", 101, 57, 98, 11, %BS_FLAT OR %WS_DISABLED OR %WS_TABSTOP CONTROL ADD BUTTON, hDlgStart, 102, "&wait for interaction", 201, 57, 98, 11, %BS_FLAT OR %WS_DISABLED OR %WS_TABSTOP CONTROL HANDLE hDlgStart, 1000 TO hProg SendMessage hProg, %PBM_SETRANGE, 0, MAKLNG(0,1000) CONTROL HANDLE hDlgStart, 2001 TO hTrack SendMessage hTrack, %TBM_SETRANGE,%TRUE, MAKLNG(0, 1000) SendMessage hTrack, %TBM_SETpagesize, 0, 5 'means shift by 5 if user clicks next to current position/presses pgup DIALOG DOEVENTS DIALOG SHOW MODELESS hDlgStart CALL MM_procMidiPlayerStartWin DIALOG DOEVENTS 0 END IF SendMessage(hTrack, %TBM_SETPOS,%TRUE, 408) 'set current pos. 408 = tempo 1 (log scaling..) FOR i = 0 TO 20: DIALOG DOEVENTS: NEXT 'otherwise dialog doesn't get drawn before the file is parsed maxevents = ParseMidiFile(BYVAL fn, BYREF md(), BYREF info$, BYREF trackinfo$) MidiLogFile "Events in file:" + STR$(maxevents) CONTROL SET TEXT @pgh.cockpit, %GMT_MSG1, "Events in file:" + STR$(maxevents) IF ISFALSE LEN(info$) THEN info$ = "-" IF ISFALSE LEN(trackinfo$) THEN trackinfo$ = "-" IF ISFALSE maxevents THEN Warning "Couldn't read file: " + fn + FUNCNAME$ + "@g_midi", 10000 MidiLogFile "Couldn't read file: " + fn + FUNCNAME$ MM_MidiPlayer 1 busyflag = 0 EXIT SUB END IF 'prepare filters ' Midilogfile "INFO:"+ info$ ' tag check bnoi longer required on request by gwr ' IF INSTR(UCASE$(REMOVE$(info$, " ")), "") THEN MM_Init_Tracks md(0), trackinfo$, hDlgStart 'fills in MMTrack array, also sends default controllers 'either this shouldn't send the controllers anymore if they are set in the file, or the frst controllers in the file should be sent immediately afterwards, and not when the file is playing ' ELSE ' Warning "This file is not made for the player!!" ' MM_MidiPlayer 1 ' busyflag = 0 ' EXIT SUB ' END IF ' warning "beta midifile cleanup in the works.." + $CRLF + "this may slow dow the start up" + $CRLF + "report bugs to xof.." #IF %DEF(%midiplayer_wordy) logfile "filter MidiEvents array.." #ENDIF '' MSGBOX "prepare.." + FUNCNAME$ maxevents = MM_PrepareParsedMidiFile(md(), mmTrack(), hDlgStart) ' logfile "prepare controllers" 'experiment MM_Prepare_Controllers md() ' logfile "controllers prepared" MM_Reset_Pitchbend mmTrack() ' logfile "pitchbend reset" mevents = MidiPlayer_SkipDlg(BYREF md()) 'als er ctrl(51) voorkomen in de file (die per 2 een pauze/continue koppel vormen), 'krijgt user hier de gelegenheid om naar een vd continues te skippen.. CONTROL ENABLE hDlgStart, 100 CONTROL ENABLE hDlgStart, 101 CONTROL ENABLE hDlgStart, 102 CONTROL ENABLE hDlgStart, 1000 @ptask(@pApp.MidiPlayerTasknr).@px.hIcon = hDlgStart 'using hdlgparam caused crashes CONTROL SET TEXT hDlgStart, 1, "Ready to play " + fn '' Midilogfile "ready to play.." pause = 0: stat = 1 busyflag = 0 EXIT SUB END IF IF ISFALSE starttime THEN IF mevents THEN starttime = timegettime - md(mevents).time 'als we naar een bepaalde ctrl(51) geskipped zijn van het begin ELSE starttime = timegettime END IF END IF '!--> CHECK: wordt deze tog gebruikt? IF ISFALSE(@ptask(@pApp.MidiPlayerTaskNr).tog) THEN @ptask(@pApp.MidiPlayerTaskNr).tog=1 'susp wordt doorgegeven vanuit interaktieve taken om de player te starten / stoppen.. IF susp = 1 THEN ' msgbox "pause" logfile "pause.." pause = 1 CONTROL GET TEXT hDlgStart, 1 TO b$ REPLACE "Playing" WITH "Paused" IN b$ CONTROL SET TEXT hDlgStart, 1, b$ tpause = timegettime END IF IF pause = 1THEN IF susp = -1 THEN ' msgbox "pause off" logfile "end pause.." pause = 0 CONTROL GET TEXT hDlgStart, 1 TO b$ REPLACE "Paused" WITH "Playing" IN b$ CONTROL SET TEXT hDlgStart, 1, b$ starttime = starttime + (timegettime - tpause) ELSE ' logfile "nada" EXIT SUB END IF END IF 'einde van de pauze in reaktie op de SKIP marker 'we seeken de volgende NEXT 'we beginnen bij het eerste event na de next!!! '!!!! als je in sonar een note en marker op hetzelfde tijdstip zet weet je niet wat eerst komt in de midifile!! IF pause = -1 THEN IF susp = -1 THEN logfile "end skip pause.." pause = 0 i = mevents ' logfile "------ skip through from" + str$(Events) DO UNTIL ((md(mevents).bstat AND &H0B0) = &H0B0) AND (md(mevents).bdat1 = 51) AND (md(mevents).bdat2 = 0) INCR mevents 'we should send controllers and noteoffs here!! IF mevents > UBOUND(md) THEN warning "Ctl 51 (for skipping) doesn't match!" '' MidiLogFile "Ctl 51 (for skipping) doesn't match!" EXIT LOOP END IF LOOP INCR mevents ' starttime = starttime + (timegettime - tpause) - (md(events).time - md(i).time) starttime = timegettime - md(mevents).time EXIT SUB ELSE DIALOG DOEVENTS 0 EXIT SUB END IF END IF 'afspeeltempo veranderd - herebereken de timings.. IF LastScale <> @ptask(@pApp.MidiPlayerTasknr).rit.minduur THEN FOR i = mevents TO maxevents md(i).time = md(mevents).time + (md(i).time - md(mevents).time) * LastScale / @ptask(@pApp.MidiPlayerTasknr).rit.minduur NEXT LastScale = @ptask(@pApp.MidiPlayerTasknr).rit.minduur END IF 'check en speel events IF busyflag THEN ''midilogfile "player still busy!!!" + STR$(timegettime/1000) EXIT SUB END IF ' logfile "SET BUSYFLAG 1" busyflag = 1 ' i = 0 INCR ddcnt IF ISFALSE ddcnt MOD 5 THEN DIALOG DOEVENTS 0 'ádded 20100104 in an attempt to fix the freezing dialog when using timerqeue timers. don't put it in the loop below.." ' logfile "doevents" END IF ' logfile "doplay DO WHILE (md(mevents).time <= (timegettime - starttime)) ' INCR i ' 'check if the following safety check is a good thing to have.. -> 20090514 APPARENTLY NOT!!! CHECK REMOVED ' IF i > 10 THEN ' starttime = starttime + ABS(timegettime - (starttime + md(mevents).time)) ' EXIT LOOP 'safety - max 10 notes at a time ' END IF SELECT CASE md(mevents).bStat CASE &H090 TO &H09F 'note on '********** here we could plug in harmony tracking.. MMTrack is musician type, so it has Har(0) and Har(1) ******* '********** MMTrack is passed to the playalong callback.. ******* '********** mmnotemap can scale the velocity or volume controllers according to user input (the volume sliders in the interface) ' for now we write the original velocity from the file in the har file IF ISFALSE MMNotemap(md(mEvents), MMtrack(md(mevents).track).channel) THEN mPlay BYVAL MMtrack(md(mevents).track).channel, md(mevents).bDat1, md(mevents).bDat2 '-1 if filter proc has played the note itself.. END IF ' MMTrack(md(mevents).track).har(0).vel = MMTrack(md(mevents).track.har(1).vel just keeping current harmony in har(1).. using har(0) in a meaningfull way would be quite complex (keeping track of simultaneous notes etc..) IF md(mevents).bdat2 THEN AddNote2Har MMTrack(md(mevents).track).har(1), md(mevents).bDat1, md(mevents).bDat2 ELSE DelNote2Har MMTrack(md(mevents).track).Har(1), md(mevents).bdat1 END IF ' logfile "track id:" + STR$(md(Mevents).track) ' logfile "track ins:" + MMTrack(md(mevents).track).naam CASE &H080 TO &H08F 'note off mPlay BYVAL MMTrack(md(mevents).track).channel, md(mevents).bDat1, md(mevents).bDat2 DelNote2Har MMTrack(md(mevents).track).Har(1), md(mevents).bdat1 CASE &H0A0 TO &H0AF 'key aftertouch KeyPress BYVAL MMTrack(md(mevents).track).channel, md(mevents).bDat1, md(mevents).bDat2 CASE &H0B0 TO &H0BF 'control change 'we reserveren controllers 50 -> 60 voor metadata - ALLEEN IN MM FILES '50: PAUZE (nog te implementeren) '51: pauzeer (Waarde > 0), en begin daarna bij de volgende, waarde 0 / (SKIP) - we gebruiken dezelfde ctrl voor skip & verder voor het invoergemak SELECT CASE md(mevents).bDat1 CASE 50 ' warning "controller 50 (for pauze) not implemented yet" CASE 51 warning "Old pausing function for CC 51 supressed because of incompability with the Hybr(Hi) cc implementation" EXIT SELECT IF md(mEvents).bDat2 > 0 THEN tpause = timegettime pause = -1 ' logfile "pauze@" + STR$(events) INCR mevents DIALOG DOEVENTS MidiPlayer_PauseWindow STR$(mEvents) logfile "reset busyflag 1" busyflag = 0 EXIT SUB ELSE ' warning "check ctrl 51 dealing - we shouldn't get a value 0 here in " + FUNCNAME$ '' MidiLogFile "check ctrl 51 dealing - we shouldn't get a value 0 here in " + FUNCNAME$ ' logfile "check ctrl 51 dealing - we shouldn't get a value 0 here in " + FUNCNAME$ + " - event" + STR$(mevents) END IF CASE ELSE IF ISFALSE MMNotemap(md(mEvents), MMtrack(md(mevents).track).channel) THEN Controller MMtrack(md(mevents).track).channel, md(mevents).bDat1, md(mevents).bDat2 '-1 if filter proc has played the note itself.. END IF ' ch = MMchmap(md(events)) '-1 if filter proc has played the note itself.. ' IF (ch >= 0) THEN ModeMess BYVAL ch, md(events).bDat1, md(events).bDat2 END SELECT CASE &H0C0 TO &H0CF 'progchange ProgChange MMTrack(md(mevents).track).channel, md(mevents).bDat1 CASE &H0D0 TO &H0DF 'channel aftertouch AfterTouch MMTrack(md(mevents).track).channel, md(mevents).bDat1 CASE &H0E0 TO &H0EF 'pitch bend Bend MMTrack(md(mevents).track).channel, md(mevents).bDat1, md(mevents).bDat2 'markers would be the most elegant solution for PAUSE/CONTINUE points, but cakepro messes up their timing! CASE &H0FF 'marker 'timing of markers is very imprecize in cakepro! (or something goes wrong with the tempo mapping) 'not usefull thus.. CASE 0 'do nothing ' incr mevents ' exit sub CASE ELSE Warning "invalid Statusbyte " + HEX$(md(mevents).bStat) + " " + FUNCNAME$ + "(" + fn + ")@g_midi", 10000 '' MidiLogFile "invalid Statusbyte " + HEX$(md(mevents).bStat) + " " + FUNCNAME$ + "(" + fn + ")@g_midi" END SELECT 'play along sub -> pointer in h field of task 'if we put it here, it only gets called when there is an event in the midi file at this time ' logfile "call cb"+ STR$(timegettime) IF @pTask(@pApp.MidiPlayerTasknr).hparam <> 0 THEN CALL DWORD @pTask(@pApp.MidiPlayerTasknr).hparam USING MM_PlayAlong(md(), MMTrack() , mevents, maxevents) END IF INCR mevents IF mevents > maxevents THEN 'was >= 040420 - bug? MM_midiplayer 1 IF hDlgStart THEN DIALOG END hDlgStart: hDlgstart = 0 logfile "reset busyflag 2" busyflag = 0 EXIT SUB END IF LOOP IF INT(1000 * md(mevents).time / md(maxevents - 1).time) <> progress THEN '<> as we can go back when tempo is slowed down!! progress = INT(1000 * md(mevents).time / md(maxevents - 1).time) SendMessage hProg, %PBM_SETPOS, progress, 0 END IF ' logfile "reset busyflag 3" busyflag = 0 ' logfile funcname$ + STR$((timegettime - ttt)/1000) END SUB 'FUNCTION CreateMarkerList (BYREF md() AS parsedmiditype, BYREF markers() AS STRING) AS LONG ' 'compiles a list of markers from a parsedmidi array, ready to use in a combobox ' 'returns the nr of markers (0 if none) ' 'NOTE: markers inserted in SONAR are NOT precise in timing! ' LOCAL i, j AS LONG ' REDIM markers(UBOUND(md)) ' FOR i = LBOUND(md) TO UBOUND(md) ' IF md(i).bstat = &H0FF THEN '' markers(j) = md(i).marker ' INCR j ' END IF ' NEXT ' REDIM PRESERVE markers(j) ' FUNCTION = j 'END FUNCTION SUB MidiPlayer_PauseWindow(OPT BYVAL msg$) 'we should add a control to skip to a certain marker.. LOCAL hw AS LONG STATIC COUNT AS DWORD INCR COUNT DIALOG NEW 0, "MidiPlayer Paused", 1, 1, 150, 49, %WS_POPUP OR %WS_CAPTION OR %WS_POPUP OR %DS_SETFOREGROUND TO hw CONTROL ADD LABEL, hw, -1, "Click to continue", 1, 1, 98, 12 CONTROL ADD LABEL, hw, -1, "pauze" + STR$(COUNT) + " - " + msg$, 1, 13, 148, 12 CONTROL ADD BUTTON, hw, 1, "&go", 1, 26, 148, 22, %BS_DEFAULT 'for some reason a modeless dialog hangs here: DIALOG SHOW MODELESS hw, CALL MidiPlayer_Continue 'MODELESS hw, CALL MidiPlayer_Continue ' dialog doevents: dialog doevents: dialog doevents END SUB CALLBACK FUNCTION MidiPlayer_continue IF CBMSG <> %WM_COMMAND THEN EXIT FUNCTION IF CBCTLMSG <> %BN_CLICKED THEN EXIT FUNCTION DIALOG DOEVENTS MM_midiPlayer 0, -1 DIALOG DOEVENTS DIALOG END CBHNDL END FUNCTION CALLBACK FUNCTION procMidiPlayerStartWin LOCAL b$ STATIC hTempoTrack AS DWORD SELECT CASE CBMSG CASE %WM_COMMAND IF CBCTLMSG = %BN_CLICKED THEN SELECT CASE CBCTL CASE 100 'start CONTROL DISABLE CBHNDL, CBCTL CONTROL DISABLE CBHNDL, 102 StartTask @pApp.MidiPlayerTasknr CONTROL GET TEXT CBHNDL, 1 TO b$ REPLACE "Ready to play" WITH "Playing" IN b$ CONTROL SET TEXT CBHNDL, 1, b$ CASE 101 'cancel StopTask @pApp.MidiPlayerTasknr MidiPlayer 1 'resets.. CASE 102 CONTROL DISABLE CBHNDL, 100 CONTROL DISABLE CBHNDL, CBCTL StartTask @pApp.MidiPlayerTasknr MidiPlayer 0, 1 'immediately tell it to pause REPLACE "Ready to play" WITH "Interactive mode!" IN b$ END SELECT END IF CASE %WM_SHOWWINDOW ' logfile FUNCNAME$ + " showwindow" IF ISFALSE hTempoTrack THEN CONTROL HANDLE CBHNDL, 2001 TO hTempoTrack 'so we can check wich trackbar we have CASE %WM_CLOSE ' logfile FUNCNAME$ + " close" hTempoTrack = %false 'window closed - forget handle so it is updated if win is recreated Destroywindow CBHNDL 'appears to be necessary!! CASE %WM_HSCROLL, %WM_VSCROLL 'note: id doesn't correspond at all with the one given at creation SELECT CASE CBLPARAM CASE hTempoTrack 'tempo trackbar moved IF (LOWRD(CBWPARAM) = %TB_THUMBPOSITION) OR (LOWRD(CBWPARAM) = %TB_THUMBTRACK) THEN @pTask(@pApp.MidiPlayerTasknr).rit.minduur = .2 + 4.8 * (HIWRD(CBWPARAM)/1000)^2 'we misuse rit.minduur for temdpo scaling 'we should rescale this! ELSE @pTask(@pApp.MidiPlayerTasknr).rit.minduur= .2 + 4.8 * (SendMessage (CBLPARAM, %TBM_GETPOS,%Null, %Null)/1000)^2 END IF CONTROL SET TEXT CBHNDL, 2000, "Speed: " + FORMAT$(@pTask(@pApp.MidiPlayerTasknr).rit.minduur, "00.00") END SELECT END SELECT END FUNCTION CALLBACK FUNCTION MM_procMidiPlayerStartWin LOCAL b$ LOCAL oldPos AS LONG LOCAL HorzVert AS DWORD STATIC w,h,vt,ht,hs,vs AS LONG STATIC hTempoTrack AS DWORD SELECT CASE CBMSG CASE %WM_INITDIALOG ' dialog get size cbhndl to w, h ' msgbox str$(w) + str$(h),,funcname$ ' dialog set size cbhndl, w, min(h, 60) h = h + 40 'scrollbar info 'w=600 : h=400 : vt=50 : ht=50 : hs=5 : vs=5 '0's where 50 resp 5 si.cbSize=LEN(si) : si.fMask=%SIF_ALL si.nMax=h : si.nPage=vt : SetScrollInfo CBHNDL, %SB_VERT, si, 1 ' si.nMax=w : si.nPage=ht : SetScrollInfo cbhndl, %SB_Horz, si, 1 CASE %WM_COMMAND IF CBCTLMSG = %BN_CLICKED THEN ' logfile FUNCNAME$ + " clicked..." SELECT CASE CBCTL CASE 100 'start ' logfile FUNCNAME$ + " start" CONTROL DISABLE CBHNDL, CBCTL CONTROL DISABLE CBHNDL, 102 ' StartTask @pApp.MidiPlayerTasknr MM_MidiPLayer 0, 0, 1 CONTROL GET TEXT CBHNDL, 1 TO b$ REPLACE "Ready to play" WITH "Playing" IN b$ CONTROL SET TEXT CBHNDL, 1, b$ FUNCTION = 1 CASE 101 'cancel ' logfile FUNCNAME$ + " cancel" StopTask @pApp.MidiPlayerTasknr MM_MidiPlayer 1 'resets.. FUNCTION = 1 CASE 102 logfile FUNCNAME$ + " set interactive" CONTROL DISABLE CBHNDL, 100 CONTROL DISABLE CBHNDL, CBCTL ' StartTask @pApp.MidiPlayerTasknr MM_MidiPlayer 0, 1, 1 'immediately tell it to pause FUNCTION = 1 REPLACE "Ready to play" WITH "Interactive mode!" IN b$ END SELECT END IF FUNCTION = 1 CASE &H231 '%WM_ENTERSIZEMOVE logfile "ENTERSIZEMOVE" CASE %WM_MOVING logfile "moving:" +STR$(timegettime) CASE %WM_NOTIFY FUNCTION = 1 CASE %WM_SHOWWINDOW IF ISFALSE hTempoTrack THEN CONTROL HANDLE CBHNDL, 2001 TO hTempoTrack 'so we can check wich trackbar we have FUNCTION = 1 CASE %WM_CLOSE hTempoTrack = %false 'window closed - forget handle so it is updated if win is recreated Destroywindow CBHNDL 'appears to be necessary!! MM_MidiPlayer 1, 0 'added 20080102 - now we should be able to start a new file after interrupting an old one '************* DISABLED FOR DEBUG CASE %WM_HSCROLL, %WM_VSCROLL 'note: id doesn't correspond at all with the one given at creation SELECT CASE CBLPARAM CASE hTempoTrack 'tempo trackbar moved IF (LOWRD(CBWPARAM) = %TB_THUMBPOSITION) OR (LOWRD(CBWPARAM) = %TB_THUMBTRACK) THEN @pTask(@pApp.MidiPlayerTasknr).rit.minduur = .2 + 4.8 * (HIWRD(CBWPARAM)/1000)^2 'we misuse rit.minduur for temdpo scaling 'we should rescale this! ELSE @pTask(@pApp.MidiPlayerTasknr).rit.minduur= .2 + 4.8 * (SendMessage (CBLPARAM, %TBM_GETPOS,%Null, %Null)/1000)^2 END IF CONTROL SET TEXT CBHNDL, 2000, "Speed: " + FORMAT$(@pTask(@pApp.MidiPlayerTasknr).rit.minduur, "00.00") FUNCTION = 1 CASE ELSE 'window scrollbar.. IF CBMSG = %WM_HSCROLL THEN HorzVert = %SB_HORZ ELSE HorzVert = %SB_VERT IF HorzVert = 0 THEN EXIT SELECT si.cbSize=SIZEOF(si) : si.fMask=%SIF_ALL GetScrollInfo CBHNDL, HorzVert, si oldPos=si.nPos SELECT CASE LO(WORD, CBWPARAM) CASE %SB_LINELEFT, %SB_LINEUP : si.nPos=si.nPos-IIF(HorzVert,hs,vs) CASE %SB_PAGELEFT, %SB_PAGEUP : si.nPos=si.nPos-si.nPage CASE %SB_LINERIGHT, %SB_LINEDOWN : si.nPos=si.nPos+IIF(HorzVert,hs,vs) CASE %SB_PAGERIGHT, %SB_PAGEDOWN : si.nPos=si.nPos+si.nPage CASE %SB_THUMBTRACK : si.nPos=HI(WORD, CBWPARAM) CASE ELSE : EXIT FUNCTION END SELECT si.nPos=MAX&(si.nMin, MIN&(si.nPos, si.nMax-si.nPage + HorzVert)) 'HorzVert=0 if horz, =1 if vert si.fMask=%SIF_POS SetScrollInfo CBHNDL,HorzVert,si,1 IF (HorzVert = %SB_HORZ) THEN ScrollWindow CBHNDL, oldPos-si.nPos, 0, BYVAL %null, BYVAL %null END IF IF (HorzVert = %SB_VERT) THEN ScrollWindow CBHNDL, 0, oldPos-si.nPos, BYVAL %null, BYVAL %null END IF END SELECT FUNCTION = 1 END SELECT END FUNCTION SUB MidiPlayerStop(OPT BYVAL musptr AS DWORD, OPT BYVAL uboundmus AS LONG) EXPORT 'pointer to array of M&M musicians ' we can't use MM_Alloff here, as g_mm.nc is not included in this lib 'call with _both_ file info and track info after opening a new file 'call without params to perform all off and reset '-----> 15.05.2007 kl question: is there a reason (other then historical ones) why we don't use mus(i).cptroffproc here? 'seems this one is not used anymore? initialised, but not called again.. STATIC mus() AS musician STATIC initialised AS LONG STATIC lastpipermuted AS LONG 'if muted in last 30 seconds, we presume it's a double mute and skip it to prevent overflow STATIC lasthumamuted AS LONG LOCAL i AS LONG, j AS LONG logfile FUNCNAME$ + STR$(musptr) IF musptr THEN initialised = 1 REDIM mus(uboundmus) AS STATIC musician AT musptr EXIT SUB END IF FOR i = 0 TO UBOUND(mus) IF mus(i).cptrOffProc THEN CALL DWORD mus(i).cptrOffProc ELSE 'the folowing select case shouldn't be necessary anymore.. warning "no off ptr for " + TRIM$(mus(i).naam) + " (@" + FUNCNAME$ + ")" 'probablye we can delete all special cases here.. SELECT CASE UCASE$(TRIM$(mus(i).naam)) 'trim$ is necessary as .naam = fixed length!! CASE "HARMA" ModeMess mus(i).channel, 66, 0 'motor af i.p.v. wind op 0!! DIALOG DOEVENTS CASE "PIPEROLA"" IF ABS(TIMER - lastpipermuted) < 30 THEN ITERATE FOR lastpipermuted = TIMER mus(i).ctrl(7) = 0 Controller mus(i).channel, 7, %False Controller mus(i).channel, 123, %False '?? CASE "BOURDONOLA" mus(i).ctrl(1) = 0 Controller mus(i).channel, 1, %False CASE "HUMANOLA" IF ABS(TIMER - lasthumamuted) < 30 THEN ITERATE FOR lasthumamuted = TIMER mus(i).ctrl(7) = 0 ' Humanolawind mus(i) ', 0 ' removed here 25.01.2005 Controller mus(i).channel, 7, %False FOR j = mus(i).lowtes TO mus(i).hightes 'allnotesof mPlay mus(i).channel, j, 0 SLEEP 10 NEXT CASE "SO" mus(i).ctrl(1) = 0 Controller mus(i).channel, 1, 0 CASE "AKE" mus(i).ctrl(1) = 0 Modemess mus(i).channel, 1, 0 mus(i).ctrl(7) = 64 Modemess mus(i).channel, 7, 0 DIALOG DOEVENTS CASE "BAKO" mus(i).ctrl(1) = 0 Controller mus(i).channel, 1, 0 ' wind prepressure CASE "KRUM" mus(i).ctrl(7) = 0 Controller mus(i).channel, 7, 0 CASE "QT", "QTQ" mus(i).ctrl(7) = 0 Controller mus(i).channel, 7, 0 CASE "HARMO" mus(i).ctrl(66) = 0 Controller mus(i).channel, 66, 0 CASE "BOMI" mus(i).ctrl(7) = 0 Controller mus(i).channel, 7, %False Controller mus(i).channel, 123, %False '?? END SELECT SLEEP 1 InstrumAllNotesOff mus(i) END IF DIALOG DOEVENTS: DIALOG DOEVENTS NEXT logfile FUNCNAME$ + " do pb resset" + STR$(UBOUND(mus)) IF initialised THEN MidiPlayer 1: initialised = 0 END SUB ' FUNCTION MidiPlayer_SkipDlg(BYREF md() AS PArsedMidiType) AS LONG LOCAL i AS LONG LOCAL j AS LONG LOCAL hw AS DWORD LOCAL stops AS LONG 'first check if there's any ctrl 51 in md FOR i = LBOUND(md) TO UBOUND(md) IF ((md(i).bStat AND &H0F0) = &H0B0) AND (md(i).bDat1 = 51) THEN INCR stops NEXT IF ISFALSE stops THEN FUNCTION = 0: EXIT FUNCTION Warning " implementation on CC51 supressed because of incompatibility with the HybrHy implementation" EXIT FUNCTION IF BIT(stops, 1) THEN warning "Pause/Continue count (Ctrl51) does not match!" DIALOG NEW 0, "skip to marker?",,, 200, 26, %WS_POPUP OR %WS_CAPTION TO hw CONTROL ADD LABEL, hw, 1, "Do you want to skip to one of the " + STR$(stops/2) + " pauze points?", 1, 1, 198, 12 CONTROL ADD BUTTON, hw, 2, "&no", 1, 13, 30, 12, %BS_DEFAULT OR %WS_TABSTOP CONTROL ADD TEXTBOX, hw, 3, "1", 100, 13, 30, 12, %ES_NUMBER OR %WS_TABSTOP CONTROL ADD BUTTON, hw, 4, "&yes", 150, 13, 30, 12, %WS_TABSTOP DIALOG SHOW MODAL hw, CALL CB_SkipDlg TO j IF ISFALSE j THEN FUNCTION = 0: EXIT FUNCTION IF j > stops/2 THEN MSGBOX "There are only" + STR$(Stops/2) + " pauze points!" FUNCTION = MidiPlayer_SKipDlg(md()) EXIT FUNCTION END IF stops = j * 2 FOR i = LBOUND(md) TO UBOUND(md) IF ((md(i).bStat AND &H0F0) = &H0B0) AND (md(i).bDat1 = 51) THEN DECR stops IF ISFALSE stops THEN EXIT FOR END IF NEXT warning "stop:"+ STR$(i) FUNCTION = i END FUNCTION CALLBACK FUNCTION CB_SkipDlg LOCAL b$ LOCAL i AS LONG IF (CBMSG <> %WM_COMMAND) OR (CBCTLMSG <> %BN_CLICKED) THEN EXIT FUNCTION 'only do something if user clicked a button SELECT CASE CBCTL CASE 2: DIALOG END CBHNDL, 0 CASE 4 CONTROL GET TEXT CBHNDL, 3 TO b$ i = VAL(b$) DIALOG END CBHNDL, i END SELECT END FUNCTION 'FUNCTION ChMap(BYVAL md AS parsedmiditype, OPT BYVAL cpchfilt AS DWORD, OPT BYVAL clearflag AS LONG) EXPORT AS WORD ' 'applies midi channel mapping ' 'by default returns channel from status byte ' 'return value -1 means the note/controller is handled here completely and should not be played anymore by the calling function.. ' 'cpchfilt is a codeptr to a function that accepts a byval byte, returns a word ' ' the function @cpchfilt should return a valid channel, or -1 in the case it decides to play the note itself ' ' this function will be used until this chmap is called with the clear flag <> 0 ' STATIC cpchannelfilter AS DWORD ' LOCAL ochan AS WORD ' IF cpchfilt THEN cpchannelfilter = cpchfilt: EXIT FUNCTION ' IF clearflag THEN cpchannelfilter = 0: EXIT FUNCTION ' IF cpchannelfilter THEN ' CALL DWORD cpchannelfilter USING SoMap(BYVAL md) TO ochan ' FUNCTION = ochan ' ELSE ' FUNCTION = md.bStat AND &H0F ' END IF 'END FUNCTION FUNCTION MMNotemap _ (BYVAL md AS parsedmiditype, OPT BYVAL channel AS DWORD, OPT BYVAL trackinfo$, OPT BYVAL wh AS DWORD, OPT BYVAL msg1 AS DWORD, OPT BYVAL msg2 AS DWORD) AS LONG 'puts a velocity slider + minval box for each instrument (NOT TRACK) in M&M file 'trackinfo$ and wh should be passed simultaneously 'creates sliders in wh - this proc should give ths sliders a callback that calls this again with msg1 and msg2 set 'this function returns -1 if a note has been played, otherwise o 'task.rit.maxduur is used for global velo scaling. the user is responsible for making sure it is not set that low that nothing sounds anymore!! '2011.01.05: qtq and xyq don't get their own slider anymore. they scale along with qt and xi LOCAL basey AS LONG LOCAL i AS LONG, j AS LONG, k AS LONG, l AS LONG LOCAL x AS LONG LOCAL fPOS AS LONG, length AS LONG LOCAL vel AS BYTE LOCAL b$ LOCAL dummymusician AS musician LOCAL vpos AS LONG STATIC trh() AS DWORD 'keeps handle of trackbar per instrument STATIC isc() AS SINGLE 'scaling per instrument STATIC track2ins() AS LONG 'remembers which track is which instrum num STATIC insmuted AS QUAD 'a bit for each track, 1 = muted STATIC instrum$ STATIC lastlabel AS LONG STATIC hw AS LONG STATIC piperola AS musician STATIC bourdonola AS musician STATIC humanola AS musician STATIC harma AS musician STATIC trump AS musician STATIC tubi AS musician STATIC Ake AS musician STATIC Krum AS musician STATIC QT AS musician STATIC QTQ AS musician STATIC Bako AS musician STATIC Xy AS musician STATIC Xyq AS musician STATIC So AS musician STATIC Bono AS musician STATIC Heli AS musician STATIC Korn AS musician STATIC toypi AS musician STATIC ob AS musician STATIC HarmO AS musician STATIC Bomi AS musician STATIC Fa AS musician STATIC Synchro AS musician STATIC Klar AS musician STATIC Horny AS musician STATIC Asa AS musician STATIC Rodo AS musician STATIC Zi AS musician STATIC rumo AS musician STATIC hybr AS musician STATIC tinti AS musician STATIC Chi AS musician STATIC HybrLo AS musician STATIC bug AS musician STATIC melauton AS musician STATIC Pi_ AS musician STATIC Pos_ AS musician STATIC Per AS musician STATIC Pi2_ AS musician ' 09.09.2018 STATIC Tubo AS musician STATIC Roro AS musician STATIC Steely AS musician ' 02.01.2022 STATIC PI3 AS musician STATIC Pi4 AS musician STATIC glovelscal AS SINGLE 'global velo/wind rescaler for interactive implementations STATIC warningissued AS DWORD 'for prevention of multiple warnings 'bit 0 for old piperola implementatio warning 'bit 1 for krum wind limitation 'bit 2 for humanola wind limit STATIC lastpiperwind AS DOUBLE STATIC lasthumawind AS DOUBLE STATIC bourdonolawind AS LONG STATIC akewind AS LONG STATIC init AS LONG IF ISFALSE init THEN init=%true GetinstrumentParams Piperola, %IDM_PIPEROLA SetRobotPort Piperola, "", hMidiO() GetinstrumentParams Humanola, %IDM_HUMANOLA SetRobotPort Humanola, "", hMidiO() ' Humanola.Hightes = 127 ' that's a very bad patch... -> removed 27.07.2007 - which means you can't play the castagnets with instrument anymore! use GetInstrumentParams Bourdonola, %IDM_BOURDONOLA SetRobotPort Bourdonola, "", hMidiO() GetInstrumentParams Harma, %IDM_HARMA SetRobotPort Harma, "", hMidiO() GetInstrumentParams Trump, %IDM_Trump SetRobotPort Trump, "", hMidiO() GetInstrumentParams Ake, %IDM_AKE SetRobotPort Ake, "", hMidiO() GetInstrumentParams Krum, %IDM_KRUM SetRobotPort Krum, "", hMidiO() GetInstrumentParams Bako, %IDM_BAKO SetRobotPort Bako, "", hMidiO() GetInstrumentParams Qt, %IDM_Qt GetInstrumentParams Qtq, %IDM_QT_Q SetRobotPort Qt, "", hMidiO() SetRobotPort Qtq, "", hMidiO() GetInstrumentParams Tubi, %IDM_TUBI Controller Tubi.channel, 66, %True GetInstrumentParams Xy, %IDM_Xy GetInstrumentPArams Xyq, %IDM_Xy_q SetRobotPort Xy, "", hMidiO() SetRobotPort Xyq, "", hMidiO() GetInstrumentParams So,%IDM_SO SetRobotPort So, "", hMidiO() GetInstrumentparams Bono, %IDM_Bono SetRobotPort Bono, "", hMidiO() GetInstrumentParams Vacca, %IDM_VACCA SetRobotPort Vacca,"", hMidiO() GetInstrumentParams Vitello, %IDM_VITELLO SetRobotPort Vitello,"", hMidiO() GetInstrumentParams BELLY, %IDM_BELLY SetRobotPort Belly,"", hMidiO() GetInstrumentParams Llor, %IDM_LLOR SetRobotPort LLor,"", hMidiO() GetInstrumentParams Korn, %IDM_Korn SetRobotPort Korn, "", hMidiO() GetInstrumentParams Heli, %IDM_HELI SetRobotPort Heli, "", hMidiO() GetInstrumentParams Toypi, %IDM_TOYPI SetRobotport Toypi, "", hMidiO() GetInstrumentParams Ob, %IDM_OB SetRobotport Ob, "", hMidiO() GetInstrumentParams HarmO, %IDM_HARMO SetRobotPort HarmO, "", hMidiO() GetInstrumentParams Bomi, %IDM_BOMI SetRobotPort Bomi, "", hMidiO() GetInstrumentParams Fa, %IDM_FA SetRobotPort Fa, "", hMidiO() GetInstrumentParams Synchro, %IDM_SYNChROCHORD SetRobotPort Synchro, "", hMidiO() GetInstrumentPArams Klar, %IDM_KLAR SetRobotPort Klar, "", hMidiO() GetInstrumentParams Horny, %IDM_HORNY SetRobotPort Horny, "", hMidiO() GetInstrumentParams Asa, %IDM_ASA SetRobotPort Asa, "", hMidiO() GetInstrumentParams Rodo, %IDM_RODO SetRobotPort Rodo, "", hMidiO() GetInstrumentParams Rumo, %IDM_RUMO SetRobotPort Rumo, "", hMidiO() GetInstrumentParams Zi, %IDM_RODO SetRobotPort Zi, "", hMidiO() GetInstrumentParams Hybr, %IDM_HYBR SetRobotPort Hybr, "", hMidiO() GetInstrumentparams Tinti, %IDM_TINTI SetRobotPort Tinti, "", hMidiO() GetInstrumentparams Chi, %IDM_CHI SetRobotPort Chi, "", hMidiO() GetInstrumentparams HybrLo, %IDM_HYBRLO SetRobotPort HybrLo, "", hMidiO() GetInstrumentparams Bug, %IDM_BUG SetRobotPort Bug, "", hMidiO() GetInstrumentparams Melauton, %IDM_MELAUTON SetRobotPort Melauton, "", hMidiO() GetInstrumentParams Pi_, %IDM_Pi SetRobotPort Pi_, "", hMidiO() GetInstrumentParams Pos_, %IDM_Pos SetRobotPort Pos_, "", hMidiO() GetInstrumentParams Per, %IDM_Pos SetRobotPort Per, "", hMidiO() GetInstrumentParams Pi2_, %IDM_2PI SetRobotPort Pi2_, "", hMidiO() ' warning "2pi chan"+ hex$(Pi2_.channel) GetinstrumentPArams Pi3, %IDM_3PI SetRobotPort PI3, "", hMidiO() GetinstrumentPArams Pi4, %IDM_4PI SetRobotPort PI4, "", hMidiO() GetInstrumentParams Tubo, %IDM_TUBO Controller Tubo.channel, 66, %True GetInstrumentParams Hat, %IDM_HAT GetInstrumentParams Roro, %IDM_RORO SetRobotPort Roro, "", hMidiO() GetInstrumentParams Steely, %IDM_STEELY ' 02.01.2022 SetRobotPort Steely, "", hMidiO() glovelscal = 1 @pTask(@pApp.MidiPlayerTasknr).rit.maxduur = 1 END IF IF wh AND (LEN(trackinfo$) > 0) THEN 'on opening a new file RESET insmuted hw = wh: DIALOG GET SIZE wh TO x, basey x = x - 30 'for scrollbar basey = basey + 8 ' logfile "windowhandle:" + STR$(hw) instrum$ = "" 'parse trackinfo$; keep string with instrums and remember instrum nr for each track REDIM track2ins(PARSECOUNT(trackinfo$, CHR$(1))) FOR i = 1 TO PARSECOUNT (trackinfo$, CHR$(1)) STEP 2 '1 was 3, as cakepro creates a dummy track, but not always, so it's changed again.. j = VAL(PARSE$(trackinfo$, CHR$(1), i)) b$ = PARSE$(trackinfo$, CHR$(1), i + 1) REGEXPR "<([a-zA-Z0-9_ ]+)>" IN b$ TO fPOS, length b$ = UCASE$(REMOVE$(MID$(b$, fPOS, length), ANY "<> ")) IF ISFALSE LEN(b$) THEN ITERATE FOR IF ISFALSE LEN(instrum$) OR ISFALSE(INSTR(instrum$, b$+CHR$(1))) THEN '+chr$(1) added 20070313 so qt and qtq don't get mixed up.. instrum$ = instrum$ + b$ + CHR$(1): track2ins(j) = PARSECOUNT(instrum$, CHR$(1)) - 2 ' midilogfile "new instrument " + instrum$ ' midilogfile "track" + STR$(i) + " track2ins" + STR$(j) + " =" + STR$(track2ins(j)) ELSE ' midilogfile "existing instrument" FOR k = 1 TO PARSECOUNT(instrum$, CHR$(1)) IF PARSE$(instrum$, CHR$(1), k) = b$ THEN track2ins(j) = k - 1 '-1: added kl 040803 - was this the bug with multiple tracks on the same instrument not playing??? yes ' midilogfile "track" + STR$(i) + " track2ins" + STR$(j) + " =" + STR$(track2ins(j)) EXIT FOR ELSE END IF NEXT END IF NEXT instrum$ = TRIM$(LEFT$(instrum$, LEN(instrum$) - 1)) DIALOG SET SIZE wh, x + 10 + 24, MIN(420, basey + 2 + 13 * (PARSECOUNT(instrum$, CHR$(1)) + 1)) ' ádapt scrollbar si.cbSize=LEN(si) : si.fMask=%SIF_ALL si.nMax=basey + 2 + 14 * (5 + PARSECOUNT(instrum$, CHR$(1)) ) : si.nPage= 420 : SetScrollInfo wh, %SB_VERT, si, 1 x = x + 24 REDIM trh(PARSECOUNT(instrum$, CHR$(1)) - 1): REDIM isc(UBOUND(trh)) 'put sliders and other controls in midiplayer window 'don't change the label below - callback function relies on the nrinstruments being after the komma! CONTROL ADD LABEL, wh, 4000, "Volume Scalings," + STR$(PARSECOUNT(instrum$, CHR$(1))) + " instruments" , _ 1, basey - 13, 298, 12 FOR i = 1 TO PARSECOUNT(instrum$, CHR$(1)) isc(i-1) = 1 'qtq doesn't get it's own track but uses the qt one IF TRIM$(PARSE$(instrum$, CHR$(1), i)) = "QTQ" THEN FOR k = 1 TO PARSECOUNT(instrum$, CHR$(1)) IF TRIM$(PARSE$(instrum$, CHR$(1), k)) = "QT" THEN trh(i-1) = trh(k-1) EXIT FOR END IF NEXT ITERATE FOR END IF 'same for xyq IF TRIM$(PARSE$(instrum$, CHR$(1), i)) = "XYQ" THEN FOR k = 1 TO PARSECOUNT(instrum$, CHR$(1)) IF TRIM$(PARSE$(instrum$, CHR$(1), k)) = "XY" THEN trh(i-1) = trh(k-1) EXIT FOR END IF NEXT ITERATE FOR END IF INCR vpos CONTROL ADD LABEL, wh, 3000 + i, PARSE$(instrum$, CHR$(1), i), 1, basey -13 + 13 * vpos, 65, 12 CONTROL ADD LABEL, wh, 5000 + i, "", 70, basey -13 + 13 * vpos, 25, 12, %SS_NOTIFY CALL cbmmnotemap ' logfile "label" + STR$(5000 + i) + " " + PARSE$(instrum$, CHR$(1), i) CONTROL SET COLOR wh, 5000 + i, &H000000, &H00DDDDDD CONTROL ADD "msctls_trackbar32", wh, 6000 + i, "velo", 102, basey - 13 + 13 * vpos, x - 148, 10, _ %WS_CHILD OR %WS_VISIBLE OR %TBS_HORZ OR %TBS_NOTICKS CALL cbMMnotemap CONTROL ADD LABEL, wh, 7000 + i, "", x - 20, basey - 15 + 13 * vpos, 10, 10, %SS_SUNKEN CONTROL ADD CHECKBOX, wh, 8000 + i, "M", x - 40, basey - 15 + 13 * vpos, 12, 12, %BS_PUSHLIKE OR %BS_VCENTER OR %WS_TABSTOP CALL cbmm_mute 'set trackbar propertiers.. CONTROL HANDLE wh, 6000 + i TO trh(i-1) ' logfile "Trackbar" + STR$(trh(i-1)) + " " + PARSE$(instrum$, CHR$(1), i) SendMessage trh(i-1), %TBM_SETpagesize, 0, 5 'means shift by 5 if usr clicks next 2 current position/presses pgup SELECT CASE TRIM$(PARSE$(instrum$, CHR$(1), i)) CASE "HUMANOLA", "TRUMP" CONTROL SET TEXT wh, 5000 + i, "0" SendMessage trh(i-1), %TBM_SETRANGE,%TRUE, MAKLNG(0, 100): SendMessage trh(i-1), %TBM_SETPOS,%TRUE, 0 CASE "HARMA", "AKE", "PIPEROLA", "BOURDONOLA", "BAKO", "QT", "QTQ", "SO", "HARMO", "BOMI", "POS", "RORO" CONTROL SET TEXT wh, 5000 + i, "0" SendMessage trh(i-1), %TBM_SETRANGE,%TRUE, MAKLNG(1, 127): SendMessage trh(i-1), %TBM_SETPOS,%TRUE, 0 CASE "SIRE", "KRUM", "QTQ" 'for sire velo is dependent on pitch, so we can't rescale it, krum should only use it's default wind. for qtq, the qt slider should be used CONTROL DISABLE wh, 6000 + i CONTROL DISABLE wh, 5000 + i ' CONTROL DISABLE wh, 7000 + i 'velo is dependent on pitch, so we can't rescale it 'For bono, korn, so, ... we could either just scale velocities, or map thiss slider to ctrols 7 or 17.. CASE ELSE CONTROL SET TEXT wh, 5000 + i, "100%" SendMessage trh(i-1), %TBM_SETPOS,%TRUE, 100 'set current pos. 408 = tempo 1 (log scaling..) SendMessage trh(i-1), %TBM_SETRANGE,%TRUE, MAKLNG(0, 200) END SELECT isc(i-1) = 1 NEXT ' harmawind = -1 'means we don't have to update it from here.. EXIT FUNCTION END IF 'global velo scaling from interactive input IF @pTask(@pApp.MidiPlayerTasknr).rit.maxduur <> glovelscal THEN Piperola.ctrl(7) = MIN(127, Piperola.ctrl(7) * @pTask(@pApp.MidiPlayerTasknr).rit.maxduur / glovelscal) Bourdonola.ctrl(1) = MIN(127,Bourdonola.ctrl(1) * @pTask(@pApp.MidiPlayerTasknr).rit.maxduur / glovelscal) Humanola.ctrl(7) = MIN(127,Humanola.ctrl(7) * @pTask(@pApp.MidiPlayerTasknr).rit.maxduur / glovelscal) Harma.ctrl(7) = MIN(127,Harma.ctrl(7) * @pTask(@pApp.MidiPlayerTasknr).rit.maxduur / glovelscal) Trump.ctrl(7) = MIN(%MM_Trump_Motor,Trump.ctrl(7) * @pTask(@pApp.MidiPlayerTasknr).rit.maxduur / glovelscal) Ake.ctrl(1) = Piperola.ctrl(1) * @pTask(@pApp.MidiPlayerTasknr).rit.maxduur / glovelscal 'we use the motor ctrl as long as the valve is not reliable Bako.ctrl(7) = Bako.ctrl(7) * @pTask(@pApp.MidiPlayerTasknr).rit.maxduur / glovelscal HarmO.ctrl(1) = MIN(127,HarmO.ctrl(1) * @pTask(@pApp.MidiPlayerTasknr).rit.maxduur / glovelscal) Bomi.ctrl(7) = MIN(127,Bomi.ctrl(1) * @pTask(@pApp.MidiPlayerTasknr).rit.maxduur / glovelscal) Pos_.ctrl(7) = MIN(127,Pos_.ctrl(1) * @pTask(@pApp.MidiPlayerTasknr).rit.maxduur / glovelscal) ' QT.ctrl(7) = Qt.ctrl(7) * @pTask(@pApp.MidiPlayerTasknr).rit.maxduur / glovelscal: Controller QT.channel, 7, QT.ctrl(7) 'do we want to rescale So here? might e dangerous.. 20070807 'note: sending the controllers below without changing the values (above) makes no sense!! Controller Piperola.channel, 7, Piperola.ctrl(7) Controller Bourdonola.channel, 1, Bourdonola.ctrl(1) Controller Humanola.channel, 7, Humanola.ctrl(7) Controller Harma.channel, 7, Harma.ctrl(7) Controller Trump.channel, 7, Trump.ctrl(7) Controller Ake.channel, 1, Ake.ctrl(1) Controller Bako.channel, 7, Bako.ctrl(7) Controller HarmO.channel, 1, HarmO.ctrl(1) Controller bomi.channel, 7, Bomi.ctrl(7) Controller Pos_.channel, 7, Pos_.ctrl(7) ' Controller Roro.channel, 7, Roro.ctrl(7) ' Controller Qt.channel, 7, Qt.ctrl(7) glovelscal = @pTask(@pApp.MidiPlayerTasknr).rit.maxduur ' CONTROL SET TEXT @pgh.cockpit, %GMT_AUTHOR, STR$(glovelscal) ' END IF 'handle all notes that need special translation here (= all , pitch remapping instruments (,,...) and organs.wind) '!!!!!!!!!!!!!! we should add controllers for new wind instruments here - at least to update the piperwind etc variables !!!!! IF ISFALSE BIT(insmuted, track2ins(md.track)+1) THEN 'if track is not muted.. SELECT CASE PARSE$(instrum$, CHR$(1), track2ins(md.track)+1) '?? CASE "SO" 'SO ' logfile "so" 'notes handled in a normal way since july 2007 ' SoMap(md) ' IF hw AND ISFALSE md.bDat2 THEN CONTROL SET TEXT hw, 7001 + track2ins(md.track), " " ELSE CONTROL SET TEXT hw, 7001 + track2ins(md.track), "|||||" '!!!!!!!! IF controller 7 is used for velo scaling in the final implementation it should be dealt with here..!!!!! IF ((md.bstat AND &H0F0) = &H0B0) AND (md.bdat1 = 7) THEN So.ctrl(7) = md.bdat2 * glovelscal SendMessage trh(track2ins(md.track)), %TBM_SETPOS,%TRUE, So.ctrl(7) CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(So.ctrl(7)) Controller So.channel, 7, So.ctrl(7) ' logfile "so wind" + STR$(So.ctrl(7)) FUNCTION = -1: EXIT FUNCTION END IF EXIT FUNCTION '-1 means that we handled playing of the event and calling proc shouldn't process it anymore CASE "SIRE" Siremap(md, md.track) IF hw AND ISFALSE md.bDat2 THEN CONTROL SET TEXT hw, 7001 + track2ins(md.track), " " ELSE CONTROL SET TEXT hw, 7001 + track2ins(md.track), "|||||" FUNCTION = -1 EXIT FUNCTION CASE "VACCA" FUNCTION = VaccaMap(md) IF hw AND ISFALSE md.bDat2 THEN CONTROL SET TEXT hw, 7001 + track2ins(md.track), " " ELSE CONTROL SET TEXT hw, 7001 + track2ins(md.track), "|||||" EXIT FUNCTION CASE "LLOR" #IF %DEF(%midiplayer_wordy) logfile "calling Llormap with" + HEX$(md.bstat) + STR$(md.bdat1) + STR$(md.bdat2) #ENDIF i = LlorMap(md) #IF %DEF(%midiplayer_wordy) logfile " res:" + STR$(i) #ENDIF FUNCTION = i IF hw AND ISFALSE md.bDat2 THEN CONTROL SET TEXT hw, 7001 + track2ins(md.track), " " ELSE CONTROL SET TEXT hw, 7001 + track2ins(md.track), "|||||" EXIT FUNCTION CASE "BELLY" #IF %DEF(%midiplayer_wordy) logfile FUNCNAME$ + " calling bellymap" + HEX$(md.bstat) + " " + HEX$(md.bdat1) + " " + HEX$(md.bdat2) #ENDIF i = Bellymap(md) #IF %DEF(%midiplayer_wordy) logfile " res:" + STR$(i) #ENDIF FUNCTION = i IF hw AND ISFALSE md.bDat2 THEN CONTROL SET TEXT hw, 7001 + track2ins(md.track), " " ELSE CONTROL SET TEXT hw, 7001 + track2ins(md.track), "|||||" EXIT FUNCTION CASE "VITELLO" FUNCTION = VitelloMap(md) IF hw AND ISFALSE md.bDat2 THEN CONTROL SET TEXT hw, 7001 + track2ins(md.track), " " ELSE CONTROL SET TEXT hw, 7001 + track2ins(md.track), "|||||" EXIT FUNCTION CASE "KLOKS" #IF %DEF(%midiplayer_wordy) logfile "calling kloks..." #ENDIF FUNCTION = KloksMap(md) IF hw AND ISFALSE md.bDat2 THEN CONTROL SET TEXT hw, 7001 + track2ins(md.track), " " ELSE CONTROL SET TEXT hw, 7001 + track2ins(md.track), "|||||" EXIT FUNCTION CASE "PIPEROLA" 'obsoleted - was voor oude windbesturing, but may occur in some older files IF ((md.bStat AND &H0F0) = &H090) AND (md.bDat1 <= 6) THEN IF ISFALSE BIT(warningissued, 0) THEN '' MidiLogFile "this file still uses old piperola implementation!" warning "this file still uses old piperola implementation!" warningissued = warningissued OR &B01 END IF END IF IF ((md.bstat AND &H0F0) = &H0B0) AND (md.bdat1 = 7) THEN piperola.ctrl(7) = md.bdat2 * glovelscal SendMessage trh(track2ins(md.track)), %TBM_SETPOS,%TRUE, piperola.ctrl(7) CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(piperola.ctrl(7)) Controller piperola.channel, 7, piperola.ctrl(7) FUNCTION = -1: EXIT FUNCTION END IF CASE "HUMANOLA" IF ((md.bstat AND &H0F0) = &H0B0) AND (md.bdat1 = 7) THEN 'tranlate ctrl 7 to wind DIALOG DOEVENTS: DIALOG DOEVENTS humanola.ctrl(7) = MIN(%MM_Humanola_Motor, md.bdat2 * glovelscal) IF (md.bdat2 > %MM_Humanola_Motor) AND ISFALSE BIT(WarningIssued, 2) THEN Warning "This file contains wind controllers with too high values for Humanola. Absolute maximum is" + STR$(%MM_Humanola_Motor) + "!" '' MidiLogFile "This file contains wind controllers with too high values for Humanola. Absolute maximum is" + STR$(%MM_Humanola_Motor) + "!" BIT SET WarningIssued, 2 END IF SendMessage trh(track2ins(md.track)), %TBM_SETPOS,%TRUE, humanola.ctrl(7) CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(humanola.ctrl(7)) Controller humanola.channel, 7, humanola.ctrl(7) FUNCTION = -1: EXIT FUNCTION END IF CASE "HARMA" IF (md.bdat1 = 7) AND ((md.bstat AND &H0F0) = &H0B0) THEN 'wind controller sent by main filtr, we only update visuals here harma.ctrl(7) = md.bdat2 * glovelscal IF ISFALSE harma.ctrl(7) THEN harma.ctrl(7) = 1 'prevent overheating DIALOG DOEVENTS: DIALOG DOEVENTS Sendmessage trh(track2ins(md.track)), %TBM_SETPOS, %TRUE, BYVAL md.bDat2 CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(md.bDat2) controller harma.channel, 7, harma.ctrl(7) FUNCTION = -1 EXIT FUNCTION END IF CASE "BOURDONOLA" IF (md.bdat1 = 1) AND ((md.bstat AND &H0F0) = &H0B0) THEN 'wind controller sent by main filtr, we only update visuals here bourdonola.ctrl(1) = md.bdat2 * glovelscal DIALOG DOEVENTS: DIALOG DOEVENTS Sendmessage trh(track2ins(md.track)), %TBM_SETPOS, %TRUE, BYVAL md.bDat2 CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(md.bDat2) controller Bourdonola.channel, 1, bourdonola.ctrl(1) FUNCTION = -1 EXIT FUNCTION ELSE 'probably this is a remainder from when bourdonola 'forgot' it's wind value and is not necessary anymore now.. modemess channel, 1, BYVAL bourdonola.ctrl(1) 'wind: bourdonolawind = -1 FUNCTION = -1 END IF CASE "TRUMP" IF (md.bdat1 = 7) AND ((md.bstat AND &H0F0) = &H0B0) THEN Trump.ctrl(7) = md.bdat2 DIALOG DOEVENTS: DIALOG DOEVENTS Sendmessage trh(track2ins(md.track)), %TBM_SETPOS, %TRUE, BYVAL md.bDat2 CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(md.bDat2) controller trump.channel, 7, MIN(%MM_Trump_Motor, trump.ctrl(7) * glovelscal) FUNCTION = -1 EXIT FUNCTION END IF CASE "AKE" DIALOG DOEVENTS: DIALOG DOEVENTS IF (md.bdat1 = 1) AND ((md.bstat AND &H0F0) = &H0B0) THEN Ake.ctrl(1) = md.bdat2 * glovelscal DIALOG DOEVENTS: DIALOG DOEVENTS Sendmessage trh(track2ins(md.track)), %TBM_SETPOS, %TRUE, BYVAL md.bDat2 CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(md.bDat2) controller ake.channel, 1, Ake.ctrl(1) FUNCTION = -1 EXIT FUNCTION END IF CASE "BAKO" '.... te checken... in-gepast gwr 30.12.2006 correctie KL: waarde ingevuld in .ctrl(7) stemde niet overeen met eigenlijk uitgezonden waarde.. IF (md.bdat1 = 7) AND ((md.bstat AND &H0F0) = &H0B0) THEN Bako.ctrl(7) = md.bdat2 * glovelscal DIALOG DOEVENTS ': DIALOG DOEVENTS Sendmessage trh(track2ins(md.track)), %TBM_SETPOS, %TRUE, BYVAL md.bDat2 CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(md.bDat2) controller bako.channel, 7, bako.ctrl(7) FUNCTION = -1 EXIT FUNCTION END IF CASE "KRUM" IF (md.bdat1 = 7) AND ((md.bstat AND &H0F0) = &H0B0) THEN IF (md.bdat2 > 0) AND(md.bdat2 <> %MM_Krum_Motor) AND ISFALSE BIT(WarningIssued, 1) THEN Warning "This file contains wrong wind controllers for Krum (" + STR$(md.bdat2) + ") Valid values are 0 and" + STR$(%MM_Krum_Motor) + "!" '' MidiLogFile "This file contains wrong wind controllers for Krum (" + STR$(md.bdat2) + ") Valid values are 0 and" + STR$(%MM_Krum_Motor) + "!" BIT SET WarningIssued, 1 Krum.ctrl(7) = %MM_Krum_Motor END IF DIALOG DOEVENTS: DIALOG DOEVENTS Sendmessage trh(track2ins(md.track)), %TBM_SETPOS, %TRUE, BYVAL Krum.ctrl(7) CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(Krum.ctrl(7)) controller Krum.channel, 7, Krum.ctrl(7) END IF CASE "QT", "QTQ" IF (md.bdat1 = 7) AND ((md.bstat AND &H0F0) = &H0B0) THEN 'wind controller sent by main filtr, we only update visuals here Qt.ctrl(7) = md.bdat2 * glovelscal DIALOG DOEVENTS: DIALOG DOEVENTS Sendmessage trh(track2ins(md.track)), %TBM_SETPOS, %TRUE, BYVAL md.bDat2 CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(md.bDat2) controller Qt.channel, 7, Qt.ctrl(7) FUNCTION = -1 EXIT FUNCTION END IF CASE "HARMO" IF (md.bdat1 = 1) AND ((md.bstat AND &H0F0) = &H0B0) THEN 'wind controller sent by main filtr, we only update visuals here harmO.ctrl(1) = md.bdat2 * glovelscal IF ISFALSE harmo.ctrl(1) THEN harmo.ctrl(1) = 1 'prevent overheating DIALOG DOEVENTS: DIALOG DOEVENTS Sendmessage trh(track2ins(md.track)), %TBM_SETPOS, %TRUE, BYVAL md.bDat2 CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(md.bDat2) controller harmO.channel, 1, harmO.ctrl(1) FUNCTION = -1 EXIT FUNCTION END IF CASE "BOMI" IF (md.bdat1 = 7) AND ((md.bstat AND &H0F0) = &H0B0) THEN 'wind controller sent by main filtr, we only update visuals here Bomi.ctrl(7) = md.bdat2 * glovelscal DIALOG DOEVENTS: DIALOG DOEVENTS Sendmessage trh(track2ins(md.track)), %TBM_SETPOS, %TRUE, BYVAL md.bDat2 CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(md.bDat2) controller Bomi.channel, 7, Bomi.ctrl(7) FUNCTION = -1 EXIT FUNCTION END IF CASE "POS" IF (md.bdat1 = 7) AND ((md.bstat AND &H0F0) = &H0B0) THEN 'wind controller sent by main filtr, we only update visuals here Pos_.ctrl(7) = md.bdat2 * glovelscal DIALOG DOEVENTS: DIALOG DOEVENTS Sendmessage trh(track2ins(md.track)), %TBM_SETPOS, %TRUE, BYVAL md.bDat2 CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(md.bDat2) controller Pos_.channel, 7, Pos_.ctrl(7) FUNCTION = -1 EXIT FUNCTION END IF CASE "RORO" IF (md.bdat1 = 7) AND ((md.bstat AND &H0F0) = &H0B0) THEN 'wind controller sent by main filtr, we only update visuals here Roro.ctrl(7) = md.bdat2 * glovelscal DIALOG DOEVENTS: DIALOG DOEVENTS Sendmessage trh(track2ins(md.track)), %TBM_SETPOS, %TRUE, BYVAL md.bDat2 CONTROL SET TEXT hw, 5001 + track2ins(md.track), STR$(md.bDat2) controller Roro.channel, 7, Roro.ctrl(7) 'was bug _ roro was _pos FUNCTION = -1 EXIT FUNCTION END IF END SELECT END IF 'volume adapted from user input.. msg1 = id, msg2 = new val 'or mute button is pressed, then trackinfo$ = "mute" IF msg1 THEN IF trackinfo$ = "mute" THEN IF msg2 THEN 'mute = %true BIT SET insmuted, msg1 'track2ins(msg1) '' midilogfile "MUTE " + PARSE$(instrum$, CHR$(1), track2ins(msg1)+1) 'following is to be checked - if it works, extend to other quartertone instrumets IF PARSE$(instrum$, CHR$(1), track2ins(msg1)+1) = "XY" THEN 'look foor xYQ and mute it too FOR i = 0 TO UBOUND(track2ins) logfile "check: " + PARSE$(instrum$, CHR$(1), track2ins(msg1)+1) IF PARSE$(instrum$, CHR$(1), track2ins(i)+1) = "XYQ" THEN logfile "mutealong" BIT SET insmuted, i EXIT FOR END IF NEXT END IF ELSE BIT RESET insmuted, msg1 'track2ins(msg1) IF PARSE$(instrum$, CHR$(1), track2ins(msg1)+1) = "XY" THEN 'look foor xYQ and mute it too FOR i = 0 TO UBOUND(track2ins) IF PARSE$(instrum$, CHR$(1), track2ins(i)+1) = "XYQ" THEN BIT RESET insmuted, i EXIT FOR END IF NEXT END IF END IF CONTROL SET TEXT @pgh.cockpit, %GMT_AUTHOR, BIN$(insmuted) EXIT FUNCTION END IF IF trackinfo$ = "fromnrinput" THEN SELECT CASE PARSE$(instrum$, CHR$(1), track2ins(msg1)+1) CASE "HUMANOLA", "PIPEROLA", "BOURDONOLA", "HARMA", "TRUMP", "AKE","BAKO", "QT", "QTQ", "KRUM", "SO", "HARMO", "BOMI", "POS", "RORO" msg2 = MAX(0, MIN(msg2, 127)) CONTROL SET TEXT hw, msg1 + 5000, STR$(msg2) CASE ELSE CONTROL SET TEXT hw, msg1 + 5000, STR$(msg2) + "%" msg2 = MAX(0, MIN(msg2, 200)) END SELECT Sendmessage trh(track2ins(msg1) + 1), %TBM_SETPOS, %TRUE, msg2 '+ 1 added 20081128 - was bug END IF SELECT CASE PARSE$(instrum$, CHR$(1), msg1) CASE "PIPEROLA" piperola.ctrl(7) = msg2': controller mus(track2ins(md.track)).channel, 7, piperwind controller piperola.channel, 7, piperola.ctrl(7) CASE "BOURDONOLA" bourdonola.ctrl(1) = msg2': controller mus(track2ins(md.track)).channel, 1, bourdonolawind controller bourdonola.channel, 1, bourdonola.ctrl(1) DIALOG DOEVENTS: DIALOG DOEVENTS CASE "HUMANOLA" humanola.ctrl(7) = msg2 controller humanola.channel, 7, humanola.ctrl(7) DIALOG DOEVENTS: DIALOG DOEVENTS CASE "HARMA" harma.ctrl(7) = msg2 IF harma.ctrl(7) = 0 THEN harma.ctrl(7) = 1 controller harma.channel, 7, harma.ctrl(7) CASE "TRUMP": trump.ctrl(7) = MIN(%MM_Trump_Motor, msg2): controller trump.channel, 7, trump.ctrl(7) CASE "AKE": ake.ctrl(1) = msg2: controller msg2, 1, akewind ' !!!!!!TO BE UPDATED CASE "KRUM": Krum.ctrl(7)=IIF(Krum.ctrl(7)>0, %MM_Krum_Motor, 0): Controller Krum.channel, 7, Krum.ctrl(7) CASE "BAKO": Bako.ctrl(7) = msg2: Controller Bako.channel, 7, Bako.ctrl(7) CASE "QT", "QTQ": QT.ctrl(7) = msg2: Controller QT.channel, 7, QT.ctrl(7) CASE "SO": So.ctrl(7) = msg2: Controller So.channel, 7, So.ctrl(7) CASE "HARMO": HarmO.ctrl(1) = msg2: Controller HarmO.channel, 1, HarmO.ctrl(1) CASE "BOMI": Bomi.ctrl(7) = msg2: Controller Bomi.channel, 7, Bomi.ctrl(7) CASE "XY" isc(msg1 - 1) = msg2/100 FOR l = 1 TO PARSECOUNT(instrum$, CHR$(1)) IF UCASE$(LTRIM$(PARSE$(instrum$, CHR$(1), l))) = "XYQ"THEN isc(l-1) = isc(msg1-1) EXIT FOR END IF NEXT CASE "POS": Pos_.ctrl(7) = msg2: Controller Pos_.channel, 7, Pos_.ctrl(7) CASE "RORO" : Roro.ctrl(7) = msg2 : Controller Roro.channel, 7, Roro.ctrl(7) ' 04.05.2021 gwr CASE ELSE: isc(msg1-1) = msg2/100 logfile "rescale " + PARSE$(instrum$, CHR$(1),msg1) + " - id" + STR$(msg1-1) EXIT FUNCTION 'track velo updated.. END SELECT END IF 'play note with velo scaled according to instr val from UI 'if muted we put vel to 0 ' IF (md.bStat < &H090) OR (md.bStat > &H09F) THEN EXIT FUNCTION 'this is a double check.. keep it? IF ISFALSE BIT(insmuted, track2ins(md.track)+1) THEN vel = MIN(127, md.bDat2 * isc(track2ins(md.track)) * glovelscal) ELSE vel = 0 END IF IF (md.bStat AND &H0F0) = &H0B0 THEN EXIT FUNCTION 'let calling sub handle this controller mPlay channel, md.bDat1, vel IF hw AND ISFALSE vel THEN CONTROL SET TEXT hw, 7001 + track2ins(md.track), " " ELSE CONTROL SET TEXT hw, 7001 + track2ins(md.track), "|||||" FUNCTION = -1 END FUNCTION CALLBACK FUNCTION cbMMNotemap 'handles %WM_HSCROLL messages from trackbars and %BN_CLICKED messages from their labelsfrom MMNotemap window LOCAL b$ LOCAL value AS LONG LOCAL i AS LONG LOCAL md AS parsedmiditype 'dummy for calling MMNotemap STATIC htrack() AS DWORD STATIC init AS LONG ' logfile "command?" + STR$(CBMSG) + STR$(CBCTLMSG) + STR$(%WM_COMMAND) + STR$(%BN_CLICKED) + STR$(%WM_NOTIFY) + STR$(%WM_VSCROLL) + STR$(%WM_HSCROLL) ' IF (CBMSG <> %WM_NOTIFY) and (cbmsg <> %WM_COMMAND) THEN EXIT FUNCTION ' logfile "clicked?" ' IF (CBCTLMSG <> %WM_VSCROLL) and (CBCTLMSG <> %WM_HSCROLL) and (cbctlmsg <> %BN_CLICKED) THEN EXIT FUNCTION 'reject verything we don't want to deal with, otherwise this function gets initialised to early and we don't have all the handles.. ' logfile "ok" IF ISFALSE init THEN ' logfile "do trackbar inits.. " + b$ inits: init = %true CONTROL GET TEXT CBHNDL, 4000 TO b$ REDIM htrack(VAL(PARSE$(b$, ",", 2)) - 1) FOR i = 0 TO UBOUND(htrack) CONTROL HANDLE CBHNDL, 6001 + i TO htrack(i) 'DIT LOOPT FOUT... waarom?? ' logfile "get handle" + STR$(htrack(i)) NEXT END IF 'the following is the only way to find out in this cb if the window has been renewed 'it's clumsy, but not that bad, as we get few calls to this cb - only %WM_HSCROLL gets through here.. CONTROL HANDLE CBHNDL, 6001 TO i IF i <> htrack(0) OR ISFALSE(htrack(UBOUND(htrack))) THEN init = 0: EXIT FUNCTION 'try again next time.. SELECT CASE CBMSG CASE %WM_HSCROLL, %WM_VSCROLL ' logfile FUNCNAME$ + " - params:" + STR$(CBHNDL) + STR$(CBLPARAM) + STR$(CBWPARAM) FOR i = 0 TO UBOUND(htrack) ' logfile " check hadndle " + STR$(htrack(i)) IF CBLPARAM = htrack(i) THEN ' logfile " hit!" IF (LOWRD(CBWPARAM) = %TB_THUMBPOSITION) OR (LOWRD(CBWPARAM) = %TB_THUMBTRACK) THEN value = HIWRD(CBWPARAM) 'we misuse rit.minduur for tempo scaling 'we should rescale this! ELSE value = SendMessage (CBLPARAM, %TBM_GETPOS,%Null, %Null) END IF CONTROL GET TEXT CBHNDL, 3001 + i TO b$ ' logfile "trackbar for " + b$ ' logfile "scroll " + b$ + STR$(CBLPARAM) SELECT CASE b$ CASE "HUMANOLA", "BOURDONOLA", "PIPEROLA", "HARMA", "TRUMP", "AKE", "KRUM","BAKO", "QT", "SO", "HARMO", "BOMI", "POS", "RORO" ' "QTQ" kan niet CONTROL SET TEXT CBHNDL, 5001 + i, STR$(value) CASE ELSE CONTROL SET TEXT CBHNDL, 5001 + i, STR$(value) + "%" END SELECT ' warning "Send wind to notemap " + str$(i+1) + str$(value), 15000 MMNotemap md, 0, "", 0, i+1, value 'tell notemap function to update value for this instr END IF NEXT FUNCTION = 1 CASE %WM_COMMAND IF CBCTLMSG = %BN_CLICKED THEN ' logfile "nrinput" Notemap_nrinput CBCTL, CBHNDL FUNCTION = 1 END IF END SELECT FUNCTION = 1 END FUNCTION FUNCTION Notemap_nrinput(ID AS LONG, hw AS LONG) AS LONG 'text input box as alternative for slider - on request by XA4.. 'helper function of CB_MMNotemap 'creates a number input window for velo scaling / wind value, with ctrl id = cbctl (so we now later which instrum we need to update LOCAL hdlg AS LONG LOCAL b$ CONTROL GET TEXT hw, ID TO b$ DIALOG NEW hw, "value", , , 35, 13 TO hdlg CONTROL ADD TEXTBOX, hdlg, ID, b$, 1, 1, 33, 11, %ES_MULTILINE OR %ES_WANTRETURN OR %ES_AUTOVSCROLL CALL cbMMnm_nrinput 'style sic!! workaround for trapping the enter key DIALOG SHOW MODELESS hdlg ',CALL cbMMnm_nrinput END FUNCTION CALLBACK FUNCTION CBMMnm_nrinput LOCAL b$ LOCAL md AS parsedmiditype 'dummy IF CBMSG <> %WM_COMMAND OR CBCTLMSG <> %EN_CHANGE THEN EXIT FUNCTION CONTROL GET TEXT CBHNDL, CBCTL TO b$ IF RIGHT$(b$, 1) = CHR$(10) THEN b$ = RETAIN$(b$, ANY "0123456789") IF b$ = "" THEN DIALOG END CBHNDL: EXIT FUNCTION MMNotemap md, 0, "fromnrinput", 0, CBCTL - 5000, VAL(b$) DIALOG END CBHNDL END IF END FUNCTION CALLBACK FUNCTION cbMM_mute LOCAL i AS LONG LOCAL md AS parsedmiditype 'dummy IF CBCTL < 8000 OR CBCTL > 9000 THEN EXIT FUNCTION IF CBMSG<>%WM_COMMAND OR CBCTLMSG <> %BN_CLICKED THEN EXIT FUNCTION CONTROL GET CHECK CBHNDL, CBCTL TO i MMNotemap md, 0, "mute", 0, CBCTL - 8000, i END FUNCTION SUB MM_Init_Tracks(BYVAL md AS parsedmiditype, BYVAL trackinfo$, BYVAL wh AS DWORD) 'replaces MMChmap 'initialises global MMTrack array 'trackinfo$ as returned by ParseMidifile (in g_file.bas) 'wh: window handle of the Midiplayer window - if you don't want to update it, set wh to 0 ' it is required to be filled in when you call this function while initialsing the GMT midifile player!! LOCAL i AS LONG LOCAL j AS LONG LOCAL fPOS AS LONG LOCAL length AS LONG LOCAL b$ ' LOCAL containsSo AS LONG LOCAL containsvibi AS LONG 'voor damping ctrl.. '!--> first part of this function (if trackinfo$ filled in) should become just an init function '!--> second part should become a macro or simply put inline in MM_MidiPlayer ' midilogfile "trackinfo @"+ FUNCNAME$ + ":"+ trackinfo$ IF LEN(trackinfo$) THEN i = VAL(PARSE$(trackinfo$, CHR$(1), PARSECOUNT(trackinfo$, CHR$(1)) - 1)) 'ERASE MMTrack(): REDIM MMTrack(i) AS STATIC musician REDIM MMtrack(i) FOR i = 1 TO PARSECOUNT (trackinfo$, CHR$(1)) STEP 2 j = VAL(PARSE$(trackinfo$, CHR$(1), i)) b$ = PARSE$(trackinfo$, CHR$(1), i + 1) '' midilogfile "tack"+ STR$(j) + " instrument definition: '" + b$ + "'" REGEXPR "<([a-zA-Z0-9_ ]+)>" IN b$ TO fPOS, length b$ = UCASE$(REMOVE$(MID$(b$, fPOS, length), ANY "<> ")) '' midilogfile " MM instrument: " + b$ SELECT CASE b$ CASE "PIANOLA", "PLAYER", "PLAYERPIANO": GetInstrumentParams MMTrack(j), %IDM_PLAYERPIANO CASE "HUMANOLA", "VOXHUMANOLA": GetInstrumentParams MMTrack(j), %IDM_HUMANOLA CASE "PIPEROLA": GetInstrumentParams MMTrack(j), %IDM_PIPEROLA CASE "BOURDONOLA": GetInstrumentParams MMTrack(j), %IDM_BOURDONOLA CASE "AUTOSAX": GetInstrumentParams MMTrack(j), %IDM_AUTOSAX CASE "KLUNG": GetInstrumentParams MMTrack(j), %IDM_KLUNG CASE "THUNDERWOOD": GetInstrumentParams MMTrack(j), %IDM_THUNDERWOOD CASE "TROMS": GetInstrumentParams MMTrack(j), %IDM_TROMS ' changed 12.04.2004 CASE "SPRINGERS": GetInstrumentParams MMTrack(j), %IDM_SPRINGERS CASE "ROTOMOTON": GetInstrumentParams MMTrack(j), %IDM_ROTOMOTON CASE "HARMA": GetInstrumentParams MMTrack(j), %IDM_HARMA CASE "VIBI": GetInstrumentParams MMTrack(j), %IDM_VIBI: containsVibi = j CASE "BELLY": GetInstrumentParams MMTrack(j), %IDM_BELLY CASE "FLEX": GetInstrumentParams MMTrack(j), %IDM_FLEX CASE "SO": GetInstrumentParams MMTrack(j), %IDM_SO ': containsSo = j CASE "TUBI": GetInstrumentParams MMTrack(j), %IDM_TUBI ' gwr 23.01.2005 CASE "PUFF": GetInstrumentParams MMTrack(j), %IDM_PUFF ' gwr 15.11.2003 CASE "TRUMP": GetInstrumentParams MMTrack(j), %IDM_TRUMP ' gwr 18.07.2004 CASE "HURDY": GetInstrumentParams MMTrack(j), %IDM_HURDY ' gwr 18.07.2004 CASE "AKE": GetInstrumentParams MMTrack(j), %IDM_AKE CASE "LLOR": GetInstrumentParams MMTrack(j), %IDM_LLOR CASE "DRIPPER": GetInstrumentParams MMTrack(j), %IDM_DRIPPER ' 16.03.2005 CASE "SIRE": GetInstrumentParams MMTrack(j), %IDM_SIRE ' 16.03.2005 CASE "VACCA": GetInstrumentParams MMTrack(j), %IDM_VACCA': containsvacca=j ' 16.03.2005 CASE "VITELLO": GetInstrumentParams MMTrack(j), %IDM_VITELLO ' 30.12.2006 CASE "CASTA", "CASTAGNETS": GetInstrumentParams MMTrack(j), %IDM_CASTA '19.07.2005 CASE "KRUM": GetInstrumentParams MMTrack(j), %IDM_KRUM CASE "PSCH": GetInstrumentParams MMTrack(j), %IDM_PSCH '8.03.2006 CASE "SNAR": GetInstrumentParams MMTrack(j), %IDM_SNAR CASE "BAKO": GetInstrumentParams MMTrack(j), %IDM_BAKO ' 30.12.2006 CASE "QT": GetInstrumentParams MMTrack(j), %IDM_QT ' 30.12.2006 CASE "QTQ": GetInstrumentParams MMTrack(j), %IDM_QT_Q ' 30.12.2006 CASE "XY": GetInstrumentPArams MMTrack(j), %IDM_XY '12.04.07 CASE "XYQ": GetInstrumentParams MMTrack(j), %IDM_XY_Q CASE "CASTA2": GetInstrumentParams MMTrack(j), %IDM_Casta2 CASE "SIMBA": GetInstrumentParams MMTrack(j), %IDM_SIMBA CASE "KLOKS" GetInstrumentParams MMTrack(j), %IDM_BELLY MMTrack(j).lowtes = MIN(Belly.LowTes, Llor.Lowtes, Vitello.Lowtes, Vacca.LowTes) MMTrack(j).lowtes = MAX(Belly.LowTes, Llor.Lowtes, Vitello.Lowtes, Vacca.LowTes) CASE "BONO": GetInstrumentParams MMTrack(j), %IDM_BONO CASE "KORN": GetInstrumentParams MMTrack(j), %IDM_KORN CASE "TOYPI": GetInstrumentParams MMTrack(j), %IDM_TOYPI CASE "HELI": GetInstrumentParams MMTrack(j), %IDM_HELI ' 01.11.2008 CASE "OB": GetInstrumentParams MMTrack(j), %IDM_OB ' 01.11.2008 CASE "HARMO": GetInstrumentParams MMTrack(j), %IDM_HARMO CASE "BOMI": GetInstrumentParams MMTrack(j), %IDM_BOMI ': msgbox "bomi! CASE "FA": GetInstrumentParams MMTrack(j), %IDM_FA CASE "SPIRO": GetInstrumentParams MMTrack(j), %IDM_SPIRO CASE "SYNCHROCHORD": GetInstrumentParams MMTrack(j), %IDM_SYNCHROCHORD CASE "KLAR": GetInstrumentPArams MMTrack(j), %IDM_KLAR CASE "TEMBLO": GetInstrumentParams MMTrack(j), %IDM_TEMBLO CASE "HORNY": GetInstrumentParams MMTrack(j), %IDM_HORNY CASE "ASA": GetInstrumentParams MMTrack(j), %IDM_ASA CASE "WHISPER": GetInstrumentParams MMTrack(j), %IDM_WHISPER CASE "RODO": GetInstrumentParams MMTrack(j), %IDM_RODO CASE "HYBR", "HYBRHI": GetInstrumentParams MMTrack(j), %IDM_HYBR ': Hybr_Patchwindow ' : msgbox " hybr!" CASE "BALMEC", "BELLO": GetInstrumentParams MMTrack(j), %IDM_BALMEC CASE "TINTI": GetInstrumentParams MMTrack(j), %IDM_TINTI CASE "CHI":GetInstrumentParams MMTrack(j), %IDM_CHI CASE "HYBRLO": GetInstrumentParams MMTrack(j), %IDM_HYBRLO CASE "BUG": GetInstrumentParams MMTrack(j), %IDM_BUG CASE "MELAUTON": GetInstrumentParams MMTrack(j), %IDM_MELAUTON CASE "PI": GetInstrumentParams MMTrack(j), %IDM_PI CASE "POS": GetInstrumentParams MMTrack(j), %IDM_POS CASE "PER": GetInstrumentParams MMTrack(j), %IDM_PER CASE "2PI": GetInstrumentParams MMTrack(j), %IDM_2Pi CASE "3PI": GetInstrumentParams MMTrack(j), %IDM_3Pi CASE "4PI": GetInstrumentParams MMTrack(j), %IDM_4Pi CASE "BALSI": GetInstrumentParams MMTrack(j), %IDM_BALSI CASE "TUBO": GetInstrumentParams MMTrack(j), %IDM_TUBO CASE "FLUT" :GetInstrumentParams MMTrack(j), %IDM_FLUT CASE "HAT" :GetInstrumentParams MMTrack(j), %IDM_HAT CASE "RUMO", "HUNT": GetInstrumentParams MMTrack(j), %IDM_RUMO CASE "RORO" : GetInstrumentParams MMTrack(j), %IDM_RORO ' 04.05.2021 gwr CASE "STEELY" : GetInstrumentParams MMTrack(j), %IDM_STEELY ' 02.01.2022 gwr '**** here we could foresee something like "HARMTRACK", which doesn't ge tplayed but can be followed by the callback for interactive implementations ' we have to deal in some way with _not_ playing the track thow then.. CASE "HARMTRACK": MMTrack(j).naam = "HARMTRACK" 'port 0 channel 0 is safe for now.. '' CASE "": Midilogfile " NOT an M&Mrobot!- ignore " 'do nothing - empty track CASE ELSE '!!something goes wrong if this happens!! - check IF j > 0 THEN Warning "unknown instrument for M&M @ track" + STR$(j)+ " : " + b$, 10000: ''midilogfile " !! Unknown instrument for M&M @ track" + STR$(j)+ " : " + b$ MMTrack(j).naam = "" 'fill in... 'ETC END SELECT ''midilogfile " "+MMtrack(J).naam + STR$(j) + "->" + HEX$(MMTrack(j).channel) NEXT Warning "Starting up the robots with their default controller values." '+ $CRLF + "Make sure to set the desired values at the start of your file!!", 15000 ' '***************************************************************************************************************** ' '******** here we sent default controllers to selected automats.. ' '******* this is now happening in MM_PreparControllers.. ' '********************************************************************************************************************* ' FOR i = 0 TO UBOUND(MMTrack) ' setRobotPort MMTrack(i), "", hMidiO() '' warning MMtrack(i).naam + STR$(i) + "->" + hex$(MMTrack(i).channel) ' FOR j = 126 TO 0 STEP -1 '127 = pic reset on some machines, which shouldn't be sent from here.. ' IF MMTrack(i).ctrl(j) THEN ' Controller MMTrack(i).channel, j, MMTrack(i).ctrl(j) ' END IF ' NEXT ' NEXT ' 'we set vibi in damping mode by default (not handled in the for next above here because we need to send zero to ctrl 64 ' IF containsvibi THEN ' Controller MMTrack(containsVibi).channel, 64, 0 ' Controller MMTrack(containsVibi).channel, 24, 1 ' Controller MMTrack(containsVibi).channel, 23, 40 ' END IF 'inits for instruments that can be remapped by notemap function GetInstrumentPArams Vacca, %IDM_VACCA REDIM VaccaNotes(Vacca.LowTes TO Vacca.HighTes) GetVaccaMapping VaccaNotes() GetInstrumentParams Llor, %IDM_LLOR REDIM LlorNotes(Llor.LowTes TO Llor.Hightes) GetLlormapping LlorNotes() GetInstrumentPArams Vitello, %IDM_VITELLO REDIM VitelloNotes(44 TO Vitello.hightes) GetVitelloMapping VitelloNotes() GetInstrumentPArams Belly, %IDM_BELLY REDIM BellyNotes(Belly.LowTes TO Belly.HighTes) GetBellyMapping BellyNotes() #IF %DEF(%midiplayer_wordy) logfile "vitello check" FOR i = LBOUND(vitellonotes) TO UBOUND(vitellonotes) logfile STR$(i) + STR$(vitellonotes(i).nf) NEXT logfile "belly check" FOR i = LBOUND(bellynotes) TO UBOUND(bellynotes) logfile STR$(i) + STR$(bellynotes(i).nf) NEXT #ENDIF 'init MMnotemap function IF wh THEN MMNotemap md, 0, trackinfo$, wh 'init notemap filterf MidiPlayerStop BYVAL VARPTR(MMTrack(0)), BYVAL UBOUND(MMTrack) 'pass instrument data.. END IF EXIT SUB END IF 'and END SUB FUNCTION MM_Prepare_Controllers(md() AS ParsedMidiType) AS LONG 'call this function after MM_Init tracks 'sends first value in file for each controller (for controllers in this track that occur before first note) or default controller if the one in file is not present 'update 2012.09.10 when sending standard controllers, now ctrl 66 is sent first, before all the rest. ' implemented because resets the other controllers when it receives ctrl 66 ' other ctrl66's in the file for Klar are surpressed STATIC ctls() AS INTEGER LOCAL filled() AS INTEGER LOCAL i AS LONG, j AS LONG, n AS BYTE REDIM ctls(UBOUND(MMTrack), 126) 'never sent ctl 127 (pic reset) from here DIM filled(7) ' MSGBOX "Warning: experimental controller prefetch active",,FUNCNAME$ MAT ctls() = CON(-1) '-1 = don't send ctl, so we can distinguish no ctrl from ctrl with value 0 '' midilogfile "********************** " + FUNCNAME$ + " **********************" ' logfile "" ' logfile "-------------------- ++ MM DEFAULTS" ' logfile "" 'first fill in from standard controllers FOR i = 0 TO UBOUND(MMTrack) setRobotPort MMTrack(i), "", hMidiO() ' warning MMtrack(i).naam + STR$(i) + "->" + hex$(MMTrack(i).channel) FOR j = 126 TO 0 STEP -1 '127 = pic reset on some machines, which shouldn't be sent from here.. IF MMTrack(i).ctrl(j) THEN 'Controller MMTrack(i).channel, j, MMTrack(i).ctrl(j) ctls(i, j) = MMTrack(i).ctrl(j) IF j = 7 THEN 'check wind controllers SELECT CASE UCASE$(TRIM$(MMTrack(i).naam)) CASE "KRUM": IF ctls(i,j) THEN ctls(i,j) = %MM_Krum_Motor CASE "HUMANOLA": IF ctls(i,j) THEN ctls(i,j) = %MM_Humanola_Motor CASE "TRUMP": IF ctls(i,j) THEN ctls(i,j) = %MM_Trump_Motor END SELECT END IF logfile "default " + MMTrack(i).naam + STR$(MMTrack(i).channel) + STR$(j) + STR$(ctls(i,j)) END IF NEXT j NEXT i 'we set vibi in damping mode by default (not handled in the for next above here because we need to send zero to ctrl 64 ' IF containsvibi THEN ctls(containsvibi, 64) = 0: ctls(containsvibi, 24) = 1: ctls(containsvibi, 23) = 40 'now see what's in file logfile "" logfile "-------------------- ++ FIRST IN TRACK" logfile "" FOR i = LBOUND(MMTrack) TO UBOUND(MMTrack) IF ISFALSE LEN(REMOVE$(MMTrack(i).naam, CHR$(0))) THEN ITERATE FOR 'skip tracks that are not M&M instruments RESET filled() FOR j = LBOUND(md) TO UBOUND(md) 'TO DO 'we're only interested in track j.. IF md(j).track <> i THEN ITERATE FOR ' logfile " event" + STR$(j) + HEX$(md(j).bstat) + STR$(md(j).bdat1) + STR$(md(j).bdat2) 'note? - go to next track IF (md(j).bstat AND &H0F0) = &H090 THEN EXIT FOR 'iterates the for i 'controller? not flagged? -> fill in and flag IF ((md(j).bstat AND &H0F0) = &H0B0) THEN IF BIT(filled(0), md(j).bdat1) THEN ITERATE FOR IF TRIM$(UCASE$(MMTrack(i).naam)) = "THUNDERWOOD" AND md(j).bdat1 = 70 THEN ITERATE FOR 'zwaailicht IF TRIM$(UCASE$(MMTrack(i).naam)) = "SPRINGERS" AND md(j).bdat1 = 70 THEN ITERATE FOR 'zwaailicht IF TRIM$(UCASE$(MMTrack(i).naam)) = "KLAR" AND md(j).bdat1 = 66 THEN ITERATE FOR 'klar forgets all other controllers on ctrl66!! 'IF TRIM$(UCASE$(MMTrack(i).naam)) = "FA" AND md(j).bdat1 = 66 THEN ITERATE FOR 'fa forgets all other controllers on ctrl66!! 'IF TRIM$(UCASE$(MMTrack(i).naam)) = "HORNY" AND md(j).bdat1 = 66 THEN ITERATE FOR BIT SET filled(0), md(j).bdat1 ctls(i, md(j).bdat1) = md(j).bdat2 IF (j = 7) AND (TRIM$(UCASE$(MMTrack(i).naam)) = "HARMA") THEN ctls(i, j) = MIN(ctls(i,j), %MM_Harma_Motor) END IF '' midilogfile " first occurence of cc - " + MMTrack(i).naam + STR$(MMTrack(i).channel) + STR$(md(j).bdat1) + STR$(ctls(i,md(j).bdat1)) END IF NEXT j NEXT i ' logfile "" '' midilogfile "-------------------- ++ SEND INITIAL CONTROLLERS" ' logfile "" 'now send controllers with some pacing FOR i = 0 TO UBOUND(ctls, 1) 'tracknr 'IF ctls(i, 66) THEN SLEEP 1 Controller MMTrack(i).channel, 66, 127 'ctls(i, 66) 'END IF FOR j = 0 TO UBOUND(ctls, 2) IF j = 66 THEN ITERATE FOR IF ctls(i, j) >= 0 THEN Controller MMTrack(i).channel, j, ctls(i,j) 'CHECK: is MMTrack.channel filled in -> yes , or do we need the musician indirection? '' midilogfile "ctlout " + MMTrack(i).naam + STR$(MMTrack(i).channel) + STR$(j) + STR$(ctls(i,j)) END IF NEXT j ' remmed gwr 25.04.2020 ' IF TRIM$(UCASE$(MMTrack(i).naam)) = "HYBR" THEN ' SLEEP 1 ' FOR n = hybr.lowtes TO hybr.hightes ' KeyPress Hybr.channel, i, 64 ' NEXT ' SLEEP 1 ' END IF NEXT i END FUNCTION SUB MM_Reset_Pitchbend(BYREF MMTrack() AS musician) LOCAL i AS LONG FOR i = LBOUND(MMTrack) TO UBOUND(MMTrack) IF INSTR("SO KORN OB BONO HELI AUTOSAX FA KLAR HORNY ASA BUG", UCASE$(TRIM$(MMtrack(i).naam))) THEN bend MMTrack(i).channel, 64, 64: logfile "reset bend for" + MMTrack(i).naam NEXT 'reset tuning controllers (only the ones that default to zero. other ones are already initialised with the value set in GetInstrumentParams) Controller autosax.channel, 20, 0 Controller so.channel, 20, 0 Controller bono.channel, 20, 0 Controller korn.channel, 20, 0 Controller heli.channel, 20, 0 END SUB %midiplayer_wordy = 1 'note: we could not put the following function in g_mm.inc or mrobots.inc without the libraries being dependent on an executable that contains the M&M functions, so 'we put it here.. FUNCTION MM_PrepareParsedMidiFile(BYREF md() AS parsedmiditype, BYREF mmTrack() AS musician, hdlgstart AS DWORD) AS LONG 'deletes unnecessary elements from the parsedmidi array (such as note offs for percussion, controllers that have no effect, out of range notes '20080212: update: we no longer delete unnecessary elements from the parsedmidi array, we just reset the status byte ' ARRAY DELETE appeared to be very slow.. LOCAL i AS DWORD LOCAL j AS DWORD LOCAL mevents AS DWORD LOCAL ctrl$() DIM ctrl$(UBOUND(MMTrack)) 'deze vullen we in met chr$(de controllernummers die zin hebben voor dit instrument) ' logfile FUNCNAME$ + " disabled!!" ' EXIT FUNCTION #IF %DEF(%midiplayer_wordy) logfile FUNCNAME$ + " @" + STR$(timegettime) #ENDIF '20070808 doesn't crash anymore. linked from player now. ' pitch bend still to do 'cleans up parsed midi data -mm specific (removes note offs for percussion etc.. 'related functions: ParseMidiFile (in g_file.bas), MM_MidiPlayer in g_midi.inc '1 - remove note offs for percussion CONTROL SET TEXT hDlgStart, 1, "filtering noteoffs" mevents = UBOUND(md) - LBOUND(md) FOR i = LBOUND(md) TO UBOUND(md) IF i > mevents THEN EXIT FOR IF ISFALSE i MOD 100 THEN DIALOG DOEVENTS 'stay responsive - this filtering may take some time IF (md(i).bstat AND &H0F0) <> &H090 THEN ITERATE FOR IF md(i).bdat2 THEN ITERATE FOR 'if this note on this instrument does require note off, then iterate for ' logfile UCASE$(TRIM$(MMTrack(md(i).track).naam)) SELECT CASE UCASE$(TRIM$(MMTrack(md(i).track).naam)) CASE "TUBI", "CASTA", "VACCA", "DRIPPER" 'to remove events do NOT iterate.. don't forget about the lights of percussion instruments! CASE "TOYPI": IF INSTR(CHR$(48 TO 53, 60 TO 70), CHR$(md(i).bdat1)) THEN ITERATE FOR CASE "VITELLO": IF INSTR(CHR$(12 TO 18), CHR$(md(i).bdat1)) THEN ITERATE FOR CASE "PUFF" 'weg als het niet voor lichtjes is IF INSTR(CHR$(53, 54, 100 TO 105), CHR$(md(i).bdat1)) THEN ITERATE FOR CASE "THUNDERWOOD" 'behalve wind, storm IF INSTR(CHR$(0,15,21,23, 24,25, 26, 120 TO 125), CHR$(md(i).bdat1)) THEN ITERATE FOR CASE "XY", "XYQ" : IF md(i).bdat1 > MMTrack(md(i).track).HighTes THEN ITERATE FOR 'lichtjes CASE "TROMS": IF md(i).bdat1 <= 21 THEN ITERATE FOR 'lights and damper CASE "PSCH": IF md(i).bdat1 > MMTrack(md(i).track).HighTes THEN ITERATE FOR CASE "CASTA2": IF md(i).bdat1 = 111 THEN ITERATE FOR 'CASE "KLUNG": IF md(i).bdat1 >= 120 AND md(i).bdat1 <= 123 THEN ITERATE FOR 'requires note of now with the automatic repeats CASE "BELLY": IF md(i).bdat1 >= 120 AND md(i).bdat1 <= 125 THEN ITERATE FOR CASE "SNAR": IF md(i).bdat1 >= 75 AND md(i).bdat1 <= 77 THEN ITERATE FOR CASE "ROTOMOTON": IF md(i).bdat1 >= 114 AND md(i).bdat1 <= 119 THEN ITERATE FOR ' CASE "SPRINGERS": IF md(i).bdat1 <> 24 THEN ITERATE FOR 'sirenn CASE "SIMBA": IF INSTR(CHR$(58,59,64,71,76,81,110 TO 114), CHR$(md(i).bdat1)) THEN ITERATE FOR 'motors,dampers,open-close cymbal, light CASE "PUFF": IF INSTR(CHR$(100,101,102), CHR$(md(i).bdat1)) THEN ITERATE FOR CASE "LLOR": IF INSTR(CHR$(1,2,3,4,5, 36 TO 47), CHR$(md(i).bdat1)) THEN ITERATE FOR CASE "TEMBLO": IF INSTR(CHR$(69, 120 TO 125), CHR$(md(i).bdat1)) THEN ITERATE FOR 'lights ' CASE "HARMO": IF INSTR(CHR$(1,7,66, 70 TO 82), CHR$(md(i).bdat1)) THEN ITERATE FOR ' case else 'TO DO some more have lights CASE ELSE: ITERATE FOR END SELECT #IF %DEF(%midiplayer_wordy) logfile "remove note off on " + MMTrack(md(i).track).naam #ENDIF 'if we get here, the event is a not-needed note off and we delete it 'ARRAY DELETE md(i) '->in big files this takes a while.. probably the 'array delete' is the culprit 'DECR events 'DECR i md(i).bstat = 0 'will cause the event to be disregarded by the player NEXT ' REDIM PRESERVE md(events) #IF %DEF(%midiplayer_wordy) logfile " noteoffs removed @" + STR$(timegettime) #ENDIF '2 - remove notes out of range (watch out - don't remove lights!!) 'first compile a list of actual ranges, INCLUDING lights etc.. 'we stick to continuous ranges, which means we don't allways exlcude all meaningless notes.. CONTROL SET TEXT hDlgStart, 1, "filtering out of range notes in " FOR i = LBOUND(MMTrack) TO UBOUND(MMTrack) 'update ranges - lights etc 'note: you only have to add instruments for which the range is different from the one of getinstrumentparams (because of lights etc..) SELECT CASE UCASE$(TRIM$(MMTrack(i).naam)) CASE "HUMANOLA", "VOXHUMANOLA":MMTrack(i).lowtes = 31: MMTRack(i).Hightes=127 'horn, casta and lights 'to prevent breaking older files we allow piperola notes in bourdonola tracks and vice versa CASE "PIPEROLA":MMTrack(i).HighTes = 127: MMTrack(i).Lowtes = 32 'lights &percussion CASE "BOURDONOLA": MMTrack(i).LowTes = 32: MMTrack(i).HighTes = 127 'lights CASE "TROMS":MMTrack(i).LowTes = 18 CASE "KRUM":MMTrack(i).Hightes = 102 CASE "KLUNG":MMTrack(i).HighTes = 123 CASE "SPRINGERS": MMTrack(i).lowtes = 0: MMTrack(i).HighTes = 127 'we allow all notes that where in old as well as in new range CASE "HARMA":MMTrack(i).HighTes = 98 CASE "AKE":MMTrack(i).HighTes =96 CASE "LLOR":MMTrack(i).LowTes = 1: MMTrack(i).HighTes = 127 'also allow notes for pitchmapping funxion CASE "SIRE":MMTrack(i).HighTes = 92 CASE "CASTA2": MMTrack(i).LowTes= 111 CASE "QT", "QTQ":MMTrack(i).LowTes = 35: MMTrack(i).HighTes = 120 CASE "PSCH":MMTrack(i).HighTes = 97 CASE "BAKO":MMTrack(i).LowTes = 10 CASE "XY", "XYQ":MMTrack(i).HighTes = 127 CASE "SNAR":MMTrack(i).HighTes = 77 CASE "SO": MMTrack(i).LowTes = 8: MMTrack(i).HighTes = 69 CASE "SIMBA": MMTrack(i).HighTes = 114 CASE "PUFF:": MMTrack(i).hightes = 105 CASE "VITELLO": MMTrack(i).lowtes = 12 CASE "BONO": MMTrack(i).lowtes = 12: MMTrack(i).highTes = 127 ' CASE "OB": MMTrack(i).lowtes = 58 'same as in getinstrumentparams, so no need to add it here.. CASE "KORN": MMTrack(i).lowtes = 48: MMTRack(i).hightes = 127 CASE "HELI": MMTrack(i).lowtes = 12: MMTrack(i).HighTes = 127 'lichtjes... hightes is lower in g_file, but documentation on site says 91 CASE "TOYPI": MMTrack(i).lowtes = 48 'voor lichtjes.. CASE "HARMO": MMTrack(i).HighTes = 127 'licht.. CASE "BOMI": MMTrack(i).HighTes = 127 'licht CASE "VIBI": MMTrack(i).HighTes = 127 'licht CASE "FA": MMTrack(i).LowTes = 0: MMTrack(i).highTes = 90 CASE "OB": MMTrack(i).LowTes = 0 'for lights CASE "THUNDERWOOD": MMTrack(i).HighTes = 127 'lights CASE "SYNCHROCHORD": CASE "KLAR": MMTrack(i).HighTes = 126 'lights CASE "TEMBLO": MMTrack(i).HighTes = 125 'lights CASE "HORNY": MMTrack(i).HighTes = 122 'lights CASE "ASA": MMTrack(i).HighTes = 127 'lights CASE "WHISPER": MMTrack(i).HighTes = 123 'lights CASE "RODO": MMTrack(i).HighTes = 125 CASE "BUG": MMTrack(i).HighTes = 127 CASE "POS": MMTrack(i).HighTes = 127 'lights CASE "2PI": MMTrack(i).HighTes = 101 CASE "RORO": MMTrack(i).HighTes = 122 : MMTrack(i).LowTes = 36 'lights gwr 04.05.2021 CASE "STEELY": MMTrack(i).HighTes = 122 : MMTrack(i).LowTes = 65 ' check for and , END SELECT NEXT FOR i = LBOUND(md) TO UBOUND(md) ' logfile "i = "+STR$(i) + ", track =" + STR$(md(i).track) IF i > mevents THEN EXIT FOR IF ISFALSE i MOD 100 THEN DIALOG DOEVENTS 'stay responsive - this filtering may take some time IF (md(i).bstat AND &H0F0) <> &H090 THEN ITERATE FOR IF ISFALSE(MMTrack(Md(i).track).hightes) THEN ITERATE FOR IF(md(i).bdat1 < MMTrack(Md(i).track).lowtes) OR (md(i).bdat1 > MMTrack(Md(i).track).Hightes) THEN '#IF %DEF(%midiplayer_wordy) '' midilogfile "DELETE event " + STR$(i) + "on " + MMTrack(md(i).track).naam + " (out off range)" + STR$(md(i).bdat1) + STR$(md(i).bdat2) '#ENDIF ' ARRAY DELETE md(i) ' DECR events ' FOR j = i TO (UBOUND(md) - 1) ' md(j) = md(j + 1) ' NEXT ' DECR i md(i).bstat = 0 END IF NEXT ' logfile STR$(events) + " events left" ' REDIM PRESERVE md(events) #IF %DEF(%midiplayer_wordy) logfile " out of range notes removed @" + STR$(timegettime) #ENDIF ' MSGBOX "scan controllers",,FUNCNAME$ '3 - throw away unnecessary controllers, pitch bend, aftertouch, ... 'first we compile a list of used controllers for each instrument CONTROL SET TEXT hDlgStart, 1, "filtering controllers in " logfile "filtering controllers.." + STR$(UBOUND(MMTrack())) FOR i = LBOUND(MMTrack()) TO UBOUND(MMTrack()) logfile "track" + STR$(i) + " ->" + MMTrack(i).naam 'smartest would be if we could derive which controllers are used from the instrument params.. SELECT CASE UCASE$(TRIM$(MMTrack(i).naam)) 'to be filled in.. CASE "BOURDONOLA": ctrl$(i) = CHR$(1, 7, 10, 11, 65, 66, 123) 'we include the piperola-specific controllers because they are on the same channel CASE "HARMA": ctrl$(i) = CHR$(7, 66,123) CASE "KRUM": ctrl$(i) = CHR$(1, 7, 11, 12, 13, 66,100,101,123) CASE "PIPEROLA": ctrl$(i) = CHR$(1, 7, 10, 11, 65, 66, 123) 'also bourdonola ctrls allowed.. CASE "HUMANOLA", "VOXHUMANOLA", "CASTA": ctrl$(i) = CHR$(7,10,11,123) CASE "TRUMP": ctrl$(i) = CHR$(123,7) CASE "AKE": ctrl$(i) = CHR$(1,7,66,123) CASE "BAKO":ctrl$(i) = CHR$(1,7,20,66,70,123) CASE "QT", "QTQ": ctrl$(i) = CHR$(1,2,7,8,11,12,66,67,68,69,70,123) CASE "PUFF": ctrl$(i) = CHR$(123) CASE "KLUNG": ctrl$(i) = CHR$(30, 66, 67) CASE "ROTOMOTON": ctrl$(i)= CHR$(65,66,81,82,83,84,85,91,92,93,94,95,101,102,103,104,105) CASE "SPRINGERS": ctrl$(i) = CHR$(70, 123) CASE "THUNDERWOOD": ctrl$(i) = CHR$(1,70,123) CASE "PSCH": ctrl$(i) = CHR$(123) CASE "TROMS": ctrl$(i) = CHR$(11, 123) 'also include snar.. CASE "SNAR": ctrl$(i) = CHR$(11,123) CASE "VIBI": ctrl$(i) = CHR$(7,20,21,22,23,24,64,66,123) CASE "BELLY": ctrl$(i) = CHR$(4,66,67,68,72,123) CASE "FLEX": ctrl$(i) = CHR$(1,2,3,4,20,21,40,41,42,43,44,45,46,52,53,66,123) CASE "XY", "XYQ": ctrl$(i)= CHR$(66,123) CASE "VACCA":ctrl$(i) = CHR$(72) CASE "LLOR": ctrl$(i) = CHR$(72,123) CASE "TUBI": ctrl$(i) = CHR$(66) CASE "CASTA2": ctrl$(i) = CHR$(123) CASE "SIMBA": ctrl$(i)= CHR$(123) CASE "AUTOSAX":ctrl$(i)=CHR$(1,7,12,13,17 TO 20, 65,66,67, 123) CASE "PLAYERPIANO", "PIANOLA", "PLAYER": ctrl$(i) = CHR$(64, 65, 66, 67, 123) 'added new pedal controllers @ 2010.10.19 CASE "DRIPPER": ctrl$(i) = CHR$(66, 123) CASE "SO": ctrl$(i) = CHR$(1,7,13,14,15,16,17,18,20,21,22,66,123) CASE "SIRE": ctrl$(i) = CHR$(72,123) CASE "HURDY":ctrl$(i) = CHR$(1 TO 7,20 TO 25,64 TO 72) CASE "BONO": ctrl$(i) = CHR$(1,7,17 TO 20, 25,66,123) CASE "VITELLO": ctrl$(i) = CHR$(72) CASE "OB": ctrl$(i) = CHR$(1,7,17 TO 20, 22,66,123) CASE "HELI": ctrl$(i) = CHR$(7,8,13,14,17 TO 20, 25, 26,27,66,123) CASE "KORN": ctrl$(i) = CHR$(17,18,21,22,25,70,123) CASE "HARMO": ctrl$(i) = CHR$(1, 7, 66, 70 TO 82) CASE "BOMI": ctrl$(i) = CHR$(1, 7, 11, 12, 66, 123) CASE "FA": ctrl$(i) = CHR$(1,3 TO 7, 16 TO 26, 30, 31, 42, 66, 100 TO 103, 123) 'úpdated 2017.02.28 - was filtering out tremolo! CASE "SPIRO": ctrl$(i) = CHR$(28, 29, 66, 123) 'still to be determined CASE "SYNCHROCHORD": 'still to be determined CASE "KLAR": ctrl$(i) = CHR$(1, 3 TO 7,16 TO 20,22,25,26,30,31,41,42,43,44,66,100,102,123) 'still to be determined CASE "HORNY": ctrl$(i) = CHR$(1,3 TO 7,16 TO 20,22,25 TO 30,33,40 TO 44,66,123) CASE "ASA": ctrl$(i) = CHR$(1,3 TO 7,16,17 TO 20,22,25 TO 31, 33,40,42, 43,44,66,123) CASE "TEMBLO": ctrl$(i) = CHR$(66, 123) CASE "WHISPER": ctrl$(i) = CHR$(123) ' CASE "RODO":ctrl$(i) = CHR$(1 TO 7, 11,13 TO 19,64 TO 66, 70 TO 79, 123) CASE "HYBR": ctrl$(i) = CHR$(1, 3 TO 7, 16 TO 20, 23 TO 62, 66, 67, 73 TO 112, 124 ) CASE "HYBRHI": ctrl$(i) = CHR$(1, 3 TO 7, 16 TO 20, 63, 66, 67, 113, 124) CASE "HYBRLO": ctrl$(i) = CHR$(1, 7, 15,17 TO 59, 66, 70 TO 81, 90) CASE "TINTI": ctrl$(i) = CHR$(7, 8, 30, 31, 66) ' CASE "CHI": ctrl$(i) = CHR$(7, 8, 30, 31, 65, 66, 70, 74, 75, 76) CASE "MELAUTON": ctrl$(i) = CHR$(7, 66, 68) CASE "PI", "PI_": ctrl$(i) = CHR$(1, 7, 15 TO 19, 66) CASE "POS": ctrl$(i) = CHR$(7, 30, 66, 123) CASE "PER": ctrl$(i) = CHR$(30, 66, 123) 'volgens docu 30?/6/2018 CASE "TUBO": ctrl$(i) = CHR$(20, 21, 22, 25, 64, 66, 123) CASE "RORO": ctrl$(i) = CHR$(7, 11, 30, 66, 69, 123) ' gwr 04.04.2021 ' to do: add flut CASE ELSE: ctrl$(i) = "": logfile "controller filtering not implemented in "+ FUNCNAME$ + " for "+ MMTrack(i).naam 'catch all -> empty means let all controllers through (so player keeps working if new instruments are not yet added here) END SELECT NEXT 'now scan for controllers mevents = UBOUND(md) logfile STR$(mevents) + " events" FOR i = LBOUND(md) TO UBOUND(md) logfile STR$(i) + " - " + HEX$(md(i).bstat) + " " + HEX$(md(i).bdat1) + " " + STR$(md(i).track) + " - " + MMTrack(md(i).track).naam IF md(i).track > UBOUND(MMTrack) THEN ITERATE FOR 'seems to be possible in case tracks are muted in sonar.. IF ISFALSE LEN(MMTrack(md(i).track).naam) THEN logfile "skip" ITERATE FOR END IF IF i > mevents THEN EXIT FOR IF ISFALSE i MOD 100 THEN DIALOG DOEVENTS 'stay responsive - this filtering may take some time IF (md(i).bstat AND &H0F0) <> &H0B0 THEN ITERATE FOR 'only controllers IF ISFALSE LEN(ctrl$(md(i).track)) THEN ITERATE FOR IF INSTR(CHR$(50,51), CHR$(md(i).bdat1)) THEN ITERATE FOR 'controllers with special meaning in the player IF ISFALSE INSTR(ctrl$(md(i).track), CHR$(md(i).bdat1)) THEN ' ARRAY DELETE md(i) ' DECR events ' FOR j = i TO (UBOUND(md) - 1) ' md(j) = md(j + 1) ' NEXT ' DECR i '' midilogfile "delete ctl" + STR$(md(i).bdat1) + " on " + UCASE$(TRIM$(MMTrack(md(i).track).naam)) md(i).bstat = 0 END IF NEXT '?? plug in correction of invalid controllers?? ' REDIM PRESERVE md(events) #IF %DEF(%midiplayer_wordy) logfile " controllers filtered @" + STR$(timegettime) #ENDIF FUNCTION = mevents logfile "done " + FUNCNAME$ END FUNCTION SUB Midi2mdi(MMTrack() AS musician, md() AS ParsedMidiType , sourcefilename$) 'first step for parsed midi format: dump of parsedmiditype, 2 chunks in csv-like format.. 'dependant on where you put thsi in the processing chain it can return a representation of the original file in parsedmiditype format, or the cleaned up version 'ready to play 'note that at this point certain things (like translating of klok notes, limiting of some controllers) still happens during playback, which may or may not be desirable.. LOCAL filenam$ LOCAL f AS LONG LOCAL i AS LONG filenam$ = REMOVE$(sourcefilename$, ".mid") + ".mdi" f = FREEFILE OPEN filenam$ FOR OUTPUT ACCESS WRITE LOCK WRITE AS f PRINT# f, "mdi - LogoSoft Preparsed midi format" PRINT# f, "[TRACKINFO]" PRINT# f, "id,","name" FOR i = LBOUND(MMTrack) TO UBOUND(MMTrack) PRINT# f, STR$(i) ; ",", MMTrack(i).naam 'other params can be derived from name NEXT PRINT# f, "[/TRACKINFO] PRINT# f, "[EVENTS]" '!TO DO: headers and parsedmidifile() dump PRINT# f, "time (ms),","track,","tempo,", "status,","data1,","data2" 'time = double precision!! - maybe it's not necessary to include tempo here? (used for computations if user changes the tempo..) FOR i = LBOUND(md) TO UBOUND(md) PRINT# f, md(i).time;",", md(i).track;",", md(i).tempo;",", md(i).bstat;",",md(i).bdat1;",", md(i).bdat2 NEXT PRINT# f, "[/EVENTS] PRINT# f, "[EOF]" CLOSE f END SUB 'FUNCTION MMChMap(BYVAL md AS parsedmiditype, OPT BYVAL trackinfo$, OPT BYVAL wh AS DWORD) AS WORD ' 'actual filter for M&M ' 'for some events just gives channel, takes care of some events (notes that serve as wind ctrl for organs etcc..) ' 'invokes MMNotemap for 'normal' notes ' 'IN THE REWORKS '' STATIC m() AS musician replaced by global MMTRACK() ' LOCAL i AS LONG ' LOCAL j AS LONG ' LOCAL fPOS AS LONG ' LOCAL length AS LONG ' LOCAL b$ ' LOCAL containsSo AS LONG ' LOCAL containsvibi AS LONG 'voor damping ctrl.. ' '!--> first part of this function (if trackinfo$ filled in) should become just an init function ' '!--> second part should become a macro or simply put inline in MM_MidiPlayer ' IF LEN(trackinfo$) AND (wh > 0) THEN ' i = VAL(PARSE$(trackinfo$, CHR$(1), PARSECOUNT(trackinfo$, CHR$(1)) - 1)) ' ERASE MMTrack(): REDIM MMTrack(i) AS STATIC musician ' FOR i = 1 TO PARSECOUNT (trackinfo$, CHR$(1)) STEP 2 ' j = VAL(PARSE$(trackinfo$, CHR$(1), i)) ' b$ = PARSE$(trackinfo$, CHR$(1), i + 1) ' REGEXPR "<([a-zA-Z0-9_ ]+)>" IN b$ TO fPOS, length ' b$ = UCASE$(REMOVE$(MID$(b$, fPOS, length), ANY "<> ")) ' SELECT CASE b$ ' CASE "PIANOLA", "PLAYER", "PLAYERPIANO": GetInstrumentParams MMTrack(j), %IDM_PLAYERPIANO ' CASE "HUMANOLA", "VOXHUMANOLA": GetInstrumentParams MMTrack(j), %IDM_HUMANOLA ' CASE "PIPEROLA": GetInstrumentParams MMTrack(j), %IDM_PIPEROLA ' CASE "BOURDONOLA": GetInstrumentParams MMTrack(j), %IDM_BOURDONOLA ' CASE "AUTOSAX": GetInstrumentParams MMTrack(j), %IDM_AUTOSAX ' CASE "KLUNG": GetInstrumentParams MMTrack(j), %IDM_KLUNG ' CASE "THUNDERWOOD": GetInstrumentParams MMTrack(j), %IDM_THUNDERWOOD ' CASE "TROMS": GetInstrumentParams MMTrack(j), %IDM_TROMS ' changed 12.04.2004 ' CASE "SPRINGERS": GetInstrumentParams MMTrack(j), %IDM_SPRINGERS ' CASE "ROTOMOTON": GetInstrumentParams MMTrack(j), %IDM_ROTOMOTON ' CASE "HARMA": GetInstrumentParams MMTrack(j), %IDM_HARMA ' CASE "VIBI": GetInstrumentParams MMTrack(j), %IDM_VIBI: containsVibi = j ' CASE "BELLY": GetInstrumentParams MMTrack(j), %IDM_BELLY ' CASE "FLEX": GetInstrumentParams MMTrack(j), %IDM_FLEX ' CASE "SO": GetInstrumentParams MMTrack(j), %IDM_SO: containsSo = j ' CASE "TUBI": GetInstrumentParams MMTrack(j), %IDM_TUBI ' gwr 23.01.2005 ' CASE "PUFF": GetInstrumentParams MMTrack(j), %IDM_PUFF ' gwr 15.11.2003 ' CASE "TRUMP": GetInstrumentParams MMTrack(j), %IDM_TRUMP ' gwr 18.07.2004 ' CASE "HURDY": GetInstrumentParams MMTrack(j), %IDM_HURDY ' gwr 18.07.2004 ' CASE "AKE": GetInstrumentParams MMTrack(j), %IDM_AKE ' CASE "LLOR": GetInstrumentParams MMTrack(j), %IDM_LLOR ' CASE "DRIPPER": GetInstrumentParams MMTrack(j), %IDM_DRIPPER ' 16.03.2005 ' CASE "SIRE": GetInstrumentParams MMTrack(j), %IDM_SIRE ' 16.03.2005 ' CASE "VACCA": GetInstrumentParams MMTrack(j), %IDM_VACCA': containsvacca=j ' 16.03.2005 ' CASE "CASTA", "CASTAGENTS": GetInstrumentParams MMTrack(j), %IDM_CASTA '19.07.2005 ' CASE "" 'do nothing - empty track ' CASE ELSE '!!something goes wrong if this happens!! - check ' IF j > 0 THEN Warning "unknown instrument for M&M @ track" + STR$(j)+ " : " + b$, 10000 ' 'fill in... ' 'ETC ' END SELECT ' NEXT ' Warning "Starting up the robots with their default controller values." + $CRLF + "Make sure to set the desired values at the start of your file!!", 15000 ' 'send default controllers to selected automats.. ' FOR i = 0 TO UBOUND(MMTrack) ' setRobotPort MMTrack(i), "", hMidiO() ' FOR j = 126 TO 0 STEP -1 '127 = pic reset on some machines, which shouldn't be sent from here.. ' IF MMTrack(i).ctrl(j) THEN ' Controller MMTrack(i).channel, j, MMTrack(i).ctrl(j) ' END IF ' NEXT ' NEXT ' IF containsso THEN SO_Play MMTrack(containsso) ' 'we set vibi in damping mode by default (not handled in the for next above here because we need to send zero to ctrl 64 ' IF containsvibi THEN ' Controller MMTrack(containsVibi).channel, 64, 0 ' Controller MMTrack(containsVibi).channel, 24, 1 ' Controller MMTrack(containsVibi).channel, 23, 40 ' END IF ' 'inits for instruments that can be remapped by notemap function ' GetInstrumentPArams Vacca, %IDM_VACCA ' REDIM VaccaNotes(Vacca.LowTes TO Vacca.HighTes) ' GetVaccaMapping VaccaNotes() ' GetInstrumentParams Llor, %IDM_LLOR ' 'init MMnotemap function ' MMNotemap md, 0, trackinfo$, wh 'init notemap filterf '' MidiPlayerStop BYVAL VARPTR(m(0)), BYVAL UBOUND(m) 'pass instrument data.. ' EXIT FUNCTION ' END IF 'and ' '!--> the following belongs inline in the MM_Midiplayer funxion ' 'status byte specific filters.. ' 'use their return values: channel if event has 2b handled by main filter, otherwise -1 ' SELECT CASE md.bStat ' 'normal notes: filter that alows velo scaling, add also other limit/transl-ations.. ' CASE &H090 TO &H09F, &H0B0 TO &H0BF 'we pass controllers to notemap for information for harma velo slider.. ' i = MMNotemap (md, MMTrack(md.track).channel) ' IF i THEN FUNCTION = i ELSE FUNCTION = MMTrack(md.track).channel ' EXIT FUNCTION ' END SELECT ' FUNCTION = MMtrack(md.track).channel 'END FUNCTION FUNCTION SireMap(BYVAL md AS ParsedMidiType, OPT BYVAL ID AS BYTE) AS LONG 'special handling for 'id: a track id. - can be whatever value that fits in a byte. we map track id's to sirens here 'mode: BIT 0: break on (1) or off (0) ' BIT 1: 0 = pitchmapping, 1 = velo to pitch 'toggle mode with ctrl 72 'remark: in current implementation id is allways filled in when this function is called from the player ' theoretically you can use this function without id, but in practice this mode doesn't work very well ' because the sirens take a lot of time to come from silence to the right pitch.. STATIC Sire AS musician STATIC initialised AS LONG STATIC idlist$ 'in this string we keep the tracknr to id mapping - autoupdated as new tracks appear STATIC MODE AS LONG '0: translate midi note to pitch; >0: send velocities directly LOCAL sirennr AS LONG IF ISFALSE initialised THEN GetInstrumentParams Sire, %IDM_SIRE SetRobotPort Sire, "", hMidiO() initialised = %true idlist$ = CHR$(127) 'dummy fisrt char END IF SELECT CASE MODE AND &B010 CASE 0 'pitch mapping IF (md.bStat >= &H090) AND (md.bStat <= &H09F) THEN 'note on IF ID THEN sirennr = INSTR(idlist$, CHR$(ID)) IF sirennr <= 1 THEN idlist$ = idlist$ + CHR$(ID): sirennr = LEN(idlist$) IF sirennr > 24 THEN EXIT FUNCTION Sire_Play md.bDat1, md.bDat2, sirennr, MODE ELSE Sire_Play md.bDat1, md.bDat2, 0, MODE 'automatically handles selection of siren and doubling for low notes END IF FUNCTION = 1 END IF CASE 2 'velo and controller mapping IF (md.bStat >= &H090) AND (md.bStat <= &H09F) THEN 'note on IF md.bDat2 THEN ' logfile "on" + STR$(md.bDat1) + STR$(md.bDat2) mPlay Sire.channel, md.bDat1, md.bDat2 ELSE ' logfile "off" + STR$(md.bDat1) + STR$((NOT mode) AND &B01) mPlay Sire.channel, md.bDat1, ((NOT MODE) AND &B01) END IF ELSEIF (md.bdat1 >= 20) AND (md.bdat1 <= 71) AND ((md.bstat AND &H0F0) = &H0B0) THEN controller Sire.channel, md.bdat1, md.bdat2 END IF END SELECT IF (md.bdat1 = 72) AND ((md.bstat AND &H0F0) = &H0B0) THEN MODE = (md.bdat2 AND &B011) SELECT CASE MODE CASE 0: warning "sire mode: pitch mapping, break off" CASE 1: warning "sire mode: pitch mapping, break on" CASE 2: warning "sire mode: velo mapping, break off" CASE 3: warning "sire mode: velo mapping, break on" END SELECT FUNCTION = 1 END IF END FUNCTION FUNCTION VaccaMap (BYVAL md AS ParsedMidiType) AS LONG 'toggle mode with ctrl 72 '0 = no mapping, other value = allowed deviation (cents) for mapping STATIC modus AS LONG STATIC devi AS SINGLE LOCAL note AS BYTE IF (md.bdat1 = 72) AND ((md.bstat AND &H0F0) = &H0B0) THEN 'controller IF ISFALSE md.bdat2 THEN warning "vacca pitchmapping off" modus = 0 ELSE modus = 1 devi = MIN(100, md.bDat2) warning "vacca pitchmapping on, devi:" + STR$(devi) END IF FUNCTION = -1 END IF IF (md.bStat >= &H090) AND (md.bStat <= &H09F) THEN 'note on IF modus THEN note = GetNoteNrFromKloktype(VARPTR(VaccaNotes(LBOUND(vaccanotes))), LBOUND(VAccanotes), UBOUND(vaccanotes), BYVAL md.bdat1, BYVAL devi) IF note THEN mPlay Vacca.channel, note, md.bDat2 'why does vacca play along with this??! END IF FUNCTION = -1 END IF 'else let calling function handle the note END IF END FUNCTION FUNCTION LlorMap (BYVAL md AS ParsedMidiType) AS LONG 'toggle mode with ctrl 72 '0 = no mapping, other value = allowed deviation (cents) for mapping STATIC modus AS LONG STATIC devi AS SINGLE LOCAL note AS BYTE #IF %DEF(%midiplayer_wordy) logfile FUNCNAME$ #ENDIF IF (md.bdat1 = 72) AND ((md.bstat AND &H0F0) = &H0B0) THEN 'controller IF ISFALSE md.bdat2 THEN #IF %DEF(%midiplayer_wordy) logfile "llor pitchmapping off" #ENDIF warning "Llor pitchmapping of" modus = 0 ELSE modus = 1 #IF %DEF(%midiplayer_wordy) logfile "llor pitchmapping onf, devi:" + STR$(devi) #ENDIF devi = MIN(100, md.bDat2) 'cents warning "Llor pitchmapping on, devi:" + STR$(devi) END IF FUNCTION = -1 END IF IF (md.bStat >= &H090) AND (md.bStat <= &H09F) THEN 'note on logfile " llor with velo" + STR$(md.bdat2) IF modus THEN IF md.bdat2 THEN PlayLlor(md.bDat1, md.bDat2, devi) FUNCTION = -1 END IF 'else let calling function handle this event in a normal way.. END IF END FUNCTION FUNCTION BellyMap (BYVAL md AS ParsedMidiType) AS LONG 'toggle mode with ctrl 72 '0 = no mapping, other value = allowed deviation (cents) for mapping STATIC modus AS LONG STATIC devi AS SINGLE LOCAL note AS BYTE ' logfile FUNCNAME$ + STR$(devi) + STR$(modus) IF (md.bdat1 = 72) AND ((md.bstat AND &H0F0) = &H0B0) THEN 'controller IF ISFALSE md.bdat2 THEN warning "Belly pitchmapping of" modus = 0 ELSE modus = 1 devi = MIN(100, md.bDat2) warning "Belly pitchmapping on, devi:" + STR$(devi) END IF FUNCTION = -1 END IF IF (md.bStat >= &H090) AND (md.bStat <= &H09F) THEN 'note on IF modus THEN note = GetNoteNrFromKloktype(VARPTR(BellyNotes(LBOUND(Bellynotes))), LBOUND(Bellynotes), UBOUND(Bellynotes), BYVAL md.bdat1, BYVAL devi) IF note THEN mPlay Belly.channel, note, md.bdat2 FUNCTION = -1 END IF 'else let calling function handle the note END IF END FUNCTION FUNCTION VitelloMap (BYVAL md AS ParsedMidiType) AS LONG 'toggle mode with ctrl 72 '0 = no mapping, other value = allowed deviation (cents) for mapping STATIC modus AS LONG STATIC devi AS SINGLE STATIC init AS DWORD 'debug LOCAL i AS LONG LOCAL note AS BYTE IF (md.bdat1 = 72) AND ((md.bstat AND &H0F0) = &H0B0) THEN 'controller IF ISFALSE md.bdat2 THEN warning "Vitello pitchmapping off" modus = 0 ELSE modus = 1 devi = MIN(100, md.bDat2) warning "Vitello pitchmapping on, devi:" + STR$(devi) END IF FUNCTION = -1 END IF IF (md.bStat >= &H090) AND (md.bStat <= &H09F) THEN 'note on IF modus THEN 'debug: ' IF ISFALSE init THEN ' init = 1 ' logfile "----------VITELLONOTES DOUBLECHECK-----------" ' FOR i = LBOUND(vitellonotes) TO UBOUND(vitellonotes) ' logfile STR$(i) + STR$(vitellonotes(i).nf) ' NEXT ' END IF note = GetNoteNrFromKloktype(VARPTR(VitelloNotes(LBOUND(vitellonotes))), LBOUND(Vitellonotes), UBOUND(Vitellonotes), BYVAL md.bdat1, BYVAL devi) IF note THEN mPlay Vitello.channel, note, md.bdat2 END IF FUNCTION = -1 END IF END IF END FUNCTION FUNCTION KloksMap (BYVAL md AS ParsedMidiType) AS LONG 'toggle mode with ctrl 72 '0 = no mapping, other value = allowed deviation (cents) for mapping STATIC devi AS SINGLE LOCAL vaccanote AS BYTE, vaccasound AS CURRENCY LOCAL bellynote AS BYTE, bellysound AS CURRENCY LOCAL vitellonote AS BYTE, vitellosound AS CURRENCY LOCAL llornote AS BYTE, llorsound AS CURRENCY LOCAL mn AS CURRENCY ' logfile FUNCNAME$ IF ISFALSE devi THEN devi = 25 IF (md.bdat1) = 72 AND ((md.bstat AND &H0F0) = &H0B0) THEN devi = MIN(100, md.bdat2) FUNCTION = -1 warning "klokmapping devi (cents):" + STR$(devi) END IF IF (md.bStat >= &H090) AND (md.bStat <= &H09F) THEN ' logfile "check llor" llornote = PlayLlor(md.bDat1, md.bDat2, devi, 1) ' logfile STR$(llornote) ' logfile "check vitelo" vitellonote = GetNoteNrFromKloktype(VARPTR(VitelloNotes(LBOUND(Vitellonotes))), LBOUND(Vitellonotes), UBOUND(Vitellonotes), BYVAL md.bdat1, BYVAL devi) ' logfile STR$(vitellonote) ' logfile "check belly" bellynote = GetNoteNrFromKloktype(VARPTR(BellyNotes(LBOUND(Bellynotes))), LBOUND(Bellynotes), UBOUND(Bellynotes), BYVAL md.bdat1, BYVAL devi) ' logfile STR$(bellynote) ' logfile "check vacca" vaccanote = GetNoteNrFromKloktype(VARPTR(VaccaNotes(LBOUND(vaccanotes))), LBOUND(VAccanotes), UBOUND(vaccanotes), BYVAL md.bdat1, BYVAL devi) ' logfile STR$(vaccanote) ' logfile "check sounds" IF vaccanote THEN vaccasound = Vaccanotes(vaccanote).nf 'convert to currency IF vitellonote THEN vitellosound = Vitellonotes(vitellonote).nf IF bellynote THEN bellysound = Bellynotes(bellynote).nf IF llornote THEN llorsound = Llornotes(llornote).nf mn = MIN(ABS(vaccasound - md.bdat1), ABS(vitellosound - md.bdat1), ABS(bellysound - md.bdat1), ABS(llorsound - md.bdat1)) ' logfile STR$(llorsound) + STR$(vitellosound) + STR$(bellysound) + str$(vaccasound) + str$(md.bdat1) ' logfile "mindif:" + str$(mn) ' logfile "difs:" + str$(ABS(llorsound - md.bdat1)) + STR$(ABS(vitellosound - md.bdat1)) + STR$(ABS(bellysound - md.bdat1)) + STR$(ABS(vaccasound - md.bdat1)) SELECT CASE INT(100 * mn) CASE md.bdat1 'nothing to play CASE ABS(INT(100 *(vaccasound - md.bdat1))) ' logfile "sell vacca" mPlay Vacca.channel, Vaccanote, md.bdat2 CASE ABS(INT(100 *(Vitellosound - md.bdat1))) mPlay vitello.channel, vitellonote, md.bdat2 ' logfile "sell vitello" CASE ABS(INT(100 *(bellysound - md.bdat1))) mPlay Belly.channel, Bellynote, md.bdat2 ' logfile "sell belly" CASE ABS(INT(100 *(llorsound - md.bdat1))) PlayLlor md.bDat1, md.bDat2, devi, 0 ' logfile "sell llor" CASE ELSE 'nothing to play END SELECT FUNCTION = -1 END IF ' IF (md.bStat >= &H090) AND (md.bStat <= &H09F) THEN 'note on ' PlayKloks(md.bDat1, md.bDat2, devi) ' -> we can't use playkloks here!! in another lib.. ' end if END FUNCTION ' since we have the booter box, this should no longer be required.: 'FUNCTION Hybr_Patchwindow AS LONG ' 'here we group all elements that can influence Hybr tuning. ' '' this should help out finding a solution for when Hybr spontaneously gets out of tune again ' STATIC hw AS DWORD ' IF hw THEN EXIT FUNCTION ' DIALOG NEW @pgh.cockpit, "Hybr patch", 20, 20, 200, 100 TO hw ' CONTROL ADD CHECKBOX, hw, 1000, "CC66", 1, 3, 198, 12, %BS_PUSHLIKE ' CONTROL ADD CHECKBOX, hw, 1001, "CC124 - enable keypress", 1, 16, 198, 12, %BS_PUSHLIKE ' CONTROL ADD LABEL, hw, 2100, "KeyPress", 1, 29,45, 12 ' CONTROL ADD OPTION, hw, 2101, "0", 46, 29, 30,12, %WS_GROUP OR %BS_PUSHLIKE ' CONTROL ADD OPTION, hw, 2102, "64", 77, 29, 30,12, %BS_PUSHLIKE ' CONTROL ADD OPTION, hw, 2103, "127", 108, 29, 20,12, %BS_PUSHLIKE ' CONTROL SET OPTION hw, 2102, 2101, 2103 ' CONTROL ADD LABEL, hw, 2200, "CC20", 1, 44,45, 12 ' CONTROL ADD OPTION, hw, 2201, "0", 46, 44, 30,12, %WS_GROUP OR %BS_PUSHLIKE ' CONTROL ADD OPTION, hw, 2202, "64", 77, 44, 30,12, %BS_PUSHLIKE ' CONTROL ADD OPTION, hw, 2203, "127", 108, 44, 20,12, %BS_PUSHLIKE ' CONTROL SET OPTION hw, 2202, 2201, 2203 ' ' ' DIALOG SHOW MODELESS hw CALL cbhybrpatch 'END FUNCTION ' 'CALLBACK FUNCTION CBHybrPatch ' LOCAL i AS LONG ' IF CBMSG <> %WM_COMMAND THEN EXIT FUNCTION ' SELECT CASE CBCTL ' CASE 1000 ' IF CBCTLMSG = %BN_CLICKED THEN ' CONTROL GET CHECK CBHNDL, CBCTL TO i ' i = i * 127 ' Warning "CC66 "+ STR$(i) ' Controller Hybr.channel, 66, i ' END IF ' CASE 1001 ' IF CBCTLMSG = %BN_CLICKED THEN ' CONTROL GET CHECK CBHNDL, CBCTL TO i ' i = i * 127 ' Warning "CC124 "+ STR$(i) ' Controller Hybr.channel, 124, i ' END IF ' CASE 2101 ' IF CBCTLMSG = %BN_CLICKED THEN ' Warning "Keypress 0" ' FOR i = hybr.LowTes TO Hybr.hightes ' KeyPress Hybr.channel, i, 0 ' NEXT ' END IF ' CASE 2102 ' IF CBCTLMSG = %BN_CLICKED THEN ' Warning "Keypress 64" ' FOR i = hybr.LowTes TO Hybr.hightes ' KeyPress Hybr.channel, i, 64 ' NEXT ' END IF ' CASE 2103 ' IF CBCTLMSG = %BN_CLICKED THEN ' Warning "Keypress 127" ' FOR i = hybr.LowTes TO Hybr.hightes ' KeyPress Hybr.channel, i, 127 ' NEXT ' END IF ' CASE 2201 ' IF CBCTLMSG = %BN_CLICKED THEN ' Warning "CC20 0" ' Controller Hybr.channel, 20, 0 ' END IF ' CASE 2202 ' IF CBCTLMSG = %BN_CLICKED THEN ' Warning "CC20 64" ' Controller Hybr.channel, 20, 64 ' END IF ' CASE 2203 ' IF CBCTLMSG = %BN_CLICKED THEN ' Warning "CC20 127" ' Controller Hybr.channel, 20, 127 ' END IF ' END SELECT ' ' ' 'END FUNCTION ' FUNCTION ToggleMM_Filter(BYVAL onoff AS DWORD) EXPORT AS LONG 'if onoff<> 0: creates thread and returns handle ' = 0: closes thread and returns thread close result STATIC hThread AS LONG STATIC stat AS DWORD LOCAL pStat AS DWORD PTR LOCAL RES AS LONG IF stat = onoff THEN EXIT FUNCTION SELECT CASE onoff CASE 0 stat = 0 IF hThread THEN THREAD CLOSE hThread TO RES FUNCTION = RES CASE 1 stat=1 pStat = VARPTR(stat) THREAD CREATE MM_MidiFilter(pstat) TO hThread FUNCTION = hThread END SELECT END FUNCTION MACRO MM_MidiFilter_ChannelSelecton 'shows window to offer default or alternate mapping 'in case of alternate asks for and parses a config file DIALOG NEW 0, "Select port mapping",,,72, 33, %WS_POPUP OR %WS_CAPTION TO hw CONTROL ADD BUTTON, hw, 1, "&default mapping", 1, 1, 70, 14, %BS_DEFAULT CONTROL ADD BUTTON, hw, 2, "&alternate mapping", 1, 17, 70, 14 DIALOG SHOW MODAL hw, CALL CBMMFilt TO i IF i = 2 THEN ofn.lStructSize = SIZEOF(ofn) ofn.hwndOwner = 0 ofn.hInstance = @pgh.Inst MID$(filn,1) = CHR$(0) ofn.lpStrFile = VARPTR(filn) ofn.nMaxfile = 300 origdir = CURDIR$ inidir = "C:\b\pb\gmt\robots\config" + CHR$(0) CHDIR "C:\b\pb\gmt\robots\config" ofn.lpStrInitialDir = VARPTR(inidir) filtr = "config files" + CHR$(0) + "*.cfg" + CHR$(0) +"all files" + CHR$(0) + "*.*" + CHR$(0,0,0,0) ofn.lpStrFilter = VARPTR(filtr) ofn.nFilterIndex=1 titl = "Open Config File" 'title$ ofn.lpStrTitle= VARPTR(titl) ofn.flags = %OFN_FILEMUSTEXIST OR %OFN_LONGNAMES OR %OFN_HIDEREADONLY OR %OFN_NOCHANGEDIR OR %OFN_EXPLORER GetOpenFileName ofn CHDIR origdir i = FREEFILE OPEN ofn.@lpStrFile FOR BINARY ACCESS READ LOCK WRITE AS i GET$ i, LOF(i), buf$ CLOSE i FOR i = LBOUND(inports) TO UBOUND(inports) inports(i) = -1 NEXT REPLACE $CRLF WITH CHR$(13) IN buf$ REPLACE CHR$(10) WITH CHR$(13) IN buf$ FOR i = 1 TO PARSECOUNT(buf$, CHR$(13)) b$ = PARSE$(buf$, CHR$(13), i) IF UCASE$(TRIM$(b$)) = "[ROBOT_CHANNEL_MAPPING]" THEN EXIT FOR NEXT INCR i FOR j = i TO UBOUND(inports) + i b$ = PARSE$(buf$, CHR$(13), j) IF UCASE$(TRIM$(b$)) = "[ROBOT_CHANNEL_MAPPING]" THEN EXIT FOR FOR k = LBOUND(MM) TO UBOUND(MM) IF UCASE$(TRIM$(@MM(k).naam)) = UCASE$(TRIM$(PARSE$(b$, 1))) THEN inports(k) = VAL(PARSE$(b$, 2)) ' logfile TRIM$(@MM(k).naam) +" " + HEX$(k) + "->" + HEX$(inports(k)) EXIT FOR END IF NEXT NEXT ' logfile "eos" warning "Midifilter: " + ofn.@lpStrFile ELSE warning "Midifilter: default mapping" FOR k = LBOUND(MM) TO UBOUND(MM) inports(k) = @MM(k).channel NEXT END IF END MACRO CALLBACK FUNCTION CBMMFilt IF CBMSG <> %WM_COMMAND THEN EXIT FUNCTION IF CBCTLMSG <> %BN_CLICKED THEN EXIT FUNCTION FUNCTION = CBCTL DIALOG END CBHNDL, CBCTL END FUNCTION THREAD FUNCTION MM_MidiFilter(BYVAL pS AS LONG) AS LONG 'midi trough, with filter for midi commands that might damage the automats (basically controls timing) 'we only need notes, controllers, progchanges. for klung: aftertouch 'for now we only filter out things that can be dangerous. we might consider implementing smart mappings though.. 'CALL THIS AS A THREAD. ps is a pointer to a static variable that remains 1 as long as the thread should run, become 0 afterwards 'presumes that input- and output channel have the same nr.. '060830ready for first tests 'after work with bruno spoerie: ' everything seems to work, but no thorough long note test done ' remapping of ports and channels added LOCAL i AS DWORD, j AS DWORD, k AS DWORD LOCAL buf$, b$ LOCAL dummy AS DWORD LOCAL init AS DWORD STATIC flags() AS LONG STATIC lastvels() AS BYTE STATIC timeouts() AS DWORD STATIC inports() AS LONG 'actually input port + channel for ins @MM(i) - -1 skips instrument. by default same as @MM(i).channel, but can be remapped.. STATIC pStat AS WORD PTR LOCAL hw AS DWORD LOCAL nv% LOCAL ofn AS OPENFILENAME LOCAL shortfiln AS STRING * 28 LOCAL filnnopath AS STRING * 80 LOCAL filn AS STRING * 300 LOCAL titl AS STRING * 80 LOCAL filtr AS STRING * 200 LOCAL exts AS STRING * 3 LOCAL inidir AS STRING * 256 LOCAL origdir AS STRING * 256 IF ps THEN pStat = ps ELSE Warning FUNCNAME$ + "expects a valid pointer as parameter!", 5000 END IF IF ISFALSE init THEN init = %true ' Init_mm REDIM flags(UBOUND(MM)) 'value -1: from here on no instruments filled in anymnore.. 'bit 0: requires note off, 1 get controllers, 2 get progchanges, 3 get aftertouch, 4 special mapping/treatment, 5 requires pitchbend '8 warning issued for this instrument REDIM inports(UBOUND(MM)) FOR i = LBOUND(MM) TO UBOUND(MM) SELECT CASE UCASE$(TRIM$(@MM(i).naam)) CASE "PLAYPIAN" flags(i) = &B0111 CASE "HUMANOLA" flags(i) = &B011 CASE "PIPEROLA" flags(i) = &B011 CASE "BOURDONOLA" flags(i) = &B011 CASE "KRUM" flags(i) = &B011 CASE "KLUNG" flags(i) = &B01111 CASE "TROMS" flags(i) = &B0 CASE "THUNDERWOOD" flags(i) = &B0110 CASE "SPRINGERS" flags(i) = &B0111 CASE "ROTOMOTON" flags(i) = &B01010 CASE "HARMA" flags(i) = &B00111 CASE "VIBI" flags(i) = &B011 CASE "BELLY" flags(i) = &B0110 CASE "AUTOSAX" flags(i) = &B0111 CASE "FLEX" flags(i) = &B0101111 CASE "TUBI" flags(i) = &B011 CASE "TRUMP" flags(i) = &B011 CASE "SO" flags(i)= &B010111 CASE "PUFF" flags(i) = &B0 CASE "HURDY" flags(i) = &B0111 CASE "AKE" flags(i) = &B011 CASE "LLOR" flags(i) = &B0111 CASE "SIRE" flags(i) = &B010010 CASE "DRIPPER" flags(i) = &B010 CASE "VACCA" flags(i) = &B0110 CASE "CASTA" 'bit 0: requires note off, 1 get controllers, 2 get progchanges, 3 get aftertouch, 4 special mapping/treatment, 5 requires pitchbend flags(i) = &B0110 CASE "VITELLO" flags(i) = &B0110 CASE "QT" flags(i) = &B01111 ' 30.12.2006 CASE "QTQ" flags(i) = &B01111 ' 13.03.2007 CASE "PSCH" flags(i) = &B0 CASE "SNAR" flags(i) = &B0110 CASE "BAKO" flags(i) = &B0011 ' 30.12.2006 CASE "XY" '13.04.2007 flags(i) = &B0101 CASE "XYQ" '13.04.2007 flags(i) = &B0100 CASE "TOYPI" flags(i) = &B01111 CASE "KORN" flags(i) = &B0110111 'special mapping that is much more liberal - on request by Yvan CASE "BONO" flags(i) = &B0100111 CASE "HELI" flags(i) = &B0110111 'special mapping that is much more liberal - on request by Yvan CASE "OB" flags(i) = &B0100111 CASE "HARMO" flags(i) = &B00111 logfile "harmo.flags:" + BIN$(flags(i)) + STR$(i) CASE "BOMI" flags(i) = &B011 CASE "FA" flags(i) = &B0100111 CASE "SPIRO" flags(i) = &B0111 CASE "SYNCHROCHORD" 'bit 0: requires note off, 1 get controllers, 2 get progchanges, 3 get aftertouch, 4 special mapping/treatment, 5 requires pitchbend flags(i) = &B0111 CASE "KLAR" flags(i) = &B0101111 CASE "HORNY" flags(i) = &B0101111 CASE "ASA" flags(i) = &B0101111 CASE "WHISPER" flags(i) = &B001011 CASE "RODO" flags(i) = &B0101111 CASE "HYBR", "HYBRHI", "HYBRLO" flags(i) = &B0101111 'bit 0: requires note off, 1 get controllers, 2 get progchanges, 3 get aftertouch, 4 special mapping/treatment, 5 requires pitchbend CASE "BALMEC", "BELLO" flags(i) = &B001111 CASE "TINTI" flags(i) = &B0001111 CASE "CHI" flags(i) = &B111111 CASE "BUG" flags(i) = &B0100111 CASE "MELAUTON" flags(i) = &B0111 warning FUNCNAME$ + "- check melauton flags when full midi implementation is documented. using defaults for now at" + FUNCNAME$ CASE "PI" flags(i) = &B01011 CASE "POS" flags(i) = &B01011 CASE "PER" flags(i) = &B01011 CASE "BALSI" flags(i) = &B01011 CASE "TUBO" flags(i) = &B01011 ' to be checked. CASE "" flags(i)= -1 EXIT FOR CASE ELSE flags(i) = &B0111 warning "using default flags for " + TRIM$(@MM(i).naam) + " at " + FUNCNAME$ ' CASE ELSE ' ' MSGBOX TRIM$(@MM(i).naam) + "not implemeted yet in " + FUNCNAME$ ,,"g_midi.inc" END SELECT ' inports(i) = @MM(i).channel SetMidiListenChannel inports(i), 1 'dummy, 1 '1-PORT INPUT PATCH!!!!! NEXT ' warning "The midifilter has a temporary one-port input patch!!!!" GetInstrumentParams So, %IDM_SO SetRobotPort So, "", hMidiO() DIM timeouts(i-1, 127) DIM lastvels(i-1, 127) MM_MidiFilter_ChannelSelecton ' ' logfile "--- --- --- --- ---" FOR i = LBOUND(MM) TO UBOUND(MM) ' logfile TRIM$(@MM(i).naam) + " " + HEX$(inports(i)) + "->" + HEX$(@MM(i).channel) IF inports(i)= &HFFFFFFFF THEN ITERATE FOR SetMidiListenChannel inports(i), 1 'dummy, 1 '1-PORT INPUT PATCH!!!!! NEXT END IF ' Warning "MidiFilter thread started!", 5000 DO WHILE @pStat FOR i = LBOUND(MM) TO UBOUND(MM) IF ISFALSE(i MOD 5) THEN SLEEP 1 'allow some time for other processes IF inports(i) = -1 THEN ITERATE FOR IF flags(i) = -1 THEN EXIT FOR 'TO DO: first job here shouldbe special treatment check IF BIT(flags(i), 4) THEN 'machines that require special treatment.. SELECT CASE UCASE$(TRIM$(@MM(i).naam)) CASE "SIRE" nv% = GetMidiNote(inports(i) , %Remove OR %Oldest) IF nv% <> %notfalse THEN mPlay @MM(i).channel, HIBYT(nv%), LOBYT(nv%) END IF nv% = Getpitchbendraw(inports(i), %Remove OR %Oldest) '1-PORT INPUT PATCH!!!!!! IF nv% <> %notfalse THEN Bend @MM(i).channel, LOBYT(nv%), HIBYT(nv%) 'check this! really lsb first?? yes! END IF ITERATE FOR CASE "HELI", "KORN" ' logfile "special mapping for " + @MM(i).naam nv% = GetMidiNote(inports(i), %Remove OR %oldest) IF nv% <> %notfalse THEN ' logfile " note" + STR$(HIBYT(nv%)) + STR$(LOBYT(nv%)) mPlay @MM(i).channel, HIBYT(nv%), LOBYT(nv%) 'we don't filter for double notes etc here, because they are harmless and can effectively be used (e.g. to make glissando's of more then a quartertone) END IF nv% = GetPitchBendRaw(inports(i), %Remove OR %Oldest) IF (nv% <> %notfalse) THEN ' logfile " bend" + STR$(LOBYT(nv%)) + STR$(HIBYT(nv%)) Bend @MM(i).channel, LOBYT(nv%), HIBYT(nv%) END IF nv% = GetControllers(inports(i), %remove OR %oldest) IF (nv% <> %notfalse) THEN ' logfile " ctl" + STR$(HIBYT(nv%)) + STR$(LOBYT(nv%)) Controller @MM(i).channel, HIBYT(nv%), LOBYT(nv%) END IF nv% = GetProgChange(inports(i), %remove OR %Oldest) IF (nv% <> %notfalse) THEN ' logfile " pgc" + STR$(nv%) ProgChange @MM(i).channel, nv% END IF ITERATE FOR CASE "SO" 'also after 2007 renewal special treatment is retained for monophony and pitchbend nv% = GetMidiNote(inports(i), %Remove OR %Oldest) '1-PORT INPUT PATCH!!!!!! IF nv% <> %notfalse THEN IF (HIBYT(nv%) = lastvels(i, 1)) AND ((LOBYT(nv%) > 0) AND (lastvels(i, 0) > 0)) THEN IF ISFALSE BIT(flags(i), 8) THEN Warning "ERROR: double note on blocked on " + TRIM$(@MM(i).naam) Warning "Further errors on" + TRIM$(@MM(i).naam) + " will be logged but not shown on screen" BIT SET flags(i), 8 END IF logfile "ERROR: double note on blocked on " + TRIM$(@MM(i).naam) ITERATE FOR END IF IF LOBYT(nv%) THEN IF (timeouts(i, 0) > timegettime) AND (LOBYT(nv%) > 0) THEN 'we always use timeouts(i, 0) - so is monophonic and this way we don't 'have to scan the whole array for the too-long-notes check IF ISFALSE BIT(flags(i), 8) THEN Warning "ERROR: note blocked on " + TRIM$(@MM(i).naam) + "- too fast repetition!" Warning "Further errors on" + TRIM$(@MM(i).naam) + " will be logged but not shown on screen" BIT SET flags(i), 8 END IF logfile "ERROR: note blocked on " + TRIM$(@MM(i).naam) + "- too fast repetition!" ITERATE FOR END IF RESET So.har(1).vel 'for monophony AddNote2Har So.har(1), HIBYT(nv%), LOBYT(nv%) timeouts(i, 0) = timegettime + 200 END IF 'else noteoff -> don't fill in anything lastvels(i, 0) = LOBYT(nv%) 'here we also use(i, 0) lastvels(i, 1) = IIF(LOBYT(nv%), HIBYT(nv%), 0) InstrumPlay So END IF IF (lastvels(i, 0) > 0) AND (timeouts(i, 0) < timegettime - 12000) THEN IF ISFALSE BIT(flags(i), 8) THEN warning "ERROR: too long note on SO" Warning "Further errors on" + TRIM$(@MM(i).naam) + " will be logged but not shown on screen" BIT SET flags(i), 8 END IF logfile "ERROR: too long note on SO" InstrumPlay So lastvels(i, 0) = 0 END IF nv% = GetControllers(inports(i), %remove OR %oldest) IF nv% <> %notfalse THEN IF HIBYT(nv%) = 1 THEN So.ctrl(1) = LOBYT(nv%) Controller So.channel, 1, So.ctrl(1) END IF END IF nv% = Getpitchbendraw(inports(i), %Remove OR %Oldest) '1-PORT INPUT PATCH!!!!!! IF nv% <> %notfalse THEN Bend @MM(i).channel, LOBYT(nv%), HIBYT(nv%) 'check this! really lsb first?? yes! END IF nv% = GetProgChange(inports(i), %remove OR %Oldest) IF nv% <> %notfalse THEN ProgChange @MM(i).channel, nv% END IF ITERATE FOR CASE ELSE Warning "INTERNAL ERROR: Check flags for " + TRIM$(@MM(i).naam) + " @" + FUNCNAME$ END SELECT END IF 'first check for note - noteoffs are apparently translated to note on with velo 0 in the midiproc ' logfile "check " + trim$(@MM(i).naam) + str$(inports(i)) 'ok.. nv% = GetMidiNote(inports(i), %Remove OR %Oldest) '1-PORT INPUT PATCH!!!!!! IF nv% <>%notfalse THEN ' logfile " noot " + TRIM$(@MM(i).naam) + " " + HEX$(inports(i)) + " " + HEX$(nv) ' warning "filter?" + TRIM$(@MM(i).naam) + chr$(HIBYT(nv%)) + chr$(LOBYT(nv%)) IF (timeouts(i, HIBYT(nv%)) > timegettime) AND (LOBYT(nv%) > 0) THEN IF ISFALSE BIT(flags(i), 8) THEN Warning "ERROR: note blocked on" + TRIM$(@MM(i).naam) + "- too fast repetition!" Warning "Further errors on " + TRIM$(@MM(i).naam) + " will be logged but not shown on screen" BIT SET flags(i), 8 END IF logfile "ERROR: note blocked on " + TRIM$(@MM(i).naam) + "- too fast repetition!" ITERATE FOR END IF ' if isfalse(lobyt(nv%)) and (lastvels(i) > 0) then timeouts(i, HIBYT(nv%)) = timegettime + MAX(40, @MM(i).minduur, 1.5 * LOBYT(nv%), 1.5 * lastvels(i)) timeouts(i, HIBYT(nv%)) = timegettime + MAX(40, @MM(i).minduur, 2 * LOBYT(nv%), 2 * lastvels(i)) 'double note on check IF (BIT(flags(i), 0) > 0) AND (lastvels(i, HIBYT(nv%)) > 0) AND (LOBYT(nv%) > 0) THEN IF ISFALSE BIT(flags(i), 8) THEN Warning "NOTICE: double note (" + STR$(HIBYT(nv%)) + ") on blocked on " + TRIM$(@MM(i).naam) Warning "Further errors on " + TRIM$(@MM(i).naam) + " will be logged but not shown on screen" BIT SET flags(i), 8 END IF logfile "NOTICE: double note (" + STR$(HIBYT(nv%)) + " ) on blocked on " + TRIM$(@MM(i).naam) mPlay @MM(i).channel, HIBYT(nv%), 0 timeouts(i, HIBYT(nv%)) = timegettime + MAX(50, @MM(i).minduur, 2 * LOBYT(nv%), 2 * lastvels(i)) lastvels(i, HIBYT(nv%)) = 0 ELSE lastvels(i, HIBYT(nv%)) = LOBYT(nv%) mPlay @MM(i).channel, HIBYT(nv%), LOBYT(nv%) END IF END IF 'controllers - we block instrument on/off, limit wind where necessary 'we still might consider thinning controllers.. (pedal/snar magnet/...) IF BIT(flags(i), 1) THEN nv% = GetControllers(inports(i), %remove OR %Oldest) '1-PORT INPUT PATCH!!!!!! IF nv% <> %notfalse THEN IF (HIBYT(nv%) = 65) OR (LOBYT(nv%) = 66) THEN logfile "NOTICE: power on/off blocked - this is done automatically on startup/shutdown" ELSE IF HIBYT(nv%) = 7 THEN 'wind -> limit where necessary SELECT CASE UCASE$(TRIM$(@MM(i).naam)) CASE "KRUM" Controller @MM(i).channel, 7, IIF(LOBYT(nv%)> 0, %MM_Krum_Motor, 0) CASE "HUMANOLA" Controller @MM(i).channel, 7, MIN(%MM_Humanola_Motor, LOBYT(nv%)) CASE "TRUMP" Controller @MM(i).channel, 7, MIN(%MM_Trump_Motor, LOBYT(nv%)) CASE ELSE Controller @MM(i).channel, 7, LOBYT(nv%) END SELECT END IF Controller @MM(i).channel, HIBYT(nv%), LOBYT(nv%) END IF END IF END IF 'program changes IF BIT(flags(i), 2) THEN nv% = GetProgChange(inports(i), %remove OR %Oldest) IF nv% <> %notfalse THEN ProgChange @MM(i).channel, nv% END IF END IF 'aftertouch IF BIT(flags(i), 3) THEN nv% = GetPressure(inports(i), %remove OR %oldest) IF nv% <> %Notfalse THEN KeyPress @MM(i).channel, HIBYT(nv%), LOBYT(nv%) END IF END IF 'pitch bend IF BIT(flags(i), 5) THEN nv% = Getpitchbendraw(inports(i), %Remove OR %Oldest) IF nv% <> %notfalse THEN Bend @MM(i).channel, LOBYT(nv%), HIBYT(nv%) 'check this! really lsb first?? yes! END IF END IF NEXT SLEEP 1 LOOP FOR i = LBOUND(MM) TO UBOUND(MM) Controller @MM(i).channel, 123, 0 NEXT Warning "MidiFilter thread stopped!" ', 5000 END FUNCTION '-----------midi to seq----------- 'This function resides here and not in g_file.dll because it needs some M&M specific functions that are also in this library 'Otherwise g_file.dll would become dependant on g_lib.dll 'xof 20070126 FUNCTION Midi2seq(BYVAL sourcefile AS STRING, OPT BYVAL destfile AS STRING) EXPORT AS LONG 'TO DO: SYSTEMATISCHE TEST 'note on/offs that are closer to each other then 10 ms are put together (the seq file format is counting in centiseconds ' 'the SEQ file format '------------------- ' spaces are used as separator, CRLF separates events (except some special cases -see further) ' principally, xactly one space should be used as separator, but parsing software should be forgiving if there are several spaces ' 1. Events in the header ' "E" + STR$(DWORD tracknr) + HEX$(DWORD channel) 'port + channel for this track ' !!!NOTE if you use the function outside of the SetRoboPorts function fails, so the ports don't get set!!! ' 2. Normal events in the body ' each normal line begins with: ' STR$(WORD tracknr) + STR$(LONG tick(cs)) ' after the tick a space follows, followed by a letter designating the kind of event and appropriate data ' " H" + (STRING * 128): a Harmstring to be played. the string corresponds to Harmtype.veland follows the 'H' immediately, without space ' " C" + str$(BYTE nr) + STR$(BYTE value) ->controller ' " A" + (STRING * 128) ->key presssure ' " P" + STR$(WORD pitchbendvalue) ->pitch bend ' " I" + STR$(BYTE progranchange) ->program change ' " Z" + (STRING * 128) -> note off with velocity - allways accompagnied by a " H" at the same tick!! ' 3. Special events in body ' "0 " + STR$(LONG tick) + " M" + STR$(BYTE numerator) + STR$(BYTE denominator) 'time signature ' ' Sysex: starts with X, ends with &H7F. timestamp make sno sense here(?) ' (dit is voorzien voor de toekomst maar voorlopig niet geimplementeerd) ' 4. Comments ' start with a ' and can appear everywhere ' ' unknown commands should be ignored ' LOCAL f AS LONG LOCAL b$, t$ LOCAL x AS BYTE LOCAL i AS LONG, j AS LONG LOCAL spr AS WORD LOCAL sq() AS ParsedMidiType LOCAL h() AS HarmType LOCAL hkey() AS HarmType LOCAL hoff AS Harmtype LOCAL cc AS BYTE LOCAL info$ LOCAL trackinfo$ LOCAL tempo AS SINGLE LOCAL mevents AS LONG DIM h(255) 'nr of tracks limited to 256.. (midi format actualy allows 65535) DIM hkey(255) DIM sq(1000) mevents = ParseMidifile(sourcefile, sq(), info, trackinfo) logfile "total events:" + STR$(mevents) + STR$(UBOUND(sq())) IF mevents <= 0 THEN MSGBOX "Couldn't read midi file " + sourcefile,, FUNCNAME$ EXIT FUNCTION END IF ERRCLEAR IF ISFALSE(LEN(TRIM$(destfile))) THEN destfile = sourcefile REPLACE ".mid" WITH ".seq" IN destfile MSGBOX "destination: " + destfile,,FUNCNAME$ END IF f = FREEFILE OPEN destfile FOR OUTPUT ACCESS WRITE LOCK WRITE AS f IF ERR THEN MSGBOX "Failed opening destination file " + destfile + $CRLF + "Err:" + STR$(ERRCLEAR),,FUNCNAME$ EXIT FUNCTION END IF 'if it's a M&M file, we provide meta data about ports'n channels IF INSTR(UCASE$(REMOVE$(info$, " ")), "") THEN MM_Init_Tracks sq(0), trackinfo$, 0 'fills in MMTrack array FOR i = LBOUND(MMTrack) TO UBOUND(MMTrack) PRINT# f, "E" + STR$(i) + " &H" + HEX$(MMTrack(i).channel) NEXT END IF FOR i = 0 TO mevents IF i > UBOUND(sq) THEN EXIT FOR 'kan gebeuren omdat we in bepaalde omstandigheden elementen uit het array deleten SELECT CASE sq(i).bstat AND &HF0 CASE &H090, &H080 'note on / off logfile "note on/off @" + STR$(sq(i).time/10) logfile STR$(j) + "-" + HEX$(sq(i).bstat) + STR$(sq(i).bdat1) +STR$(sq(i).bdat2) 'hier moeten we direct doorzoeken naar alle note on/offs voor dezelfde timestamp, track en channel, deze hier verwerken en uit het array gooien j = i DO WHILE ((sq(j).time / 10) - sq(i).time/10) < 1 logfile " check" + STR$(j) + " @" + STR$(sq(j).time / 10) logfile " track:" + STR$(sq(j).track) IF sq(i).track <> sq(j).track THEN logfile " different track - incr j" INCR j IF j > UBOUND(sq) THEN EXIT LOOP ITERATE LOOP END IF IF (sq(j).bstat AND &HF0) = &H090 THEN 'note on logfile " note on" +STR$(sq(j).bdat1) + STR$(sq(j).bdat2) MID$(h(sq(j).track).vel, sq(j).bdat1 + 1, 1) = CHR$(sq(j).bdat2) 'DON'T use addnote2har here: double notes should be ignored, not played louder.. IF ISFALSE sq(j).bdat2 THEN MID$(hkey(sq(j).track).vel, sq(j).bdat1 + 1) = CHR$(0) 'reset keypressure on note off IF i<> j THEN logfile "clear from array ARRAY DELETE sq(j) ITERATE LOOP ELSE logfile "incr j" INCR j IF j > UBOUND(sq) THEN EXIT LOOP ITERATE LOOP END IF ELSEIF (sq(j).bstat AND &HF0) = &H080 THEN 'note off with velocity - untested because we don't have any midi file using this.. logfile " note off" +STR$(sq(j).bdat1) + STR$(sq(j).bdat2) MID$(h(sq(j).track).vel, sq(j).bdat1 + 1) = CHR$(0) MID$(hoff.vel, sq(j).bdat1 + 1) = CHR$(sq(j).bdat2) MID$(hkey(sq(j).track).vel, sq(j).bdat1 + 1) = CHR$(0) IF i<> j THEN logfile "clear from array ARRAY DELETE sq(j) ITERATE LOOP ELSE logfile"incr j" INCR j IF j > UBOUND(sq) THEN EXIT LOOP ITERATE LOOP END IF ELSE logfile " no note - incr j" INCR j IF j > UBOUND(sq) THEN EXIT LOOP END IF LOOP logfile " out of loop - dump " + h(sq(i).track).vel PRINT# f, STR$(sq(i).track) + " " + STR$(INT(sq(i).time / 10)) + " H" + h(sq(i).track).vel 'if there are not offs with velocity.. b$ = REMOVE$(hoff.vel, CHR$(0)) IF LEN(b$) THEN PRINT# f, STR$(sq(i).track) + " " + STR$(INT(sq(i).time / 10)) + " Z" + hoff.vel RESET hoff END IF CASE &H0B0 'controller logfile "ctrl" 'uitdunnen tot 1/10 ms j = i DO WHILE ((sq(j).time/10) - sq(i).time/10) < 1 IF (sq(i).track <> sq(j).track) THEN INCR j IF j > UBOUND(sq) THEN EXIT LOOP ITERATE LOOP END IF IF (sq(j).bstat = &H0B0) AND (sq(i).bdat1 = sq(j).bdat1) THEN sq(i).bdat2 = sq(j).bdat2 IF i<> j THEN ARRAY DELETE sq(j) ELSE INCR j IF j > UBOUND(sq) THEN EXIT LOOP ITERATE LOOP END IF ELSE INCR j IF j > UBOUND(sq) THEN EXIT LOOP END IF LOOP PRINT# f, STR$(sq(i).track) + STR$(INT(sq(i).time / 10)) + " C" + STR$(sq(i).bdat1) + STR$(sq(i).bdat2) CASE &H0C0 'progchange logfile "prgch" j = i DO WHILE ((sq(j).time/10 - sq(i).time/10) < 1) IF (sq(i).track <> sq(j).track) THEN INCR j IF j > UBOUND(sq) THEN EXIT LOOP ITERATE LOOP END IF IF sq(j).bstat = &H0C0 THEN sq(i).bdat1 = sq(j).bdat1 IF i<> j THEN ARRAY DELETE sq(j) ELSE INCR j IF j > UBOUND(sq) THEN EXIT LOOP ITERATE LOOP END IF ELSE INCR j IF j > UBOUND(sq) THEN EXIT LOOP END IF LOOP PRINT# f, STR$(sq(i).track) + STR$(INT(sq(i).time / 10)) + " I" + STR$(sq(i).bdat1) CASE &H0A0 'keypress logfile "key" j = i DO WHILE ((sq(j).time/10 - sq(i).time/10)) < 1 IF (sq(i).track <> sq(j).track) THEN INCR j IF j > UBOUND(sq) THEN EXIT LOOP ITERATE LOOP END IF IF sq(j).bstat = &H0A0 THEN MID$(hkey(sq(j).track).vel, sq(j).bdat1 + 1) = CHR$(sq(j).bdat2) IF i<> j THEN ARRAY DELETE sq(j) ELSE INCR j IF j > UBOUND(sq) THEN EXIT LOOP ITERATE LOOP END IF ELSE INCR j IF j > UBOUND(sq) THEN EXIT LOOP END IF LOOP PRINT# f, STR$(sq(i).track) + STR$(INT(sq(i).time/10)) + " A" + hkey(sq(i).track).vel CASE &H0D0 'aftertouch warning "channel aftertouch not implemented in " + FUNCNAME$ CASE &H0E0 'pitchbend logfile "bend" j = i DO WHILE ((sq(j).time/10 - sq(i).time) < 1) IF j > UBOUND(sq) THEN EXIT LOOP IF (sq(i).track <> sq(j).track) THEN INCR j IF j > UBOUND(sq) THEN EXIT LOOP ITERATE LOOP END IF IF sq(j).bstat = &H0C0 THEN sq(i).bdat1 = sq(j).bdat1 sq(i).bdat2 = sq(j).bdat2 IF i<> j THEN ARRAY DELETE sq(j) ELSE INCR j IF j > UBOUND(sq) THEN EXIT LOOP ITERATE LOOP END IF ELSE INCR j IF j > UBOUND(sq) THEN EXIT LOOP END IF LOOP PRINT# f, STR$(sq(i).track) + STR$(INT(sq(i).time \ 10)) + " P" + STR$(128 * sq(i).bdat1 + sq(i).bdat2) 'doublecheck this CASE &HFF 'meta event - we only care about time signature IF SQ(i).bdat1 = &H58 THEN PRINT# f, "0" + STR$(INT(sq(i).time/10)) + " M" + STR$(HI(BYTE, sq(i).extra)) + STR$(2 ^ LOBYT(HIWRD(sq(i).extra))) END IF INCR j CASE ELSE logfile "other " + HEX$(sq(i).bstat) + STR$(sq(i).bdat1) + STR$(sq(i).bdat2) END SELECT NEXT END FUNCTION ' added 21.07.2004: -------------------------------------------------------------------------------- ' for data acquisition using Midi: ' listentask for Pic radar devices. SUB PicRadarInput () ' no need to EXPORT ' PicRad() is global in this library. ' PicRad is accessed through its pointer in GMT application code. ' the tasknumber for the listentask should be set in PicRad(0).listentask ' This task does not create a user interface itself. ' ' 9.10.2007 !change in buffer direction: the last element of the buffer used to contain the newest data. ' now the newest data is added on index 0. (similar to the HY1 input task) ' we did not find any code that could be affected by this change STATIC tasknr AS DWORD LOCAL i AS DWORD LOCAL amp AS INTEGER LOCAL vel AS INTEGER LOCAL tt AS DWORD tt = timegettime /1000 IF ISFALSE @pTask(PicRad(0).listentasknr).tog THEN FOR i = 0 TO UBOUND(PicRad) IF PicRad(i).pabuf THEN SetMidiListenChannel (PicRad(i).channel, %True) END IF NEXT i tasknr = PicRad(0).listentasknr @pTask(tasknr).tog = %True END IF ' this is the listening code itself. FOR i = 0 TO %Max_nrPicRads -1 IF PicRad(i).pabuf THEN ' we only have a bufferpointer if the device was properly initialized. DO amp = GetController (PicRad(i).channel, 7, %Remove OR %Oldest) ' now 7 bit IF amp = %Notfalse THEN EXIT DO PicRad(i).amp = ((PicRad(i).amp * (PicRad(i).da - 1)) + amp) / (PicRad(i).da) ' this was a serious ' bug before we made .amp a float! ' add to databuffers: ' REDIM buf(%PicRadBufSize) AS LOCAL INTEGER AT Picrad(i).pabuf ' ARRAY DELETE buf(), amp POKE$ Picrad(i).pabuf + 2, PEEK$(Picrad(i).pabuf, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 Picrad(i).@pabuf = amp LOOP 'UNTIL amp = %NotFalse END IF IF PicRad(i).ptbuf THEN DO vel = GetPitchbendRaw (PicRad(i).channel, %Remove OR %Oldest) ' still 14 bit IF vel = %Notfalse THEN EXIT DO PicRad(i).per = ((PicRad(i).per * (PicRad(i).dv - 1)) + vel) / (PicRad(i).dv) ' float ' add to databuffer: ' REDIM buf(%PicRadBufSize) AS LOCAL INTEGER AT PicRad(i).ptbuf ' ARRAY DELETE buf(), vel POKE$ Picrad(i).ptbuf + 2, PEEK$(Picrad(i).ptbuf, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 Picrad(i).@ptbuf = vel IF PicRad(i).per > 1 THEN PicRad(i).f = 16384! / PicRad(i).per ' convert to frequency - 14 bit scale ' values too small, so we can rescale ' 10.07.2004: max value: 33 ' 19.07.2004: max value: 27 ' we could rescale here, or, let the user do it... ELSE PicRad(i).f = %False END IF LOOP 'UNTIL vel = %NotFalse IF PicRad(i).f = %False THEN PicRad(i).amp = %False IF PicRad(i).amp = %False THEN PicRad(i).f = %False END IF NEXT i END SUB SUB PicRadarInput_Stop () LOCAL i AS LONG FOR i = 0 TO UBOUND(Picrad) IF PicRad(i).pabuf THEN SetMidiListenChannel (PicRad(i).channel, %False) END IF NEXT i END SUB SUB HY1_Input () ' no need to EXPORT ' This listen-task is called from within this library, ' initialised by GetHY1Sensorpointer () function. ' Hybridsensor is global in this library. ' HY1 is accessed through its pointer in GMT application code. ' the tasknumber for the listentask should be set in Hybridsensor.listentask ' This task does not create a user interface itself. ' added datafield 13.10.2007: .slowspeed (signed in m/s) ' added datafield 16.10.2007: .speedangle and . samplingrate LOCAL retval AS INTEGER LOCAL datakanaal AS DWORD LOCAL msb AS WORD LOCAL lsb AS WORD LOCAL dta AS WORD STATIC s1 AS SINGLE STATIC s2 AS SINGLE STATIC f1 AS SINGLE STATIC f2 AS SINGLE STATIC value AS SINGLE ' - maxima for valid distances ' STATIC dist AS INTEGER ' STATIC spd1 AS INTEGER ' STATIC spd2 AS INTEGER ' STATIC surf1 AS INTEGER ' STATIC surf2 AS INTEGER ' maxima for invalid distances: ' STATIC dist_i AS INTEGER ' STATIC spd1_i AS INTEGER ' STATIC spd2_i AS INTEGER ' STATIC surf1_i AS INTEGER ' STATIC surf2_i AS INTEGER ' for offset research: 'STATIC avg1 AS QUAD 'STATIC avg2 AS QUAD 'STATIC cnt1 AS DWORD 'STATIC cnt2 AS DWORD 'STATIC av1 AS SINGLE 'STATIC av2 AS SINGLE ' for measurement of effective sampling rate: STATIC starttime AS DWORD STATIC samples AS DWORD IF ISFALSE @pTask(Hybridsensor.listentasknr).tog THEN IF Hybridsensor.pdistancebuf THEN SetMidiListenChannel (Hybridsensor.channel, %True) END IF ' variables for debug: 'valid = %False 'dist = %False 'spd1 = %False 'spd2 = %False 'surf1 = %False 'surf2 = %False 'dist_i = %False 'spd1_i = %False 'spd2_i = %False 'surf1_i = %False 'surf2_i = %False starttime = timegettime ' in ms. samples = 0 'may overflow... @pTask(Hybridsensor.listentasknr).tog = %True END IF ' this is the listening code itself. IF Hybridsensor.pDistancebuf THEN ' we only have a bufferpointer if the device was properly initialized. DO retval = GetPressure (Hybridsensor.channel,%Remove OR %Oldest) ' integer IF retval = %Notfalse THEN EXIT DO ' for sampling_rate calculation debug: INCR samples ' samplecounter datakanaal = retval SHIFT RIGHT datakanaal,12 ' 0-7, only 0-5 is used. retval = retval AND &B0000111111111111 ' mask lsb = LOBYT(retval) ' must be 7 bit msb = HIBYT(retval) ' must be 3 bit dta = lsb + (msb * 128) ' 10 bit data value 0-1023 SELECT CASE datakanaal CASE 0 ' Pepperl+Fuchs sensor - data rate 7 S/s Hybridsensor.distance = (dta/ 1023!) ' normalized to 0-1 ' add to databuffers: 'the following was a bug: array delete puts the new data in buf1(%Picradbufsize) in stead of buf1(0) ' REDIM buf1(%PicRadBufSize) AS LOCAL INTEGER AT Hybridsensor.pDistancebuf ' ARRAY DELETE buf1(), dta POKE$ Hybridsensor.pDistancebuf + 2, PEEK$(Hybridsensor.pDistanceBuf, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 Hybridsensor.@pDistanceBuf = dta ' of, Hy0buf(0) = dta IF (dta > 0) AND (dta < 1023) THEN INCR Hybridsensor.valid ' gives number of succesive valid words in the buffer Hybridsensor.valid = MIN(%PicradBufSize, Hybridsensor.valid) ' overflow protected now. ' dist = MAX(dist, dta) ' for debug monitoring IF Hybridsensor.valid > 2 THEN ' now we can derive the slow movement speed in m/s ' note that the real sampling rate is 7S/s for Pepperl + Fuchs ' since 2/10 > 1/7 > 1/10 we should retrieve the data with a distance of i point: ' datapoints 0 and 2 always represent different sampled values. 'Hybridsensor.slowspeed = 7 * (dta - Hy0buf(2)) / 255.25 ' omgerekend, terwille van de rekensnelheid: Hybridsensor.slowspeed = (dta-Hy0buf(2)) * 0.027424 ' 14.10.2007 ' wrong: ' over a period of 300ms 'Hybridsensor.slowspeed = 5 * ((dta + Hy0buf(1)) - (Hy0buf(2) + Hy0buf(3))) / 505.5 ' above formula is better than: 'Hybridsensor.slowspeed = 10 * ((dta - Hy0buf(1)) / 255.5) ' voor S/r = 10S/s ' because the real sample rate of the pepperl and fuchs is 7S/s and not 10S/s ' by applying the above formula we get 5S/s for speed and a realistic estimation ' of fluent movement within the capture range. ' note: 505.5 = 2022 for the range over 4 meters, so 2022/4 = 505.5 ' * 5, because we now have 200ms between measurements. ' if positive: movement towards the sensor ' if negative: movement away from the sensor ' if zero: standstill. ELSE Hybridsensor.slowspeed = 0 END IF ELSE Hybridsensor.valid = %False ' reset counter Hybridsensor.slowspeed = 0 ' dist_i = MAX(dist_i, dta) END IF CASE 1 ' tacho phase 1 Hybridsensor.speed = (Hybridsensor.speed/ 2!) + (dta/2047!) ' normalised 0-1 POKE$ Hybridsensor.pXf + 2, PEEK$(Hybridsensor.pXf, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 Hybridsensor.@pxf = dta f1 = dta / 1024! ' IF valid THEN ' spd1 = MAX(spd1, dta) ' for debug monitoring ' ELSE ' spd1_i = MAX(spd1_i, dta) ' END IF ' for research on tacho assymmetry: 'IF dta THEN ' INCR cnt1 ' avg1 = avg1 + dta 'END IF CASE 2 ' tacho phase 2 Hybridsensor.speed = (Hybridsensor.speed/ 2!) + (dta/2047!) ' normalised 0-1 POKE$ Hybridsensor.pYf + 2, PEEK$(Hybridsensor.pYf, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 Hybridsensor.@pYf = dta f2 = dta / 1024! ' IF valid THEN ' spd2 = MAX(spd2, dta) ' ELSE ' spd2_i = MAX(spd2_i,dta) ' END IF ' for research on tacho assymetry: 'IF dta THEN ' INCR cnt2 ' avg2 = avg2 + dta 'END IF CASE 3 ' surface phase 1 - we multiply this value to better cover the range: ' dta = MIN((dta * 1.56), 1023!) - done in arm code now Hybridsensor.amplitude = (Hybridsensor.amplitude / 2!) + (dta/ 2047!) ' 0-1 s1 = dta / 1024! POKE$ Hybridsensor.pXAmp + 2, PEEK$(Hybridsensor.pXAmp, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 Hybridsensor.@pXamp = dta ' IF valid THEN ' surf1 = MAX(surf1, dta) ' ELSE ' surf1_i = MAX(surf1_i, dta) ' END IF ' for research: calculate the average received value: ' if dta then ' INCR cnt1 ' avg1 = avg1 + dta ' end if CASE 4 ' surface phase 2 ' this signal is always 1.4 times lower then phase 1, so we do a correction here again ' dta = MIN((dta * 2.55), 1023!) - done in arm code now Hybridsensor.amplitude = (Hybridsensor.amplitude / 2!) + (dta/ 2047!) '0-1 s2 = dta / 1024! POKE$ Hybridsensor.pYAmp + 2, PEEK$(Hybridsensor.pYAmp, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 Hybridsensor.@pYAmp = dta ' IF valid THEN ' surf2 = MAX(surf2, dta) ' ELSE ' surf2_i = MAX(surf2_i, dta) ' END IF ' for research: ' if dta then ' incr cnt2 ' avg2 = avg2 + dta ' end if CASE ELSE ' mag niet voorkomen END SELECT LOOP ' now we try to calculate the angle: (based on the values for surface value = s1 - s2 ' -1 to + 1 - this is the sine of the angle Hybridsensor.angle = ATN(value / SQR(1 - value * value)) ' ArcSin formula value = f1 - f2 'based on the tacho channels - -0.45 to +0.61, avg.0.027 16.10.07 Hybridsensor.phase = ATN(value / SQR(1 - value * value)) ' ArcSin formula END IF ' for debugging: ' IF valid THEN ' ' maxima with valid distances ' CONTROL SET TEXT @pgh.cockpit, %GMT_MSG1, "maxes:" + STR$(dist) + STR$(spd1) + STR$(spd2) + STR$(surf1) + STR$(surf2) ' ELSE ' CONTROL SET TEXT @pgh.cockpit, %GMT_MSG2, "maxes:" + STR$(dist_i) + STR$(spd1_i) + STR$(spd2_i) + STR$(surf1_i) + STR$(surf2_i) ' END IF ' for measurement of radarsensor assymetry on amplitude channels: ' measurements done 13.10 and implemented in Arm code firmware. ' av1 = avg1 / cnt1 ' av2 = avg2 / cnt2 ' control set text @pgh.cockpit, %GMT_MSG1, "avg1:" + STR$(av1) ' CONTROL SET TEXT @pgh.cockpit, %GMT_MSG2, "avg2:" + STR$(av2) + " ratio: " & format$((av1/av2),"0.000") ' for debugging sensor assymetry on tacho channels: ' a less then 5% assymetry can be explained by component spread, the rest is ' due to intrinsic properties of the radar sensor. ' av1 = avg1 / cnt1 ' av2 = avg2 / cnt2 ' CONTROL SET TEXT @pgh.cockpit, %GMT_MSG1, "avg1:" + STR$(av1) ' CONTROL SET TEXT @pgh.cockpit, %GMT_MSG2, "avg2:" + STR$(av2) + " ratio: " & FORMAT$((av1/av2),"0.000") ' for debugging effective sampling rate calculation: ' -13.10.2007: 50.3 S/s checked o.k. ' -16.10.2007: 50.83 S/s checked o.k. IF ISFALSE (timegettime - starttime) MOD 1000 THEN Hybridsensor.samplingrate = samples / ((timegettime - starttime) \1000) CONTROL SET TEXT @pgh.cockpit, %GMT_TEXT_SR, FORMAT$(Hybridsensor.samplingrate,"00.00") END IF END SUB FUNCTION GetHY1Sensorpointer (BYVAL nr AS LONG, BYVAL listentasknr AS LONG) EXPORT AS DWORD ' to be called by the application code to get access to the data in the structure. ' 07.10.2007 - gwr - seems to work o.k. ' done 09.10.2007: read config data (inport & channel) from ini-file. ' improved 14.10.2007 LOCAL miport AS WORD LOCAL kanaal AS WORD LOCAL port_channel AS WORD port_channel = ReadHY1ConfigFromFile(IniFileName) ' InifileName is function in g_indep.dll) ' ReadHY1Config is in g_file.dll ' check for availability of midi input ports: miport = HIBYT(port_channel) AND &H0F kanaal = LOBYT(port_channel) AND &H0F ' first check for available ports IF miport > UBOUND(hMidiI) THEN Warning "This computer does not have enough midi inports for the HY1 device (" + FUNCNAME$ + ")",10000 EXIT FUNCTION END IF ' then check for valid handles and opened midi-ports: IF ISFALSE hMidiI(miport) THEN Warning "You cannot use the HY1 sensor without opening the requested midi port(" + FUNCNAME$ + ")", 10000 EXIT FUNCTION END IF Hybridsensor.channel = port_channel ' now this is validated. ' check validity of requested listentasknr. : IF listentasknr > %NumberOfTasks -1 THEN Warning "Tasknumber exceeds GMT's limit of 64 in " + FUNCNAME$, 10000 EXIT FUNCTION ELSE Hybridsensor.listentasknr = listentasknr END IF Hybridsensor.nearlimit = 1 Hybridsensor.farlimit = 1022 @pTask(listentasknr).cptr = CODEPTR(HY1_Input) ' code in this same module @pTask(listentasknr).naam = "HY1-In" @pTask(listentasknr).freq = 50 ' this is the minimum required rate ' the HY1 outputs 50 messages per second. @pTask(listentasknr).flags = %DLL_TASK 'OR %PERTIM_TASK @pTaskEX(listentasknr).stopcptr = CODEPTR(HY1_Input_Stop) DIM hy0buf(%PicRadBufsize) AS GLOBAL INTEGER DIM hy1buf(%PicRadBufSize) AS GLOBAL INTEGER DIM hy2buf(%PicRadBufsize) AS GLOBAL INTEGER DIM hy3buf(%PicRadBufSize) AS GLOBAL INTEGER DIM hy4buf(%PicRadBufsize) AS GLOBAL INTEGER Hybridsensor.pdistancebuf = VARPTR(hy0buf(0)) 'INTEGER PTR ' Pepperl+Fuchs sonar - distance data 10 bit Hybridsensor.pxamp = VARPTR(hy1buf(0)) 'INTEGER PTR ' 2.4GHz radar phase 1 surface data - 10 bit Hybridsensor.pyamp = VARPTR(hy2buf(0)) 'INTEGER PTR ' id. phase 2 Hybridsensor.pxf = VARPTR(hy3buf(0)) 'INTEGER PTR ' 2.4GHz radar phase 1: doppler frequency data 10 bit Hybridsensor.pyf = VARPTR(hy4buf(0)) 'INTEGER PTR ' id. phase 2 SetMidiListenChannel (Hybridsensor.channel, %False) ' reset recording flag! (set on start of listentask) FUNCTION = VARPTR(Hybridsensor) ' return pointer to the initialized structure END FUNCTION SUB HY1_Input_Stop () IF Hybridsensor.pdistancebuf THEN SetMidiListenChannel (Hybridsensor.channel, %False) END IF END SUB FUNCTION GetHandySensorPointer (BYVAL nr AS LONG, BYVAL listentasknr AS LONG) EXPORT AS DWORD ' to be called by the application code to get access to the data in the structure. ' call with listentasknr -1 to obtain the pointer to the Handysensortype without creating a listentask ' 30.12.2007 - gwr ' done 30.12.2007: read config data (inport & channel) from ini-file. ' tested o.k. LOCAL miport AS WORD LOCAL kanaal AS WORD LOCAL port_channel AS WORD IF listentasknr > -1 THEN ' initialisation and error checking: port_channel = ReadHandyConfigFromFile(IniFileName) ' InifileName is function in g_indep.dll) ' ReadHandyConfig is in g_file.dll ' check for availability of midi input ports: miport = HIBYT(port_channel) AND &H0F kanaal = LOBYT(port_channel) AND &H0F ' first check for available ports IF miport > UBOUND(hMidiI) THEN Warning "This computer does not have enough midi inports for Handy (" + FUNCNAME$ + ")",10000 EXIT FUNCTION END IF ' then check for valid handles and opened midi-ports: IF ISFALSE hMidiI(miport) THEN Warning "You cannot use Handy without opening the requested midi port(" + FUNCNAME$ + ")", 10000 EXIT FUNCTION END IF Handy.channel = port_channel ' now this is validated. ' check validity of requested listentasknr. : IF listentasknr > %NumberOfTasks -1 THEN Warning "Tasknumber exceeds GMT's limit of 64 in " + FUNCNAME$, 10000 EXIT FUNCTION ELSE Handy.listentasknr = listentasknr END IF @pTask(listentasknr).cptr = CODEPTR(Handy_Input) ' code in this same module @pTask(listentasknr).naam = "Handy1" @pTask(listentasknr).freq = 32 ' this is the minimum required rate ' Handy outputs 32 scans per second. @pTask(listentasknr).flags = %DLL_TASK 'OR %PERTIM_TASK @pTaskEX(listentasknr).stopcptr = CODEPTR(Handy_Input_Stop) DIM h0buf(%PicRadBufsize) AS GLOBAL INTEGER DIM h1buf(%PicRadBufSize) AS GLOBAL INTEGER DIM h2buf(%PicRadBufsize) AS GLOBAL INTEGER DIM h3buf(%PicRadBufSize) AS GLOBAL INTEGER DIM h4buf(%PicRadBufsize) AS GLOBAL INTEGER DIM h5buf(%PicRadBufSize) AS GLOBAL INTEGER DIM h6buf(%PicRadBufsize) AS GLOBAL INTEGER DIM h7buf(%PicRadBufSize) AS GLOBAL INTEGER Handy.a0 = VARPTR(h0buf(0)) 'INTEGER PTR ' data 10 bit Handy.a1 = VARPTR(h1buf(0)) 'INTEGER PTR ' data - 10 bit Handy.a2 = VARPTR(h2buf(0)) 'INTEGER PTR ' data Handy.a3 = VARPTR(h3buf(0)) 'INTEGER PTR ' data Handy.a4 = VARPTR(h4buf(0)) 'INTEGER PTR ' data 10 bit Handy.a5 = VARPTR(h5buf(0)) 'INTEGER PTR ' data - 10 bit Handy.a6 = VARPTR(h6buf(0)) 'INTEGER PTR ' data Handy.a7 = VARPTR(h7buf(0)) 'INTEGER PTR ' data SetMidiListenChannel (Handy.channel, %False) ' reset recording flag! (set on start of listentask) END IF FUNCTION = VARPTR(Handy) ' return pointer to the initialized structure END FUNCTION SUB Handy_Input() ' listentask ' no need to EXPORT ' This listen-task is called from within this library, ' initialised by GetHandySensorpointer () function. ' Handy is global in this library. ' Handy is accessed through its pointer in GMT application code. ' the tasknumber for the listentask should be set in Handy.listentask ' This task does not create a user interface itself. LOCAL retval AS INTEGER LOCAL datakanaal AS DWORD LOCAL msb AS WORD LOCAL lsb AS WORD LOCAL dta AS WORD IF ISFALSE @pTask(Handy.listentasknr).tog THEN IF Handy.a0 THEN SetMidiListenChannel (Handy.channel, %True) END IF @pTask(Handy.listentasknr).tog = %True ' logfile "listen channel now " + hex$(handy.channel) END IF ' this is the listening code itself. IF Handy.a0 THEN ' we only have a bufferpointer if the device was properly initialized. DO retval = GetPressure (Handy.channel,%Remove OR %Oldest) ' integer IF retval = %Notfalse THEN EXIT DO ' logfile "h " + hex$(retval) datakanaal = retval SHIFT RIGHT datakanaal,12 ' 0-7 retval = retval AND &B0000111111111111 ' mask lsb = LOBYT(retval) ' must be 7 bit msb = HIBYT(retval) ' must be 3 bit dta = lsb + (msb * 128) ' 10 bit data value 0-1023 SELECT CASE datakanaal CASE 0 Handy.a(10) = dta ^ 0.699 ' rechterpink - 10 bits reduced to 7 bits ' add to databuffers: POKE$ Handy.a0 + 2, PEEK$(Handy.a0, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 Handy.@a0 = dta ' of, h0buf(0) = dta CASE 1 Handy.a(9) = dta ^ 0.699 ' rechterringvinger POKE$ Handy.a1 + 2, PEEK$(Handy.a1, %PicRadBufSize * 2) Handy.@a1 = dta ' of, h1buf(0) = dta CASE 2 Handy.a(8) = dta ^ 0.699 ' rechtermiddenvinger POKE$ Handy.a2 + 2, PEEK$(Handy.a2, %PicRadBufSize * 2) Handy.@a2 = dta ' of, h2buf(0) = dta CASE 3 Handy.a(7) = dta ^ 0.699 ' rechterwijsvinger POKE$ Handy.a3 + 2, PEEK$(Handy.a3, %PicRadBufSize * 2) Handy.@a3 = dta ' of, h3buf(0) = dta CASE 4 Handy.a(4) = dta ^ 0.699 ' linkerwijsvinger POKE$ Handy.a4 + 2, PEEK$(Handy.a4, %PicRadBufSize * 2) Handy.@a4 = dta ' of, h4buf(0) = dta CASE 5 Handy.a(3) = dta ^ 0.699 ' linkermiddelvinger POKE$ Handy.a5 + 2, PEEK$(Handy.a5, %PicRadBufSize * 2) Handy.@a5 = dta ' of, h5buf(0) = dta CASE 6 Handy.a(2) = dta ^ 0.699 ' linkerringvinger POKE$ Handy.a6 + 2, PEEK$(Handy.a6, %PicRadBufSize * 2) Handy.@a6 = dta ' of, h6buf(0) = dta CASE 7 Handy.a(1) = dta ^ 0.699 ' linkerpink POKE$ Handy.a7 + 2, PEEK$(Handy.a7, %PicRadBufSize * 2) Handy.@a7 = dta ' of, h7buf(0) = dta CASE ELSE ' mag niet voorkomen END SELECT LOOP 'en nu nog de switches inlezen: 'linkerduim = Handy.a(5) 'rechterduim = Handy.a(6) DO retval = GetControllers (Handy.channel,%Remove OR %Oldest) ' integer IF retval = %Notfalse THEN EXIT DO SELECT CASE HIBYT(retval) CASE 70 IF LOBYT(retval) THEN handy.a(5) = %False ELSE handy.a(5) = 127 CASE 71 IF LOBYT(retval) THEN handy.a(6) = %False ELSE handy.a(6) = 127 CASE ELSE ' mag niet voorkomen. END SELECT LOOP END IF END SUB SUB Handy_Input_Stop () IF Handy.a0 THEN SetMidiListenChannel (Handy.channel, %False) END IF END SUB '%ax3dbg = 1 SUB AX3_Input () ' listentask code for the Axe3 accelaration sensing device ' no need to EXPORT ' This listen-task is called from within this library, ' initialised by GetAX3Sensorpointer () function. ' Ax3sensor is global in this library. ' AXE3 is accessed through its pointer in GMT application code. ' the tasknumber for the listentask should be set in Ax3sensor.listentask ' This task does not create a user interface. ' Study this code always in conjunction with the ARM firmware source code for the transducer microcontroller. ' 2007.10.31 tempo extraction doesnt' work well yet ' 2007.11.09 tempo extraction seems to work reasonably well (at least for x channels) - thorough testing is still required.. LOCAL retval AS INTEGER LOCAL datakanaal AS DWORD LOCAL msb AS WORD LOCAL lsb AS WORD LOCAL dta AS WORD LOCAL g AS SINGLE STATIC s1 AS SINGLE STATIC s2 AS SINGLE STATIC f1 AS SINGLE STATIC f2 AS SINGLE STATIC value AS SINGLE ' for measurement of effective sampling rate: STATIC starttime AS DWORD STATIC samples AS DWORD STATIC lastsignrx AS INTEGER STATIC lastsignry AS INTEGER STATIC lastsignlx AS INTEGER STATIC lastsignly AS INTEGER ' for MM tempo derivation LOCAL nuls AS LONG LOCAL ones AS LONG LOCAL skips AS LONG LOCAL i AS LONG IF ISFALSE @pTask(Ax3sensor.listentasknr).tog THEN IF Ax3sensor.plx THEN SetMidiListenChannel (Ax3sensor.channel, %True) ELSE EXIT SUB ' we only have a bufferpointer if the device was properly initialized. END IF starttime = timegettime ' in ms. samples = 0 'may overflow... @pTask(Ax3sensor.listentasknr).tog = %True END IF ' this is the listening code itself. DO retval = GetPressure (Ax3sensor.channel,%Remove OR %Oldest) ' integer IF retval = %Notfalse THEN EXIT DO ' for sampling_rate calculation debug: INCR samples ' samplecounter datakanaal = retval SHIFT RIGHT datakanaal,12 ' 0-7, only 0-3 is used. retval = retval AND &B0000111111111111 ' mask lsb = LOBYT(retval) ' must be 7 bit msb = HIBYT(retval) ' must be 3 bit but can overflow to 4 bits (0-2047) dta = lsb + (msb * 128) ' 10 bit data value 0-1023 ' 512 is callibrated to 0g SELECT CASE datakanaal CASE 0 ' right x channel (vingerrichting op en neerwaarts) ' add to databuffers: POKE$ Ax3sensor.prx + 2, PEEK$(Ax3sensor.prx, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 Ax3sensor.@prx = dta ' of, Ax2buf(0) = dta ' now we derive information from the data received on this channel: ' averages integrated over 1 second: Ax3sensor.avgrx = ((Ax3sensor.avgrx * 31) + dta)/ 32 ' for ca.128 S/s or 32 S/s per channel ' absolute acceleration in g units (-2g to + 2g) - single precision Ax3sensor.accrx = (dta - 512) / 250 ' scaling factor measured 27.10.2007 1g= 250 ' relative acceleration in g units Ax3sensor.darx = (dta - Ax3sensor.avgrx)/ 250 ' following only valid for -1g < avgrx < +1g g = (Ax3sensor.avgrx - 512) / 250 IF g < -1 THEN g = -1 IF g > 1 THEN g = 1 Ax3sensor.tiltrx = Arcsin(g) ' in radialen '' ' derive tempo information if possible: '' ' first we convert the entire buffer to a differential square wave: '' ' as long as dta is larger then the previous reading we output a 1, else a 0 '' ' the period is now the duration of a full 1 - 0 cycle '' ' to cancel out noise, we work on 8 bit data instead of 10 bit '' ' --> xof test results: data appear to be too noisy for this strategy to be succesfull.. 'nieuwe poging tempo extractie: uit acceleratie '20071107: on downward movement it often shows what looks like a possible value, 'on upward movement it shows way too high values.. 'looks like we can get there with some extra filtering.. ' '20071108 solved some bugs in the counting mechanism 'when we stop moving, acceleration usually goes over and back quite strongly -> some filtering necessary '20071109 seems to be working quite ok now for rx! '20071113 algorithm improved - extra jitter filter and 128 bits #IF %DEF(%ax3dbg) ' logfile "" logfile "----accrx:" + STR$(Ax3sensor.accrx) #ENDIF SHIFT RIGHT Ax3sensor.qrx,1 ' make place - shift data 1 bit to the right BIT CALC Ax3sensor.qrx, 63, BIT(Ax3sensor.qrx2, 0) SHIFT RIGHT Ax3sensor.qrx2, 1 'ignore small movements - otherwise we have too much noise IF (Ax3sensor.accrx > 1) OR (Ax3sensor.accrx < -.5) THEN 'sic, assymetrical - negative values go much less low.. IF SGN(Ax3sensor.accrx) <> lastsignrx THEN lastsignrx = SGN(Ax3sensor.accrx) IF lastsignrx > 0 THEN BIT SET Ax3sensor.qrx,127 'else leave it 0 ELSE BIT RESET Ax3sensor.qrx, 127 'shouldn't be necessary END IF ' logfile " change sign" + STR$(lastsignrx) ELSE 'sign doesn't change -> we keep moving in the same direction ' logfile " continue, same sign" + STR$(lastsignrx) IF BIT(Ax3sensor.qrx, 126) THEN BIT SET Ax3Sensor.qrx, 127 ELSE BIT RESET Ax3Sensor.qrx, 127 END IF END IF ELSE ' logfile " continue, no trig" + STR$(lastsignrx) 'we presume that the direction doesn't change - this will cause an assymetry between the twohalves of a period, 'but the full period should be accurate.. IF BIT (Ax3sensor.qrx, 126) THEN BIT SET Ax3Sensor.qrx, 127 ELSE BIT RESET Ax3Sensor.qrx, 127 END IF END IF #IF %DEF(%ax3dbg) logfile " qrs: " + BIN$(HI(DWORD, Ax3sensor.qrx2), 32) + BIN$(LO(DWORD, Ax3sensor.qrx2), 32)+ BIN$(HI(DWORD, Ax3sensor.qrx), 32) + BIN$(LO(DWORD, Ax3sensor.qrx), 32) #ENDIF IF BIT(Ax3sensor.qrx, 127) THEN ' we wrote a 1,so we now look at the next continous series of zeros: i = 126 skips = 0 DO INCR skips DECR i IF i < 0 THEN EXIT LOOP ' should not happen LOOP UNTIL BIT (Ax3sensor.qrx,i) = 0 ' now we must have the first occurence of a zero nuls = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR nuls LOOP UNTIL BIT (Ax3sensor.qrx,i) ' now we have the first occurence of a 1 ones = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR ones LOOP UNTIL BIT (Ax3sensor.qrx,i) = 0 ' logfile "0's:" + STR$(nuls) + ", 1's:" + STR$(ones) + ", skips:" + STR$(skips) ELSE ' we wrote a 0,so we now look at the next continous series of ones: i = 126 skips = 0 DO INCR skips DECR i IF i < 0 THEN EXIT LOOP ' should not happen LOOP UNTIL BIT (Ax3sensor.qrx,i) ' now we must have the first occurence of a one ones = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR ones LOOP UNTIL BIT (Ax3sensor.qrx,i)=0 ' now we have the first occurence of a 0 nuls = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR nuls LOOP UNTIL BIT (Ax3sensor.qrx,i) ' logfile "0's:" + STR$(nuls) + ", 1's:" + STR$(ones) END IF IF i < 0 THEN ' invalid result Ax3sensor.mmrx = %False ELSE ' IF nuls + ones > 1 THEN IF (skips > 2) AND (nuls > 2) AND (ones > 2) THEN 'if the sign changes faster then this, it's usually a consequence of resonance when a movement stops.. 'this makes it work quite reliably! #IF %DEF(%ax3dbg) logfile " period ok:" + STR$(nuls + ones) #ENDIF ' nuls + ones = a full period Ax3sensor.mmrx = 2 * 60! / ((nuls + ones) * (1!/(Ax3Sensor.samplingrate/4)) ) ' Ax3Sensor.mmrx = MIN(MAX(29,Ax3Sensor.mmrx),480) ' limit return values 'if you reach this limits, you can be quite sure you are not measuring anything meaningfull -> better retur 0 IF Ax3sensor.mmrx <= 40 THEN Ax3sensor.mmrx = 0 IF Ax3sensor.mmrx >= 240 THEN Ax3sensor.mmrx = 0 '240 was 480 #IF %DEF(%ax3dbg) logfile " mm:" + STR$(Ax3sensor.mmrx) 'actually is mm/2 , as it's a full period (up + down) #ENDIF ELSE ' logfile " period not ok" ' invalid result Ax3sensor.mmrx = %False END IF END IF CASE 1 ' right y channel - lateral hand movement. ' add to databuffers: POKE$ Ax3sensor.pry + 2, PEEK$(Ax3sensor.pry, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 Ax3sensor.@pry = dta ' of, Ax3buf(0) = dta Ax3sensor.avgry = ((Ax3sensor.avgry * 31) + dta)/ 32 ' for ca.128 S/s or 32 S/s per channel Ax3sensor.accry = (dta - 512) / 243 ' scaling 17.10.2007 gwr Ax3sensor.dary = (dta - Ax3sensor.avgry)/ 243 ' condition -1g +1g!!! g = (Ax3sensor.avgry - 512) / 243 IF g < -1 THEN g = -1 IF g > 1 THEN g = 1 Ax3sensor.tiltry = Arcsin(g) ' in radialen 'tempo procedure: ' logfile "" #IF %DEF(%ax3dbg) logfile "----accry:" + STR$(Ax3sensor.accry) #ENDIF SHIFT RIGHT Ax3sensor.qry,1 ' make place - shift data 1 bit to the right BIT CALC Ax3sensor.qry, 63, BIT(Ax3sensor.qry2, 0) SHIFT RIGHT Ax3sensor.qry2, 1 'ignore small movements - otherwise we have too much noise IF (Ax3sensor.accry > 1) OR (Ax3sensor.accry < -1) THEN 'exact values to be determined - will be different then rx values for sure IF SGN(Ax3sensor.accry) <> lastsignry THEN lastsignry = SGN(Ax3sensor.accry) IF lastsignry > 0 THEN BIT SET Ax3sensor.qry,127 'else leave it 0 ELSE BIT RESET Ax3sensor.qry, 127 'shouldn't be necessary END IF ' logfile " change sign" + STR$(lastsignry) ELSE 'sign doesn't change -> we keep moving in the same direction ' logfile " continue, same sign" + STR$(lastsignry) IF BIT(Ax3sensor.qry, 126) THEN BIT SET Ax3Sensor.qry, 127 ELSE BIT RESET Ax3Sensor.qry, 127 END IF END IF ELSE ' logfile " continue, no trig" + STR$(lastsignry) 'we presume that the direction doesn't change - this will cause an assymetry between the twohalves of a period, 'but the full period should be accurate.. IF BIT (Ax3sensor.qry, 126) THEN BIT SET Ax3Sensor.qry, 127 ELSE BIT RESET Ax3Sensor.qry, 127 END IF END IF #IF %DEF(%ax3dbg) logfile " qrs: " +BIN$(HI(DWORD, Ax3sensor.qry2), 32) + BIN$(LO(DWORD, Ax3sensor.qry2), 32) + BIN$(HI(DWORD, Ax3sensor.qry), 32) + BIN$(LO(DWORD, Ax3sensor.qry), 32) #ENDIF IF BIT(Ax3sensor.qry, 127) THEN ' we wrote a 1,so we now look at the next continous series of zeros: i = 126 skips = 0 DO DECR i INCR skips IF i < 0 THEN EXIT LOOP ' should not happen LOOP UNTIL BIT (Ax3sensor.qry,i) = 0 ' now we must have the first occurence of a zero nuls = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR nuls LOOP UNTIL BIT (Ax3sensor.qry,i) ' now we have the first occurence of a 1 ones = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR ones LOOP UNTIL BIT (Ax3sensor.qry,i) = 0 ' logfile "0's:" + STR$(nuls) + ", 1's:" + STR$(ones) ELSE ' we wrote a 0,so we now look at the next continous series of ones: i = 126 skips = 0 DO DECR i INCR skips IF i < 0 THEN EXIT LOOP ' should not happen LOOP UNTIL BIT (Ax3sensor.qry,i) ' now we must have the first occurence of a one ones = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR ones LOOP UNTIL BIT (Ax3sensor.qry,i)=0 ' now we have the first occurence of a 0 nuls = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR nuls LOOP UNTIL BIT (Ax3sensor.qry,i) ' logfile "0's:" + STR$(nuls) + ", 1's:" + STR$(ones) + ", skips:" + STR$(skips) END IF IF i < 0 THEN ' invalid result Ax3sensor.mmry = %False ELSE IF (skips > 2) AND (nuls > 2) AND (ones > 2) THEN 'if the sign changes faster then this, it's usually a consequence of resonance when a movement stops.. 'this makes it work quite reliably! #IF %DEF(%ax3dbg) logfile " period ok:" + STR$(nuls + ones) #ENDIF ' nuls + ones = a full period Ax3sensor.mmry = 2 * 60! / ((nuls + ones) * (1!/(Ax3Sensor.samplingrate/4)) ) ' Ax3Sensor.mmrx = MIN(MAX(29,Ax3Sensor.mmrx),480) ' limit return values 'if you reach this limits, you can be quite sure you are not measuring anything meaningfull -> better retur 0 IF Ax3sensor.mmry <= 40 THEN Ax3sensor.mmry = 0 IF Ax3sensor.mmry >=240 THEN Ax3sensor.mmry = 0 '150 was 480 #IF %DEF(%ax3dbg) logfile " mm:" + STR$(Ax3sensor.mmry) 'actually is mm/2 , as it's a full period (up + down) #ENDIF ELSE ' logfile " period not ok" ' invalid result Ax3sensor.mmry = %False END IF END IF CASE 2 ' left x channel ' add to databuffers: POKE$ Ax3sensor.plx + 2, PEEK$(Ax3sensor.plx, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 Ax3sensor.@plx = dta ' of, Ax0buf(0) = dta Ax3sensor.avglx = ((Ax3sensor.avglx * 31) + dta)/ 32 ' for ca.128 S/s or 32 S/s per channel Ax3sensor.acclx = (dta - 512) / 238 ' scaling factor gwr 27.10.2007 Ax3sensor.dalx = (dta - Ax3sensor.avglx)/ 238 ' konditie -1g --- 1g g = (Ax3sensor.avglx - 512) / 238 IF g < -1 THEN g = -1 IF g > 1 THEN g = 1 Ax3sensor.tiltlx = Arcsin(g) ' in radialen 'tempo procedure: 'logfile "" #IF %DEF(%ax3dbg) logfile "----acclx:" + STR$(Ax3sensor.acclx) #ENDIF SHIFT RIGHT Ax3sensor.qlx,1 ' make place - shift data 1 bit to the right BIT CALC Ax3sensor.qlx, 63, BIT(Ax3sensor.qlx2, 0) SHIFT RIGHT Ax3sensor.qlx2, 1 'ignore small movements - otherwise we have too much noise IF (Ax3sensor.acclx > 1) OR (Ax3sensor.acclx < -.5) THEN 'sic, assymetrical - negative values go much less low.. IF SGN(Ax3sensor.acclx) <> lastsignlx THEN lastsignlx = SGN(Ax3sensor.acclx) IF lastsignlx > 0 THEN BIT SET Ax3sensor.qlx,127 'else leave it 0 ELSE BIT RESET Ax3sensor.qlx, 127 'shouldn't be necessary END IF 'logfile " change sign" + STR$(lastsignlx) ELSE 'sign doesn't change -> we keep moving in the same direction ' logfile " continue, same sign" + STR$(lastsignlx) IF BIT(Ax3sensor.qlx, 126) THEN BIT SET Ax3Sensor.qlx, 127 ELSE BIT RESET Ax3Sensor.qlx, 127 END IF END IF ELSE ' logfile " continue, no trig" + STR$(lastsignlx) 'we presume that the direction doesn't change - this will cause an assymetry between the twohalves of a period, 'but the full period should be accurate.. IF BIT (Ax3sensor.qlx, 126) THEN BIT SET Ax3Sensor.qlx, 127 ELSE BIT RESET Ax3Sensor.qlx, 127 END IF END IF #IF %DEF(%ax3dbg) logfile "qrs: " + BIN$(HI(DWORD, Ax3sensor.qlx2), 32) + BIN$(LO(DWORD, Ax3sensor.qlx2), 32)+ BIN$(HI(DWORD, Ax3sensor.qlx), 32) + BIN$(LO(DWORD, Ax3sensor.qlx), 32) #ENDIF IF BIT(Ax3sensor.qlx, 127) THEN ' we wrote a 1,so we now look at the next continous series of zeros: i = 126 skips = 0 DO DECR i INCR skips IF i < 0 THEN EXIT LOOP ' should not happen LOOP UNTIL BIT (Ax3sensor.qlx,i) = 0 ' now we must have the first occurence of a zero nuls = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR nuls LOOP UNTIL BIT (Ax3sensor.qlx,i) ' now we have the first occurence of a 1 ones = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR ones LOOP UNTIL BIT (Ax3sensor.qlx,i) = 0 ' logfile "0's:" + STR$(nuls) + ", 1's:" + STR$(ones) ELSE ' we wrote a 0,so we now look at the next continous series of ones: i = 126 skips = 0 DO DECR i INCR skips IF i < 0 THEN EXIT LOOP ' should not happen LOOP UNTIL BIT (Ax3sensor.qlx,i) ' now we must have the first occurence of a one ones = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR ones LOOP UNTIL BIT (Ax3sensor.qlx,i)=0 ' now we have the first occurence of a 0 nuls = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR nuls LOOP UNTIL BIT (Ax3sensor.qlx,i) ' logfile "0's:" + STR$(nuls) + ", 1's:" + STR$(ones) + ", skips:" + STR$(skips) END IF IF i < 0 THEN ' invalid result Ax3sensor.mmlx = %False ELSE IF (skips>0) AND (nuls > 2) AND (ones > 2) THEN 'if the sign changes faster then this, it's usually a consequence of resonance when a movement stops.. 'this makes it work quite reliably! #IF %DEF(%ax3dbg) logfile " period ok:" + STR$(nuls + ones) #ENDIF ' nuls + ones = a full period Ax3sensor.mmlx = 2 * 60! / ((nuls + ones) * (1!/(Ax3Sensor.samplingrate/4)) ) ' Ax3Sensor.mmrx = MIN(MAX(29,Ax3Sensor.mmrx),480) ' limit return values 'if you reach this limits, you can be quite sure you are not measuring anything meaningfull -> better retur 0 IF Ax3sensor.mmlx <= 40 THEN Ax3sensor.mmlx = 0 IF Ax3sensor.mmlx >= 240 THEN Ax3sensor.mmlx = 0 '150 was 480 #IF %DEF(%ax3dbg) logfile " mm:" + STR$(Ax3sensor.mmlx) 'actually is mm/2 , as it's a full period (up + down) #ENDIF ELSE ' logfile " period not ok" ' invalid result Ax3sensor.mmlx = %False END IF END IF CASE 3 ' left y channel - lateraal ' add to databuffers: POKE$ Ax3sensor.ply + 2, PEEK$(Ax3sensor.ply, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 Ax3sensor.@ply = dta ' of, Ax1buf(0) = dta Ax3sensor.avgly = ((Ax3sensor.avgly * 31) + dta)/ 32 ' for ca.128 S/s or 32 S/s per channel Ax3sensor.accly = (dta - 512) / 240 ' scaling factor gwr 27.10.2007 Ax3sensor.daly = (dta - Ax3sensor.avgly)/ 240 ' konditie -1g to + 1g g = (Ax3sensor.avgly - 512) / 240 IF g < -1 THEN g = -1 IF g > 1 THEN g = 1 Ax3sensor.tiltly = Arcsin(g) ' in radialen 'tempo procedure: ' logfile "" #IF %DEF(%ax3dbg) logfile "----accly:" + STR$(Ax3sensor.accly) #ENDIF SHIFT RIGHT Ax3sensor.qly,1 ' make place - shift data 1 bit to the right BIT CALC Ax3sensor.qly, 63, BIT(Ax3sensor.qly2, 0) SHIFT RIGHT Ax3sensor.qly2, 1 'ignore small movements - otherwise we have too much noise IF (Ax3sensor.accly > 1) OR (Ax3sensor.accly < -1) THEN 'sic, assymetrical - negative values go much less low.. IF SGN(Ax3sensor.accly) <> lastsignly THEN lastsignly = SGN(Ax3sensor.accly) IF lastsignly > 0 THEN BIT SET Ax3sensor.qly,127 'else leave it 0 ELSE BIT RESET Ax3sensor.qly, 127 'shouldn't be necessary END IF ' logfile " change sign" + STR$(lastsignly) ELSE 'sign doesn't change -> we keep moving in the same direction ' logfile " continue, same sign" + STR$(lastsignly) IF BIT(Ax3sensor.qly, 126) THEN BIT SET Ax3Sensor.qly, 127 ELSE BIT RESET Ax3Sensor.qly, 127 END IF END IF ELSE ' now we have the first occurence of a 1 ' logfile " continue, no trig" + STR$(lastsignly) 'we presume that the direction doesn't change - this will cause an assymetry between the twohalves of a period, 'but the full period should be accurate.. IF BIT (Ax3sensor.qly, 126) THEN BIT SET Ax3Sensor.qly, 127 ELSE BIT RESET Ax3Sensor.qly, 127 END IF END IF IF BIT(Ax3sensor.qly, 127) THEN ' we wrote a 1,so we now look at the next continous series of zeros: i = 126 skips = 0 DO DECR i INCR skips IF i < 0 THEN EXIT LOOP ' should not happen LOOP UNTIL BIT (Ax3sensor.qly,i) = 0 ' now we must have the first occurence of a zero nuls = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR nuls LOOP UNTIL BIT (Ax3sensor.qly,i) ones = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR ones LOOP UNTIL BIT (Ax3sensor.qly,i) = 0 ' logfile "0's:" + STR$(nuls) + ", 1's:" + STR$(ones) ELSE ' we wrote a 0,so we now look at the next continous series of ones: i = 126 skips = 0 DO DECR i INCR skips IF i < 0 THEN EXIT LOOP ' should not happen LOOP UNTIL BIT (Ax3sensor.qly,i) ' now we must have the first occurence of a one ones = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR ones LOOP UNTIL BIT (Ax3sensor.qly,i)=0 ' now we have the first occurence of a 0 nuls = %False DO DECR i IF i < 0 THEN EXIT LOOP INCR nuls LOOP UNTIL BIT (Ax3sensor.qly,i) ' logfile "0's:" + STR$(nuls) + ", 1's:" + STR$(ones) + ", skips:" + STR$(skips) END IF #IF %DEF(%ax3dbg) logfile " qrs: " + BIN$(HI(DWORD, Ax3sensor.qly2), 32) + BIN$(LO(DWORD, Ax3sensor.qly2), 32) + BIN$(HI(DWORD, Ax3sensor.qly), 32) + BIN$(LO(DWORD, Ax3sensor.qly), 32) #ENDIF IF i < 0 THEN ' invalid result Ax3sensor.mmly = %False ELSE ' IF nuls + ones > 1 THEN IF (skips > 2) AND (nuls > 2) AND (ones > 2) THEN 'if the sign changes faster then this, it's usually a consequence of resonance when a movement stops.. 'this makes it work quite reliably! #IF %DEF(%ax3dbg) logfile " period ok:" + STR$(nuls + ones) #ENDIF ' nuls + ones = a full period Ax3sensor.mmly = 2 * 60! / ((nuls + ones) * (1!/(Ax3Sensor.samplingrate/4)) ) ' Ax3Sensor.mmrx = MIN(MAX(29,Ax3Sensor.mmrx),480) ' limit return values 'if you reach this limits, you can be quite sure you are not measuring anything meaningfull -> better retur 0 IF Ax3sensor.mmly <= 40 THEN Ax3sensor.mmly = 0 IF Ax3sensor.mmly >= 240 THEN Ax3sensor.mmly = 0 '150 was 480 #IF %DEF(%ax3dbg) logfile " mm:" + STR$(Ax3sensor.mmly) 'actually is mm/2 , as it's a full period (up + down) #ENDIF ELSE ' logfile " period not ok" ' invalid result Ax3sensor.mmly = %False END IF END IF END SELECT LOOP ' ' for debugging effective sampling rate calculation: ' note that the effective sampling rate per channel is only 1/4th of this value. IF ISFALSE (timegettime - starttime) MOD 1000 THEN Ax3sensor.samplingrate = samples / ((timegettime - starttime) \1000) CONTROL SET TEXT @pgh.cockpit, %GMT_TEXT_SR, FORMAT$(Ax3sensor.samplingrate,"000") END IF END SUB FUNCTION GetAX3Sensorpointer (BYVAL nr AS LONG, BYVAL listentasknr AS LONG) EXPORT AS DWORD ' to be called by the application code to get access to the data in the structure. ' call with listentasknr -1 to obtain the pointer to the Ax3sensortype without creating a listentask (feature used by Axe3Mon g_glib.bas) ' 22.10.2007 - gwr ' done 22.10.2007: read config data (inport & channel) from ini-file. ' 24.10.2007: further development work LOCAL miport AS WORD LOCAL kanaal AS WORD LOCAL port_channel AS WORD IF listentasknr > -1 THEN ' initialisation and error checking: port_channel = ReadAX3ConfigFromFile(IniFileName) ' InifileName is function in g_indep.dll) ' ReadAX3Config is in g_file.dll ' check for availability of midi input ports: miport = HIBYT(port_channel) AND &H0F kanaal = LOBYT(port_channel) AND &H0F ' first check for available ports IF miport > UBOUND(hMidiI) THEN Warning "This computer does not have enough midi inports for the Axe3 device (" + FUNCNAME$ + ")",10000 EXIT FUNCTION END IF ' then check for valid handles and opened midi-ports: IF ISFALSE hMidiI(miport) THEN Warning "You cannot use the Axe3 sensor without opening the requested midi port(" + FUNCNAME$ + ")", 10000 EXIT FUNCTION END IF Ax3sensor.channel = port_channel ' now this is validated. ' check validity of requested listentasknr. : IF listentasknr > %NumberOfTasks -1 THEN Warning "Tasknumber exceeds GMT's limit of 64 in " + FUNCNAME$, 10000 EXIT FUNCTION ELSE Ax3sensor.listentasknr = listentasknr END IF @pTask(listentasknr).cptr = CODEPTR(AX3_Input) ' code in this same module @pTask(listentasknr).naam = "AXE3-In" @pTask(listentasknr).freq = 128 ' this is the minimum required rate ' the Axe3 outputs 129 messages per second. @pTask(listentasknr).flags = %DLL_TASK 'OR %PERTIM_TASK @pTaskEX(listentasknr).stopcptr = CODEPTR(AX3_Input_Stop) DIM ax0buf(%PicRadBufsize) AS GLOBAL INTEGER DIM ax1buf(%PicRadBufSize) AS GLOBAL INTEGER DIM ax2buf(%PicRadBufsize) AS GLOBAL INTEGER DIM ax3buf(%PicRadBufSize) AS GLOBAL INTEGER Ax3sensor.plx = VARPTR(ax0buf(0)) 'INTEGER PTR ' left x data 10 bit Ax3sensor.ply = VARPTR(ax1buf(0)) 'INTEGER PTR ' left y data - 10 bit Ax3sensor.prx = VARPTR(ax2buf(0)) 'INTEGER PTR ' right x data Ax3sensor.pry = VARPTR(ax3buf(0)) 'INTEGER PTR ' right y data SetMidiListenChannel (Ax3sensor.channel, %False) ' reset recording flag! (set on start of listentask) END IF FUNCTION = VARPTR(Ax3sensor) ' return pointer to the initialized structure END FUNCTION SUB AX3_Input_Stop () IF Ax3sensor.plx THEN SetMidiListenChannel (Ax3sensor.channel, %False) END IF Ax3sensor.qlx = %False Ax3sensor.qly = %False Ax3sensor.qrx = %False Ax3sensor.qry = %False END SUB FUNCTION GetPir2SensorPointer (BYVAL nr AS LONG, BYVAL listentasknr AS LONG) EXPORT AS DWORD ' to be called by the application code to get access to the data in the structure. ' call with listentasknr -1 to obtain the pointer to the PIRsensortype without creating a listentask ' (feature may be used by PIR2Mon g_glib.bas) ' 17.11.2007 - gwr ' done 17.11.2007: read config data (inport & channel) from ini-file. LOCAL miport AS WORD LOCAL kanaal AS WORD LOCAL port_channel AS WORD IF listentasknr > -1 THEN ' initialisation and error checking: port_channel = ReadPIR2ConfigFromFile(IniFileName) ' InifileName is function in g_indep.dll) ' ReadPIR2Config is in g_file.dll ' check for availability of midi input ports: miport = HIBYT(port_channel) AND &H0F kanaal = LOBYT(port_channel) AND &H0F ' first check for available ports IF miport > UBOUND(hMidiI) THEN Warning "This computer does not have enough midi inports for the PIR2 device (" + FUNCNAME$ + ")",10000 EXIT FUNCTION END IF ' then check for valid handles and opened midi-ports: IF ISFALSE hMidiI(miport) THEN Warning "You cannot use the PIR2 sensor without opening the requested midi port(" + FUNCNAME$ + ")", 10000 EXIT FUNCTION END IF PIR2Sensor.channel = port_channel ' now this is validated. ' check validity of requested listentasknr. : IF listentasknr > %NumberOfTasks -1 THEN Warning "Tasknumber exceeds GMT's limit of 64 in " + FUNCNAME$, 10000 EXIT FUNCTION ELSE PIR2sensor.listentasknr = listentasknr END IF @pTask(listentasknr).cptr = CODEPTR(PIR2_Input) ' code in this same module @pTask(listentasknr).naam = "PIR2-In" @pTask(listentasknr).freq = 25 ' this is the minimum required rate @pTask(listentasknr).flags = %DLL_TASK OR %PERTIM_TASK @pTaskEX(listentasknr).stopcptr = CODEPTR(PIR2_Input_Stop) DIM Pirlbuf(%PicRadBufsize) AS GLOBAL INTEGER ' 256 x 40ms = 10 sekonden buffer DIM Pircbuf(%PicRadBufSize) AS GLOBAL INTEGER DIM Pirrbuf(%PicRadBufsize) AS GLOBAL INTEGER Pir2sensor.pleft = VARPTR(Pirlbuf(0)) ' left data 10 bit Pir2sensor.pcenter = VARPTR(Pircbuf(0)) ' center data - 10 bit Pir2sensor.pright = VARPTR(Pirrbuf(0)) ' right data SetMidiListenChannel (Pir2sensor.channel, %False) ' reset recording flag! (set on start of listentask) END IF FUNCTION = VARPTR(Pir2sensor) ' return pointer to the initialized structure END FUNCTION SUB PIR2_Input () ' listentask for the PIR2 sensing device 11/2007 ' no need to EXPORT ' This listen-task is called from within this library, ' initialised by GetPIR2Sensorpointer () function. ' Pir2sensor is global in this library. ' PIR2 is accessed through its pointer in GMT application code. ' the tasknumber for the listentask should be set in PIR2sensor.listentask ' This task does not create a user interface. LOCAL retval AS INTEGER LOCAL datakanaal AS DWORD LOCAL msb AS WORD LOCAL lsb AS WORD LOCAL dta AS WORD STATIC oldleftcnt AS WORD STATIC oldcentercnt AS WORD STATIC oldrightcnt AS WORD STATIC lones AS DWORD STATIC lzeros AS DWORD STATIC cones AS DWORD STATIC czeros AS DWORD STATIC rones AS DWORD STATIC rzeros AS DWORD LOCAL period AS SINGLE STATIC oldlbit AS BYTE STATIC oldcbit AS BYTE STATIC oldrbit AS BYTE STATIC lref AS SINGLE ' zero reference values STATIC cref AS SINGLE STATIC rref AS SINGLE IF ISFALSE @pTask(Pir2sensor.listentasknr).tog THEN IF Pir2sensor.pleft THEN SetMidiListenChannel (PIR2sensor.channel, %True) ELSE EXIT SUB END IF oldleftcnt = 1023 oldcentercnt = 1023 oldrightcnt = 1023 @pTask(PIR2sensor.listentasknr).tog = %True END IF DO retval = GetPressure (Pir2sensor.channel,%Remove OR %Oldest) ' integer IF retval = %Notfalse THEN EXIT DO datakanaal = retval SHIFT RIGHT datakanaal,12 ' 0-7 retval = retval AND &B0000111111111111 ' mask lsb = LOBYT(retval) ' must be 7 bit msb = HIBYT(retval) ' must be 3 bit dta = lsb + (msb * 128) ' 10 bit data value 0-1023 ' logfile "Datakanaal:" + STR$(datakanaal) SELECT CASE datakanaal CASE 0 ' left PIR channel - analog signal POKE$ PIR2sensor.pleft + 2, PEEK$(PIR2sensor.pleft, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 PIR2sensor.@pleft = dta lref = ((lref * 255) + dta )/ 256 ' averaged reference level ' distance calculation (body surface being constant, the amplitude must be proportional to ' the distance to the body) ' here we apply an integration depth of 480ms (12 x 40ms) PIR2sensor.avgl = ((PIR2sensor.avgl * 11) + ABS(dta - lref))/ 12 ' range: 0 - 484.1908 as measured 18.11.2007 gwr. ' for normalisation 0-1: PIR2sensor.avgl = (SQR(PIR2sensor.avgl)) / 22 CASE 1 ' center PIR channel - analog signal POKE$ PIR2sensor.pcenter + 2, PEEK$(PIR2sensor.pcenter, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 PIR2sensor.@pcenter = dta cref = ((cref * 255) + dta) / 256 PIR2sensor.avgc = ((PIR2sensor.avgc * 11) + ABS(dta - cref)) / 12 CASE 2 ' right PIR channel- analog signal POKE$ PIR2sensor.pright + 2, PEEK$(PIR2sensor.pright, %PicRadBufSize * 2) 'sic, as real size of buffer is %PicradbufSize + 1 PIR2sensor.@pright = dta rref = ((rref * 255) + dta) / 256 PIR2sensor.avgr = ((PIR2sensor.avgr * 11) + ABS(dta - rref)) / 12 CASE 3 ' duration of the left movement detector positive pulse - in 40ms units ' if the value is 1023 we have to add it up ' if < 1023, we have a stop and we know the pulse duration in full IF oldleftcnt < 1023 THEN PIR2sensor.dleft = dta ELSE PIR2sensor.dleft = PIR2sensor.dleft + dta + 1 END IF oldleftcnt = dta CASE 4 ' duration of the center movement detector positive pulse - in 40ms units IF oldcentercnt < 1023 THEN PIR2sensor.dcenter = dta ELSE PIR2sensor.dcenter = PIR2sensor.dcenter + dta + 1 END IF oldcentercnt = dta CASE 5 ' duration of the right movement detector positive pulse - in 40ms units IF oldrightcnt < 1023 THEN PIR2sensor.dright = dta ELSE PIR2sensor.dright = PIR2sensor.dright + dta + 1 END IF oldrightcnt = dta ' logfile "d's:" + STR$(PIR2sensor.dleft)+ STR$(PIR2sensor.dcenter)+ STR$(PIR2sensor.dright) CASE 6 ' bit train IF BIT (PIR2sensor.lefttrain,63) THEN oldlbit = 1 ELSE oldlbit = 0 IF BIT(lsb,0) <> oldlbit THEN ' dan hebben we een overgang en kunnen we frekwentie berekeken... period = lones + lzeros PIR2sensor.fleft = 1! / (period * 0.04) ' 40ms scan rate IF BIT(lsb,0) THEN lzeros = 0 ELSE lones = 0 END IF END IF SHIFT RIGHT PIR2sensor.lefttrain, 1 IF BIT(lsb,0) THEN BIT SET PIR2sensor.lefttrain, 63 INCR lones ELSE BIT RESET PIR2sensor.lefttrain, 63 INCR lzeros END IF ' center channel: IF BIT (PIR2sensor.centertrain,63) THEN oldcbit = 1 ELSE oldcbit = 0 IF BIT(lsb,0) <> oldcbit THEN ' dan hebben we een overgang en kunnen we frekwentie berekeken... period = cones + czeros PIR2sensor.fcenter = 1! / (period * 0.04) ' 40ms scan rate IF BIT(lsb,0) THEN czeros = 0 ELSE cones = 0 END IF END IF SHIFT RIGHT PIR2sensor.centertrain, 1 IF BIT(lsb,1) THEN BIT SET PIR2sensor.centertrain, 63 INCR cones ELSE BIT RESET PIR2sensor.centertrain, 63 INCR czeros END IF ' right channel: IF BIT (PIR2sensor.righttrain,63) THEN oldrbit = 1 ELSE oldrbit = 0 IF BIT(lsb,0) <> oldrbit THEN ' dan hebben we een overgang en kunnen we frekwentie berekeken... period = rones + rzeros PIR2sensor.fright = 1! / (period * 0.04) ' 40ms scan rate IF BIT(lsb,0) THEN rzeros = 0 ELSE rones = 0 END IF END IF SHIFT RIGHT PIR2sensor.righttrain, 1 IF BIT(lsb,2) THEN BIT SET PIR2sensor.righttrain, 63 INCR rones ELSE BIT RESET PIR2sensor.righttrain, 63 INCR rzeros END IF ' logfile "f's" + STR$(PIR2sensor.fleft) + STR$(PIR2sensor.fcenter)+ STR$(PIR2sensor.fright) CASE ELSE ' mag niet voorkomen END SELECT LOOP ' try to derive distance and angle: ' find maximum amplitude: LOCAL d AS SINGLE LOCAL dl,dr,dce AS SINGLE d = MAX(PIR2sensor.avgl, PIR2sensor.avgc, PIR2sensor.avgr) IF d THEN PIR2sensor.distance = 1! / SQR(d) ' from close to 0 to 0.9263636 - normalisation o.k. 18.11.07 gwr ' try to determine the angular position: dl = ((SQR(PIR2sensor.avgl) - SQR(PIR2sensor.avgc))) /22 ' -1... +1 if avg's are normalized... dr = ((SQR(PIR2sensor.avgr) - SQR(PIR2sensor.avgc))) /22 ' -1... +1 dce =((SQR(PIR2sensor.avgl) - SQR(PIR2sensor.avgr))) /22 ' -1... +1 ' the following angle computation did not work very well.. '' IF (dl >= dce) AND (dl > dr) THEN '' ' helemaal links - hoeken in radialen. '' ' de hoek tussen de l en r sensoren en de middenas is telkens 30 graden of Pi/6 '' ' de scaling kan hier nog fout zitten! '' PIR2sensor.angle = dl - (Pi# / 6) '' ELSEIF (dr >= dce) AND (dr > dl) THEN '' PIR2sensor.angle = dr + (Pi# / 6) '' ELSEIF (dce >= dl) AND (dce >= dr) THEN '' PIR2sensor.angle = dce '' ELSE '' ' undeterminable '' END IF 'new attampt by xof 'note: hoek = afwijking van het midden 'debug results" ' -still extra case necessary: sometimes avgl, avgc and avgr are more or less equal!!! ' -> note: in the distance calc, all sensors at the samve value will show the same as one at that value and the others at 0 -> is this ok? ' -weirdness: somteimes left and right are both higher then centre ?! ' logfile "avgl-c-r" + STR$(Pir2sensor.avgl) + STR$(Pir2sensor.avgc)+ STR$(Pir2sensor.avgr) IF ISFALSE(Pir2sensor.avgl) AND ISFALSE(Pir2sensor.avgr) AND Pir2sensor.avgc > 0 THEN Pir2sensor.angle = 0 ELSEIF Pir2sensor.avgl > Pir2sensor.avgr THEN IF Pir2sensor.avgc THEN ' Pir2sensor.angle = MIN(-Pi/6, (atn(Pir2sensor.avgl/Pir2sensor.avgc) / (Pi/2) * (-Pi/6)) Pir2sensor.angle = MAX(-Pi/6, - ATN(Pir2sensor.avgl/Pir2sensor.avgc) / 3) ELSE Pir2sensor.angle = -Pi#/6 'kan ook groter zijn, maar dat onderscheid kunnen we niet maken END IF ELSE IF Pir2sensor.avgc THEN ' Pir2sensor.angle = MAX(Pi#/6, (pir2sensor.avgr/(1 + pIR2sensor.avgc)) * (Pi/6)) Pir2sensor.angle = MIN(Pi/6, ATN(Pir2sensor.avgr/Pir2sensor.avgc) / 3) ELSE Pir2sensor.angle = Pi#/6 END IF END IF ELSE PIR2sensor.distance = 1 ' should be infinity... PIR2sensor.angle = -Pi# ' should be indeterminable, hence we set it to -Pi rather than 0. END IF ' logfile "->Pir2sensor.angle(deg):" + STR$(180 * (Pir2sensor.angle / Pi#)) + " - d:" + STR$(Pir2sensor.distance) END SUB SUB PIR2_Input_Stop () IF PIR2sensor.pleft THEN SetMidiListenChannel (PIR2sensor.channel, %False) END IF END SUB SUB Create_PicRadar_Control (BYREF Slider() AS SliderController, BYREF UDctrl() AS UpDownController) EXPORT ' not done on task creation, since this always crashed! ' 22.07.2004 - gwr ' 10.01.2005: ' we added an up-down for individual control of devices. ' in this case 0 means all dev's, 1-8, the picrad devices individually LOCAL tasknr AS DWORD STATIC slnr AS DWORD LOCAL udnr AS DWORD LOCAL m AS ASCIIZ * 14 tasknr = PicRad(0).listentasknr IF ISFALSE @pTask(tasknr).cptr THEN Warning "Error Picradar in" + FUNCNAME$, 10000 : EXIT SUB IF ISFALSE @pTask(tasknr).hparam THEN ' simplified version: DIM TaskParamLabels(2) AS STATIC ASCIIZ * 8 TaskParamLabels(0) = "dta" TaskParamLabels(1) = "dtf" TaskParamLabels(2) = "dev" MakeTaskParameterDialog tasknr,2,Slider(),1,UDctrl(),TaskParamlabels() END IF IF ISFALSE slnr THEN slnr = @pTaskEX(tasknr).SliderNumbers(0) udnr = @pTaskEX(tasknr).UpDownNumbers(0) Slider(slnr).cptr = CODEPTR(PicRadar_Slider_dta) Slider(slnr+1).cptr = CODEPTR(PicRadar_Slider_dtf) UDctrl(udnr).cptr = CODEPTR(PicRadar_UD_Dev) UDctrl(udnr).value = %False END IF m = "" SendMessage @pTask(tasknr).hparam, %WM_SETTEXT,0, VARPTR(m) CornerWindow @pTask(tasknr).hParam, "dl" END SUB SUB PicRadar_Slider_dta () LOCAL slnr AS DWORD LOCAL udnr AS DWORD LOCAL i AS DWORD slnr = @pTaskEX(PicRad(0).listentasknr).SliderNumbers(0) udnr = @pTaskEX(PicRad(0).listentasknr).UpDownNumbers(0) IF ISFALSE @pUDctrl(udnr).value THEN ' set value to all devices FOR i = 0 TO UBOUND(PicRad) PicRad(i).da = @pSlider(slnr).value 'MAX(@pSlider(slnr).value, 1) IF PicRad(i).da < 1.0 THEN PicRad(i).da = 1.0 NEXT i ELSE ' set value of slider only to the selected device. IF @pUDctrl(Udnr).value - 1 <= UBOUND(PicRad) THEN i = @pUDctrl(Udnr).value -1 PicRad(i).da = @pSlider(slnr).value 'MAX(@pSlider(slnr).value, 1) IF PicRad(i).da < 1.0 THEN PicRad(i).da = 1.0 END IF END IF END SUB SUB PicRadar_Slider_dtf () LOCAL slnr AS DWORD LOCAL udnr AS DWORD LOCAL i AS DWORD slnr = @pTaskEX(PicRad(0).listentasknr).SliderNumbers(1) udnr = @pTaskEX(PicRad(0).listentasknr).UpDownNumbers(0) IF ISFALSE @pUDctrl(udnr).value THEN ' set value to all devices FOR i = 0 TO UBOUND(PicRad) PicRad(i).dv = @pSlider(slnr).value 'MAX(@pSlider(slnr).value, 1) IF PicRad(i).dv < 1.0 THEN PicRad(i).dv = 1.0 NEXT i ELSE ' set value of slider only to the selected device. IF @pUDctrl(Udnr).value - 1 <= UBOUND(PicRad) THEN i = @pUDctrl(Udnr).value -1 PicRad(i).dv = @pSlider(slnr).value 'MAX(@pSlider(slnr).value, 1) IF PicRad(i).dv < 1.0 THEN PicRad(i).dv = 1.0 END IF END IF END SUB SUB PicRadar_UD_Dev () ' call back for UD - select Picra device LOCAL value AS BYTE value = @pUDCtrl(@pTaskEX(PicRad(0).listentasknr).UpdownNumbers(0)).value IF value > UBOUND(PicRad)+1 THEN value = UBOUND(PicRad)+1 IF value < 0 THEN value = 0 IF ISFALSE value THEN SetDlgItemText @pTask(PicRad(0).listentasknr).hparam, %GMT_TEXT0_ID + 16, "All" ELSE SetDlgItemText @pTask(PicRad(0).listentasknr).hparam, %GMT_TEXT0_ID + 16, "Rad=" & STR$(value) END IF END SUB FUNCTION GetPicRadarPointer (BYVAL n AS DWORD, BYVAL listentasknr AS DWORD, BYVAL channel AS WORD) EXPORT AS DWORD ' picrad() is global ' the listentasknr. can only be set on the first call! LOCAL i AS DWORD LOCAL miport AS BYTE LOCAL kanaal AS BYTE STATIC init AS DWORD IF ISFALSE init THEN '%Max_nrPicRads = 8 ' maximum number of PicRad devices that can be used 'REDIM Picrad(%Max_NrPicRads - 1) AS GLOBAL RadarPicController ' done on init library. FOR i = 0 TO UBOUND(PicRad) PicRad(i).channel = &H0FFF ' word NEXT i ' Make_ii_VU_Window 7 ' parameter = resolution AS BYTE - left to user app. init = 1 END IF IF n > UBOUND(PicRad) THEN Warning "Maximum number of PIC-radar devices exceeded in" + FUNCNAME$, 10000 EXIT FUNCTION END IF ' PicRads do not work with UPD ports: IF (channel AND &H0F000) THEN Warning "UDP ports not supported for PicRad devices" & HEX$(channel),10000 EXIT FUNCTION END IF ' check for availability of midi input ports: miport = HIBYT(channel) AND &H0F kanaal = LOBYT(channel) AND &H0F ' first check for available ports IF miport > UBOUND(hMidiI) THEN Warning "This computer does not have enough midi inports for the PicRad device (" + FUNCNAME$ + ")",10000 EXIT FUNCTION END IF ' then check for valid handles and opened midi-ports: IF ISFALSE hMidiI(miport) THEN Warning "You cannot use PicRad" & STR$(n)& " device without opening the requested midi port(" + FUNCNAME$ + ")", 10000 EXIT FUNCTION END IF ' check for devices on the same port/channel!: FOR i = 0 TO UBOUND(picrad) IF PicRad(i).channel <> &H0FFF THEN IF channel = PicRad(i).channel THEN Warning "Port/Channel already in use for PicRad" & STR$(i) + "(" + FUNCNAME$ + ")",10000 EXIT FUNCTION END IF END IF NEXT i ' now we passed all tests and we can set the channel/port: PicRad(n).channel = channel IF init = 1 THEN ' check validity of requested listentasknr. : IF listentasknr > %NumberOfTasks -1 THEN Warning "Tasknumber exceeds GMT's limit of 64 i n" + FUNCNAME$, 10000 EXIT FUNCTION ELSE FOR i = 0 TO UBOUND(PicRad) PicRad(i).listentasknr = listentasknr ' must be the same for all devices. NEXT i END IF @pTask(listentasknr).cptr = CODEPTR(PicRadarInput) @pTask(listentasknr).naam = "PicRadIn" @pTask(listentasknr).freq = 50 @pTask(listentasknr).flags = %DLL_TASK 'OR %PERTIM_TASK @pTaskEX(listentasknr).stopcptr = CODEPTR(PicRadarInput_Stop) END IF PicRad(n).da = 1.0 'MAX(PicRad(n).da,1) 040722 PicRad(n).dv = 1.0 'MAX(PicRad(n).dv,1) ' msgbox str$(n) + " - " + str$(picrad(n).da),,funcname$ SELECT CASE n CASE 0 DIM a0buf(%PicRadBufSize) AS GLOBAL INTEGER ' declared global in g_lib.bas, only dimmed here. DIM t0buf(%PicRadBufSize) AS GLOBAL INTEGER PicRad(0).pabuf = VARPTR(a0buf(0)) PicRad(0).ptbuf = VARPTR(t0buf(0)) CASE 1 DIM a1buf(%PicRadBufSize) AS GLOBAL INTEGER DIM t1buf(%PicRadBufSize) AS GLOBAL INTEGER PicRad(1).pabuf = VARPTR(a1buf(0)) PicRad(1).ptbuf = VARPTR(t1buf(0)) CASE 2 DIM a2buf(%PicRadBufSize) AS GLOBAL INTEGER DIM t2buf(%PicRadBufSize) AS GLOBAL INTEGER PicRad(2).pabuf = VARPTR(a2buf(0)) PicRad(2).ptbuf = VARPTR(t2buf(0)) CASE 3 DIM a3buf(%PicRadBufSize) AS GLOBAL INTEGER DIM t3buf(%PicRadBufSize) AS GLOBAL INTEGER PicRad(3).pabuf = VARPTR(a3buf(0)) PicRad(3).ptbuf = VARPTR(t3buf(0)) CASE 4 DIM a4buf(%PicRadBufSize) AS GLOBAL INTEGER DIM t4buf(%PicRadBufSize) AS GLOBAL INTEGER PicRad(4).pabuf = VARPTR(a4buf(0)) PicRad(4).ptbuf = VARPTR(t4buf(0)) CASE 5 DIM a5buf(%PicRadBufSize) AS GLOBAL INTEGER DIM t5buf(%PicRadBufSize) AS GLOBAL INTEGER PicRad(5).pabuf = VARPTR(a5buf(0)) PicRad(5).ptbuf = VARPTR(t5buf(0)) CASE 6 DIM a6buf(%PicRadBufSize) AS GLOBAL INTEGER DIM t6buf(%PicRadBufSize) AS GLOBAL INTEGER PicRad(6).pabuf = VARPTR(a6buf(0)) PicRad(6).ptbuf = VARPTR(t6buf(0)) CASE 7 DIM a7buf(%PicRadBufSize) AS GLOBAL INTEGER DIM t7buf(%PicRadBufSize) AS GLOBAL INTEGER PicRad(7).pabuf = VARPTR(a7buf(0)) PicRad(7).ptbuf = VARPTR(t7buf(0)) END SELECT INCR init SetMidiListenChannel (PicRad(n).channel, %False) ' reset recording flag! (set on start of listentask) FUNCTION = VARPTR(PicRad(n)) END FUNCTION FUNCTION GethMidiO(i AS LONG) EXPORT AS DWORD 'returns hWo(i), or 0 if i is out of bounds 'needed in g_wmix.inc IF (i <= UBOUND(hMidiO)) AND (i >= LBOUND(hMidio)) THEN FUNCTION = hMidio(i) ELSE FUNCTION = 0 END IF END FUNCTION FUNCTION GethMidiI(i AS LONG) EXPORT AS DWORD 'returns hWo(i), or 0 if i is out of bounds 'needed in g_wmix.inc IF (i <= UBOUND(hMidiI)) AND (i >= LBOUND(hMidiI)) THEN FUNCTION = hMidiI(i) ELSE FUNCTION = 0 END IF END FUNCTION '[EOF]