'************************************************* '* g_mus.bas * '* music composition procedure library * '* by Prof.Dr.Godfried-Willem Raes * '* source code for dll file g_mus.dll * '* version 10.02 * '************************************************* ' 20.12.2001: contains most context independent functions ' for music composition. ' 05.06.2003: Text2Har function for german language added. ' 21.06.2003: F2QT added, for quartertone implementation. ' 02.08.2003: bugs removed in GetHighest and GetLowest... ' 21.09.2003: leading 0 added in hexadecimal constants. ' 08.10.2003: GetNrNotesinHar added. ' 01.11.2004: Hindemith functions HarForce and MelForce added. ' 05.03.2005: Kristof: hier worden enkele procs. gedeclared die niet in de lib voorkomen!!! ' 26.03.2005: HEX$ compiler bug remedied. ' 04.09.2005: New spectral functions added. Kernel crash in ModSpekFak ' 10.09.2005: blijft crashen op Yes! ' 13.09.2005: new library created: g_har.dll ' 06.06.2006: TxtG2Har function modified ' 01.10.2006: Quartertone harmony and composition functions added. ' 16.01.2007: Quartertone functions moved to g_har.bas ' 20.01.2007: moving all harmony related functions to g_har ' we keep melody and rhythm functions here. ' 22.01.2007: more harmony functions moved to g_har. ' chordnumber harmony related functions moved to g_crd.inc ' 31.08.2008: adapted to PB9.0 compiler ' 13.07.2009: Macros added, replacing globals. ' 05.06.2011: PB10.0 include once's added. ' 08.01.2012: PB10.03 #COMPILER PBWIN 10 #COMPILE DLL "g_mus.dll" #OPTION VERSION5 ' version5 = compile for Windows2000 and/or NT5 #REGISTER ALL ' This metastatement should appear only once. #DIM ALL #TOOLS OFF #RESOURCE "resource\g_mus.pbr" ' resource contains only version info #INCLUDE ONCE "..\winapi\g_win.inc" ' ` #INCLUDE ONCE "g_kons.bi" ' only integer constants and strings can be declared in PB #INCLUDE ONCE "g_type.bi" ' This declares all our own structures, user defined types #INCLUDE ONCE "g_indep.bi" ' include our independent function library. (dll) #INCLUDE ONCE "g_file.bi" ' include our split-of file I/O library '#INCLUDE once ".\kristof\kl_Debug.inc" #INCLUDE ONCE "g_lib.bi" #INCLUDE ONCE "g_har.bi" %g_mus_inc = %True #INCLUDE ONCE "g_mus.bi" ' exported procs. and functions GLOBAL La AS SINGLE ' value set on init of dll GLOBAL GrondDo AS SINGLE ' calculated on initialisation GLOBAL Domq AS SINGLE ' idem. GLOBAL FuzMel() AS SINGLE ' read on initialisation ' local procs: DECLARE SUB GetTangoRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' 30.05.2002 - no export DECLARE SUB GetMilongaRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' 30.05.2002 - no export DECLARE SUB GetTechnoRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' 30.05.2002 - no export DECLARE SUB GetMarchRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' 30.05.2002 - no export DECLARE SUB GetWalsRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' 30.05.2002 - no export DECLARE SUB GetTangoWalsRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' 30.05.2002 - no export DECLARE SUB GetSalsaRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' 30.05.2002 - no export DECLARE SUB GetBossaNovaRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' 30.05.2002 - no export DECLARE SUB GetRumbaRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' 30.05.2002 - no export FUNCTION DLLMAIN(BYVAL hInstance AS LONG, _ BYVAL fwdReason AS LONG, _ BYVAL lpvReserved AS LONG) AS LONG DLLMAIN = 1 'success DLLMain = 0 is failure SELECT CASE fwdReason CASE %DLL_PROCESS_ATTACH La = 440.00 GrondDo = La * (2!^(3!/12!))/64! ' Domq = 7.94305: ' quartertone lower for semitone bands in FFT's Domq = La * (2!^(5!/24!))/64! DIM FuzMel(-11 TO 11) AS GLOBAL SINGLE CALL GetFuzzyMelo(IniFileName,FuzMel()) ' needs explicit call for full array passing CASE %DLL_PROCESS_DETACH, %DLL_THREAD_ATTACH, %DLL_THREAD_DETACH CASE ELSE DLLMAIN = %False END SELECT END FUNCTION SUB GetFuzzyMelo (f AS STRING, FuzMel() AS SINGLE) EXPORT ' called on dll initialisation ' exported to allow users to change the data set LOCAL a%, regel$, i% IF ISFALSE ExistFile (f) THEN 'IF %Wordy > 1 THEN MSGBOX "No ini-file found... Using default fuzzy melo set.",,FUNCNAME$ 'END IF ' if we do not find an external data file, we read default data residing in this procedure. GetDefaultFuzzyMelValues FuzMel() ELSE a% = FREEFILE OPEN f FOR INPUT AS #a% DO WHILE ISTRUE(NOT EOF(a%)) LINE INPUT #a%, regel$ IF LEFT$(UCASE$(LTRIM$(regel$)), 15) = UCASE$("[Melodiousness]") THEN DO INPUT #a%, i%, FuzMel(i%) LOOP UNTIL i% = 11 EXIT DO END IF LOOP CLOSE #a% END IF END SUB SUB GetDefaultFuzzyMelValues (BYREF FuzMel() AS SINGLE) EXPORT REDIM FuzMel(-11 TO 11) AS GLOBAL SINGLE FuzMel(0)= .02 FuzMel(1)= .06 FuzMel(-1)= .06 FuzMel(2)= .04 FuzMel(-2)= .04 FuzMel(3)= .1 FuzMel(-4)= .1 FuzMel(4)= .2 FuzMel(-3)= .2 FuzMel(5)= .35 FuzMel(-7)= .35 FuzMel(6)= .8 FuzMel(-6)= .8 FuzMel(7)= .08 FuzMel(-5)= .08 FuzMel(8)= .7 FuzMel(-9)= .7 FuzMel(9)= .6 FuzMel(-8)= .6 FuzMel(10)= .7 FuzMel(-10)= .7 FuzMel(-11)= .81 FuzMel(11)= .81 END SUB FUNCTION Dismel (BYVAL i%, BYVAL j%) EXPORT AS SINGLE LOCAL Oktaaf!, di! , DiI!, d! LOCAL interval%, r% ' this look-up is pretty good. ' of course, it can be shaped to specific tastes and purposes. ' ook voor het horizontaal verloop binnen een stem gaan we op die wijze ' tewerk. We bekijken het interval tussen twee opeenvolgende noten: ' bepaal eerst de oktaafligging: Oktaaf! = ABS(i% - j%) / 12! di! = Oktaaf! / 10!: ' basiswaarde voor Di! di! = SQR(di!) ' bepaal dan het tonaal interval in halve tonen interval% = ABS(i% - j%) MOD 12 ' bepaal de richting: r% = Richt(i%, j%) ' vektorisatie: DiI! = FuzMel(interval% * r%) DiI! = DiI! ^ 2 ' exception case: IF (Oktaaf! = 0) AND (interval% = 0) THEN d! = 0 ELSE d! = (di! + DiI!) IF d! > 1 THEN d! = 1 FUNCTION = d! END FUNCTION FUNCTION Flue (BYVAL b1%, BYVAL b2%, BYVAL b3%) EXPORT AS SINGLE LOCAL ngem%, weightdismel%, weightline%, dividefaktor%, profilexponent% LOCAL vd1!, vd2!, vd3!, vd4!, vd5!, fl! ' dit kan uitgebreid worden naar een willekeurige melodische lengte. ' bereken de gemiddelde toonhoogte voor de opgegeven reeks: ngem% = (b1% + b2% + b3%) / 3: ' range= 0-127 vd1! = Dismel(b1%, b2%) vd2! = Dismel(b2%, b3%) vd3! = ABS((ngem% - b1%) / 128): ' 0-1 vd4! = ABS((ngem% - b2%) / 128) vd5! = ABS((ngem% - b3%) / 128) ' fuzzy sum: weightdismel% = 3 weightline% = 1 dividefaktor% = (weightdismel% * 2) + (weightline% * 3) fl! = 1 - ((((vd1! + vd2!) * weightdismel%) + vd3! + vd4! + vd5!) / dividefaktor%) profilexponent% = 2 FUNCTION = fl! ^ profilexponent% END FUNCTION FUNCTION MelFrameQual (Ml%(), BYVAL siz%) EXPORT AS SINGLE STATIC Ctmp%() LOCAL pt%, i% ' returns a normalised value for a melodic sequence passed in Ml%() ' integrated over and limited to size% (nr. of notes) ' This function is an application of MelQualWeight! and makes use of its ' code. IF siz% > UBOUND(Ml%, 1) THEN siz% = UBOUND(Ml%, 1) DIM Ctmp%(siz%) ' we make a copy of the considered frame, and pass that pt% = UBOUND(Ml%, 1) FOR i% = siz% TO 0 STEP -1 Ctmp%(i%) = Ml%(pt%) DECR pt% NEXT i% FUNCTION = MelQualWeight(Ctmp%()) END FUNCTION FUNCTION MeloQual (Ml%())EXPORT AS SINGLE LOCAL nrnotes%, i%, sum%, weightdismel%, weightline%, dividefaktor%, profilexponent% LOCAL sm0!, sm1!, fl! LOCAL Mcoef!(), Mavg!() ' returns a fuzzy value for the global 'quality' of a melody ' here defined as a horizontal succession of notes passed in Ml% nrnotes% = UBOUND(Ml%) ' bereken de gemiddelde toonhoogte voor de melodie: FOR i% = 0 TO nrnotes% sum% = sum% + Ml%(i%) NEXT i% sum% = sum% / (nrnotes% + 1): ' range= 0-127 ' bereken nu alle Dismel coefficienten: DIM Mcoef!(1 TO nrnotes%) FOR i% = 1 TO nrnotes% Mcoef!(i%) = Dismel!(Ml%(i% - 1), Ml%(i%)) NEXT i% ' bereken alle average line coefficienten: DIM Mavg!(nrnotes%) FOR i% = 0 TO nrnotes% Mavg!(i%) = ABS((sum% - Ml%(i%)) / 128): ' 0-1 NEXT i% ' bereken de fuzzy sum: weightdismel% = 3: ' empirische wegingsfaktoren weightline% = 1 ' normalisation faktor: dividefaktor% = (weightdismel% * nrnotes%) + (weightline% * (nrnotes% + 1)) FOR i% = 1 TO nrnotes% sm0! = sm0! + Mcoef!(i%) NEXT i% sm0! = sm0! / weightdismel% FOR i% = 0 TO nrnotes% sm1! = sm1! + Mavg!(i%) NEXT i% sm1! = sm1! / weightline% fl! = 1 - ((sm0! + sm1!) / dividefaktor%) profilexponent% = nrnotes%: ' kontoerscherpte van de definitiekurve FUNCTION = fl! ^ profilexponent% END FUNCTION FUNCTION MelQualWeight (Ml%())EXPORT AS SINGLE LOCAL nrnotes%, sum%, i%, weightdismel%, weightline%, dividefaktor%, profilexponent% LOCAL Mcoef!(), Mavg!() LOCAL sm0!, sm1!, fl! ' returns a fuzzy value for the global 'quality' of a melody ' here defined as a horizontal succession of notes passed in Ml% ' The result is weighted over history. The integration frame depends ' on the lenght of Ml%. ' An improved version would also take into account objective ' timing information in the weighting procedure. ' A timeframe no longer than 3 seconds is appropriate. nrnotes% = UBOUND(Ml%) ' bereken de gemiddelde toonhoogte voor de melodie: FOR i% = 0 TO nrnotes% sum% = sum% + Ml%(i%) NEXT i% sum% = sum% / (nrnotes% + 1): ' range= 0-127 ' bereken nu alle Dismel coefficienten: DIM Mcoef!(1 TO nrnotes%) FOR i% = 1 TO nrnotes% Mcoef!(i%) = Dismel(Ml%(i% - 1), Ml%(i%)) NEXT i% ' bereken alle average line coefficienten: DIM Mavg!(nrnotes%) FOR i% = 0 TO nrnotes% Mavg!(i%) = ABS((sum% - Ml%(i%)) / 128): ' 0-1 NEXT i% ' bereken nu de fuzzy sum: weightdismel% = 3: ' empirische wegingsfaktoren weightline% = 1 ' normalisation faktor: dividefaktor% = (weightdismel% * nrnotes%) + (weightline% * (nrnotes% + 1)) FOR i% = nrnotes% TO 1 STEP -1 ' sum up with linear weighting of individual components. sm0! = sm0! + (Mcoef!(i%) * ((i% * 1!) / (1! * nrnotes%))) NEXT i% ' normalize again: sm0! = sm0! / (nrnotes% / 2!) sm0! = sm0! / weightdismel% FOR i% = 0 TO nrnotes% ' sum up with linear weighting: sm1! = sm1! + (Mavg!(i%) * ((i% * 1!) / (1! * nrnotes%))) NEXT i% ' renormalize: sm1! = sm1! / (nrnotes% / 2!) sm1! = sm1! / weightline% ' fuzzy product: fl! = 1 - (sm0! * sm1!) profilexponent% = nrnotes% * 4: ' kontoerscherpte van de definitiekurve ' must be empirically determined. FUNCTION = fl! ^ profilexponent% END FUNCTION SUB ShowMelFuz (BYVAL noot%) EXPORT LOCAL m AS ASCIIZ * 1896 LOCAL szTitelBox AS ASCIIZ * 70 LOCAL i AS BYTE,nn AS BYTE szTitelBox = " Data set in use for fuzzy melodic dissonance. Reference note:" + STR$(noot%) + " :" m = "Fuzzy data for note succession:" + CHR$(13) FOR nn = 0 TO 11 ' notes FOR i = 0 TO 10 ' octaves IF nn + (i*12) < 128 THEN m = m + FORMAT$(Dismel!(nn + (i*12),noot%),"#.###") END IF m = m + SPACE$(4) NEXT i m = m + CHR$(13) NEXT nn MessageBox 0,m, szTitelbox,%MB_OK OR %MB_ICONASTERISK OR %MB_TOPMOST END SUB FUNCTION Har2MelAr (H AS Harmtype, BYREF m() AS WORD) EXPORT AS LONG ' added 02.11.2004 ' m() is a fixed length array m(0-127) of packed note/velo's ' the function returns the number of notes. LOCAL n AS DWORD LOCAL i AS DWORD FUNCTION = %False IF UBOUND(m) < 127 THEN MSGBOX "Array size error",, FUNCNAME$ : EXIT FUNCTION FOR i = 1 TO 128 IF ASC(MID$(H.vel,i,1)) THEN INCR n m(n-1) = ASC(MID$(H.vel,i,1)) ' set the velo byte (low byte) m(n-1) = m(n-1) OR ((i-1)* 256) ' set the note in the high byte NEXT i FUNCTION = n END FUNCTION '*********************************** ' Procedures and Functions: Harm_Ana '*********************************** FUNCTION IsChordClassic (BYVAL k&) EXPORT AS INTEGER FUNCTION = %False SELECT CASE k& CASE &H730, &H740, &H630, &H840 FUNCTION = %NotFalse CASE &H0B740, &H0A730, &H0A740, &H0A630 FUNCTION = %NotFalse CASE &H0B840, &H0B730, &H09630 FUNCTION = %NotFalse END SELECT END FUNCTION FUNCTION QuestTcCnr (BYVAL cnr AS INTEGER) EXPORT AS INTEGER ' 04.12.1999 - This function attempts to find the tonality of a chord passed as a chordnumber. LOCAL tc AS INTEGER LOCAL ctp AS LONG LOCAL initc AS INTEGER IF GetNrNotes(cnr) > 7 THEN FUNCTION = -1 : EXIT FUNCTION initc = cnr SHIFT RIGHT initc, 12 ' tonality byte, it set IF initc > 11 THEN initc = 0 tc = initc '%False DO ctp = Cnr2Ctp (cnr, tc) IF IsChordClassic (ctp) THEN FUNCTION = tc EXIT FUNCTION END IF tc = (tc + 7) MOD 12 ' search following the circle of fifths... LOOP UNTIL tc = initc FUNCTION = -1 ' we return -1 if no tonal center could be found this way. END FUNCTION FUNCTION Name3Chord$ (BYVAL crd%) EXPORT LOCAL ton% LOCAL Grond$, ak$ LOCAL Ctp& ton% = GetTc(crd%) Grond$ = Tonality$(ton%, ton%) Ctp& = Cnr2Ctp(crd%, ton%) SELECT CASE Ctp& CASE 0 TO 15 : ak$ = lTrimZero(HEX$(Ctp&,1)) CASE 16 TO 255: ak$ = LtrimZero(HEX$(Ctp&,2)) CASE &HB72: ak$ = "V " CASE &H950: ak$ = "IV " CASE &H952: ak$ = "II " CASE &HB52: ak$ = "VII " CASE &HB74: ak$ = "IIImaj" CASE &HB73: ak$ = "IIImin" CASE &H940: ak$ = "VImaj " CASE &H930: ak$ = "VImin " CASE &HB52: ak$ = "VII " CASE &H730: ak$ = "I Min": CASE &H740: ak$ = "I Maj": CASE &H630&: ak$ = "I Dim" CASE &H840&: ak$ = "I Aug" CASE &H720: ak$ = "5th+5th" ' vierklanken - septiemakkoorden CASE &HB740&: ak$ = "I Maj7th" CASE &HA730&: ak$ = "I Min7th" CASE &HA740&: ak$ = "I Dom7th" CASE &HA630&: ak$ = "I Half dim7th" CASE &HB840&: ak$ = "I Aug7th" CASE &HB730&: ak$ = "I Min7th+" CASE &H9630&: ak$ = "I Dim7th" CASE &H97520: ak$ = "I- Penta Scale" CASE &HA7530: ak$ = "II- Penta Scale" CASE &H97420: ak$ = "III- Penta Scale" CASE &HA7520: ak$ = "IV- Penta Scale" CASE &HA8530: ak$ = "V- Penta Scale" CASE &HB875320: ak$ = "Minor Scale" CASE ELSE: ak$ = LtrimZero(HEX$(Ctp&)) END SELECT FUNCTION = Grond$ + ak$ END FUNCTION FUNCTION NameChord$ (BYVAL crd%) EXPORT LOCAL ton% LOCAL Grond$ LOCAL Ctp& ton% = GetTc(crd%) Grond$ = Tonality$(ton%, ton%) Ctp& = Cnr2Ctp(crd%, ton%) FUNCTION = Grond$ & LtrimZero(HEX$(Ctp&)) END FUNCTION FUNCTION Tonality$ (BYVAL noot%, BYVAL ton%) EXPORT ' noot% is de gevraagde nootnaam en ton% is de toonaard LOCAL lnt% LOCAL ta% lnt% = noot% MOD 12 ta% = ton% MOD 12 IF lnt% = 0 THEN Tonality$ = "Do _" IF lnt% = 1 THEN Tonality$ = "Do#_" IF lnt% = 2 THEN Tonality$ = "Re _" IF lnt% = 3 THEN Tonality$ = "Mib_" IF lnt% = 4 THEN Tonality$ = "Mi _" IF lnt% = 5 THEN Tonality$ = "Fa _" IF lnt% = 6 THEN Tonality$ = "Fa#_" IF lnt% = 7 THEN Tonality$ = "Sol_" IF lnt% = 8 THEN Tonality$ = "Lab_" IF lnt% = 9 THEN Tonality$ = "La _" IF lnt% = 10 THEN Tonality$ = "Sib_" IF lnt% = 11 THEN Tonality$ = "Si _" SELECT CASE ta% CASE 2 IF lnt% = 8 THEN Tonality$ = "So#_" CASE 9 IF lnt% = 8 THEN Tonality$ = "So#_" IF lnt% = 3 THEN Tonality$ = "Re#_" CASE 4 IF lnt% = 8 THEN Tonality$ = "So#_" IF lnt% = 3 THEN Tonality$ = "Re#_" IF lnt% = 10 THEN Tonality$ = "La#_" CASE 11 IF lnt% = 7 THEN Tonality$ = "Fa*_" IF lnt% = 2 THEN Tonality$ = "Do*_" IF lnt% = 8 THEN Tonality$ = "So#_" IF lnt% = 3 THEN Tonality$ = "Re#_" IF lnt% = 10 THEN Tonality$ = "La#_" CASE 6 IF lnt% = 7 THEN Tonality$ = "Fa*_" IF lnt% = 2 THEN Tonality$ = "Do*_" IF lnt% = 8 THEN Tonality$ = "So#_" IF lnt% = 3 THEN Tonality$ = "Re#_" IF lnt% = 10 THEN Tonality$ = "La#_" IF lnt% = 5 THEN Tonality$ = "Mi#_" IF lnt% = 0 THEN Tonality$ = "Si#_" CASE 10 IF lnt% = 1 THEN Tonality$ = "Reb_" CASE 3 IF lnt% = 1 THEN Tonality$ = "Reb_" IF lnt% = 6 THEN Tonality$ = "Sob_" CASE 8 IF lnt% = 1 THEN Tonality$ = "Reb_" IF lnt% = 6 THEN Tonality$ = "Sob_" IF lnt% = 11 THEN Tonality$ = "Dob_" CASE 1 IF lnt% = 1 THEN Tonality$ = "Reb_" IF lnt% = 6 THEN Tonality$ = "Sob_" IF lnt% = 11 THEN Tonality$ = "Dob_" IF lnt% = 4 THEN Tonality$ = "Fab_" END SELECT END FUNCTION ' end of section harm_ana. '************************************************** ' Procedures and Functions: Fuzzy Harmony Module * '************************************************** FUNCTION HarForce (BYVAL i%, BYVAL j%) EXPORT AS SINGLE ' retourneert de harmonische kracht (0-1) voor een vertikaal harmonisch interval volgens ' de reeks opgesteld door Paul Hindemith ' Harmonic Force LOCAL hf AS SINGLE LOCAL Oktaven AS INTEGER SELECT CASE ABS(i% - j%) MOD 12 CASE 0 hf = 0 CASE 1,11 hf = 0.2 CASE 2,10 hf = 0.4 CASE 3,9 hf = 0.7 '0.6 CASE 4,8 hf = 1 CASE 7,5 hf = 0.8 '0.7 CASE 6 hf = 0.1 END SELECT ' verminder de waarden proportioneel voor elk oktaaf tussen de noten: Oktaven = MIN(ABS(i% - j%) \ 12, 10) FUNCTION = hf * ((10 - Oktaven) / 10) END FUNCTION FUNCTION MelForce (BYVAL i%, BYVAL j%, BYVAL ltes%, BYVAL htes%) EXPORT AS SINGLE ' retourneert de melodische kracht (0-1) voor een melodisch interval volgens ' de reeks opgesteld door Paul Hindemith ' Melodic Force LOCAL hf AS SINGLE LOCAL Oktaven AS INTEGER IF ltes% > htes% THEN SWAP ltes%, htes% IF i% < ltes% OR j% < ltes% THEN FUNCTION = %False EXIT FUNCTION END IF IF i% > htes% OR j% > htes% THEN FUNCTION = %False EXIT FUNCTION END IF SELECT CASE ABS(i% - j%) MOD 12 CASE 0 hf = 0 CASE 1,11 hf = 0.8 CASE 2,10 hf = 1 CASE 3,9 hf = 0.7 CASE 4,8 hf = 0.6 CASE 7,5 hf = 0.2 CASE 6 hf = 0 END SELECT ' halveer de waarden voor elk oktaaf tussen de noten: Oktaven = MIN(ABS(i% - j%) \ 12, 10) IF oktaven = %False THEN FUNCTION = hf EXIT FUNCTION ELSE i% = %False DO hf = hf / 2! INCR i% LOOP UNTIL i% = oktaven FUNCTION = hf END IF END FUNCTION FUNCTION SecSolveQual (BYVAL crd1%, BYVAL crd2%) EXPORT AS SINGLE LOCAL nrminsec%, nrmajsec%, ij%, n1%,n2%,n3%, ns11%,ns21%,dmin% LOCAL nrsec%, dmaj%, ns2%, ns1% ' nrminsec% = 0 ' nrmajsec% = 0 ' dmin% = 0 ' dmaj% = 0 ' first we handle minor seconds: FOR ij% = 0 TO 11 ' we did not have the mod 12 here before 21.04.2000 - must have been bug!!! n1% = %False n2% = %False n3% = %False BIT SET n1%,ij% 'n1% = 2 ^ ij% BIT SET n2%,(ij% + 1) MOD 12 ' n2% = (2 ^ (ij% + 1)): ' for minor seconds BIT SET n3%,(ij% + 2) MOD 12 'n3% = (2 ^ (ij% + 2)): ' for major seconds ' is er kleine sekonde ?: IF ((crd1% AND n1%) > 0) AND ((crd1% AND n2%) > 0) THEN ' ga na op ze opgelost zijn in Ch%(i%+1)... ' de oplossingsnoten moeten zijn (kleine terts): ' in eerste orde: 'ns1% = 2 ^ ((ij% + 2) MOD 12) 'ns2% = 2 ^ ((ij% + 11) MOD 12) ns1% = %False ns2% = %False BIT SET ns1%,(ij%+2)MOD 12 BIT SET ns2%,(ij%+11) MOD 12 ' in tweede orde: ( een van beide...) 'ns11% = 2 ^ ((ij% + 3) MOD 12) 'ns21% = 2 ^ ((ij% + 10) MOD 12) ns11% = %False ns21% = %False BIT SET ns11%,(ij% + 3) MOD 12 BIT SET ns21%,(ij% + 10) MOD 12 ' eerste konditie: de secunde mag zelf niet aanwezig zijn in het ' volgende akkoord: IF ISFALSE(crd2% AND n1%) AND ISFALSE(crd2% AND n2%) THEN ' hiervoor geven we alvast drie goede punten: dmin% = dmin% + 3 IF ((crd2% AND ns1%) > 0) AND ((crd2% AND ns2%) > 0) THEN dmin% = dmin% + 7: ' oplossing door verbreding: maximum der punten ELSEIF ((crd2% AND ns1%) > 0) THEN dmin% = dmin% + 2: ' oplossing door partiele verbreding ELSEIF (crd2% AND ns2%) > 0 THEN dmin% = dmin% + 2: ' id. 2e mogelijkheid ELSEIF ((crd2% AND ns11%) > 0) XOR ((crd2% AND ns21%) > 0) THEN dmin% = dmin% + 3: ' oplossing met 1 blijvende noot. END IF ELSEIF ((crd2% AND n1%) = 0) THEN dmin% = dmin% + 1 ' slechts 1 van beide tonen is afwezig... ' als de afwezige diatonisch is opgelost, geven we een bonus IF (crd2% AND ns11%) THEN dmin% = dmin% + 4 ELSEIF (crd2% AND ns1%) THEN dmin% = dmin% + 1 END IF ELSEIF ((crd2% AND n2%) = 0) THEN dmin% = dmin% + 1 ' slechts 1 van beide tonen, de andere nu, is afwezig... ' als de afwezige is opgelost, geven we een klein bonus IF (crd2% AND ns21%) THEN dmin% = dmin% + 2 ELSEIF (crd2% AND ns2%) THEN dmin% = dmin% + 1 END IF ELSE ' in dit geval blijft de gehele secunde liggen... dmin% = dmin% - 2: ' we geven daarvoor een slecht punt IF dmin% < 0 THEN dmin% = 0 END IF INCR nrminsec% ELSE ' no n1%- n2% minor second present in chord passed END IF ' now handle the major seconds: ' is er grote sekonde ?: IF ((crd1% AND n1%) > 0) AND ((crd1% AND n3%) > 0) THEN ' ga na op ze opgelost zijn in Ch%(i%+1)... ' de oplossingsnoten moeten zijn (grote terts): ' in eerste orde: ' ns1% = 2 ^ ((ij% + 3) MOD 12) ' ns2% = 2 ^ ((ij% + 11) MOD 12) ns1% = %False ns2% = %False BIT SET ns1%,(ij% + 3) MOD 12 BIT SET ns2%,(ij% + 11) MOD 12 ' eerste konditie: de secunde mag zelf niet aanwezig zijn in het ' volgende akkoord: IF ((crd2% AND n1%) = 0) AND ((crd2% AND n3%) = 0) THEN ' hiervoor geven we alvast drie goede punten: dmaj% = dmaj% + 3 IF ((crd2% AND ns1%) > 0) AND ((crd2% AND ns2%) > 0) THEN dmaj% = dmaj% + 7: ' oplossing door verbreding: maximum der punten ELSEIF ((crd2% AND ns1%) > 0) THEN dmaj% = dmaj% + 2: ' oplossing door partiele verbreding ELSEIF (crd2% AND ns2%) > 0 THEN dmaj% = dmaj% + 2: ' id. 2e mogelijkheid END IF ELSEIF ((crd2% AND n1%) = 0) THEN INCR dmaj% ' slechts 1 van beide tonen is afwezig... ' als de afwezige diatonisch is opgelost, geven we een bonus IF (crd2% AND ns1%) THEN dmaj% = dmaj% + 4 END IF ELSEIF ((crd2% AND n2%) = 0) THEN INCR dmaj% ' slechts 1 van beide tonen, de andere nu, is afwezig... ' als de afwezige is opgelost, geven we een klein bonus IF (crd2% AND ns2%) THEN dmaj% = dmaj% + 4 END IF ELSE ' in dit geval blijft de gehele secunde liggen... DECR dmaj% ' we geven daarvoor een slecht punt IF dmaj% < 0 THEN dmaj% = %False END IF INCR nrmajsec% ELSE ' no n1%- n2% minor second present in chord passed END IF NEXT ij% nrsec% = nrminsec% + nrmajsec% IF nrminsec% = 0 THEN dmin% = 10 IF nrmajsec% = 0 THEN dmaj% = 10 ' berekening van de kwaliteit van de akkoordsekwens m.b.t. secundenbehandeling: SELECT CASE nrsec% CASE 0 FUNCTION = 1 CASE 1 FUNCTION = (dmin% / 10!) * (dmaj% / 10) CASE ELSE IF ISFALSE nrminsec% THEN FUNCTION = (dmaj% / (nrmajsec% * 10!)): ' te checken... ELSEIF ISFALSE nrmajsec% THEN FUNCTION = (dmin% / (nrminsec% * 10!)) ELSE FUNCTION = (dmin% / (nrminsec% * 10!)) * (dmaj% / (nrmajsec% * 10!)) END IF END SELECT END FUNCTION FUNCTION TritSolveQual (BYVAL crd1%, BYVAL crd2%)EXPORT AS SINGLE ' this function returns a normalized value for the quality ' of the solution for eventual tritons present in crd1% into crd2% ' if no tritons in chord crd1% the function returns 1. ' For perfect solutions the result will be 1 also. ' to be further tested!!! (is already reasonable, but can be improved) LOCAL nrtrit%, ij%, n1%, n2%, ns10%, ns11%, ns12%, ns13%,ns20%, ns21% LOCAL ns22%, ns23%, d% nrtrit% = 0 FOR ij% = 0 TO 5 n1% = %False n2% = %False BIT SET n1%,ij% BIT SET n2%,ij% + 6 'n1% = 2 ^ ij% 'n2% = (2 ^ (ij% + 6)) ' is er een tritonus ?: IF ((crd1% AND n1%) > 0) AND ((crd1% AND n2%) > 0) THEN ' ga na op ze opgelost zijn in Ch%(i%+1)... ' de oplossingsnoten moeten zijn: ' voor n1% 'ns10% = 2 ^ ((ij% + 1) MOD 12) 'ns11% = 2 ^ ((ij% + 11) MOD 12) ns10% = %False ns11% = %False BIT SET ns10%,(ij%+1) MOD 12 BIT SET ns11%,(ij%+11) MOD 12 ' voor n2% 'ns20% = 2 ^ ((ij% + 5) MOD 12) 'ns21% = 2 ^ ((ij% + 7) MOD 12) ns20% = %False ns21% = %False BIT SET ns20%,(ij% + 5) MOD 12 BIT SET ns21%,(ij% + 7) MOD 12 ' onechte diatonische oplossingen voor n1%: ns12% = %False ns13% = %False BIT SET ns12%,(ij% + 2) MOD 12 BIT SET ns13%,(ij% + 10) MOD 12 'ns12% = 2 ^ ((ij% + 2) MOD 12) 'ns13% = 2 ^ ((ij% + 10) MOD 12) ' onechte diatonische oplossingen voor n2%: 'ns22% = 2 ^ ((ij% + 3) MOD 12) 'ns23% = 2 ^ ((ij% + 11) MOD 12) ns22% = %False ns23% = %False BIT SET ns22%,(ij% + 3) MOD 12 BIT SET ns23%,(ij% + 11) MOD 12 ' eerste konditie: de tritonus mag zelf niet aanwezig zijn in het ' volgende akkoord: IF ((crd2% AND n1%) = 0) AND ((crd2% AND n2%) = 0) THEN ' hiervoor geven we alvast drie goede punten: d% = d% + 3 IF ((crd2% AND ns11%) > 0) AND ((crd2% AND ns21%) > 0) THEN d% = d% + 7: ' oplossing door verbreding: maximum der punten ELSEIF ((crd2% AND ns10%) > 0) AND ((crd2% AND ns20%) > 0) THEN d% = d% + 6: ' oplossing door versmalling ELSEIF (crd2% AND ns11%) > 0 THEN d% = d% + 3: ' partiele oplossing ELSEIF (crd2% AND ns10%) > 0 THEN d% = d% + 3 ELSEIF (crd2% AND ns20%) > 0 THEN d% = d% + 3 ELSEIF (crd2% AND ns21%) > 0 THEN d% = d% + 3 ELSEIF (crd2% AND ns12%) > 0 THEN d% = d% + 2 ELSEIF (crd2% AND ns13%) > 0 THEN d% = d% + 2 ELSEIF (crd2% AND ns22%) > 0 THEN d% = d% + 2 ELSEIF (crd2% AND ns23%) > 0 THEN d% = d% + 2 END IF ELSEIF ((crd2% AND n1%) = 0) THEN INCR d% ' slechts 1 van beide tonen is afwezig... ' als de afwezige is opgelost, geven we een klein bonus IF (crd2% AND ns11%) THEN d% = d% + 2 IF (crd2% AND ns10%) THEN d% = d% + 2 ' voor een diatonische oplossing, wat minder... IF (crd2% AND ns12%) THEN INCR d% IF (crd2% AND ns13%) THEN INCR d% ELSEIF ((crd2% AND n2%) = 0) THEN d% = d% + 1 ' slechts 1 van beide tonen, de andere nu, is afwezig... ' als de afwezige is opgelost, geven we een klein bonus IF (crd2% AND ns20%) THEN d% = d% + 2 IF (crd2% AND ns21%) THEN d% = d% + 2 ' diatonisch is minder waard: IF (crd2% AND ns22%) THEN INCR d% IF (crd2% AND ns23%) THEN INCR d% ELSE ' in dit geval blijft de gehele tritonus liggen... DECR d% ' we geven daarvoor een slecht punt IF d% < 0 THEN d% = 0 END IF INCR nrtrit% ELSE ' no n1%- n2% triton present in chord passed END IF NEXT ij% ' berekening van de kwaliteit van de akkoordsekwens m.b.t. tritonusbehandeling: SELECT CASE nrtrit% CASE 0 FUNCTION = 1 CASE 1 FUNCTION = d% / 10!: ' perfekte oplossing als d%=10 CASE 2 FUNCTION = d% / 20!: ' dim 7th oplossing in ideaal geval CASE ELSE FUNCTION = d% / (nrtrit% * 10!): ' te checken... END SELECT END FUNCTION '*********************************** ' HARM_PSY module: * '*********************************** FUNCTION GetShepVal (BYVAL n AS BYTE) EXPORT AS SINGLE ' could be moved to g_indep. STATIC ShepVal() AS SINGLE STATIC Toggle% LOCAL i AS LONG LOCAL Ang! IF ISFALSE Toggle% THEN DIM ShepVal(127) AS STATIC SINGLE FOR i = 0 TO 127 Ang! = Pi2 * (i / 128!) ShepVal(i) = (1 - COS(Ang!)) / 2 NEXT i Toggle% = %NotFalse END IF FUNCTION = ShepVal(n) END FUNCTION FUNCTION SumVelo (BYVAL v1 AS BYTE, BYVAL v2 AS BYTE) EXPORT AS BYTE ' this function should only be used for addition of midi scaled volumes for the same pitch!!!! LOCAL SumV AS BYTE IF v2 > v1 THEN SWAP v1, v2 IF ISFALSE v1 THEN FUNCTION = %False ELSE sumV = ((v2 * dynconst) / v1) + v1 IF sumV > 127 THEN sumV = 127 FUNCTION = sumV END IF END FUNCTION FUNCTION Har2Mel (BYVAL nInst AS BYTE, h AS harmtype,BYVAL ltes AS BYTE, BYVAL htes AS BYTE) EXPORT AS WORD ' returns a packed word wherein hibyt = note and lobyte = velo ' if the returned value is negative (highest bit set in the word) , the function could not return a note. STATIC Idx() AS BYTE STATIC init AS BYTE LOCAL noot AS WORD LOCAL velo AS BYTE IF ISFALSE init THEN DIM Idx(nInst) AS STATIC BYTE init = %True END IF IF nInst > UBOUND(Idx) THEN REDIM PRESERVE Idx(0 TO nInst) AS STATIC BYTE noot = %False IF ltes < htes THEN ' upwards... IF Idx(nInst) < ltes THEN Idx(nInst) = ltes IF Idx(nInst) > htes THEN Idx(nInst) = ltes DO velo = ASC(MID$(h.vel,Idx(nInst) + 1, 1)) IF velo THEN ' was istrue bug noot = Idx(nInst) INCR Idx(nInst) EXIT LOOP END IF INCR Idx(nInst) LOOP UNTIL Idx(nInst) > htes ELSE ' downwards SWAP ltes,htes IF Idx(nInst) < ltes THEN Idx(nInst) = htes IF Idx(nInst) > htes THEN Idx(nInst) = htes DO velo = ASC(MID$(h.vel,Idx(nInst) + 1, 1)) IF velo THEN noot = Idx(nInst) DECR Idx(nInst) EXIT LOOP END IF DECR Idx(nInst) LOOP UNTIL Idx(nInst) < ltes END IF IF noot THEN SHIFT LEFT noot,8 FUNCTION = noot OR velo ELSE FUNCTION = &H0FFFF END IF END FUNCTION '************************************** ' Procedures and Functions:HARM_AKU.BAS '************************************** FUNCTION DifTone (BYVAL n1%, BYVAL n2%) EXPORT AS SINGLE FUNCTION = ABS(N2F(n1%) - N2F(n2%)) END FUNCTION FUNCTION SumTone (BYVAL n1%, BYVAL n2%) EXPORT AS SINGLE FUNCTION = N2F(n1%) + N2F(n2%) ' may be above audio! (max = 25087.7 Hz, for n1=n2 = 127) END FUNCTION FUNCTION DifNoteF (BYVAL n1%, BYVAL n2%) EXPORT AS SINGLE FUNCTION = F2NF (ABS(N2F(n1%) - N2F(n2%))) END FUNCTION FUNCTION SumNoteF (BYVAL n1%, BYVAL n2%) EXPORT AS SINGLE ' fractional midi LOCAL f AS SINGLE f = N2F(n1%) + N2F(n2%) IF f > N2F(127) THEN DO f = f /2 LOOP UNTIL f < N2F(127) END IF FUNCTION = F2NF(f) END FUNCTION FUNCTION F2N (BYVAL f!) EXPORT AS INTEGER IF f! < 8 THEN FUNCTION = %False: EXIT FUNCTION FUNCTION = INT(12 * (LOG(f!) - LOG(Domq)) / (LOG(2))) END FUNCTION FUNCTION F2NF (BYVAL f!) EXPORT AS SINGLE IF f! < 8 THEN FUNCTION = 0: EXIT FUNCTION FUNCTION = (12! * (LOG(f!) - LOG(GrondDo)) / (LOG(2))) END FUNCTION SUB GetSpecData (f AS STRING, Spec() AS SINGLE) EXPORT LOCAL af AS LONG ', Spec!(), i%, NrHarmonics%, regel$, j% LOCAL i AS WORD LOCAL NrHarmonics AS WORD LOCAL regel$ LOCAL j AS WORD IF ISFALSE ExistFile (f) THEN MSGBOX "No data file found with harmonics lookup...",, FUNCNAME$ EXIT SUB END IF af = FREEFILE OPEN f FOR INPUT AS #af DO WHILE ISTRUE(NOT (EOF(af))) LINE INPUT #af, regel$ IF LEFT$(UCASE$(LTRIM$(regel$)), 11) = UCASE$("[Harmonics]") THEN INPUT #af, NrHarmonics REDIM Spec(1, NrHarmonics) AS SINGLE DO INPUT #af, i, j, Spec(i, j) LOOP UNTIL i = NrHarmonics EXIT DO END IF LOOP CLOSE #af END SUB SUB GetSpecDefault (Spec() AS SINGLE, BYVAL NrHarmonics%) EXPORT LOCAL i AS WORD REDIM Spec(1, NrHarmonics%) AS GLOBAL SINGLE i = %False DO Spec(0, i) = i + 1 Spec(1, i) = 1! / (i + 1) INCR i LOOP UNTIL i = NrHarmonics% END SUB SUB Har2LinSpec (h AS HarmType, Sp!()) EXPORT ' deze proc. bestaat ook voor QHar's in g_har.dll LOCAL nrp%, i% , einde%, n%, mv% LOCAL oldf!, f! nrp% = UBOUND(Sp!) + 1 IF nrp% <= 1 THEN FOR i% = 128 TO 1 STEP -1 IF ASC(MID$(h.vel, i%, 1)) > 0 THEN nrp% = N2F(i%): EXIT FOR NEXT i% ' make sure we have a minimum size of 256 points IF nrp% < %d8 THEN nrp% = %d8 ' make sure our size is a always power of 2... FOR i% = 8 TO 14 IF nrp% < EXP2(i%) THEN nrp% = EXP2(i%): EXIT FOR NEXT i% IF nrp% > %d14 THEN nrp% = %d14 END IF REDIM Sp!(nrp% - 1): ' dimension array for linear spectrum ' now we do the conversion normalising midi values oldf! = -1 f! = nrp% IF F2N%(f!) <= 127 THEN einde% = F2N%(f!) ELSE einde% = 127 FOR n% = 0 TO einde%: 'F2N%(f!) f! = N2F(n%) IF f! > nrp% - 1 THEN EXIT FOR IF f! = oldf! THEN mv% = SumVelo(NormVol2Midi(Sp!(f!)), ASC(MID$(h.vel, n% + 1, 1))) Sp!(f!) = Midi2NormVol(mv%) IF Sp!(f!) > 1 THEN Sp!(f!) = 1: ' kan eigenlijk niet voorkomen... ELSE Sp!(f!) = Midi2NormVol(ASC(MID$(h.vel, n% + 1, 1))) oldf! = f! END IF NEXT n% END SUB SUB Har2Samp (h AS HarmType, Samp!()) EXPORT LOCAL siz% LOCAL Spectrum!() siz% = UBOUND(Samp!) + 1 IF siz% <= 2 THEN REDIM Spectrum!(0) ' autoregulation is active ELSE REDIM Spectrum!(siz% - 1) END IF Har2LinSpec h, Spectrum!() siz% = UBOUND(Spectrum!) + 1 REDIM PRESERVE Spectrum!((siz% * 2) - 1) REDIM Samp!(UBOUND(Spectrum!)) InvDFT Spectrum!(), Samp!() ' samp is normalized on return ERASE Spectrum! END SUB SUB Har2Shape (h AS HarmType, Shape!())EXPORT LOCAL fk%, siz%, band%, beginrange%, endrange%, pw!, j% LOCAL Sp!(), Nsp!() ' convert H.vel to a waveshape of an equal amount of points ' step 1: convert note-string to linear spectrum: REDIM Sp!(0) Har2LinSpec h, Sp!() ' step 2: rescale this spectrum to 64 linear bands REDIM Nsp!(127) siz% = UBOUND(Sp!) + 1 fk% = siz% / 64 FOR band% = 0 TO 63 beginrange% = band% * fk% endrange% = ((band% + 1) * fk%) - 1 pw! = 0 FOR j% = beginrange% TO endrange% pw! = pw! + Sp!(j%) NEXT j% pw! = pw! / fk%: ' gemiddelde Nsp!(band%) = pw! NEXT band% ERASE Sp! ' step3: REDIM Shape!(%d7 - 1) InvDFT Nsp!(), Shape!() END SUB SUB LinSpec2Har (Sp!(), h AS HarmType, BYVAL unitbandwidth AS SINGLE) EXPORT ' on calling this procedure, Sp!() may have the same number of points as the ' sample data array to the fourier transform. ' Hence only the first half of Sp() may contain relevant data. ' If unitbandwith = 1 then the indexes of the spectrum file increment in 1Hz steps. ' The Sp() array on entry is supposed to be normalized (0-1 interval) ' NOTE: higher notes always get weaker velo values. ' the scaling seems to be waveform dependent and not linear nor logarithmic... STATIC Botfrq AS SINGLE STATIC Tog AS BYTE LOCAL noot AS LONG LOCAL oldn AS LONG LOCAL s AS LONG LOCAL f!, scv! LOCAL i AS DWORD IF ISFALSE tog THEN Botfrq = N2F%(0) / (2 ^ (1/24) ) ' frequency for midi note 0 DIM NoteFreq(127) AS STATIC SINGLE 'NoteFreq(i) = ubound of freq. range for note i FOR i = 0 TO 127 NoteFreq(i)= N2F%(i) / (2 ^ (1/24) ) '/ was * NEXT Tog = %True END IF h.vel = STRING$(128, 0) i = 1 DO f! = i * unitbandwidth IF f! >= Botfrq THEN FOR noot = MAX(oldn, 1) TO 127 'we can start at oldn here as f! will always increase IF (f! > NoteFreq(noot - 1)) AND (f! <= NoteFreq(noot)) THEN EXIT FOR NEXT IF noot > 127 THEN EXIT LOOP ' following returns a normalized scaling: (0-1) IF noot = oldn THEN scv! = scv! + (Sp!(i) / SQR(i)) ELSE scv! = Sp!(i) / SQR(i) oldn = noot END IF ' s = INT(scv! * 127) ' depends on scaling. To be parameterized. ' the best sollution is: s = MIN( INT(NormVol2Midi (scv!) ), 127 ) 'dB scaling MID$(h.vel, noot, 1) = CHR$(s) ' need midi-range END IF INCR i LOOP UNTIL i > UBOUND(Sp!) END SUB ' added 13.11.2001: FUNCTION SpectralNote (BYVAL basenote AS INTEGER, BYVAL number AS LONG, BYVAL factor AS SINGLE, BYVAL flags AS LONG) EXPORT AS INTEGER ' documented in Harmlib_aku.html 13.11.2001 ' acoustical modelling with param %StringSpec added - modified 24.03.2007! LOCAL tmp AS INTEGER LOCAL DomFak AS SINGLE LOCAL OktFak AS SINGLE ' patch for compatibility with code in Technofaustus (paradiso...): ' added 15.04.2007 gwr (removed again, changed in the paradiso code) ' now for debugging: IF factor >63 THEN MSGBOX "Wrong params passed in g_mus",, FUNCNAME$ ' select case factor ' case %MajSpec ' flags = %MajSpec ' case %Domspec ' 64 ' flags = %Domspec ' case %SubDomSpec ' 128 ' flags = %Subdomspec ' case %ParMinSpec ' flags = %ParMinSpec ' case %MinSpec ' flags = %MinSpec ' case %SqrSpec ' flags = %SqrSpec ' end select IF number <= 1 THEN number = 1 FUNCTION = %False SELECT CASE flags CASE %False, <%False FUNCTION = basenote EXIT FUNCTION CASE %True ,%MajSpec ' retourneert de gewone boventoonreeks op de gegeven grondnoot, afgerond naar ' getemperde kromatische halve tonen. tmp = N2F(basenote) * number ' boventoon CASE %DomSpec ' 64 ' retourneert een boventoonspektrum dat kan gebruikt worden als leidspektrum om naar ' de dominant te moduleren. DomFak = 1 - (0.01 * Number) OktFak = 1 - (0.005 * Number) SELECT CASE number CASE 1,2,4,8,16,32 ' we verlagen de even boventonen - de oktaven- halfzoveel als de andere tmp = N2F(basenote) tmp = tmp *number * OktFak CASE ELSE ' we verlagen alle oneven boventonen progressief tmp = N2F(basenote) tmp = tmp * number * DomFak END SELECT CASE %SubDomSpec ' 128 OktFak = 1 + (number * 0.005) ' we vergroten de oktaven wat... SELECT CASE number CASE 1,2,4,8,16,32 tmp = N2F(basenote) tmp = tmp * Number * Oktfak CASE ELSE ' no changes in spectrum needed. tmp = N2F(basenote) * number ' boventoon END SELECT CASE %ParMinSpec ' van majeur naar parallel mineur toonaard ' te testen, nu gelijk aan %MinSpec DomFak = 1 + (0.01 * Number) OktFak = 1 - (0.005 * Number) SELECT CASE number CASE 1,2,4,8,16,32 tmp = N2F(basenote) tmp = tmp * Number * Oktfak CASE ELSE ' no changes in spectrum needed. tmp = N2F(basenote) tmp = tmp* Number * DomFak END SELECT CASE %MinSpec ' van majeur naar mineur DomFak = 1 + (0.01 * Number) OktFak = 1 - (0.005 * Number) SELECT CASE number CASE 1,2,4,8,16,32 tmp = N2F(basenote) tmp = tmp * Number * Oktfak CASE ELSE ' no changes in spectrum needed. tmp = N2F(basenote) tmp = tmp * Number * DomFak END SELECT ' CASE %MajSpec ' van mineur naar majeur ' normal spectrum will do it CASE %SqrSpec ' yields compressed spectrum tmp = N2F(basenote) * SQR(number) ' boventoon CASE %Stringspec ' added 24/03.2007 ' acoustical modelling of real strings : cfr kursus 4040.html en 1086.html tmp = N2F(basenote) * SQR(1+ (factor * (number ^2))) ' realistic factors for real string are in the order of 3.33E-4 (piano note 36) ' if factor = 7 , we obtain the series for free bars and rods. CASE %ExpSpec ' was: ELSE ' user factor... tmp = N2F(basenote) * (number ^ factor) END SELECT tmp = F2N(tmp) IF tmp < 128 THEN FUNCTION = tmp END FUNCTION FUNCTION SpectralNoteF (BYVAL basenote AS SINGLE, BYVAL number AS LONG,BYVAL factor AS SINGLE, BYVAL flags AS LONG) EXPORT AS SINGLE ' documented in Harmlib_aku.html 13.11.2001 ' modified 13.08.2005, 23.03.2007 ' can be used in quartertone contexts without changes. LOCAL tmp AS SINGLE LOCAL DomFak AS SINGLE LOCAL OktFak AS SINGLE IF number <= 1 THEN number = 1 FUNCTION = %False SELECT CASE flags CASE %False, <%False FUNCTION = basenote EXIT FUNCTION CASE %True ,%MajSpec ' retourneert de gewone boventoonreeks op de gegeven grondnoot tmp = NF2F(basenote) * number ' boventoon CASE %DomSpec ' 64 ' retourneert een boventoonspektrum dat kan gebruikt worden als leidspektrum om naar ' de dominant te moduleren. ' was before 13.08.2005: 'DomFak = 1 - (0.01 * Number) ' wordt negatief voor number >= 100 !!! 'OktFak = 1 - (0.005 * Number) ' changed to: DomFak = 1 - (MIN(Number,100) / 200) ' 0.5 - 1 OktFak = 1 - (MIN(Number,100) / 400) ' 0.75 - 1 SELECT CASE number CASE 1 tmp = NF2F(basenote) CASE 2,4,8,16,32,64,128,256,512,1024 ' we verlagen de even boventonen - de oktaven- halfzoveel als de andere tmp = NF2F(basenote) tmp = tmp *number * OktFak CASE ELSE ' we verlagen alle oneven boventonen progressief tmp = NF2F(basenote) tmp = tmp * number * DomFak END SELECT CASE %SubDomSpec ' 128 ' was: 'OktFak = 1 + (number * 0.005) ' we vergroten de oktaven wat... OktFak = 1 + (Number/400) SELECT CASE number CASE 2,4,8,16,32, 64,128,256,512,1024 tmp = NF2F(basenote) tmp = tmp * Number * Oktfak CASE ELSE ' no changes in spectrum needed. tmp = NF2F(basenote) * number ' boventoon END SELECT CASE %ParMinSpec ' van majeur naar parallel mineur toonaard ' te testen, nu gelijk aan %MinSpec ' was: ' DomFak = 1 + (0.01 * Number) ' OktFak = 1 - (0.005 * Number) ' becomes negative for number >= 200 DomFak = 1 + (Number/ 200) OktFak = 1 - (MIN(Number,100) / 400) SELECT CASE number CASE 2,4,8,16,32,64,128 ',256 ',512,1024 tmp = NF2F(basenote) tmp = tmp * Number * Oktfak CASE ELSE ' no changes in spectrum needed. tmp = NF2F(basenote) tmp = tmp* Number * DomFak END SELECT CASE %MinSpec ' van majeur naar mineur ' was: ' DomFak = 1 + (0.01 * Number) ' OktFak = 1 - (0.005 * Number) DomFak = 1 + (Number /200) OktFak = 1 - (MIN(Number,100) / 400) SELECT CASE number CASE 2,4,8,16,32,64,128,256,512,1024 tmp = NF2F(basenote) tmp = tmp * Number * Oktfak CASE ELSE ' no changes in spectrum needed. tmp = NF2F(basenote) tmp = tmp * Number * DomFak END SELECT ' CASE %MajSpec ' van mineur naar majeur ' normal spectrum will do it CASE %SqrSpec ' yields compressed spectrum tmp = NF2F(basenote) * SQR(number) ' boventoon CASE %StringSpec ' acoustical modelling of real strings : cfr kursus 4040.html en 1086.html tmp = NF2F(basenote) * SQR(1+ (factor * (number ^2))) ' realistic factors for real string are in the order of 3.33E-4 (piano note 36) ' if factor = 7 , we obtain the series for free bars and rods. CASE %ExpSpec ' was:ELSE ' user factor... tmp = NF2F(basenote) * (number ^ factor) END SELECT tmp = F2NF(tmp) IF tmp < 128 THEN FUNCTION = tmp ' so function returns false if spectral note requested is too high for midi. END FUNCTION FUNCTION Midi2NormVol (BYVAL v%) EXPORT AS SINGLE IF v% > 0 THEN FUNCTION = (v% / 128!) ^ dBexponent ' normalisatie 0-1 ' van 0 - 90dB is 15 oktaven , 6dB per oktaaf ' 1dB is dan 2^(1/6)= 1.122462= konstante dBexponent ELSE FUNCTION = 0 END IF END FUNCTION FUNCTION N2F (BYVAL noot AS INTEGER) EXPORT AS INTEGER FUNCTION = ROUND(GrondDo * (2 ^ (noot / 12!)), 0) 'changed kl 20050907 - ROUND was INT END FUNCTION FUNCTION NF2F (BYVAL noot AS SINGLE) EXPORT AS SINGLE FUNCTION = GrondDo * (2 ^ (noot / 12!)) END FUNCTION FUNCTION NormVol2Midi (BYVAL v!) EXPORT AS INTEGER ' konstante InvdBexponent= .8908987#: ' voor 90dB range = 1/ (2^(1/6)) , in 6dB/Oct steps IF v! > 0 THEN ' db! = 20 * (LOG(v!) / LOG(10!)) ' NormVol2Midi% = (db! * 127!) / 90! :' geeft dB's FUNCTION = INT((v! ^ InvdBexponent) * 128!) ELSE FUNCTION = %False END IF END FUNCTION FUNCTION RitmSigma (Ritm AS RitmeType) EXPORT AS SINGLE ' Nul = end of pattern ' This function returns the sigma-sum of absolute values contained in Ritm.pattern LOCAL i AS LONG LOCAL tiks! 'i% = %False tiks! = 0! DO IF Ritm.pattern!(i)= %False THEN EXIT DO ' ?? = 0.0! tiks! = tiks! + ABS(Ritm.pattern!(i)) INCR i LOOP UNTIL i > %RitmArraySize FUNCTION = tiks! END FUNCTION SUB ShiftLeftOnZero (Ritm AS RitmeType, BYVAL minval!) EXPORT LOCAL i AS LONG LOCAL j AS LONG 'LOCAL i%, j% 'j% = 0 FOR i = 0 TO %RitmArraySize -1 IF ABS(Ritm.pattern(i)) < minval! THEN ' doorschuiven naar links... here we use the array functions in PB ' but it doesnt work because of PBCC bugs... 'ARRAY DELETE Ritm.pattern(i) ,0 ' replacing the old coding: FOR j = i TO %RitmArraySize Ritm.pattern(j) = Ritm.pattern(j + 1) NEXT j END IF NEXT i Ritm.pattern(%RitmArraySize) = 0! END SUB SUB PositRitm (ritm AS RitmeType, BYVAL nrtiks%) EXPORT LOCAL ii&,jj&, i%,j%, FirstValue%, LastValue% LOCAL sigma!, faktor! ' This function returns a series of positive duration values ' from a bipolar rit.pattern() array passed. ' step 1: Search the first positive value: FirstValue% = %NotFalse ' following code should be o.k. but does not work due to bugs in PBCC 1.0 ' ARRAY SCAN ritm.pattern(),>0!,TO ii& :' new PBcc statement - gives BUG !!! ' FirstValue% = ii& -1 :' returns relative pointer!, if ii& is 0, no match was found ' ===================== ' thus we use the old construction: DO IF ritm.pattern(i%) > 0 THEN FirstValue% = i%: EXIT DO INCR i% LOOP UNTIL i% > %RitmArraySize IF FirstValue% = -1 THEN 'MAT ritm0.pattern(0 TO %RitmArraySize) = ZER geeft syntax error period not allowed ritm.pattern(0)= nrtiks% ritm.pattern(1) = %False EXIT SUB END IF ' step 2: Search from this point on, the last positive value: ' again following code is correct, but PBCC1.0 prevents it from running... 'ARRAY SCAN ritm.pattern(ii&), <= 0, TO jj& 'IF jj& = %False THEN ' LastValue% = %RitmArraySize 'ELSE ' LastValue% = jj& -2 :' jj& - 1 is <=0, dus moeten we nog een stap terug!!! 'END IF '============================ ' oldcode: DO IF ritm.pattern(i%) <= 0 THEN LastValue% = i% - 1: EXIT DO INCR i% LOOP UNTIL i% > %RitmArraySize ' =============================== ' Calculate the sigma-sum for this segment: sigma! = 0 FOR i% = FirstValue% TO LastValue% sigma! = sigma! + ritm.pattern(i%) NEXT i% ' now rescale this to NrTiks% faktor! = nrtiks% / sigma! 'MAT ritm.pattern() = (faktor!) * ritm.pattern() :' do the entire array - but this gives error... FOR i% = FirstValue% TO LastValue% ritm.pattern(i%) = ritm.pattern(i%) * faktor! NEXT i% ' now shift the values to the beginning of the array: i% = 0 j% = FirstValue% DO ritm.pattern(i%) = ritm.pattern(j%) INCR i% INCR j% LOOP UNTIL j% > LastValue% IF i% <= %RitmArraySize THEN ritm.pattern(i%)= %False ELSE ritm.pattern(%RitmArraySize) = %False END IF END SUB FUNCTION GetRitme (ritm AS ritmetype,BYVAL param AS DWORD, BYVAL Stijl AS SINGLE) EXPORT AS SINGLE ' new procedure 30.05.2002 ' memo: %Tango = 1 '%Milonga = 2 '%Tangowals = 3 '%March = 4 '%Salsa = 5 '%BossaNova = 6 '%Rumba = 7 '%Techno = 8 ' the functions returns the number of tiks in the pattern (abs sum of all values) LOCAL i AS DWORD LOCAL r AS ritmetype STATIC cnt AS DWORD STATIC oldparam AS DWORD IF param <> oldparam THEN cnt = %False oldparam = param END IF SELECT CASE param CASE %Tango GetTangoRitme r, cnt INCR cnt CASE %Milonga GetMilongaRitme r, cnt INCR cnt CASE %TangoWals GetTangoWalsRitme r, cnt INCR cnt CASE %March GetMarchRitme r, cnt INCR cnt CASE %Salsa GetSalsaRitme r, cnt INCR cnt CASE %BossaNova GetBossaNovaRitme r, cnt INCR cnt CASE %Rumba GetRumbaRitme r, cnt INCR cnt CASE %Techno GetTechnoRitme r, cnt INCR cnt CASE %Wals GetWalsRitme r, cnt INCR cnt CASE ELSE MSGBOX "Not implemented rythm" EXIT FUNCTION END SELECT ' application of style: IF Stijl > 0.9395 THEN ' legato i = %False DO ritm.pattern(i) = r.pattern(i) INCR i LOOP UNTIL r.pattern(i) = %False ritm.pattern(i) = %False FUNCTION = RitmSigma!(ritm) EXIT FUNCTION END IF IF Stijl < 0.0625 THEN Stijl = 0.0625 ' staccatissimo ' now apply the style to the ritm. output structure: i = %False DO IF SGN(r.pattern(i\2)) = 1 THEN ritm.pattern(i) = r.pattern(i \ 2) * Stijl ritm.pattern(i+1) = -(r.pattern(i \ 2) * (1!- Stijl)) ELSE ritm.pattern(i) = %False ritm.pattern(i+1) = %False END IF i = i + 2 LOOP UNTIL r.pattern(i\2) = %False FUNCTION = RitmSigma!(ritm) END FUNCTION SUB GetTangoRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' not EXPORTED ' 30.05.2002 nr = nr MOD 17 SELECT CASE nr CASE %False ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 2 ritm.pattern(3)= 2 ritm.pattern(4)= 1 ritm.pattern(5)= %False CASE 1 ritm.pattern(0)= 2 ritm.pattern(1)= 2 ritm.pattern(2)= 3 ritm.pattern(3)= 1 ritm.pattern(4)= %False CASE 2 ritm.pattern(0)= 3 ritm.pattern(1)= 1 ritm.pattern(2)= 3 ritm.pattern(3)= 1 ritm.pattern(4)= %False CASE 3 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 2 ritm.pattern(3)= 2 ritm.pattern(4)= 1 ritm.pattern(5)= %False CASE 4 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 11 ritm.pattern(3)= 2 ritm.pattern(4)= %False CASE 5 ritm.pattern(0)= 3 ritm.pattern(1)= 1 ritm.pattern(2)= 2 ritm.pattern(3)= 2 ritm.pattern(4)= 4 ritm.pattern(5)= 3 ritm.pattern(6)= 1 ritm.pattern(7) = %False CASE 6 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 2 ritm.pattern(4)= 2 ritm.pattern(5)= 4 ritm.pattern(6)= 3 ritm.pattern(7)= 1 ritm.pattern(8) = %False CASE 7 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 2 ritm.pattern(4)= 2 ritm.pattern(5)= 3 ritm.pattern(6)= 1 ritm.pattern(7)= 2 ritm.pattern(8)= 2 ritm.pattern(9) = %False CASE 8 ritm.pattern(0)= 1 ritm.pattern(1)= 3 ritm.pattern(2)= 2 ritm.pattern(3)= 2 ritm.pattern(4)= 1 ritm.pattern(5)= 1 ritm.pattern(6)= 2 ritm.pattern(7)= 2 ritm.pattern(8)= 1 ritm.pattern(9)= 1 ritm.pattern(10) = %False CASE 9 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 2 ritm.pattern(3)= 5 ritm.pattern(4)= 4 ritm.pattern(5)= 2 ritm.pattern(6)= %False CASE 10 ritm.pattern(0)= 3 ritm.pattern(1)= 1 ritm.pattern(2)= 2 ritm.pattern(3)= 4 ritm.pattern(4)= 3 ritm.pattern(5)= 1 ritm.pattern(6)= 1 ritm.pattern(7)= 1 ritm.pattern(8)= %False CASE 11 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 2 ritm.pattern(3)= 2 ritm.pattern(4)= 3 ritm.pattern(5)= 2 ritm.pattern(6)= 3 ritm.pattern(7)= 1 ritm.pattern(8)= %False CASE 12 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 2 ritm.pattern(4)= 2 ritm.pattern(5)= 1 ritm.pattern(6)= 2 ritm.pattern(7)= 1 ritm.pattern(8)= 2 ritm.pattern(9) = 2 ritm.pattern(10) = %False CASE 13 ritm.pattern(0)= 3 ritm.pattern(1)= 3 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= 2 ritm.pattern(5)= 3 ritm.pattern(6)= 2 ritm.pattern(7)= 1 ritm.pattern(8)= %False CASE 14 ritm.pattern(0)= 3 ritm.pattern(1)= 1 ritm.pattern(2)= 4 ritm.pattern(3)= 1 ritm.pattern(4)= 6 ritm.pattern(5)= 1 ritm.pattern(6)= %False CASE 15 ritm.pattern(0)= 3 ritm.pattern(1)= 1 ritm.pattern(2)= 4 ritm.pattern(3)= 1 ritm.pattern(4)= 1 ritm.pattern(5)= 1 ritm.pattern(6)= 1 ritm.pattern(7)= 1 ritm.pattern(8)= 2 ritm.pattern(9) = 1 ritm.pattern(10) = %False CASE 16 ritm.pattern(0)= 1 ritm.pattern(1)= 1 ritm.pattern(2)= 2 ritm.pattern(3)= 7 ritm.pattern(4)= 1 ritm.pattern(5)= 1 ritm.pattern(6)= 2 ritm.pattern(7)= 1 ritm.pattern(8)= %False END SELECT END SUB SUB GetTangoWalsRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' not EXPORTED ' 30.05.2002 [ 12/8 ] nr = nr MOD 6 SELECT CASE nr CASE %False ritm.pattern(0)= 3 ritm.pattern(1)= 3 ritm.pattern(2)= 3 ritm.pattern(3)= 2 ritm.pattern(4)= 1 ritm.pattern(5)= %False CASE 1 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 3 ritm.pattern(3)= 3 ritm.pattern(4)= 2 ritm.pattern(5)= 1 ritm.pattern(6)= %False CASE 2 ritm.pattern(0)= 2 ritm.pattern(1)= 1 ritm.pattern(2)= 3 ritm.pattern(3)= 3 ritm.pattern(4)= 2 ritm.pattern(5)= 1 ritm.pattern(6)= %False CASE 3 ritm.pattern(0)= 2 ritm.pattern(1)= 1 ritm.pattern(2)= 2 ritm.pattern(3)= 1 ritm.pattern(4)= 2 ritm.pattern(5)= 1 ritm.pattern(6)= 2 ritm.pattern(7)= 1 ritm.pattern(8)= %False CASE 4 ritm.pattern(0)= 1 ritm.pattern(1)= 1 ritm.pattern(2)= 1 ritm.pattern(3)= 3 ritm.pattern(4)= 3 ritm.pattern(5)= 2 ritm.pattern(6)= 1 ritm.pattern(7)= %False CASE 5 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 2 ritm.pattern(3)= 1 ritm.pattern(4)= 1 ritm.pattern(5)= 2 ritm.pattern(6)= 2 ritm.pattern(7)= 1 ritm.pattern(8) = %False END SELECT END SUB SUB GetMilongaRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' not EXPORTED ' 30.05.2002 [ 3/4 maat] nr = nr MOD 17 SELECT CASE nr CASE %False ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= 1 ritm.pattern(5)= %False CASE 1 ritm.pattern(0)= 2 ritm.pattern(1)= 3 ritm.pattern(2)= 1 ritm.pattern(3)= %False CASE 2 ritm.pattern(0)= 3 ritm.pattern(1)= 1 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= %False CASE 3 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 2 ritm.pattern(3)= 1 ritm.pattern(4)= %False CASE 4 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 7 ritm.pattern(3)= 2 ritm.pattern(4)= %False CASE 5 ritm.pattern(0)= 3 ritm.pattern(1)= 1 ritm.pattern(2)= 2 ritm.pattern(3)= 2 ritm.pattern(4)= 3 ritm.pattern(5)= 1 ritm.pattern(6) = %False CASE 6 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 2 ritm.pattern(4)= 2 ritm.pattern(5)= 3 ritm.pattern(6)= 1 ritm.pattern(7) = %False CASE 7 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 2 ritm.pattern(4)= 2 ritm.pattern(5)= 3 ritm.pattern(6)= 1 ritm.pattern(7) = %False CASE 8 ritm.pattern(0)= 1 ritm.pattern(1)= 3 ritm.pattern(2)= 2 ritm.pattern(3)= 2 ritm.pattern(4)= 1 ritm.pattern(5)= 1 ritm.pattern(6)= 1 ritm.pattern(7)= 1 ritm.pattern(8) = %False CASE 9 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 2 ritm.pattern(3)= 1 ritm.pattern(4)= 4 ritm.pattern(5)= 2 ritm.pattern(6)= %False CASE 10 ritm.pattern(0)= 3 ritm.pattern(1)= 1 ritm.pattern(2)= 2 ritm.pattern(3)= 4 ritm.pattern(4)= 1 ritm.pattern(5)= 1 ritm.pattern(6)= %False CASE 11 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 3 ritm.pattern(3)= 2 ritm.pattern(4)= 3 ritm.pattern(5)= 1 ritm.pattern(6)= %False CASE 12 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 2 ritm.pattern(4)= 2 ritm.pattern(5)= 1 ritm.pattern(6)= 2 ritm.pattern(7)= 1 ritm.pattern(8) = %False CASE 13 ritm.pattern(0)= 1 ritm.pattern(1)= 3 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= 2 ritm.pattern(5)= 1 ritm.pattern(6)= 2 ritm.pattern(7)= 1 ritm.pattern(8)= %False CASE 14 ritm.pattern(0)= 3 ritm.pattern(1)= 1 ritm.pattern(2)= 4 ritm.pattern(3)= 1 ritm.pattern(4)= 2 ritm.pattern(5)= 1 ritm.pattern(6)= %False CASE 15 ritm.pattern(0)= 3 ritm.pattern(1)= 1 ritm.pattern(2)= 2 ritm.pattern(3)= 1 ritm.pattern(4)= 1 ritm.pattern(5)= 1 ritm.pattern(6)= 1 ritm.pattern(7)= 1 ritm.pattern(8) = 1 ritm.pattern(9) = %False CASE 16 ritm.pattern(0)= 1 ritm.pattern(1)= 1 ritm.pattern(2)= 2 ritm.pattern(3)= 3 ritm.pattern(4)= 1 ritm.pattern(5)= 1 ritm.pattern(6)= 2 ritm.pattern(7)= 1 ritm.pattern(8)= %False END SELECT END SUB SUB GetTechnoRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' not EXPORTED ' 30.05.2002 LOCAL i AS DWORD nr = nr MOD 16 ritm.pattern(0) = 1 + (RND(1) * 3) ritm.pattern(1) = 5 - ritm.pattern(0) ritm.pattern(2) = ritm.pattern(0) + ritm.pattern(1) ritm.pattern(3) = %False IF nr = %False THEN EXIT SUB END IF FOR i = 3 TO (2 + (nr*3)) STEP 3 ritm.pattern(i) = 1 + (RND(1) * 3) ritm.pattern(i+1) = 5 - ritm.pattern(0) ritm.pattern(i+2) = ritm.pattern(i) + ritm.pattern(i+1) ritm.pattern(i+3) = %False NEXT i END SUB SUB GetMarchRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' not EXPORTED ' 30.05.2002 nr = nr MOD 8 SELECT CASE nr CASE %False ritm.pattern(0)= 1 ritm.pattern(1)= 1 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= %False CASE 1 ritm.pattern(0)= 2 ritm.pattern(1)= 1 ritm.pattern(2)= 1 ritm.pattern(3)= %False CASE 2 ritm.pattern(0)= 4 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= %False CASE 3 ritm.pattern(0)= 4 ritm.pattern(1)= 1 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= 1 ritm.pattern(5)= %False CASE 4 ritm.pattern(0)= 1 ritm.pattern(1)= 1 ritm.pattern(2)= %False CASE 5 ritm.pattern(0)= 2 ritm.pattern(1)= 1 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= 1 ritm.pattern(5)= 2 ritm.pattern(6) = %False CASE 6 ritm.pattern(0)= 2 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= 1 ritm.pattern(5)= 1 ritm.pattern(6)= %False CASE 7 ritm.pattern(0)= 2 ritm.pattern(1)= 1 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= 1 ritm.pattern(5)= 1 ritm.pattern(6)= 1 ritm.pattern(7) = %False END SELECT END SUB SUB GetWalsRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' not EXPORTED ' 30.05.2002 nr = nr MOD 6 SELECT CASE nr CASE %False ritm.pattern(0)= 1 ritm.pattern(1)= 1 ritm.pattern(2)= 1 ritm.pattern(3)= %False CASE 1 ritm.pattern(0)= 2 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= %False CASE 2 ritm.pattern(0)= 4 ritm.pattern(1)= 4 ritm.pattern(2)= 3 ritm.pattern(3)= 1 ritm.pattern(4)= %False CASE 3 ritm.pattern(0)= 2 ritm.pattern(1)= 2 ritm.pattern(2)= 2 ritm.pattern(3)= 2 ritm.pattern(4)= 3 ritm.pattern(5)= 1 ritm.pattern(6)= %False CASE 4 ritm.pattern(0)= 2 ritm.pattern(1)= 1 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= 1 ritm.pattern(5)= %False CASE 5 ritm.pattern(0)= 2 ritm.pattern(1)= 2 ritm.pattern(2)= 2 ritm.pattern(3)= 2 ritm.pattern(4)= 2 ritm.pattern(5)= 1 ritm.pattern(6)= 1 ritm.pattern(7) = %False END SELECT END SUB SUB GetSalsaRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' not EXPORTED ' 30.05.2002 - not ready nr = nr MOD 2 SELECT CASE nr CASE %False ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 2 ritm.pattern(4)= 2 ritm.pattern(5)= %False CASE 1 ritm.pattern(0)= 1 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= 2 ritm.pattern(5)= 1 ritm.pattern(6)= %False END SELECT END SUB SUB GetBossaNovaRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' not EXPORTED ' 30.05.2002 - not filled in yet nr = nr MOD 6 SELECT CASE nr CASE %False ritm.pattern(0)= 1 ritm.pattern(1)= 1 ritm.pattern(2)= 1 ritm.pattern(3)= %False CASE 1 ritm.pattern(0)= 2 ritm.pattern(1)= 2 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= %False CASE 2 ritm.pattern(0)= 4 ritm.pattern(1)= 4 ritm.pattern(2)= 3 ritm.pattern(3)= 1 ritm.pattern(4)= %False CASE 3 ritm.pattern(0)= 2 ritm.pattern(1)= 2 ritm.pattern(2)= 2 ritm.pattern(3)= 2 ritm.pattern(4)= 3 ritm.pattern(5)= 1 ritm.pattern(6)= %False CASE 4 ritm.pattern(0)= 2 ritm.pattern(1)= 1 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= 1 ritm.pattern(5)= %False CASE 5 ritm.pattern(0)= 2 ritm.pattern(1)= 2 ritm.pattern(2)= 2 ritm.pattern(3)= 2 ritm.pattern(4)= 2 ritm.pattern(5)= 1 ritm.pattern(6)= 1 ritm.pattern(7) = %False END SELECT END SUB SUB GetRumbaRitme (ritm AS ritmetype, BYVAL nr AS DWORD) ' not EXPORTED ' 30.05.2002 nr = nr MOD 4 SELECT CASE nr CASE %False ritm.pattern(0)= 3 ritm.pattern(1)= 3 ritm.pattern(2)= 1 ritm.pattern(3)= 1 ritm.pattern(4)= %False CASE 1 ritm.pattern(0)= 1 ritm.pattern(1)= 3 ritm.pattern(2)= 3 ritm.pattern(3)= 1 ritm.pattern(4)= %False CASE 2 ritm.pattern(0)= 1 ritm.pattern(1)= 1 ritm.pattern(2)= 3 ritm.pattern(3)= 3 ritm.pattern(4)= %False CASE 3 ritm.pattern(0)= 3 ritm.pattern(1)= 1 ritm.pattern(2)= 1 ritm.pattern(3)= 3 ritm.pattern(4)= %False END SELECT END SUB FUNCTION Pwm2BitStream$ (Pwm%(), BYVAL b%) EXPORT LOCAL BitStream$ LOCAL mask%, kode%, i%, j% BitStream$ = "" ' mask% = EXP2(b%) :' = 2 ^ b% BIT SET mask%,b% DO FOR i% = 0 TO 7 kode% = 0 IF j% + i% > UBOUND(Pwm%) THEN EXIT FOR IF Pwm%(j% + i%) AND mask% THEN 'kode% = kode% OR EXP2(i%) :' = (2 ^ i%) BIT SET kode%,i% END IF NEXT i% BitStream$ = BitStream$ + CHR$(kode%) j% = j% + 8 LOOP FUNCTION = BitStream$ END FUNCTION SUB P2Har (Har AS HarmType, BYVAL i&, p%()) EXPORT ' format convertor for old P(i,j) software. LOCAL jl%, il&,n%,v%,ov% Har.vel = NUL$(128) 'STRING$(128, 0) FOR jl% = 1 TO (UBOUND(p%, 2) - 1) STEP 2 FOR il& = i& TO LBOUND(p%, 1) STEP -1 IF (p%(il&, jl% + 1) > 0) AND (p%(il&, jl%) > 0) THEN n% = p%(i&, jl%) v% = p%(i&, jl% + 1) ov% = ASC(MID$(Har.vel, n% + 1, 1)) v% = SumVelo(ov%, v%) MID$(Har.vel, n% + 1, 1) = CHR$(v%) EXIT FOR END IF NEXT il& NEXT jl% END SUB SUB Samp2Har (Samp!(), h AS HarmType) EXPORT LOCAL Sp!() ' first we call the DFT procedure: REDIM Sp!(0) DFT Samp!(), Sp!() ' in g_indep.dll - Samp() must be 1 second of length ' we use the procedure LinSpec2Har for conversion to chromatic spectrum... LinSpec2Har Sp!(), h, 1 ERASE Sp! h.flag = %False END SUB SUB Shape2Pwm (Shape!(), Pwm%(), BYVAL NrTicks%) EXPORT LOCAL Ar!() LOCAL newsize%, i%, tek%, nrpulses%, oldj%, j% REDIM Ar!(0) Shape2Time Shape!(), Ar!(), NrTicks% newsize% = 0 REDIM Pwm%(NrTicks%) FOR i% = 0 TO UBOUND(Ar!) tek% = SGN(Ar!(i%)) nrpulses% = INT(ABS(Ar!(i%))) IF nrpulses% THEN oldj% = newsize% newsize% = newsize% + nrpulses% SELECT CASE tek% CASE -1 FOR j% = oldj% TO oldj% + nrpulses% - 1 Pwm%(j%) = 0 NEXT j% CASE 1 FOR j% = oldj% TO oldj% + nrpulses% - 1 Pwm%(j%) = 1 NEXT j% END SELECT END IF NEXT i% ERASE Ar! END SUB SUB Shape2Time (Shape!(), Ar!(),BYVAL NrTicks%) EXPORT LOCAL i AS DWORD LOCAL j AS DWORD LOCAL tek AS LONG LOCAL oldtek AS LONG LOCAL delta! , sigma!, NormKonst! i = 1 REDIM Ar!(0) DO delta! = Shape!(i) - Shape!(i - 1) tek = SGN(delta!) sigma! = sigma! + ABS(delta!) INCR i IF tek = oldtek THEN Ar!(j) = Ar!(j) + delta! oldtek = tek ELSE INCR j REDIM PRESERVE Ar!(j) Ar!(j) = delta! oldtek = tek END IF LOOP UNTIL i > UBOUND(Shape!) NormKonst! = NrTicks% / sigma! MAT Ar!() = (NormKonst!) * Ar!() END SUB SUB Wave2Ritm (Shape!(),ritm AS RitmeType, BYVAL nrtiks%)EXPORT LOCAL sigma! LOCAL i%, j% 'warning: this procedure modifies Shape!() ' step 1: normalize Shape!() for unit duration: ' ********************************************* sigma! = 0 FOR i% = 0 TO UBOUND(Shape!) sigma! = sigma! + ABS(Shape!(i%)) NEXT i% SELECT CASE sigma! CASE <=0 ritm.pattern(0) = -1 ritm.pattern(1) = 0 EXIT SUB CASE < 1 ' normalisatie: MAT Shape!() = (1!/sigma!) * Shape!() ' use scalar multiplication - PB only CASE 1 ' do nothing, it must already be normalized CASE > 1 ' normalisatie: MAT Shape!() = (1!/sigma!) * Shape!() END SELECT ' step 2: ritme afleiding: som van opeenvolgende negatieve waarden worden rust ' nullen worden verwijderd ' i% = 0 DO IF Shape!(i%) =< 0 THEN IF i% + 1 <= UBOUND(Shape!) THEN IF Shape!(i% + 1) =< 0 THEN Shape!(i%) = Shape!(i%) + Shape!(i% + 1) ARRAY DELETE Shape!(i%+1), 0 :' deletes and shifts to the left ' this makes removing zeros no longer ' needed as a separate procedure as in ' previous code. This only works in PBcc END IF END IF END IF IF Shape!(i%)=0 THEN ARRAY DELETE Shape!(i%), 0 INCR i% LOOP UNTIL i% > UBOUND(Shape!) ' step 3: Omrekening naar ritmepatroon met tiklengte= nrtiks% ' *********************************************************** i% = 0: j% = 0 'MAT ritm.pattern(0 TO %RitmArraySize) = ZER :' gives error DO ritm.pattern(i%) = Shape!(j%) * nrtiks% :' MTritm!(i%) = Shape!(j%) * nrtiks% IF ritm.pattern(i%) <> 0 THEN INCR i% INCR j% ' REDIM PRESERVE MTritm!(i%) - now we use a static array part of a type ELSE ' er staat een nul in het ritmepatroon... ' we kunnen wellicht opeenvolgende te kleine waarden optellen... j% = j% + 1 IF j% > UBOUND(Shape!) THEN EXIT DO IF Shape!(j% - 1) >= 0 THEN IF Shape!(j%) >= 0 THEN Shape!(j%) = Shape!(j%) + Shape!(j% - 1) END IF ELSE IF Shape!(j%) <= 0 THEN Shape!(j%) = Shape!(j%) + Shape!(j% - 1) END IF END IF END IF IF j% > UBOUND(Shape!) THEN EXIT DO ' breek af... LOOP UNTIL i% > %RitmArraySize IF ritm.pattern(0) = 0 THEN ritm.pattern(0) = 1 ' ??? END SUB '*************************************** ' Procedures and Functions: Harm_Fil.BAS '*************************************** FUNCTION ReadHarFile (Har AS HarmType, BYVAL track%, BYVAL filenumber AS LONG)EXPORT AS LONG ' the file should have been opened for BINARY !!! - rewritten 08.12.98 LOCAL dummy$, trk%, tick&, tmp$ STATIC FilePos() AS LONG 'position in file, stored separately for every track LOCAL pseq AS SequencerType PTR pseq = ExportSeqPtr ' in g_lib.dll DIM FilePos(63) IF FilePos(track%) >= 0 THEN SEEK filenumber, FilePos(track%) DO IF EOF(filenumber) THEN FUNCTION = %NotFalse: FilePos(track%) = 0: BIT RESET @pseq.flags, track%: EXIT FUNCTION ' read the channel/track number tmp$="" DO GET$ filenumber,1,tmp$ SELECT CASE tmp$ CASE "0" TO "9" EXIT DO CASE ELSE tmp$="" END SELECT LOOP UNTIL EOF(filenumber) ' if EOF _for this track_ reset filepositon and reset its bit in the seq.flags so it stops playing IF ISTRUE EOF(filenumber) THEN FUNCTION = %NotFalse : FilePos(track%) = 0: BIT RESET @pseq.flags, track% : EXIT FUNCTION DO GET$ filenumber,1,dummy$ IF dummy$= CHR$(0) THEN EXIT DO IF dummy$= "," THEN EXIT DO tmp$ = tmp$ + dummy$ LOOP UNTIL dummy$=" " trk% = VAL(tmp$) ' now read the tickcount value: tmp$="" DO GET$ filenumber,1,tmp$ LOOP UNTIL tmp$ <> " " DO GET$ filenumber,1,dummy$ IF dummy$= CHR$(0) THEN EXIT DO IF dummy$= "," THEN EXIT DO tmp$ = tmp$ + dummy$ IF ISTRUE EOF(filenumber) THEN EXIT DO LOOP UNTIL dummy$= " " tick& = VAL(tmp$) IF ISTRUE EOF(filenumber) THEN FUNCTION = %NotFalse : FilePos(track%) = 0: BIT RESET @pseq.flags, track% : EXIT FUNCTION ' now read the harmony string: DO GET$ filenumber,1,tmp$ LOOP UNTIL tmp$="H" IF ISTRUE EOF(filenumber) THEN FUNCTION = %NotFalse : FilePos(track%) = 0: BIT RESET @pseq.flags, track%: EXIT FUNCTION dummy$=NUL$(128) GET$ filenumber,128,dummy$ IF (trk% = track%) AND (tmp$ = "H") THEN Har.vel = dummy$ FUNCTION = tick& FilePos(track%) = SEEK(filenumber) ' IF tick = 3803 THEN MSGBOX "last har!",,"readharfile" EXIT FUNCTION END IF LOOP UNTIL EOF(filenumber) ' FilePos(track%) = 0: BIT RESET seq.flags, track% FUNCTION = %NotFalse END FUNCTION SUB WriteHar2File (h AS HarmType, BYVAL track%, BYVAL filenumber AS LONG) EXPORT ' this is not to be confused with the real time task procedure in GMT : WriteSeqFile, although the file format used is the same. ' modified 08.12.1998 - now uses Win32Api GetTickCount. ' modified 09.12.1998 ' modified 25.02.2000 - use timeGetTime STATIC Tog?, initim AS DWORD GLOBAL Tik() AS DWORD ' must be global, otherwize we cannot resize it... LOCAL tick AS DWORD IF Tog? = %False THEN IF filenumber <=0 THEN EXIT SUB Tog? = %True REDIM Tik(track%) 'AS STATIC DWORD initim = timeGetTime 'GetTickCount() END IF IF track% > UBOUND(Tik) THEN REDIM PRESERVE Tik(track%) 'AS STATIC DWORD tick = (timeGetTime - initim)/ 10 '(GetTickCount - initim) / 10 IF tick <= Tik(track%) THEN tick = Tik(track%) + 1 Tik(track%) = tick PRINT# filenumber, track%; tick; "H"; h.vel END SUB ' lookups for wavelet and correlation math ' These create lookuptables with quart sinewaves for all musical notes. FUNCTION Qsine (BYVAL samplingrate AS DWORD, BYVAL noot AS SINGLE, BYREF WavLet() AS SINGLE) EXPORT AS DWORD 'returns the values of a sinewave over a quart period for the note passed (note + fraction) 'in a normalised array WavLet(), dimensioned in the function. The number of samples contained in 'WavLet() is returned by the function. LOCAL j AS DWORD LOCAL angkonst AS SINGLE LOCAL freq AS SINGLE LOCAL aantalsamples AS DWORD 'dt = 1! / samplingrate ' duur van 1 sample ' kwartperiode: loop over Pih freq = NF2F(noot) angkonst = (Pi2 * freq) / samplingrate 'hoekincrement per sample voor de gegeven frekwentie aantalsamples = (1! / (freq * 4!)) * samplingrate REDIM WavLet(aantalsamples-1) AS SINGLE FOR j = 0 TO aantalsamples -1 WavLet(j) = SIN(angkonst * j) NEXT j FUNCTION = aantalsamples END FUNCTION SUB PrepareWaveletTables (WaveLets AS WaveletData) EXPORT ' internal procedure to generate a lookup with quart sines for the noterange 36-96 ' must be 44100S/s and limit notes 36 to 96 (5 octaves) LOCAL noot AS SINGLE LOCAL j AS LONG LOCAL z AS DWORD ' LOCAL datasize AS DWORD LOCAL lengte AS DWORD DIM Wavlet(0) AS LOCAL SINGLE FOR noot = 36 TO 96 lengte = Qsine (%CD_SR, noot, WavLet()) Wavelets.ns(noot) = lengte FOR j= 0 TO lengte -1 Wavelets.dta(z) = WavLet(j) IF ISFALSE j THEN ' save the datapointer in the type: Wavelets.pd(noot) = VARPTR(Wavelets.dta(z)) END IF INCR z NEXT j ' datasize = datasize + lengte NEXT noot END SUB FUNCTION TxtG2Har(d AS STRING, BYREF HR AS HarryType) EXPORT AS LONG ' converts german text string to a harmony structure with rhythm array ' The number of harmonystrings in HR.Har() cannot exceed the size of HR.Rit (= %RitmArraySize) ' parallel functions should become: TxtE2Har for english ' TxtN2Har for dutch ' TxtF2Har for french ' modified 06.06.06 for Gnos. ' was: FUNCTION TxtG2Har(d AS STRING, BYREF R AS RitmeType, BYREF H() AS HarmType) EXPORT AS LONG LOCAL i AS LONG LOCAL j AS LONG LOCAL l AS LONG LOCAL nr AS LONG LOCAL n AS STRING * 1 LOCAL m AS STRING * 1 LOCAL o AS STRING * 1 LOCAL p AS STRING * 1 LOCAL nm AS STRING * 2 LOCAL nmo AS STRING * 3 LOCAL nmop AS STRING * 4 FUNCTION = %False l = LEN(d) j = %False ' following loop scans and maps the entire verse passed as a string FOR i = 1 TO l n = MID$(d,i,1) IF i < l THEN m = MID$(d,i+1,1) ELSE m = "" ' volgende letter IF i < l-1 THEN o = MID$(d,i+2,1) ELSE o = "" IF i < l-2 THEN p = MID$(d,i+3,1) ELSE p = "" nm = n & m nmo = n & m & o nmop = n & m & o & p ' first we handle 4 character phonemes or phonetic units SELECT CASE nmop CASE "chts" ' ch AddNote2Har HR.Har(j),F2N(500),12 HR.Rit.Pattern(j) = 40 INCR j ' t =volledig rond de 3000Hz zone FOR nr = 100 TO 102 AddNote2Har HR.Har(j),nr,60 NEXT nr HR.Rit.Pattern(j) = 20 INCR j ' s = 'volledig boven 4000Hz FOR nr = 108 TO 110 ' breedte spektrum - voorlopige cluster AddNote2Har HR.Har(j),nr, nr - 98 NEXT nr HR.Rit.Pattern(j)= 70 ' duration in ms i = i + 3 INCR j ITERATE FOR END SELECT ' 3 letter phonemes SELECT CASE nmo ' coding example: CASE "sch","Sch" FOR nr = 90 TO 96 '102 ' breedte spektrum - voorlopige cluster AddNote2Har HR.Har(j),nr, nr - 88 NEXT nr FOR nr = 97 TO 103 AddNote2Har HR.Har(j),nr, 104 - nr NEXT nr HR.Rit.Pattern(j)= 50 ' duration in ms i = i + 2 INCR j ITERATE FOR END SELECT ' 2 letter phonemes SELECT CASE nm 'two letters are the same... (komt nauwelijks voor in duits...) CASE "Aa", "aa", "ah", "Ah" ' "aa" formant : 820Hz + 1500Hz [ omgekeerde v formant] AddNote2Har HR.Har(j),F2N(820),72 AddNote2Har HR.Har(j),F2N(1500),64 HR.Rit.Pattern(j) = 200 INCR i INCR j ITERATE FOR ' "ij" formant: 650Hz + 2500Hz [ eta, fonetisch] CASE "Ei","ei" AddNote2Har HR.Har(j),F2N(650),72 AddNote2Har HR.Har(j),F2N(2500),64 HR.Rit.Pattern(j) = 140 INCR i INCR j ITERATE FOR CASE "Ee","ee", "eh", "Eh" AddNote2Har HR.Har(j),F2N(900),72 AddNote2Har HR.Har(j),F2N(2000),64 HR.Rit.Pattern(j) = 140 INCR i INCR j ITERATE FOR CASE "Ii","ii", "ih", "Ih", "Ie", "ie" ' "iii" formant: 320Hz + 3210Hz [ i formant] Addnote2Har HR.Har(j),F2N(320),74 Addnote2Har HR.Har(j),F2N(3210),68 HR.Rit.Pattern(j) = 150 INCR i INCR j ITERATE FOR CASE "Oo","oo", "Oh", "oh" ' "ooh" formant: 370Hz + 1040Hz - open o AddNote2Har HR.Har(j), F2N(370),74 AddNote2Har HR.Har(j), F2N(1040),66 HR.Rit.Pattern(j) = 180 INCR i INCR j ITERATE FOR CASE "Ü","ü","Üh","üh","Ue","ue" AddNote2Har HR.Har(j), F2N(460), 72 AddNote2Har HR.Har(j), F2N(1200), 65 HR.Rit.Pattern(j) = 160 INCR i INCR j ITERATE FOR CASE "U","u", "Uh", "uh" AddNote2Har HR.Har(j), F2N(460), 72 AddNote2Har HR.Har(j), F2N(1200), 65 HR.Rit.Pattern(j) = 220 INCR i INCR j ITERATE FOR CASE "dd","ll","tt","pp","ff","ck" INCR i ITERATE FOR END SELECT ' single character mapping in pitch/formant SELECT CASE n CASE CHR$(34),CHR$(39),CHR$(96) ' " , ' , ` ' afkappingsteken: overschrikkelen INCR i ITERATE FOR CASE " ", "-" ' spatie tussen woorden HR.Har(j).vel = NUL$(128) HR.Rit.Pattern(j) = - 150 INCR j : INCR i : ITERATE FOR CASE "," ' interpunktie komma HR.Har(j).vel = NUL$(128) HR.Rit.Pattern(j) = - 300 INCR j : INCR i : ITERATE FOR CASE ";", ":" HR.Har(j).vel = NUL$(128) HR.Rit.Pattern(j) = -350 INCR j : INCR i : ITERATE FOR CASE "." HR.Har(j).vel = NUL$(128) HR.Rit.Pattern(j) = -600 INCR j : INCR i : ITERATE FOR CASE "!" HR.Har(j).vel = NUL$(128) HR.Rit.Pattern(j) = -800 ' we should change the level of previous word INCR j : INCR i : ITERATE FOR CASE "?" HR.Har(j).vel = NUL$(128) HR.Rit.Pattern(j) = -700 INCR j : INCR i : ITERATE FOR 'VOWELS korte klinkers CASE "A","a" ' korte a ' "ah" formant : 640Hz + 990Hz - korte a AddNote2Har HR.Har(j),F2N(640), 78 AddNote2Har HR.Har(j),F2N(990), 70 HR.Rit.Pattern(j) = 80 INCR j : INCR i : ITERATE FOR CASE "I","i" ' korte i zoals in 'ik' ' "ih" formant: 400Hz + 2600Hz [ I formant] AddNote2Har HR.Har(j),F2N(400),74 AddNote2Har HR.Har(j),F2N(2600), 66 HR.Rit.Pattern(j) = 60 INCR j : INCR i : ITERATE FOR CASE "E","e","æ","Æ" ' "eeh" formant: 900Hz + 2000Hz [ ae formant] AddNote2Har HR.Har(j),F2N(900),71 AddNote2Har HR.Har(j),F2N(2000), 63 HR.Rit.Pattern(j) = 80 INCR j : INCR i : ITERATE FOR CASE "O","o" ' "och" formant: 440Hz + 770Hz - korte o AddNote2Har HR.Har(j),F2N(440),70 AddNote2Har HR.Har(j),F2N(770), 62 HR.Rit.Pattern(j) = 90 INCR j : INCR i : ITERATE FOR CASE "y","Y", "Ü","ü" ' "U formant: 460Hz + 1200Hz AddNote2Har HR.Har(j),F2N(460), 73 AddNote2Har HR.Har(j),F2N(1200), 64 HR.Rit.Pattern(j) = 70 INCR j : INCR i : ITERATE FOR CASE "ö","Ö" ' "euh formant: 600Hz + 800Hz AddNote2Har HR.Har(j),F2N(600), 76 AddNote2Har HR.Har(j),F2N(800), 62 HR.Rit.Pattern(j) = 85 INCR j : INCR i : ITERATE FOR CASE "u","U" ' "oe" formant: 300Hz + 650Hz [ u formant] AddNote2Har HR.Har(j),F2N(300), 75 AddNote2Har HR.Har(j), F2N(650), 64 HR.Rit.Pattern(j) = 100 INCR j : INCR i : ITERATE FOR CASE "ä", "Ä" ' "eeh" formant: 900Hz + 2000Hz [ ae formant] AddNote2Har HR.Har(j),F2N(900), 76 AddNote2Har HR.Har(j),F2N(2000), 68 HR.Rit.Pattern(j) = 75 INCR j : INCR i : ITERATE FOR CASE "ë" CASE "ï" ' CONSONANTS: ' PLOSIVES plofklanken: k,p,g,b CASE "P","p" AddNote2Har HR.Har(j),40,10 AddNote2Har HR.Har(j),42,10 HR.Rit.Pattern(j) = 20 INCR j INCR i ITERATE FOR CASE "G","g" AddNote2Har HR.Har(j), 37,10 AddNote2Har HR.Har(j), 36,10 HR.Rit.Pattern(j) = 22 INCR j INCR i ITERATE FOR CASE "C","K","c","K","q","Q" FOR nr = 88 TO 91 AddNote2Har HR.Har(j),nr, 48 NEXT nr HR.Rit.Pattern(j) = 12 INCR j INCR i ITERATE FOR CASE "B","b" FOR nr = 80 TO 83 AddNote2Har HR.Har(j),nr, 40 NEXT nr HR.Rit.Pattern(j) = 12 INCR j INCR i ITERATE FOR CASE "D","d" FOR nr = 84 TO 87 AddNote2Har HR.Har(j),nr, 42 NEXT nr HR.Rit.Pattern(j) = 12 INCR j INCR i ITERATE FOR CASE "T","t" ' volledig rond de 3000Hz zone FOR nr = 99 TO 103 AddNote2Har HR.Har(j),nr,80 NEXT nr HR.Rit.Pattern(j) = 20 INCR j INCR i ITERATE FOR ' FRICATIVES: f,v, s CASE "F","V" FOR nr = 92 TO 95 AddNote2Har HR.Har(j),nr, 16 NEXT nr HR.Rit.Pattern(j) = 90 INCR j INCR i ITERATE FOR ' nog niet geklasseerde medeklinkers CASE "J","j" AddNote2Har HR.Har(j), 64,48 ' i AddNote2Har HR.Har(j), 104, 40 HR.Rit.Pattern(j) = 30 INCR j AddNote2Har HR.Har(j), 75,46 ' uhh' AddNote2Har HR.Har(j), 80,44 INCR j INCR i ITERATE FOR CASE "X","x" ' ks ' k: FOR nr = 88 TO 91 AddNote2Har HR.Har(j),nr, 68 NEXT nr HR.Rit.Pattern(j) = 12 INCR j ' s: FOR nr = 108 TO 111 AddNote2Har HR.Har(j),nr, nr - 98 NEXT nr HR.Rit.Pattern(j)= 60 ' duration in ms INCR j INCR i ITERATE FOR CASE "L","l" AddNote2Har HR.Har(j),76, 20 AddNote2Har HR.Har(j),75, 20 INCR J INCR i ITERATE FOR CASE "M","m" AddNote2Har HR.Har(j),63, 14 AddNote2Har HR.Har(j),64, 13 INCR J INCR i ITERATE FOR ' SIBILANTS ruisklanken: s,z CASE "s","S","ß" 'volledig boven 4000Hz FOR nr = 108 TO 111 ' breedte spektrum - voorlopige cluster AddNote2Har HR.Har(j),nr, nr - 98 NEXT nr HR.Rit.Pattern(j)= 60 ' duration in ms INCR j INCR i ITERATE FOR CASE "Z","z" ' ts FOR nr = 100 TO 102 AddNote2Har HR.Har(j),nr,80 NEXT nr HR.Rit.Pattern(j) = 16 INCR j AddNote2Har HR.Har(j),109, 17 AddNote2Har HR.Har(j),110, 19 HR.Rit.Pattern(j) = 28 INCR j INCR i 'NASALS CASE "N","n" AddNote2Har HR.Har(j),48,16 HR.Rit.Pattern(j) = 20 INCR j INCR i ITERATE FOR CASE "H","W","h","w" AddNote2Har HR.Har(j),67,8 AddNote2Har HR.Har(j),69,9 AddNote2Har HR.Har(j),71,7 HR.Rit.Pattern(j) = 40 INCR j INCR i ITERATE FOR CASE "R", "r" AddNote2Har HR.Har(j),13,22 HR.Rit.Pattern(j) = 30 INCR j INCR i END SELECT NEXT i ' we always add a rest at the end of each verse: HR.Rit.Pattern(j) = -800 INCR j HR.Rit.Pattern(j) = %False ' afsluiter FUNCTION = j END FUNCTION FUNCTION NumberOfSpectralComponents (BYVAL tc AS SINGLE, BYVAL resolution AS WORD, BYVAL sf AS SINGLE, BYREF Sp() AS SINGLE, OPT BYVAL hl AS SINGLE ) EXPORT AS LONG ' geeft aantal verschillende spektraaltonen in het midi bereik, vanaf tc tot 127 ' resolution is passed in Cents. ' sf is the spectral exponent. ' de spektraaltonen worden retourneerd in Sp() ' 04.09.2005 - gwr LOCAL n AS CURRENCY ' - trick to get max. 1 cent resolution. single LOCAL RES AS CURRENCY LOCAL i AS LONG LOCAL cnt AS LONG IF ISFALSE hl THEN hl = 127 IF resolution = 100 THEN i = 1 DO n = ROUND(SpectralNoteF(tc,i,sf,%ExpSpec),0) 'afronding naar integer midi IF n > %False THEN IF n > hl THEN EXIT DO IF cnt THEN IF n =< Sp(cnt-1) THEN INCR i ITERATE DO END IF END IF REDIM PRESERVE Sp(cnt) AS SINGLE Sp(cnt) = n INCR i INCR cnt ELSE EXIT DO END IF LOOP ELSE RES = MIN(resolution / 100, 1) ' ceil to 100 cents i = 1 DO n = SpectralNoteF(tc,i,sf,%ExpSpec) IF n > %False THEN IF n > hl THEN EXIT DO IF cnt THEN IF n < Sp(cnt-1) + RES THEN INCR i ITERATE DO END IF END IF REDIM PRESERVE Sp(cnt) AS SINGLE Sp(cnt) = n INCR i INCR cnt ELSE EXIT DO END IF LOOP END IF FUNCTION = UBOUND(Sp) END FUNCTION FUNCTION NextSpectralFactor (BYVAL tc AS SINGLE, BYVAL resolution AS WORD, BYVAL sf AS SINGLE, BYREF Sp() AS SINGLE, OPT BYVAL hl AS SINGLE) EXPORT AS SINGLE ' returns the next value for sf, leading to a different spectral composition. ' the next different spectrum is returned in Sp() ' this function should be used to generate lookups. It may be very slow in real time. ' 04.09.2005 - gwr LOCAL i AS LONG IF ISFALSE hl THEN hl = 127 IF sf > 4 THEN MSGBOX "Too high exponent...",, FUNCNAME$ : EXIT FUNCTION IF sf < 0.01 THEN MSGBOX "Too small exponent...",, FUNCNAME$ : EXIT FUNCTION LOCAL n AS LONG DIM Spo(0) AS LOCAL SINGLE n = NumberOfSpectralComponents (tc,resolution,sf,Spo(),hl) DO sf = sf + (sf / 100) IF sf > 4 THEN EXIT FUNCTION n = NumberOfSpectralComponents (tc,resolution,sf,Sp(),hl) IF n <= 1 THEN EXIT FUNCTION IF UBOUND(Spo) <> UBOUND(Sp) THEN EXIT DO ' in this case we do have a different spectrum FOR i = UBOUND(spo) TO 0 STEP -1 IF Spo(i) <> Sp(i) THEN FUNCTION = sf EXIT FUNCTION ' as soon as we have a difference, exit do END IF NEXT i LOOP 'until Spo() <> Sp() ' what if this never happens ??? FUNCTION = sf END FUNCTION FUNCTION PreviousSpectralFactor (BYVAL tc AS SINGLE, BYVAL resolution AS WORD, BYVAL sf AS SINGLE, BYREF Sp() AS SINGLE, OPT BYVAL hl AS SINGLE) EXPORT AS SINGLE ' returns the next smaller value for sf, leading to a different spectral composition. ' the next smaller different spectrum is returned in Sp() ' this function should be used to generate lookups. It may be very slow in real time. ' 04.09.2005 - gwr LOCAL i AS LONG LOCAL loopcheck AS LONG IF ISFALSE hl THEN hl = 127 IF sf > 4 THEN MSGBOX "Too high exponent...",, FUNCNAME$ : EXIT FUNCTION IF sf < 0.01 THEN MSGBOX "Too small exponent...",, FUNCNAME$ : EXIT FUNCTION LOCAL n AS LONG REDIM Spo(0) AS LOCAL SINGLE FUNCTION = %False n = NumberOfSpectralComponents (tc,resolution,sf,Spo(),hl) DO INCR loopcheck IF loopcheck > 200 THEN warning "escape loop@" + FUNCNAME$ EXIT FUNCTION END IF sf = sf - (sf / 100) IF sf < 0.1 THEN EXIT FUNCTION ' changed from 0.01 to 0.1 04.09.2005 n = NumberOfSpectralComponents (tc,resolution,sf,Sp(),hl) IF n <= 1 THEN EXIT FUNCTION IF UBOUND(Spo) <> UBOUND(Sp) THEN EXIT DO FOR i = UBOUND(spo) TO 0 STEP -1 IF Spo(i) <> Sp(i) THEN FUNCTION = sf EXIT FUNCTION END IF NEXT i LOOP ' what if this never happens ??? FUNCTION = sf END FUNCTION FUNCTION ModSpekFak (BYVAL tc0 AS SINGLE, BYVAL tc1 AS SINGLE, BYVAL resolution AS WORD, BYREF Sp() AS SINGLE, OPT BYVAL hilim AS SINGLE) EXPORT AS SINGLE ' this function returns the spectral factor to be applied to tc0 such that the spectrum above tc0 ' contains a dissonance (triton) solvable into tc1 (i.e. it contains the sensible note in tc1 and the triton below it.) ' 04.09.2005 - gwr. '05.09.2005 - kl debugged. crash was an endless loop omdat sollnote 1 en 2 altijd vergeleken werden met dezelfde component van het spectrum ' - nu gesplitst in twee for-nexts LOCAL sf AS SINGLE LOCAL sfh AS SINGLE LOCAL sfl AS SINGLE LOCAL sollnote1 AS CURRENCY LOCAL sollnote2 AS CURRENCY LOCAL lth AS CURRENCY LOCAL ltl AS CURRENCY LOCAL RES AS SINGLE LOCAL i AS LONG LOCAL dif AS SINGLE LOCAL okflag AS LONG IF ISFALSE hilim THEN hilim = 127 IF tc1 > 11 THEN sollnote1 = tc1 - 1 sollnote2 = tc1 + 5 ELSE sollnote1 = tc1 + 11 sollnote2 = tc1 + 5 END IF FUNCTION = %False RES = MIN(resolution / 100!, 1!) sf = 1 sfh = %False sfl = %False ' eerst zoeken we bij de vergrotende spektra, vanaf sf > 1 DO sf = NextSpectralFactor (tc0,resolution/2, sf, Sp(), hilim) okflag = 0 FOR i = 0 TO UBOUND(Sp) ' note: will do sensible notes above or below next tonic (sym. harm) dif = ABS(Sp(i) - (((sollnote1 + RES/2) MOD 12) + (12 * (SP(i) \ 12)))) 'de formule direct in de vergelijking zetten geeft bugs. afrondfouten?? IF dif =< (RES / 2) THEN ''compare SP(i) with solnote transposed to the same octave okflag = 1 EXIT FOR END IF NEXT i IF ISFALSE okflag THEN ITERATE LOOP FOR i = 0 TO UBOUND(Sp) dif= ABS(Sp(i) - (((sollnote2 + RES/2) MOD 12) + (12 * (SP(i) \ 12)))) IF dif =< (RES/2) THEN sfh = sf lth = Sp(i) EXIT FOR END IF NEXT i IF sfh THEN EXIT DO LOOP UNTIL ISFALSE sf IF sfh THEN FUNCTION = sfh EXIT FUNCTION END IF ' indien niks gevonden, zoek vervolgens bij de verkleinende spektra: 'in de trance init komen we hier nooit.. sf = 1 ' reset sf IF tc1 > 11 THEN sollnote1 = tc1 - 1 sollnote2 = tc1 + 5 ELSE sollnote1 = tc1 + 11 sollnote2 = tc1 + 5 END IF i = NumberOfSpectralComponents (tc0,resolution,sf,Sp(),hilim) ' reset Sp() DO sf = PreviousSpectralFactor(tc0,resolution/2, sf, Sp(), hilim) IF ISFALSE sf THEN EXIT DO okflag = 0 FOR i = 0 TO UBOUND(Sp) dif = ABS(Sp(i) - (((sollnote1 + RES/2) MOD 12) + (12 * (Sp(i) \ 12)))) 'de formule direct in de vergelijking zetten geeft bugs. afrondfouten?? IF dif =< (RES / 2) THEN okflag = 1 EXIT FOR END IF NEXT i IF ISFALSE okflag THEN ITERATE LOOP FOR i = 0 TO UBOUND(Sp) dif= ABS(Sp(i) - (((sollnote2 + RES/2) MOD 12) + (12 * (Sp(i) \ 12)))) IF dif =< (RES/2) THEN sfl = sf ltl = Sp(i) EXIT DO END IF NEXT i IF sfl THEN EXIT DO LOOP UNTIL ISFALSE sf IF sfl THEN FUNCTION = sfl EXIT FUNCTION ELSE FUNCTION = %False END IF END FUNCTION FUNCTION InstrumTransposeToRange(BYREF m AS musician, OPT BYVAL mintes AS BYTE, OPT BYVAL maxtes AS BYTE) EXPORT AS LONG 'transposes note that are too high/low according to given limits, or to instrument properties if no limits given 'returns 0 if nothing changed, otherwise nr of changes LOCAL i AS LONG LOCAL trans AS LONG LOCAL changed AS LONG IF ISFALSE mintes THEN mintes = m.lowtes IF ISFALSE maxtes THEN maxtes = m.hightes FOR i = 1 TO mintes - 1 IF MID$(m.har(1).vel, i + 1, 1) <> CHR$(0) THEN INCR changed trans = 12 DO WHILE (i + trans) < mintes: trans = trans + 12: LOOP AddNote2har m.har(1), i + trans, ASC(MID$(m.har(1).vel, i + 1, 1)) DelNote2Har m.har(1), i END IF NEXT FOR i= 127 TO maxtes - 1 STEP -1 IF MID$(m.har(1).vel, i + 1, 1) <> CHR$(0) THEN INCR changed trans = 12 DO WHILE (i - trans) > maxtes: trans = trans + 12: LOOP 'was bug: i = i + 12: LOOP kl20051207 AddNote2har m.har(1), i - trans, ASC(MID$(m.har(1).vel, i + 1, 1)) DelNote2Har m.har(1), i END IF NEXT m.har(1).flag = %False FUNCTION = changed END FUNCTION ' [eof]