'******************************************************************* '* * '* harmony related library for GMT * '* Version 10.11 * '******************************************************************* '13.09.2005: creation date ' split off from g_mus because number of exports became too ' large for either compiler or windows. '14.09.2005: resource file added '17.01.2007: quartertone harmony support added '18.01.2007: Fuzzy consonance dipole function added '19.01.2007: Fuzzy products used instead of vector sums for fuzzyfication of properties. '20.01.2007: intensive debugging session. '22.01.2007: more harmony functions moved to g_har from g_mus '23.01.2007: all chord related harmony functions moved in an include file g_crd.inc '19.02.2007: some bugs in kons functions killed by kl. '10.02.2007: Lib. extended with dissonance functions after Herman Helmholtz (HH_ functions) ' these can be used as fractional midi chord constructors for diads, triads and tetrads. '13.02.2007: First debug of new HH functions by Kristof. '31.08.2008: adapted to PB9.0 - no changes required. '11.11.2010: CTS variables renamed to Ctns, since CTS became a reserved word. '03.04.2011: Ported to PBWin10.0 compiler '09.12.2011: Tone-clock harmony added to library: gwr & xtof '28-29.11.2012: extended with some functions for jazz harmony (15th chords) '08.08.2020: rechecked gwr. and found o.k. Some redundant statements removed. #COMPILER PBWIN 10 #COMPILE DLL "g_har.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_har.pbr" ' resource contains only version info and signature ' g_har.res is not working here! #INCLUDE ONCE "..\winapi\g_win.inc" ' reduced version of win32api #INCLUDE ONCE "g_kons.bi" ' only integer constants and strings can be declared in PB, floats are makros #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_mus.bi" %g_har_inc = %True #INCLUDE ONCE "g_har.bi" #INCLUDE ONCE "g_crd.inc" ' source for all chordnumber related harmony functions- created 22.01.2007 GLOBAL FuzInt() AS SINGLE ' read on initialisation GLOBAL QDipoles() AS QakuHarType ' lookup tables for consonance and dissonance of quartertones. ' also valid for chromatic notes. GLOBAL La AS SINGLE ' value set on init of dll GLOBAL GrondDo AS SINGLE ' calculated on initialisation GLOBAL Domq AS SINGLE ' idem. FUNCTION DLLMAIN(BYVAL hInstance AS LONG, _ BYVAL fwdReason AS LONG, _ BYVAL lpvReserved AS LONG) AS LONG LOCAL dummy AS SINGLE 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! ' for convolutions and spectrum analysis: (these need the diapason!) ' initialize the fuzzy data arrays: DIM FuzInt(11) AS GLOBAL SINGLE ' must be global array CALL GetFuzzyData(IniFileName, FuzInt()) ' needs explicit call for full array passing ' InifileName is a function in g_indep.dll ' dummy = DisMel(0,0) ' calls GetFuzzyMelo (FuzMel!()) in the dll. We do not need the data here! ' dummy = DisHar(0,0) ' calls GetFuzzyData (FuzInt!()) DIM QDipoles(255) AS GLOBAL QakuHarType ' lookup dummy = Qdip ' call function to make lookup CASE %DLL_PROCESS_DETACH, %DLL_THREAD_ATTACH, %DLL_THREAD_DETACH CASE ELSE DLLMAIN = %False END SELECT END FUNCTION SUB GetDefaultFuzzyHarValues (BYREF FuzInt() AS SINGLE) EXPORT ' called if no section found in inifile IF UBOUND(FuzInt) < 11 THEN REDIM FuzInt(11) AS GLOBAL SINGLE END IF FuzInt(0)= 0 FuzInt(1)= 1 FuzInt(2)= 0.75 FuzInt(3)= 0.4 FuzInt(4)= 0.3 FuzInt(5)= 0.05 FuzInt(6)= 0.85 FuzInt(7)= 0.05 FuzInt(8)= 0.27 FuzInt(9) = 0.32 FuzInt(10)= 0.67 FuzInt(11)= 0.91 END SUB FUNCTION Dishar (BYVAL i%, BYVAL j%) EXPORT AS SINGLE ' de naam van deze funktie moet veranderen. Teveel verwarring met har funkties. LOCAL interval%, Oktaven% ' Deze funktie retourneert de Fuzzy-dissonantiewaarde voor een vertikaal/ ' harmonisch interval (0-11). [samenklank: tweeklank] ' De input is een tweeklank in MIDI-nootwaarden: i%,j% ' Naarmate de afstand tussen i,j vergroot, moet ook de dissonantie van ' de samenklank verminderen. ' Dit rezultaat kan niet met de shepard konstruktie bereikt worden. ' Genormalizeerde mapping op de fuzzy eigenschap dissonantie. interval% = ABS(i% - j%) MOD 12 Oktaven% = ABS(i% - j%) \ 12 ' richting = SGN(n%(i%)-n%(j%)) ' vektorisatie - basis waarde: ' Di! = FuzInt!(Interval%) ' korrektie voor oktaafafstanden: ' de dissonantie verkleint naarmate de afstand groter is: FUNCTION = FuzInt(interval%) * ((10 - Oktaven%) / 10): ' fuzzy-produkt END FUNCTION SUB GetFuzzyData (f AS STRING, FuzInt!()) EXPORT ' called on dll initialisation. ' exported to allow users to change the data set. LOCAL a% LOCAL regel$, i% IF ISFALSE ExistFile (f) THEN 'IF %Wordy > 1 THEN MSGBOX "No ini-file found... Using default fuzzy set.",, FUNCNAME$ 'END IF ' if we do not find an external data file, we read default data residing in this procedure. GetDefaultFuzzyHarValues FuzInt!() ELSE a% = FREEFILE OPEN f FOR INPUT AS #a% DO WHILE ISTRUE(NOT EOF(a%)) LINE INPUT #a%, regel$ IF LEFT$(UCASE$(LTRIM$(regel$)), 20) = UCASE$("[IntervalDissonance]") THEN DO INPUT #a%, i%, FuzInt!(i%) LOOP UNTIL i% = 11 EXIT DO END IF LOOP CLOSE #a% END IF END SUB FUNCTION Dishar3 (BYVAL i%, BYVAL j%, BYVAL k%) EXPORT AS SINGLE ' Fuzzy dissonantie van drieklanken LOCAL a!, b!, c!, d! a! = Dishar!(i%, j%) b! = Dishar!(j%, k%) c! = Dishar!(i%, k%) ' hier moet een weging plaatsgrijpen. ' Immers de aanwezigheid van een kwint in een drieklank ' vermindert de dissonantie. ' get the Fuzzy values in order of size: IF a! < b! THEN SWAP a!, b! IF a! < c! THEN SWAP a!, c! IF b! < c! THEN SWAP b!, c! ' now: a! >=b! >= c! IF a! > .5 THEN IF b! > .5 THEN d! = a! + ((1 - a!) * b!) IF c! > .5 THEN d! = d! + ((1 - d!) * c!) ELSE d! = d! - ((1 - d!) * c!) END IF ELSE d! = a! - ((1 - a!) * b!) d! = d! - ((1 - d!) * c!) END IF ELSE d! = a! + ((1 - a!) * b!) d! = d! + ((1 - d!) * c!) d! = d! * d! ' ? END IF FUNCTION = d! END FUNCTION SUB ShowHarmFuz (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 diad dissonance. Reference note:" + STR$(noot%) + " :" m = "Fuzzy data for 2-note chords:" + CHR$(13) FOR nn = 0 TO 11 ' notes FOR i = 0 TO 10 ' octaves IF nn + (i*12) < 128 THEN m = m + FORMAT$(Dishar!(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 Richt (BYVAL i AS CUR, BYVAL j AS CUR) EXPORT AS INTEGER FUNCTION = SGN(j - i) END FUNCTION FUNCTION HarmFrameQual (ch%(), BYVAL maat%) EXPORT AS SINGLE LOCAL pt%, i%, Ctmp%() IF maat% > UBOUND(ch%, 1) THEN maat% = UBOUND(ch%, 1) DIM Ctmp%(maat%) ' we make a copy of the considered frame, and pass that to HarmQual! pt% = UBOUND(ch%, 1) FOR i% = maat% TO 0 STEP -1 Ctmp%(i%) = ch%(pt%) pt% = pt% - 1 NEXT i% FUNCTION = HarmQual(Ctmp%()) END FUNCTION FUNCTION HarmQual (ch%()) EXPORT AS SINGLE ' works on chordnumbers LOCAL norm!, tsq!, ssq!, FuzVal!, fv! LOCAL NrChords%, i%, crd%, crd2% LOCAL Dch!() norm! = .15: ' this has to be proved... (centroid) NrChords% = UBOUND(ch%) IF NrChords% = %False THEN FUNCTION = 0: EXIT FUNCTION ' bereken de dissonantie van elk akkoord in het array DIM Dch!(NrChords%) i% = 0 DO IF Cons(ch%(i%)) = 0 THEN ' calculate the chorddissonance: Dch!(i%) = GetDissonance(ch%(i%)): 'GetConsonance!(Ch%(i%)) ' indien deze dissonantie groter is dan de normwaarde, ga dan de ' validiteit na van de opeenvolging: ' Wanneer het akkoord wordt opgelost, vermindert de onaanvaardbaarheid ' van de akkoordsekwens, tot zelfs 0 bij goede oplossing. IF (Dch!(i%) > norm!) AND (i% < NrChords%) THEN ' onderzoek de eventuele kleine sekonden,gr. sek, triton... crd% = ch%(i%): ' huidig akkoord crd2% = ch%(i% + 1): ' volgend akkoord ' return a fuzzy value for the sequence crd%-crd2%: tsq! = TritSolveQual(crd%, crd2%): ' 1= perfect, 0= bad ssq! = SecSolveQual(crd%, crd2%): ' 1= perfect, 0= bad FuzVal! = tsq! * ssq!: ' product or average? 'FuzVal! = (tsq! + ssq!) / 2! IF FuzVal! < Dch!(i%) THEN SWAP Dch!(i%), FuzVal! END IF ELSE ' perfekte konsonant... Dch!(i%) = 1 END IF INCR i% 'i% = i% + 1 LOOP UNTIL i% > NrChords% ' calculate the integral over time: FOR i% = 0 TO NrChords% fv! = fv! + (Dch!(i%) * ((i% + 1!) / NrChords%)) NEXT i% ' normalize the result: fv! = fv! / ((NrChords% + 1) * 2!) FUNCTION = fv! END FUNCTION FUNCTION Cons (BYVAL crd%) EXPORT AS INTEGER ' returns true or false depending on whether the chord is ' a pure consonant or not. Needs the binary constants (%d0-%d11) ' This is a very classical function. LOCAL MinorMask%, MajorMask%, SymMask%, nr%, n% LOCAL kl3%, gr3%,fo%,fi%, fip%,sx% MinorMask% = %d0 + %d3 + %d7 MajorMask% = %d0 + %d4 + %d7 SymMask% = %d0 + %d4 + %d8 nr% = GetNrNotes(crd%) SELECT CASE nr% CASE 0 FUNCTION = 1: EXIT FUNCTION CASE 1 FUNCTION = 1: EXIT FUNCTION CASE 2 ' zoek kl-terts, grote terts, kwart, kwint, vergrote kwint ... ' er zijn slechts 6 konsonante tweeklanken. n% = %False kl3% = %d0 + %d3 gr3% = %d0 + %d4 fo% = %d0 + %d5 fi% = %d0 + %d7 fip% = %d0 + %d8 sx% = %d0 + %d9 DO IF (crd% AND kl3%) = kl3% THEN FUNCTION = 1: EXIT FUNCTION IF (crd% AND gr3%) = gr3% THEN FUNCTION = 1: EXIT FUNCTION IF (crd% AND fo%) = fo% THEN FUNCTION = 1: EXIT FUNCTION IF (crd% AND fi%) = fi% THEN FUNCTION = 1: EXIT FUNCTION IF (crd% AND fip%) = fip% THEN FUNCTION = 1: EXIT FUNCTION IF (crd% AND sx%) = sx% THEN FUNCTION = 1: EXIT FUNCTION kl3% = Rol(kl3%, 1) gr3% = Rol(gr3%, 1) fo% = Rol(fo%, 1) fi% = Rol(fi%, 1) fip% = Rol(fip%, 1) sx% = Rol(sx%, 1) INCR n% LOOP UNTIL n% = 12 CASE 3 n% = %False DO IF (crd% AND MinorMask%) = MinorMask% THEN FUNCTION = 1: EXIT FUNCTION IF (crd% AND MajorMask%) = MajorMask% THEN FUNCTION = 1: EXIT FUNCTION IF (crd% AND SymMask%) = SymMask% THEN FUNCTION = 1: EXIT FUNCTION MinorMask% = Rol(MinorMask%, 1) MajorMask% = Rol(MajorMask%, 1) SymMask% = Rol(SymMask%, 1) INCR n% LOOP UNTIL n% = 12 CASE > 3 FUNCTION = %False END SELECT END FUNCTION FUNCTION GetConPsy (Har AS HarmType) AS SINGLE ' changed: mat% - is reserved word in PBcc ' no longer exported. ' get same result with fillhartype with parameter %use_fuzzypsy ' result will be placed in Har.Kon LOCAL n%, il%, faktor!, matt%, Coef57!, Coef4!, Coef3!, f!, n57%, Crn% LOCAL n4%, n3%, mit%, fl%, d!, t! n% = 0 FOR il% = 0 TO 11 IF Har.c(il%) > 0 THEN INCR n% Crn% = AddNoteInChord(Crn%, il% + 12) END IF NEXT il% SELECT CASE n% CASE 0, 12 Har.Kon = 0 FUNCTION = Har.Kon EXIT FUNCTION CASE 1 Har.Kon = 1 FUNCTION = Har.Kon EXIT FUNCTION CASE 2, 3 ' isoleer de klassieke konsonanten, deze moeten steeds 1 retourneren IF Cons%(Crn%) THEN Har.Kon = 1 FUNCTION = Har.Kon EXIT FUNCTION ELSE faktor! = 1 END IF CASE ELSE faktor! = 4! / (n% + 1): ' 4/5 -> 4/12 or 0.8 to 0.3 END SELECT Coef57! = 1 Coef4! = 1 Coef3! = 1 f! = 0 ' kwintsterktefaktor. n57% = 0 n4% = 0 n3% = 0 ' count the number of fourths/fifths in the chord: FOR il% = 0 TO 11 IF Har.c(il%) > 0 THEN fl% = (il% + 7) MOD 12 matt% = (il% + 4) MOD 12 mit% = (il% + 3) MOD 12 IF Har.c(fl%) > 0 THEN f! = f! + (Har.c(il%) * Har.c(fl%) * Coef57!) INCR n57% '= n57% + 1 END IF IF Har.c(matt%) > 0 THEN t! = t! + (Har.c(il%) * Har.c(matt%) * Coef4!) INCR n4% '= n4% + 1 END IF IF Har.c(mit%) > 0 THEN d! = d! + (Har.c(il%) * Har.c(mit%) * Coef3!) INCR n3% '= n3% + 1 END IF END IF NEXT il% IF n57% THEN f! = f! / n57% ELSE f! = 0 IF n4% THEN t! = t! / n4% ELSE t! = 0 IF n3% THEN d! = d! / n3% ELSE d! = 0 Har.Kon = faktor! * ((f! + t! + d!) / 3) FUNCTION = Har.Kon END FUNCTION FUNCTION GetDisPsy (Har AS HarmType) AS SINGLE ' this function does not use the harmstring for the result. ' no longer exported. ' result can be obtained with fillHartype and flag = %use_fuzzypsy LOCAL n AS DWORD LOCAL il AS DWORD LOCAL mins AS DWORD LOCAL majs AS DWORD LOCAL trit AS DWORD LOCAL Crn% LOCAL d!, retval! STATIC Toggle%, Coef1!, Coef2!, Coef6!, Normfaktor! IF ISFALSE Toggle% THEN Coef1! = 11 '6 ' Coef1! added to d! for every semitone in the chord Coef2! = 5 '3 ' Coef2! 'bad' points added for every whole tone: Coef6! = 7 '8 ' bad points for tritons. Normfaktor! = (Coef1! * 12) + (Coef2! * 12) + (Coef6! * 6) Toggle% = %True END IF ' returns a normalized fuzzy value for the weighted dissonance ' of Har.C() taking into account toneness-amplitudes. ' Of course Har.C() must have been set on init. ' first we eliminate the pure consonants, as they must always return 0 ' regardless the amplitudes. n = 0 FOR il = 0 TO 11 IF Har.c(il) > 0 THEN INCR n: Crn% = AddNoteInChord(Crn%, il + 12) NEXT il IF Cons%(Crn%) THEN Har.Dis = 0: FUNCTION = Har.Dis: EXIT FUNCTION d! = 0 FOR il = 0 TO 11 mins = (il + 1) MOD 12 majs = (il + 2) MOD 12 Trit = (il + 6) MOD 12 IF Har.c(il) > 0 THEN IF Har.c(mins) > 0 THEN d! = d! + (Har.c(il) * Har.c(mins) * Coef1!) END IF IF Har.c(majs) > 0 THEN d! = d! + (Har.c(il) * Har.c(majs) * Coef2!) END IF IF il < 7 THEN IF Har.c(Trit) > 0 THEN d! = d! + (Har.c(il) * Har.c(Trit) * Coef6!) END IF END IF END IF NEXT il retval! = d! / Normfaktor! Har.Dis = retval! ^ (1 / n) ' curve-shaping after root FUNCTION = Har.Dis END FUNCTION SUB SortChordsOnDissonance (BYREF Akk() AS INTEGER, BYVAL param AS WORD, BYVAL velo AS BYTE) EXPORT ' pass an empty array on entry, to receive the chordnumbers ' param: %SortChordNumbers = bit 0 ' %SortAkuHarmChord = bit 1 ' %SortPsyChord = bit 2 ' set the tonality nibble on entry ! (high nibble of param) ' velo is not used with chordnumbers. LOCAL i AS INTEGER LOCAL j AS INTEGER LOCAL n AS WORD LOCAL normdis AS SINGLE LOCAL dissonance AS SINGLE LOCAL found AS BYTE LOCAL index AS WORD LOCAL h AS HARMTYPE LOCAL tc AS WORD LOCAL minnr AS WORD LOCAL maxnr AS WORD LOCAL b AS BYTE LOCAL nrnotes AS BYTE LOCAL nrchords AS WORD LOCAL isomorph AS BYTE LOCAL Dis() AS DWORD 'SINGLE tc = param AND &H0F000 ' tonal center nibble minnr = param AND &H00F0 ' minimum amount of notes to consider in the chord SHIFT RIGHT minnr, 4 IF minnr < 1 THEN minnr = 1 ' no zero chords... maxnr = param AND &H0F00 ' maximum amount of notes in chord to be considered SHIFT RIGHT maxnr, 8 IF maxnr > 12 THEN maxnr = 12 IF maxnr < minnr THEN maxnr = 12 ' safety... IF minnr > maxnr THEN minnr = maxnr -1 ' to speed up the search, we first check all chords for limiting conditions: REDIM Akk(0) AS INTEGER DIM Dis(0) AS DWORD 'SINGLE j = -1 FOR i = 1 TO &H0FFF ' check the conditions -minimum number of notes and maximum number of notes... nrnotes = %False b = %False DO IF BIT(i,b) THEN INCR nrnotes ' was istrue bug INCR b LOOP UNTIL b = 12 ' check condition nr of notes in chordnumber... IF (nrnotes >= minnr) AND (nrnotes <=maxnr) THEN ' check , in case the flag is set, whether such chord is not already in the array... IF BIT(param,%SortNoIsomorphs) THEN isomorph = %False FOR n = 0 TO UBOUND(Akk) IF SameChord (i,Akk(n)) THEN ' was istrue bug isomorph = %True EXIT FOR END IF NEXT n ELSE isomorph = %False END IF ' ---------------------------------------------------------------------------------- IF ISFALSE isomorph THEN INCR j ' -1 on entry REDIM PRESERVE Akk(j) AS INTEGER REDIM PRESERVE Dis(j) AS DWORD 'SINGLE Akk(j) = i OR tc IF BIT(param,%SortChordNumbers) THEN ' calculate the dissonance using chordnumbers, Dis(j) = GetDissonance(i OR tc) * 100000! ELSEIF BIT(param,%SortAkuHarmChord) THEN ' or - alternative using the aku functions: h.vel = NUL$(128) AddCnr2Har h, i OR tc, 1, 127, (velo) 'FillHarType h Dis(j) = GetAkuDis(h,velo) * 100000! ' use the non exported function with flag for velo ELSEIF BIT(param,%SortPsyChord) THEN ' or - using the fuzzy values... h.vel = NUL$(128) AddCnr2Har h, i OR tc, 1, 127, (velo) GetPsiChord h Dis(j) = GetDisPsy(h) * 100000! ELSE MSGBOX "SortChords called with invalid parameter" EXIT SUB END IF END IF END IF NEXT i ' now we can use array sort, to sort Akk() in order of dissonance... ' Dis() as an array of singles did'nt work well with the compiler... ARRAY SORT Dis(0) FOR UBOUND(Dis)+1, TAGARRAY Akk(), ASCEND ' after this, Akk() is ordered according to increasing dissonance END SUB SUB SortChordsOnConsonance (BYREF Akk() AS INTEGER, BYVAL param AS WORD, BYVAL velo AS BYTE) EXPORT ' pass an empty array on entry, to receive the chordnumbers ' param: %SortChordNumbers = 0 ' %SortAkuHarmChord = 1 ' set the tonality nibble on entry ! (high nibble of param) ' velo is not used with chordnumbers. LOCAL i AS INTEGER LOCAL j AS DWORD LOCAL normcon AS SINGLE LOCAL consonance AS SINGLE LOCAL found AS BYTE LOCAL index AS WORD LOCAL h AS HARMTYPE LOCAL tc AS WORD LOCAL minnr AS WORD LOCAL maxnr AS WORD LOCAL b AS BYTE LOCAL nrnotes AS BYTE LOCAL nrchords AS WORD tc = param AND &H0F000 minnr = param AND &H00F0 SHIFT RIGHT minnr, 4 IF minnr < 1 THEN minnr = 1 maxnr = param AND &H0F00 SHIFT RIGHT maxnr, 8 IF maxnr > 12 THEN maxnr = 12 IF maxnr < minnr THEN maxnr = 12 ' safety... ' calculate the number of chords: (use lookup, for speed. Newtons binomium is too slow) nrchords = %False FOR i = minnr TO maxnr SELECT CASE i CASE 1,11 nrchords = nrchords + 12 ' 12 0ne-note chords. CASE 2,10 nrchords = nrchords + 66 ' 66 diads CASE 3, 9 nrchords = nrchords + 220 CASE 4, 8 nrchords = nrchords + 495 CASE 5, 7 nrchords = nrchords + 792 CASE 6 nrchords = nrchords + 924 CASE 12 nrchords = nrchords + 1 ' 1 12-note chord END SELECT NEXT i ' for debug: test our binomialcomb function... IF BinomialComb(12,5) <> 792 THEN MSGBOX "Error [12,5] in binomium" ' calculate all 4096 possible chords and sort them in order of increasing dissonance REDIM Akk(nrchords) AS INTEGER ' allocate memory... normcon = %False FOR normcon = 0 TO 1! STEP (1!/nrchords) FOR i = 1 TO &H0FFF ' check all possible chords... ' check the conditions -minimum number of notes and maximum number of notes... nrnotes = %False b = %False DO IF BIT(i,b) THEN INCR nrnotes ' was istrue bug INCR b LOOP UNTIL b = 12 IF nrnotes >= minnr AND nrnotes <=maxnr THEN IF BIT(param,%SortChordNumbers) THEN ' calculate the consonance using chordnumbers, consonance = GetConsonance(i OR tc) ELSEIF BIT(param,%SortAkuHarmChord) THEN ' or - alternative using the aku functions: h.vel = NUL$(128) AddCnr2Har h, i OR tc, 1, 127, (velo) 'FillHarType h consonance = GetAkuCons(h) ELSEIF BIT(param,%SortPsyChord) THEN h.vel = NUL$(128) AddCnr2Har h, i OR tc, 1, 127, (velo) GetPsiChord h consonance = GetConPsy(h) ELSE MSGBOX "SortChordsOnConsonance called with invalid parameter" EXIT SUB END IF IF consonance <= normcon THEN ' check whether this chord is not already in our array: Found = %False FOR j = 0 TO index IF (i OR tc) = Akk(j) THEN Found = %True NEXT j IF ISFALSE Found THEN Akk(index) = i OR tc INCR index IF index > UBOUND(Akk) THEN EXIT SUB END IF END IF END IF NEXT i NEXT j REDIM PRESERVE Akk(index-1) AS INTEGER END SUB FUNCTION FuzFrameVar (crd%(), BYVAL siz%) EXPORT AS SINGLE ' this returns a fuzzy value for the amount of chordal ' variation in the array passed, measured over size. ' There is no weighting in this function. LOCAL m%, pt%, cnt%, il%, jl%, pr% LOCAL tss! m% = UBOUND(crd%,1) IF siz% > m% THEN siz% = m% SELECT CASE m% CASE 0 FUNCTION = 1: EXIT FUNCTION CASE 1 IF crd%(0) = crd%(1) THEN FUNCTION = 0 ELSE FUNCTION = 1 END IF CASE 2 pt% = 0 IF crd%(0) = crd%(1) THEN pt% = pt% + 1 IF crd%(1) = crd%(2) THEN pt% = pt% + 1 IF crd%(2) = crd%(0) THEN pr% = pt% + 1 FUNCTION = 1! - (pt% / 3!) CASE ELSE pt% = 0: cnt% = 0 FOR il% = m% - siz% TO m% - 1 FOR jl% = il% + 1 TO m% IF crd%(il%) = crd%(jl%) THEN pt% = pt% + 1 END IF cnt% = cnt% + 1 NEXT jl% NEXT il% tss! = pt% / cnt% FUNCTION = 1! - tss! END SELECT END FUNCTION FUNCTION GetConsonance (BYVAL crd%) EXPORT AS SINGLE STATIC oldtc%, oldcrd%, Oldretval! LOCAL tc%, nn%, c!, faktor!, f%, chk%, n%, t%, d% tc% = GetTc(crd%) IF (tc% = oldtc%) AND (crd% = oldcrd%) THEN FUNCTION = Oldretval! : EXIT FUNCTION oldcrd% = crd% oldtc% = tc% nn% = GetNrNotes(crd%) SELECT CASE nn% CASE 0 Oldretval! = 0 FUNCTION = 0 EXIT FUNCTION CASE 1 IF tc% > %NotFalse THEN 'was :IF (crd% AND EXP2((tc% + 0) MOD 12)) > %False THEN c! = 1 etc... IF BIT(crd%,tc% MOD 12) THEN c! = 1 IF BIT(crd%,(tc% +2) MOD 12) THEN c! =1 IF BIT(crd%,(tc% +3) MOD 12) THEN c! =1 IF BIT(crd%,(tc% +4) MOD 12) THEN c! =1 IF BIT(crd%,(tc% +5) MOD 12) THEN c! =1 IF BIT(crd%,(tc% +7) MOD 12) THEN c! =1 IF BIT(crd%,(tc% +9) MOD 12) THEN c! =1 IF BIT(crd%,(tc% +11) MOD 12) THEN c! =1 IF BIT(crd%,(tc% +1) MOD 12) THEN c! =0.5 IF BIT(crd%,(tc% +6) MOD 12) THEN c! =0.4 IF BIT(crd%,(tc% +8) MOD 12) THEN c! =0.6 IF BIT(crd%,(tc% +10) MOD 12) THEN c! = 0.7 ELSE c! = 1 END IF Oldretval! = c! FUNCTION = Oldretval! EXIT FUNCTION CASE 2 faktor! = 1 CASE 3 faktor! = 1 CASE 4 TO 9 faktor! = 4! / (nn% + 1) CASE 10 Oldretval! = .003 FUNCTION = Oldretval! EXIT FUNCTION CASE 11 Oldretval! = .001 FUNCTION = Oldretval! EXIT FUNCTION CASE 12 Oldretval! = 0 FUNCTION = 0 EXIT FUNCTION END SELECT f% = %False: n% = 0 ' count the number of fourths/fifths in the chord: chk% = %d0 OR %d7 DO IF (crd% AND chk%) = chk% THEN INCR f% ' f% = f% + 1 chk% = Rol(chk%, 1) INCR n% ' n% = n% + 1 LOOP UNTIL n% = 12 SELECT CASE f% CASE 0: c! = 5 CASE 1: c! = 12 ' maximum waarde. CASE 2: c! = 8 CASE 3: c! = 6 CASE 4: c! = 4 CASE 5: c! = 2 CASE > 5: c! = 0 END SELECT ' count major thirds: t% = 0: n% = 0: chk% = %d0 OR %d4 DO IF (crd% AND chk%) = chk% THEN INCR t% ' t% = t% + 1 chk% = Rol(chk%, 1) INCR n% ' n% = n% + 1 LOOP UNTIL n% = 12 ' het akkoord mag slechts 1 grote terts bevatten SELECT CASE t% CASE 0: c! = c! + 5 CASE 1: c! = c! + 12 CASE 2: c! = c! + 8 CASE 3: c! = c! + 6 CASE 4: c! = c! + 4 CASE 5: c! = c! + 2 CASE 6: c! = c! + 0 END SELECT ' zoek en tel kleine tertsen: d% = 0: n% = 0: chk% = %d0 OR %d3 DO IF crd% AND chk% = chk% THEN INCR d% ' d% = d% + 1 chk% = Rol(chk%, 1) INCR n% ' n% = n% + 1 LOOP UNTIL n% = 12 ' er mag er slechts 1 zijn. SELECT CASE d% CASE 0: c! = c! + 5 CASE 1: c! = c! + 12 CASE 2: c! = c! + 8 CASE 3: c! = c! + 6 CASE 4: c! = c! + 4 CASE 5: c! = c! + 2 CASE 6: c! = c! + 0 END SELECT ' Uitzondering: IF (f% = 0) AND (t% = 3) AND (d% = 0) AND (nn% = 3) THEN c! = 36 ' adjust faktor voor niet laddereigen noten: IF tc% > -1 THEN IF BIT(crd%,(tc%+1) MOD 12) THEN faktor! = faktor! * 0.6 IF BIT(crd%,(tc%+6) MOD 12) THEN faktor! = faktor! * 0.5 IF BIT(crd%,(tc%+8) MOD 12) THEN faktor! = faktor! * 0.8 IF BIT(crd%,(tc%+10) MOD 12) THEN faktor! = faktor! * 0.7 END IF c! = c! * faktor! Oldretval! = c! / 36! FUNCTION = Oldretval! END FUNCTION FUNCTION GetDissonance (BYVAL crd%) EXPORT AS SINGLE STATIC oldtc%, oldcrd%, Oldretval! LOCAL tc%, d%, n%, chk% tc% = GetTc(crd%) IF (tc% = oldtc%) AND (crd% = oldcrd%) THEN FUNCTION = Oldretval!: EXIT FUNCTION oldcrd% = crd% oldtc% = tc% d% = %False ' 6 points added to d% for every semitone n% = 0: chk% = %d0 + %d1 DO IF (crd% AND chk%) = chk% THEN d% = d% + 6 chk% = Rol(chk%, 1) INCR n% LOOP UNTIL n% = 12 ' 3'bad' points added for every whole tone n% = 0: chk% = %d0 + %d2 DO IF (crd% AND chk%) = chk% THEN d% = d% + 3 chk% = Rol(chk%, 1) INCR n% LOOP UNTIL n% = 12 ' tritonussen - 8 bad points n% = 0: chk% = %d0 + %d6 DO IF (crd% AND chk%) = chk% THEN d% = d% + 8 chk% = Rol(chk%, 1) INCR n% LOOP UNTIL n% = 6 ' zoek laddervreemde noten IF tc% > -1 THEN IF BIT(crd%,(tc% +1) MOD 12) THEN d% = d% +5 IF BIT(crd%,(tc% +6) MOD 12) THEN d% = d% +6 IF BIT(crd%,(tc% +8) MOD 12) THEN d% = d% +4 IF BIT(crd%,(tc% +10) MOD 12) THEN d% = d% +3 END IF Oldretval! = d% / 186! FUNCTION = Oldretval! END FUNCTION SUB AddCnr2Har (Har AS HarmType, BYVAL Cnr%, BYVAL l%, BYVAL h%, BYVAL v%) EXPORT LOCAL ov AS BYTE LOCAL nv AS BYTE LOCAL n AS INTEGER IF l% > h% THEN SWAP l%, h% IF h% > 127 THEN h% = 127 IF l% < %False THEN l% = %False IF v% > 127 THEN v% = 127 IF v% < %False THEN v% = %False FOR n = l% TO h% IF IsNoteInChord(Cnr%, n) THEN ov = ASC(MID$(Har.vel, n + 1, 1)) nv = v% * GetShepVal(n) nv = SumVelo(nv, ov) MID$(Har.vel, n + 1, 1) = CHR$(nv) END IF NEXT n Har.flag = %False END SUB ' *************************************************************************** ' * Quartertone library * ' * 2006-2007 * ' *************************************************************************** FUNCTION GetDipoleDis (BYVAL f1%, BYVAL v1%, BYVAL f2%, BYVAL v2%) EXPORT AS SINGLE ' this is the fundamental function for the calculation of the dissonance of an acoustical dipole based on ' the frequency of the pitches and their loudness. LOCAL centroid!, retval!, disson!, weight! ,fc!,fb! LOCAL f3% , fdif% centroid! = 23!: ' must be < 28 IF f1% > f2% THEN SWAP f1%, f2%: SWAP v1%, v2% IF f1% = f2% THEN GetDipoleDis! = 0: EXIT FUNCTION IF (v1% + v2%) <= 1 THEN GetDipoleDis! = 0: EXIT FUNCTION retval! = 0 disson! = 0 'weight! = sumvelo(v1% , v2%) / 127 ' fout, wordt nooit kleiner dan de kleinste waarde... weight! = SQR(v1% * v2%) / 127 ' 0-1 ' centrale frekwentie voor de bandbreedte tussen beide noten: f3% = SQR((f1% ^ 2) + (f2% ^ 2)) ' 8 - 28284 ' wanneer de beide tonen nu buiten de kritische ' bandbreedte rond deze toon vallen, is er geen dissonantie: ' Benaderingformule voor de kritische bandbreedte: fc! = f3% / 1000!: ' in kHz ' 0.008 - 28.284 fb! = (6.23 * fc! * fc!) + (93.39 * fc!) + 28.52 ' 29.26 - '(cfr.Leman, p.11) IF f2% > f1% + fb! THEN 'disson! = 0 FUNCTION = 0: EXIT FUNCTION ELSE ' mooi algoritme voor dissonantie... ' we kunnen een beta-kurve gebruiken met een maximum ' piek rond 23Hz en een breedte gelijk aan de ' kritische bandbreedte, maar omdat dit hier erg ' rekenintensief is, gebruiken we eerder een ' lineaire benadering, zoals gebruikelijk in Fuzzy (driehoekskurve). fdif% = f2% - f1% IF fdif% <= centroid! THEN disson! = fdif% / centroid! ELSE disson! = centroid! / fdif% END IF ' checked with PBCC test program: the range for disson = 3.822503E-3 to 1 END IF FUNCTION = SQR((disson! ^ 2) * (weight! ^ 2)) ' fuzzy product, not vector sum. ' vector sum would be: 'function = sqr((disson!^2) + (weight!^2)) / sqr(2) ' 19.01.2006, so scaling is 0-1 ' but this is clearly faulty since with weight zero, we could still have dissonance = 0.714 ' and with disson = zero but weight = 1 also... END FUNCTION FUNCTION GetDipoleKon (BYVAL f1 AS SINGLE, BYVAL v1%, BYVAL f2 AS SINGLE, BYVAL v2%) EXPORT AS SINGLE ' gwr function for calculation of fuzzy consonance of a simultaneous dipole ' written 16.01.2007 - 18.01.2007 ' te evalueren !!! LOCAL centroid!, disson!, weight! ,fc!,fb! LOCAL retval AS SINGLE LOCAL f3 AS SINGLE LOCAL fdif AS SINGLE LOCAL trit AS SINGLE LOCAL dif AS SINGLE LOCAL okt AS LONG FUNCTION = 0.5 ' default return value for non resolved cases centroid! = 23! ' must be < 28 'weight! = (SQR((v1%^2) + (v2%^2)))/ 179.605122 ' 0-1 trajekt. weight! = SQR(v1% * v2%) / 127 'weight! = sumvelo(v1%, v2%) / 127 ' 0-1 IF f1 > f2 THEN SWAP f1, f2 SWAP v1%, v2% END IF IF f1 = f2 THEN FUNCTION = 1 EXIT FUNCTION ' are unisons konsonants? END IF 'bereken eerst de zwevingen van de verschiltoon: f3 = f2 - f1 ' in Hz SELECT CASE f3 CASE < 0 'warning "impossible",100 CASE <= centroid! retval = 1 - (f3/centroid!) ' 0-1 1=konsonant 'fc! = SQR((fc!^2) + (weight!^2)) / sqr(2) 'fc! = fc! * weight! ' by 0 verschilfreq. is centroid-f3/centroid = 1 en hebben we grotere konsonantie ' by 23Hz verschilfreq is centroid - f3/centroid = 0 en hebben we nul konsonantie 'IF fc! > 1 THEN Warning "overflow error 1 " ,100 IF retval <= 0.7 THEN retval = retval / 2 GOTO weging END IF CASE =< centroid! * 2 f3 = f3 - centroid! ' 0 - centroid retval = f3 / centroid! ' 0-1 1 = konsonant 'fc! = SQR((fc!^2) + (weight!^2)) / sqr(2) 'fc! = fc! * weight! 'fc! = SQR((((f3 - centroid!)/ centroid!)^2) + (weight! ^2)) ' by 46hz verschilfreq is dit 1 en hebben we konsonantie ' by 23Hz verschilfreq is dit o en hebben we nul konsonantie 'IF fc! > 1 THEN Warning "overflow error 2", 100 IF retval <= 0.7 THEN retval = retval / 2 GOTO weging END IF END SELECT ' bereken het aantal oktaven tussen beide frekwenties: okt = 0 f3 = f2 IF f3 > f1 * 2 THEN DO f3 = f3/2 INCR okt LOOP UNTIL f3 =< (f1 * 2) END IF ' okt loopt nu van 0 tot het aantal oktaven 0 - 11 ' fuzzyfikatie van het tritonusgebied: LOCAL n3 AS SINGLE LOCAL n1 AS SINGLE n3 = F2NF(f3) ' fractional midi note, n3 is > n1 n1 = F2NF(f1) trit = (n3 - n1) - 6 ' if this is 0, we have a pure triton ' if this is 1, we have a pure fifth ' if this is -1, we have a pure fourth dif = ABS(trit) IF dif <= 1.0 THEN retval = dif / (1 + okt) '(2^okt) 'kl voorstel - was (2^okt) GOTO weging END IF IF dif <= 1.5 THEN retval = (1.0 / dif) / (1 + okt) '(2^okt) GOTO weging END IF ' fuzzyfikatie rond de oktaven: LOCAL ok AS SINGLE ok = (n3 - n1) - 12 ' if this is 0, we have a pure octave and konsonant ' if this is 1, we have a minor ninth not konsonant ' if this is -1, we have a major seventh not konsonant IF ABS(ok) <= 1 THEN dif = 1 - ABS(ok) ' so we invert ' IF (dif <= 1.0) and (dif >= 0) THEN retval = dif / (1 + okt/10) 'kl voorstel - bewust een minder gewicht door de oktaven tussen f1 en f2 dan bij tritonus.. was (2^okt) GOTO weging ' END IF END IF IF ABS(ok) <= 2 THEN '1.5 THEN dif = ABS(ok) '1 to 2 ' nu trajekt 1 to 1.5 dif = dif -1 '0 - 1 ' nu 0 - 0.5 0 = gr.septiem of kl.none= niet konsonant retval = dif / (1 + okt/10) '(2^okt) GOTO weging END IF ' IF (dif > 0) and (dif <= 1.5) THEN ' fc! = (1.0 / dif) / (1 + okt/2) '(2^okt) ' FUNCTION = fc! * weight! ' EXIT FUNCTION ' END IF ' IF (dif >= -0.5) AND (dif < 0) THEN ' grondig checken.... ' dif = abs(dif) ' 0.5 ---0 'dif + 0.5 ' 0 - 0.5 ' dif = 1 - dif ' 0.5 --- 1 ' fc! = (dif) / (1 + okt/2) '(2^okt) ' FUNCTION = fc! * weight! ' EXIT FUNCTION ' END IF ' fuzzyfikatie rond the harmonische tertsen en sixten: LOCAL interval AS SINGLE interval = f3/f1 SELECT CASE interval 'case ((6/5) - 0.06) to ((6/5) + 0.06) ' 6/5 = kleine terts , 5% afwijking CASE 1.14 TO 1.22375 '1.26 dif = ABS(interval - (6/5)) ' indien 0 hebben we konsonantie. max. value = 0.012 * 5 ' normalize: dif = dif * (1/0.06) ' invert: dif = 1 - dif ' 1 = kleine terts eigenschap maximaal aanwezig. fc! = (dif/2) / (1+ okt) retval = 0.4 + fc! GOTO weging 'case (5/4) - 0.0625 to (5/4) + 0.0625 ' 5/4 = grote terts CASE 1.22375 TO 1.3125 ' ander overlap: 1.1875 to 1.3125 dif = ABS(interval - (5/4)) ' indien 0 hebben we konsonantie. max. value = 0.0125 *5 ' normalize: dif = dif * (1/0.0625) ' invert: dif = 1 - dif ' 1 = grote terts eigenschap maximaal aanwezig. fc! = (dif/2) / (1+ okt) retval = 0.4 + fc! GOTO weging 'case (8/5) - 0.08 to (8/5) + 0.08 ' 8/5 sixt CASE 1.52 TO 1.631666 '1.68 dif = ABS(interval - (8/5)) ' indien 0 hebben we konsonantie. max. value = 0.016 * 5 ' normalize: dif = dif * (1/0.08) ' invert: dif = 1 - dif ' 1 = kleine sixt eigenschap maximaal aanwezig. fc! = (dif/2) / (1+ okt) retval = 0.4 + fc! GOTO weging 'case (5/3) - 0.08333 TO (5/3) + 0.08333 ' 5/3 sixt CASE 1.631666 TO 1.749999 '1.58333 TO 1.749999 dif = ABS(interval - (5/3)) ' indien 0 hebben we konsonantie. max. value = 0.0166 ' normalize: dif = dif * (1/0.08333) ' invert: dif = 1 - dif ' 1 = kleine terts eigenschap maximaal aanwezig. fc! = (dif/2) / (1+ okt) retval = 0.4 + fc! GOTO weging END SELECT ' voor weinige overige gevallen, keren we de dissonantie funktie om, indien er dissonantie is disson! = 0 ' centrale frekwentie voor de bandbreedte tussen beide noten: f3 = SQR((f1 ^ 2) + (f2 ^ 2)) ' wanneer de beide tonen nu buiten de kritische ' bandbreedte rond deze toon vallen, is er geen dissonantie: ' Benaderingformule voor de kritische bandbreedte: fc! = f3 / 1000!: ' in kHz fb! = (6.23 * fc! * fc!) + (93.39 * fc!) + 28.52 '(cfr.Leman, p.11) IF f2 > f1 + fb! THEN 'disson! = 0 'FUNCTION = 0.5 * weight! ' neutraal retval = 0.5 GOTO weging ELSE ' mooi algoritme voor dissonantie... ' we kunnen een beta-kurve gebruiken met een maximum ' piek rond 23Hz en een breedte gelijk aan de ' kritische bandbreedte, maar omdat dit hier erg ' rekenintensief is, gebruiken we eerder een ' lineaire benadering, zoals gebruikelijk in Fuzzy (driehoekskurve). fdif = f2 - f1 IF fdif <= centroid! THEN disson! = fdif / centroid! ELSE disson! = centroid! / fdif END IF END IF retval = (1 - disson!) / 2 ' 0 - 0.5 ' apply weighting with conservation of median value 0.5 ' as for the dissonance function, weight is not a vector sum but a fuzzy product here. weging: ' retval = (retval * 2) - 1 ' shift to traject -1 - 0 - +1 ' retval = retval * weight! ' so weight has no influence in the median area ' retval = (retval/2) + 0.5 ' restore the 0 - 1 traject. ' eenvoudiger formulering: FUNCTION = 0.5 + ((retval - 0.5) * weight!) END FUNCTION FUNCTION QDip () AS SINGLE ' not exported. ' Internal lookup generation, called once only, on initialisation of the dll ' 16.01.2007 -gwr STATIC init AS LONG LOCAL f1 AS INTEGER LOCAL f2 AS INTEGER LOCAL i AS LONG LOCAL j AS LONG IF ISFALSE init THEN ' generate lookup for dipoles on init of dll ' note: GLOBAL QDipoles() AS QakuHarType ' lookup tables for consonance and dissonance of quartertones. ' TYPE QakuHarType 'Dis(255) AS SINGLE ' contains the acoustical dissonance for the dipole i,j in QakuHar(i).Dis(j) 'Kon(255) AS SINGLE ' acoustical consonance ' END TYPE FOR i = 0 TO 255 f1 = NF2F(i/2) FOR j = 0 TO 255 f2 = NF2F(j/2) QDipoles(i).DIS(j) = GetDipoleDis (f1, 127, f2, 127) QDipoles(i).Kon(j) = GetDipoleKon (f1, 127, f2, 127) NEXT j NEXT i init = %True END IF FUNCTION = %True EXIT FUNCTION ' **************************************************************************************** ' for debug & research: ' only written for code development and generation of analysable lookup tables: ' first make a lookup-table using GetDipoleDis, with identical loudness for both freq's LOCAL cnt1 AS LONG LOCAL cnt2 AS LONG LOCAL f AS DWORD LOCAL fk AS DWORD f = FREEFILE OPEN "Qdis.txt" FOR OUTPUT AS #f fk = FREEFILE OPEN "Qkons.txt" FOR OUTPUT AS #fk FOR i = 0 TO 254 FOR j = i+1 TO 255 IF QDipoles(i).DIS(j) > 0.0 THEN PRINT #f, STR$(cnt1), STR$(i/2); STR$(j/2), STR$(QDipoles(i).DIS(j)) INCR cnt1 ' we get 3708 non-zero values in return END IF PRINT #fk, STR$(cnt2), STR$(i/2); STR$(j/2), STR$(QDipoles(i).Kon(j)) INCR cnt2 NEXT j NEXT i CLOSE #f CLOSE #fk END FUNCTION FUNCTION QDipDis (BYVAL n1 AS CUR, BYVAL v1 AS INTEGER, BYVAL n2 AS CUR, BYVAL v2 AS INTEGER) EXPORT AS SINGLE ' n1, n2 = fractional midi ' if the parameters passed are not exact quartertones, the function will round to the nearest one. LOCAL noot1 AS INTEGER LOCAL noot2 AS INTEGER LOCAL weight AS SINGLE LOCAL RES AS SINGLE IF MAX(n1, n2) > 127.5 THEN Warning "Invalid params @ " + FUNCNAME$ + STR$(n1)+ STR$(v1) + STR$(n2) + STR$(v2) + " - notes should be fractional midi!" logfile "Invalid params @ " + FUNCNAME$ + STR$(n1)+ STR$(v1) + STR$(n2) + STR$(v2) + " - notes should be fractional midi!" FOR noot1 = 1 TO CALLSTKCOUNT logfile CALLSTK$(noot1) NEXT EXIT FUNCTION END IF SELECT CASE FRAC(n1) CASE < 0.25 noot1 = FIX(n1) * 2 CASE > 0.75 noot1 = 2 + (FIX(n1) * 2) CASE ELSE noot1 = 1 + (FIX(n1) * 2) END SELECT SELECT CASE FRAC(n2) CASE < 0.25 noot2 = FIX(n2) * 2 CASE > 0.75 noot2 = 2 + (FIX(n2) * 2) CASE ELSE noot2 = 1 + (FIX(n2) * 2) END SELECT weight = (SQR(v1 * v2)) / 127 ' fuzzy product RES = SQR((QDipoles(noot1).DIS(noot2) ^ 2) * (weight ^2)) FUNCTION = RES 'SQR((QDipoles(noot1).DIS(noot2) ^ 2) * (weight ^2)) ' 19.01.2007 ' better then vector sum: 'FUNCTION = SQR((QDipoles(noot1).DIS(noot2) ^ 2) + (weight ^2)) / SQR(2) ' 0-1 18.01.2007 END FUNCTION FUNCTION QDipKon (BYVAL n1 AS CUR, BYVAL v1 AS INTEGER, BYVAL n2 AS CUR, BYVAL v2 AS INTEGER) EXPORT AS SINGLE ' n1, n2 = fractional midi ' if the parameters passed are not exact quartertones, the function will round to the nearest one. ' !!!!!!!!!!! hier is duidelijk nog een verwarring: getakucons aanroept deze functie met integers tussen 0 en 256 ipv fractional midi ' -> gepatched voor fuzzy harmony study 13, maar een consistency check doorheen alle Qhar functie is geen slecht idee.. kl20070219 LOCAL noot1 AS INTEGER LOCAL noot2 AS INTEGER LOCAL weigth AS SINGLE LOCAL t AS SINGLE LOCAL x& IF MAX(n1, n2) > 127.5 THEN Warning "Invalid params @ " + FUNCNAME$ + STR$(n1)+ STR$(v1) + STR$(n2) + STR$(v2) + " - notes should be fractional midi!" logfile "Invalid params @ " + FUNCNAME$ + STR$(n1)+ STR$(v1) + STR$(n2) + STR$(v2) + " - notes should be fractional midi!" FOR noot1 = 1 TO CALLSTKCOUNT logfile CALLSTK$(noot1) NEXT EXIT FUNCTION EXIT FUNCTION END IF SELECT CASE FRAC(n1) CASE < 0.25 noot1 = FIX(n1) * 2 CASE > 0.75 noot1 = 2 + (FIX(n1) * 2) CASE ELSE noot1 = 1 + (FIX(n1) * 2) END SELECT SELECT CASE FRAC(n2) CASE < 0.25 noot2 = FIX(n2) * 2 CASE > 0.75 noot2 = 2 + (FIX(n2) * 2) CASE ELSE noot2 = 1 + (FIX(n2) * 2) END SELECT weigth = (SQR(v1 * v2)) / 127 ' normalize 0-1 ' faulty: 'FUNCTION = SQR((QDipoles(noot1).Kon(noot2) ^ 2) + (weigth ^2))/ SQR(2) ' 18.01.2007 ' correct: t = 0.5 + (( QDipoles(noot1).Kon(noot2) - 0.5) * weigth) ' 20.01.2007 FUNCTION = t END FUNCTION FUNCTION QtriadDis (BYVAL n1 AS CUR, BYVAL n2 AS CUR, BYVAL n3 AS CUR) EXPORT AS SINGLE ' n1,n2,n3 must be quartertones in fractional midi ' returns a value for the dissonance of quartertone triads using the lookup tables ' for quartertone dipoles. LOCAL dis1, dis2, dis3 AS SINGLE 'beveiliging: n1 = MIN(127,n1) n2 = MIN(127,n2) n3 = MIN(127,n3) dis1 = QDipoles(n1*2).DIS(n2*2) ' QDipDis(n1, 127, n2, 127 ) 'QakuHar(n1*2).dIS(n2*2) dis2 = QDipoles(n2*2).DIS(n3*2) 'QDipDis(n2, 127, n3, 127 ) 'QakuHar(n2*2).dIS(n3*2) dis3 = QDipoles(n1*2).DIS(n3*2) 'QDipDis(n1, 127, n3, 127 ) 'QakuHar(n1*2).dIS(n3*2) FUNCTION = SQR(dis1^2 + dis2^2 + dis3^2) / SQR(3) ' 18.01.2007 - vektorsum END FUNCTION FUNCTION QtriadKons (BYVAL n1 AS CUR, BYVAL n2 AS CUR, BYVAL n3 AS CUR) EXPORT AS SINGLE ' n1,n2,n3 must be quartertones in fractional midi ' returns a value for the consonance of quartertone triads using the lookup tables ' for quartertone dipoles. LOCAL kon1, kon2, kon3 AS SINGLE LOCAL retval AS SINGLE 'beveiliging: n1 = MIN(127,n1) n2 = MIN(127,n2) n3 = MIN(127,n3) kon1 = QDipoles(n1*2).Kon(n2*2) 'QDipKon (n1,127,n2,127) 'QakuHar(n1*2).kon(n2*2) kon2 = QDipoles(n2*2).Kon(n3*2) 'QDipKon (n2, 127,n3,127)'QakuHar(n2*2).kon(n3*2) kon3 = QDipoles(n3*2).DIS(n1*2) 'QDipKon (n3, 127,n1,127) 'QakuHar(n1*2).kon(n3*2) ' faulty: 'FUNCTION = SQR(kon1^2 + kon2^2 + kon3^2) / SQR(3) 'normalize 0-1 18.01.2007 ' correct: retval = (kon1 - 0.5) + (kon2 - 0.5) + (kon3 - 0.5) ' fuzzy sum range -1.5- + 1.5 retval = 1.5 + retval ' 0-3 FUNCTION = retval / 3 ' met behoud van mediaan rond 0.5 END FUNCTION FUNCTION LimitQHar (h AS Qharmtype, BYVAL lowlimit AS CUR, BYVAL highlimit AS CUR) EXPORT AS STRING ' returns a quartertone harmony string containing only the notes within the range specified ' added to library 01.10.2006 STATIC ret AS STRING * 256 ret = NUL$(256) ' = STRING$(256, 0) IF highlimit < lowlimit THEN SWAP highlimit, lowlimit lowlimit = lowlimit * 2.0 ' convert fractional midi to 0-255 range highlimit = highlimit * 2.0 DO MID$(ret, lowlimit+1,1) = MID$(h.vel, lowlimit+1,1) INCR lowlimit LOOP UNTIL lowlimit > highlimit FUNCTION = ret END FUNCTION FUNCTION GetNrNotesInQHar (H AS QHarmType) EXPORT AS DWORD 'added 01.10.2006 LOCAL n AS DWORD LOCAL i AS DWORD FOR i = 1 TO 256 IF ASC(MID$(H.vel,i,1)) THEN INCR n NEXT i FUNCTION = n END FUNCTION FUNCTION GetNrNotesInHar (H AS HarmType) EXPORT AS DWORD 'added 08.10.2003 LOCAL n AS DWORD LOCAL i AS DWORD FOR i = 1 TO 128 IF ASC(MID$(H.vel,i,1)) THEN INCR n NEXT i FUNCTION = n END FUNCTION SUB GetIntProp (Har AS HarmType) ' no longer exported. used by fillhartype LOCAL n AS DWORD LOCAL ln AS DWORD LOCAL ni AS DWORD LOCAL il AS DWORD LOCAL s AS DWORD FOR n = 0 TO 6 Har.Iprop(n)= %False NEXT n FOR n = 0 TO 6 IF n = 6 THEN ln = 5 ELSE ln = 11 ni = %False FOR il = 0 TO ln s = (il + n) MOD 12 IF Har.c(il) > 0 AND Har.c(s) > 0 THEN Har.Iprop(n) = Har.Iprop(n) + Har.c(il) + Har.c(s) ni = ni + 2 END IF NEXT il IF ni > 0 THEN Har.Iprop(n) = Har.Iprop(n) / ni ELSE Har.Iprop(n) = %False END IF NEXT n END SUB FUNCTION Har2Cnr (h AS HarmType, BYVAL norm!) EXPORT AS INTEGER LOCAL n AS INTEGER LOCAL i AS DWORD GetPsiChord h FOR i = 0 TO 11 IF h.c(i) > norm! THEN BIT SET n, i ' > = added 01.11.2004, was > ' caused serious bug. Killed 10.03.2005 -krl ' must be > in fact!!! NEXT i FUNCTION = n END FUNCTION SUB DelNote2Har (Har AS HarmType, BYVAL n AS BYTE) EXPORT IF n > 127 THEN EXIT SUB MID$(Har.vel, n + 1, 1) = CHR$(0) Har.flag = %False END SUB SUB DelShNo2Har (Har AS HarmType, BYVAL n AS BYTE) EXPORT LOCAL bn AS BYTE bn = n MOD 12 DO MID$(Har.vel, bn + 1, 1) = CHR$(0) bn = bn + 12 LOOP UNTIL bn > 127 Har.Flag = %False END SUB FUNCTION AbsDifHar$ (H1 AS HarmType, H2 AS HarmType) EXPORT LOCAL ret AS STRING * 128 LOCAL i AS DWORD ret = NUL$(128) FOR i = 1 TO 128 IF ASC(MID$(H1.vel,i,1)) > %False AND ISFALSE ASC(MID$(H2.vel,i,1)) THEN MID$(ret,i,1) = MID$(H1.vel,i,1) NEXT i FUNCTION = ret END FUNCTION FUNCTION ComplementHar$ (H AS HarmType, BYVAL ltes AS BYTE, BYVAL htes AS BYTE) EXPORT ' added 26.02.2000 ' Returns in a string the series of notes not found to be present in the H.vel passed. ' The notes in the string returned are limited to the range passed in ltes and htes. ' Used in LickStick. LOCAL H2 AS HARMTYPE LOCAL i AS LONG LOCAL AvgVel AS LONG LOCAL v AS BYTE AvgVel = 48 H2.vel = NUL$(128) 'STRING$(128,0) IF ltes > htes THEN SWAP ltes, htes FOR i = ltes TO htes v = ASC(MID$(H.vel, i+1,1)) IF ISFALSE v THEN AddNote2Har H2, i, AvgVel ELSE AvgVel = AvgVel + v SHIFT RIGHT AvgVel, 1 ' divide by 2 BIT SET Avgvel, 0 ' never get 0... END IF NEXT i FUNCTION = H2.vel END FUNCTION SUB TransHarm (h AS Harmtype, BYVAL n AS INTEGER) EXPORT ' this procedure transposes a complete harmony structure in place. ' added 02.12.1999 ' the function returns the transposed harmony string without updating the complete structure, so this is ' left to the user. Call FillHarType, if you need a complete update of the type. IF n > 128 THEN n = 128 IF n < -128 THEN n = -128 SELECT CASE n CASE > %False ' upward transpositions h.vel = STRING$(n,CHR$(0)) + h.vel CASE %False ' do nothing EXIT SUB CASE ELSE h.vel = RIGHT$(h.vel,128 + n) + STRING$(ABS(n),CHR$(0)) END SELECT h.flag = %False END SUB SUB TransQHarm (h AS QHarmtype, BYVAL n AS INTEGER) EXPORT ' this procedure transposes a complete quartertone harmony structure in place. ' added 01.04.2011 ' the function returns the transposed harmony string without updating the complete structure, so this is ' left to the user. Call FillQHarType, if you need a complete update of the type. IF n > 256 THEN n = 256 IF n < -256 THEN n = -256 SELECT CASE n CASE > %False ' upward transpositions h.vel = STRING$(n,CHR$(0)) + h.vel CASE %False ' do nothing EXIT SUB CASE ELSE h.vel = RIGHT$(h.vel,256 + n) + STRING$(ABS(n),CHR$(0)) END SELECT h.flag = %False END SUB FUNCTION QuestTcHar (BYREF h AS HarmType, BYVAL norm AS SINGLE) EXPORT AS INTEGER ' 04.12.1999 - This function attempts to find the tonality of a chord passed as a harmony string. ' first step: convert to chordnumber, and check QuestoTcCnr...: FUNCTION = -1 LOCAL tc AS INTEGER LOCAL cnr AS INTEGER LOCAL crit AS SINGLE IF norm < %False THEN norm = %False IF norm > %True THEN norm = %True crit = %False DO ' would be better to use the getstrongest 3 and 4 functions... cnr = Har2Cnr (h,crit) ' norm! = 0 - uses psychord. IF GetNrNotes(cnr) < 5 THEN tc = QuestTcCnr (cnr) IF tc > -1 THEN EXIT LOOP 'FUNCTION = tc : EXIT FUNCTION ELSE EXIT LOOP END IF crit = crit + 0.05 ' we consider 20 steps... LOOP UNTIL crit > norm IF tc > -1 THEN FUNCTION = tc EXIT FUNCTION ELSE ' ... FUNCTION = GetStrongest(h,1) END IF END FUNCTION FUNCTION InBetweenHarUp$ (H1 AS HarmType, H2 AS HarmType) EXPORT ' added 28.02.2000 ' this function returns a chord 'in between' the chords passed. ' we start from the bass of the first chord... LOCAL H AS HARMTYPE LOCAL i AS LONG LOCAL j AS LONG LOCAL v1 AS BYTE LOCAL v2 AS BYTE LOCAL v3 AS BYTE LOCAL newnote AS BYTE j = %False i = %False H.vel = NUL$(128) DO ' find lowest note in H1...: v1 = ASC(MID$(H1.vel, i+1,1)) IF v1 THEN ' now find the lowest note in H2...: DO v2 = ASC(MID$(H2.vel,j+1,1)) IF v2 THEN newnote = i + j SHIFT RIGHT newnote, 1 v3 = v1 + v2 SHIFT RIGHT v3, 1 AddNote2Har H, newnote, v3 INCR i INCR j IF j > 127 THEN FUNCTION = H.vel : EXIT FUNCTION EXIT DO ' exit inner do loop ELSE INCR j END IF IF j > 127 THEN FUNCTION = H.vel : EXIT FUNCTION LOOP ELSE INCR i END IF IF i > 127 THEN FUNCTION = H.vel : EXIT FUNCTION LOOP FUNCTION = H.vel END FUNCTION FUNCTION InBetweenHarDown$ (H1 AS HarmType, H2 AS HarmType) EXPORT ' added 28.02.2000 ' this function returns a chord 'in between' the chords passed. ' we start from the highest note of the first chord... LOCAL H AS HARMTYPE LOCAL i AS LONG LOCAL j AS LONG LOCAL v1 AS BYTE LOCAL v2 AS BYTE LOCAL v3 AS BYTE LOCAL newnote AS BYTE j = 127 i = 127 H.vel = NUL$(128) DO ' find highest note in H1...: v1 = ASC(MID$(H1.vel, i+1,1)) IF v1 THEN ' now find the highest note in H2...: DO v2 = ASC(MID$(H2.vel,j+1,1)) IF v2 THEN newnote = i + j SHIFT RIGHT newnote, 1 v3 = v1 + v2 SHIFT RIGHT v3, 1 AddNote2Har H, newnote, v3 DECR i DECR j IF j = %False THEN FUNCTION = H.vel : EXIT FUNCTION EXIT DO ' exit inner do-loop ELSE DECR j END IF IF j = %False THEN FUNCTION = H.vel : EXIT FUNCTION LOOP ELSE DECR i END IF IF i = %False THEN FUNCTION = H.vel : EXIT FUNCTION LOOP FUNCTION = H.vel END FUNCTION FUNCTION InbetweenHar$ (H1 AS HarmType, H2 AS HarmType) EXPORT ' added 28.02.2000 LOCAL Hl AS HarmType LOCAL Hh AS HarmType Hl.vel = NUL$(128) Hh.vel = NUL$(128) hl.vel = InbetweenHarUp (H1, H2) hh.vel = InbetweenHarDown (H1, H2) FUNCTION = SumHar$ (Hl, Hh) END FUNCTION FUNCTION DimIntInHar$ (h AS HarmType, BYVAL tc%, BYVAL mode%, BYVAL degree%, BYVAL sg%) EXPORT LOCAL stap%, i%, Scn%, d% , oln%, v%, nn%, ov%, nv%, note% LOCAL ret$ stap% = SGN(sg%) IF stap% = %False THEN DimIntInHar$ = h.vel: EXIT FUNCTION IF mode% < 12 THEN Scn% = GetScaleCnr(mode%, tc%) ELSE Scn% = mode% d% = 0 i% = tc% MOD 12 DO IF IsNoteInChord(Scn%, i%) THEN INCR d%: note% = i% i% = (i% + 1) MOD 12 LOOP UNTIL d% = degree% ret$ = h.vel FOR i% = %d0 TO %d7 oln% = i% - 1 IF (oln% MOD 12) = note% THEN v% = ASC(MID$(ret$, i%, 1)) MID$(ret$, i%, 1) = CHR$(0) nn% = oln% + stap% IF (nn% > -1) AND (nn% < 128) THEN ov% = ASC(MID$(ret$, nn% + 1, 1)) nv% = SumVelo(ov%, v%) MID$(ret$, nn% + 1, 1) = CHR$(nv%) END IF END IF NEXT i% FUNCTION = ret$ END FUNCTION FUNCTION GetScaleHar$ (BYVAL m%, BYVAL tc%, BYVAL v%)EXPORT LOCAL i AS DWORD LOCAL Sc% IF m% < 12 THEN Sc% = GetScaleCnr(m%, tc%) ELSE Sc% = m% DIM Scl AS HarmType Scl.vel = NUL$(128) 'STRING$(128, 0) FOR i = 0 TO 11 IF IsNoteInChord(Sc%, i) THEN AddShNo2Har Scl, i, v% NEXT i FUNCTION = Scl.vel END FUNCTION FUNCTION GetStrongest (Har AS HarmType, BYVAL n%) EXPORT AS INTEGER ' returns a single note or a chordnumber, depending on the value of n% LOCAL il AS DWORD LOCAL InNt AS DWORD LOCAL CrNum%, tc%, cr& LOCAL Maxval! LOCAL Nt%() IF n% > 12 THEN n% = 12 IF n% <= 0 THEN FUNCTION = %NotFalse: EXIT FUNCTION ' return -1 IF ISFALSE Har.flag THEN GetPsiChord Har DIM Tmp AS HarmType DIM Nt%(1 TO n%) MAT Nt%() = CON(%NotFalse) InNt = 1 Tmp = Har DO MaxVal! = 0 Nt%(InNt) = -1 FOR il = 0 TO 11 IF Tmp.c(il) > MaxVal! THEN MaxVal! = Tmp.c(il): Nt%(InNt) = il NEXT il IF Nt%(InNt) = %NotFalse THEN FUNCTION = %NotFalse: EXIT FUNCTION Tmp.c(Nt%(InNt)) = 0: ' wis het element INCR InNt LOOP UNTIL InNt > n% IF n% = 1 THEN FUNCTION = Nt%(1): EXIT FUNCTION ' wanneer er slechts 1 noot gevraagd wordt, retourneren we ' die ene noot, mod 12. ' make the chordnumber: CrNum% = 0 InNt = 1 DO FOR il = 0 TO 11 IF Nt%(InNt) = il THEN BIT SET CrNum%,il 'CrNum% = CrNum% OR (2 ^ il%) NEXT il INCR InNt LOOP UNTIL InNt > n% IF n% = 2 THEN FUNCTION = CrNum%: EXIT FUNCTION IF n% > 4 THEN CrNum% = SetTc(CrNum%, Nt%(1)) FUNCTION = CrNum% EXIT FUNCTION END IF ' try to find a tonal center... InNt = 1 DO tc% = Nt%(InNt) + 12 Cr& = Cnr2Ctp&(CrNum%, tc%) IF IsChordClassic(Cr&) THEN CrNum% = SetTc(CrNum%, tc%) FUNCTION = CrNum% EXIT FUNCTION END IF INCR InNt LOOP UNTIL InNt > n% CrNum% = SetTc(CrNum%, -1) FUNCTION = CrNum% ' in this case we do not set Tc% END FUNCTION FUNCTION GetStrongestNoteVelo (H AS HarmType) EXPORT AS INTEGER 'returns the strongest noot in hibyte of return value and velo in the low byte 'added 27.02.2011 - gwr LOCAL i AS DWORD LOCAL v AS BYTE LOCAL noot AS INTEGER FOR i = 1 TO 128 IF ASC(MID$(H.vel,i,1)) > v THEN noot = i-1 : v = ASC(MID$(H.vel,i,1)) NEXT i ROTATE LEFT noot,8 ' put in the high byte FUNCTION = noot + v END FUNCTION FUNCTION GetStrongestQNote (H AS QHarmType, velo AS BYTE, BYVAL lolim AS CUR, BYVAL hilim AS CUR) EXPORT AS CUR 'returns the strongest note in a quartertone harmstring ' velo returns the velo value found in the qharmstring ' lolim= fractional midi ' hilim = idem. ' return value is a note in fractional midi.(Quartertones) 'added 13.07.2013 - gwr RESET velo LOCAL i AS DWORD LOCAL noot AS CUR lolim = (lolim + lolim) + 1 hilim = (hilim + hilim) + 1 FOR i = lolim TO hilim ' 1 TO 256 IF ASC(MID$(H.vel,i,1)) > velo THEN noot = (i-1)/2 : velo = ASC(MID$(H.vel,i,1)) NEXT i IF FRAC(noot) < 0.4 THEN noot = INT(noot) ELSE noot = INT(noot) + 0.50 ' is dit wel nodig? FUNCTION = noot END FUNCTION FUNCTION DiminuteHar$ (h AS HarmType, BYVAL tc%, BYVAL m%, BYVAL st%) EXPORT LOCAL stap% , ret$, i%, bn%, tonref%, v%, j%, cnt%, nv%, doit%, noot% stap% = SGN(st%) IF stap% = 0 THEN FUNCTION = h.vel: EXIT FUNCTION DIM ladder AS HarmType ret$ = ladder.vel ladder.vel = GetScaleHar$(m%, tc%, 127) FOR i% = 1 TO 128 bn% = (i% - 1) MOD 12: noot% = i% - 1 tonref% = tc% + ((i% \ 12) * 12) IF stap% > 0 THEN tonref% = tonref% + 12 v% = ASC(MID$(h.vel, i%, 1)) IF v% > %False THEN IF bn% <> (tc% MOD 12) THEN j% = i% + stap% cnt% = 0 IF (j% > 0) OR (j% < 129) THEN DO nv% = ASC(MID$(ladder.vel, j%, 1)) IF nv% > %False THEN cnt% = cnt% + stap% IF cnt% = st% THEN EXIT DO j% = j% + stap% LOOP UNTIL (j% < 1) OR (j% > 128) END IF IF cnt% = st% THEN doit% = %False SELECT CASE stap% CASE > 0 IF (j% - 1) <= tonref% THEN doit% = %NotFalse CASE < 0 IF (j% - 1) >= tonref% THEN doit% = %NotFalse END SELECT IF doit% THEN nv% = ASC(MID$(ret$, j%, 1)) IF nv% > 0 THEN nv% = SumVelo(nv%, v%) ELSE nv% = v% END IF MID$(ret$, j%, 1) = CHR$(nv%) END IF END IF ELSE MID$(ret$, i%, 1) = CHR$(v%) END IF END IF NEXT i% FUNCTION = ret$ END FUNCTION FUNCTION DifHar$ (H1 AS HarmType, H2 AS HarmType) EXPORT LOCAL i AS DWORD LOCAL H3 AS HarmType LOCAL b1%, b2%, b% FOR i = 0 TO 127 b1% = ASC(MID$(H1.vel, i + 1, 1)) b2% = ASC(MID$(H2.vel, i + 1, 1)) IF b2% > b1% THEN SWAP b1%, b2% IF b1% <= 0 THEN b% = 0 ELSE b% = b1% - ((b2% * dynconst) / b1%) END IF IF b% < 0 THEN b% = 0 MID$(H3.vel, i + 1, 1) = CHR$(b%) NEXT i FUNCTION = H3.vel END FUNCTION FUNCTION ReturnStrongestInHar (h AS harmtype, BYVAL number AS LONG) EXPORT AS STRING ' written 02.07.2001 - added to harmlib. ' returns harmony string - used in 'Eary Lis Trimbl' LOCAL i AS LONG LOCAL j AS LONG LOCAL hw AS harmtype DIM Strongest(number -1) AS LOCAL BYTE DIM strongnote(number -1) AS LOCAL BYTE IF ISFALSE(number) THEN FUNCTION= NUL$(128) EXIT FUNCTION END IF hw.vel = h.vel j = 0 DO FOR i = 1 TO 128 IF ASC(MID$(hw.vel,i,1)) > Strongest(j) THEN Strongest(j) = ASC(MID$(hw.vel,i,1)) StrongNote(j)= i-1 END IF NEXT i DelNote2har hw, StrongNote(j) INCR j LOOP UNTIL j > number -1 hw.vel = NUL$(128) i = 0 DO IF Strongnote(i) THEN IF Strongest(i) THEN AddNote2Har hw,Strongnote(i),Strongest(i) END IF END IF INCR i LOOP UNTIL i = number FUNCTION = hw.vel END FUNCTION FUNCTION ReturnStrongestInQHar (h AS Qharmtype, BYVAL number AS LONG) EXPORT AS STRING ' written 13.07.2013 - added to harmlib. -gwr ' returns Qharmony string ' used in Namuda Three, july 2013 LOCAL i AS LONG LOCAL j AS LONG STATIC hw AS Qharmtype DIM Strongest(number -1) AS LOCAL BYTE DIM strongnote(number -1) AS LOCAL CUR IF ISFALSE(number) THEN FUNCTION= NUL$(256) EXIT FUNCTION END IF hw.vel = h.vel j = 0 DO FOR i = 1 TO 256 IF ASC(MID$(hw.vel,i,1)) > Strongest(j) THEN Strongest(j) = ASC(MID$(hw.vel,i,1)) StrongNote(j)= (i-1) /2 END IF NEXT i DelNote2Qhar hw, StrongNote(j) INCR j LOOP UNTIL j > number -1 hw.vel = NUL$(256) i = 0 DO IF Strongnote(i) THEN IF Strongest(i) THEN AddNote2QHar hw,Strongnote(i),Strongest(i) END IF END IF INCR i LOOP UNTIL i = number FUNCTION = hw.vel END FUNCTION FUNCTION SymDimHar$ (h AS HarmType, BYVAL tc AS BYTE, BYVAL sg%) EXPORT LOCAL ret$, i%, Velo%, noot%, interval%, newnote%, ov%, nv% IF sg% = %False THEN FUNCTION = h.vel: EXIT FUNCTION ret$ = NUL$(128) FOR i% = %d0 TO %d7 Velo% = ASC(MID$(h.vel, i%, 1)) IF Velo% > %False THEN noot% = i% - 1 interval% = (tc MOD 12) - (noot% MOD 12) IF sg% < 0 THEN SELECT CASE interval% CASE > 6: newnote% = noot% + 1 CASE 6: newnote% = noot% CASE > 0: newnote% = noot% - 1 CASE 0: newnote% = noot% CASE > -6: newnote% = noot% + 1 CASE -6: newnote% = noot% CASE < -6: newnote% = noot% - 1 END SELECT ELSE SELECT CASE interval% CASE > 6: newnote% = noot% - 1 CASE 6: newnote% = noot% CASE > 0: newnote% = noot% + 1 CASE 0: newnote% = noot% CASE > -6: newnote% = noot% - 1 CASE -6: newnote% = noot% CASE < -6: newnote% = noot% + 1 END SELECT END IF ov% = ASC(MID$(ret$, newnote% + 1, 1)) nv% = SumVelo(ov%, Velo%) MID$(ret$, newnote% + 1, 1) = CHR$(nv%) END IF NEXT i% FUNCTION = ret$ END FUNCTION SUB SubstNtInHar (h AS HarmType, BYVAL n1%, BYVAL n2%) EXPORT ' recoded 10.03.2000 LOCAL i AS LONG LOCAL pH AS BYTE PTR LOCAL v1 AS BYTE 'LOCAL v2% LOCAL nv AS BYTE i = VARPTR(h.vel) IF n1% < 128 AND n1% > %NotFalse THEN 'v1% = ASC(MID$(h.vel, n1% + 1, 1)) 'MID$(h.vel, n1% + 1, 1) = CHR$(0) pH = i + n1% v1 = @pH @pH = %False END IF IF n2% < 128 AND n2% > %NotFalse THEN 'v2% = ASC(MID$(h.vel, n2% + 1, 1)) pH = i + n2% nv = SumVelo(v1, @pH) 'MID$(h.vel, n2% + 1, 1) = CHR$(nv%) @pH = nv END IF h.flag = %False END SUB SUB SubstNtInQHar (h AS QHarmType, BYVAL n1 AS CUR, BYVAL n2 AS CUR) EXPORT ' 23.01.2006 LOCAL i AS LONG LOCAL pH AS BYTE PTR LOCAL v1 AS BYTE LOCAL nv AS BYTE i = VARPTR(h.vel) n1 = n1 * 2 n2 = n2 * 2 IF n1 < 256 AND n1 > %NotFalse THEN pH = i + n1 v1 = @pH @pH = %False END IF IF n2 < 256 AND n2 > %NotFalse THEN pH = i + n2 nv = SumVelo(v1, @pH) @pH = nv END IF h.flag = %False END SUB FUNCTION MorfHar$ (H1 AS HarmType, H2 AS HarmType, BYVAL modus%, BYVAL tc%, BYVAL dx%) EXPORT LOCAL dy%, v%, nv%, i%, todo% ,n% LOCAL n1%, v1%, n2%, v2%, n3%,v3%,n4%,v4% LOCAL nt1%, vt1%, nt2%, vt2% , tv%, ov%, stap%, nn%, vo% LOCAL ret$, Ing$, Ut$ , Tmpgoal$ IF H1.vel = H2.vel THEN FUNCTION = H2.vel: EXIT FUNCTION IF dx% < 1 THEN dx% = 1 IF dx% > 30 THEN dx% = 30 dy% = dynconst * dx%: IF dy% > 127 THEN dy% = 127 ret$ = H1.vel ' H1=empty IF ret$ = STRING$(128, 0) THEN FOR i% = %d0 TO %d7 v% = ASC(MID$(H2.vel, i%, 1)) IF v% > %False THEN nv% = dy%: IF nv% > v% THEN nv% = v% MID$(ret$, i%, 1) = CHR$(nv%) END IF NEXT i% FUNCTION = ret$ EXIT FUNCTION END IF ' H2=empty IF H2.vel = STRING$(128, 0) THEN FOR i% = %d0 TO %d7 v% = ASC(MID$(ret$, i%, 1)) IF v% > %False THEN v% = v% - dy%: IF v% < %False THEN v% = %False MID$(ret$, i%, 1) = CHR$(v%) END IF NEXT i% FUNCTION = ret$ EXIT FUNCTION END IF ' morph common notes Ing$ = CommonHar$(H1, H2) Ut$ = CommonHar$(H2, H1) todo% = %False FOR i% = 1 TO 128 v1% = ASC(MID$(Ing$, i%, 1)) nv% = %False IF v1% > %False THEN v2% = ASC(MID$(Ut$, i%, 1)) SELECT CASE v2% - v1% CASE < %False nv% = v1% - dy% IF nv% < v2% THEN nv% = v2%: ' dim CASE %False nv% = v2% CASE > %False nv% = v1% + dy% IF nv% > v2% THEN nv% = v2%: ' cres END SELECT MID$(ret$, i%, 1) = CHR$(nv%): v1% = nv% END IF NEXT i% IF H2.vel = ret$ THEN FUNCTION = ret$ EXIT FUNCTION ELSE DIM NewIn AS HarmType NewIn.vel = STRING$(128, 0) NewIn.vel = ret$ END IF ' 3: non-common notes will be morphed further Ing$ = AbsDifHar$(NewIn, H2) tmpgoal$ = H2.vel: ' copy of complete destination for morph v1% = %False: v2% = %False: v3% = %False: v4% = %False n1% = %NotFalse: n2% = %NotFalse: n3% = %NotFalse: n4% = %NotFalse ' search source/destination couples i% = 0 DO IF n1% = %NotFalse THEN v% = ASC(MID$(Ing$, i% + 1, 1)) IF v% > %False THEN n1% = i%: v1% = v% END IF IF n2% = %NotFalse THEN v% = ASC(MID$(tmpgoal$, i% + 1, 1)) IF v% > %False THEN n2% = i%: v2% = v% END IF ' pitch-morfing inside the loop... IF (n1% > %NotFalse) AND (n2% > %NotFalse) THEN nt1% = n1%: nt2% = n2%: vt1% = v1%: vt2% = v2% GOSUB Pimorf n1% = %NotFalse: n2% = %NotFalse: v1% = %False: v2% = %False END IF IF n3% = %NotFalse THEN v% = ASC(MID$(Ing$, 128 - i%, 1)) IF v% > %False THEN n3% = 127 - i%: v3% = v% END IF IF n4% = %NotFalse THEN v% = ASC(MID$(tmpgoal$, 128 - i%, 1)) IF v% > %False THEN n4% = 127 - i%: v4% = v% END IF IF (n3% > %NotFalse) AND (n4% > %NotFalse) THEN nt1% = n3%: nt2% = n4%: vt1% = v3%: vt2% = v4% GOSUB Pimorf n3% = %NotFalse: n4% = %NotFalse: v3% = %False: v4% = %False END IF i% = i% + 1 LOOP UNTIL i% > 127 IF tmpgoal$ = STRING$(128, 0) THEN ' nothing anymore to morphe to... fade out notes FOR i% = 1 TO 128 tv% = ASC(MID$(H2.vel, i%, 1)) IF tv% = %False THEN ov% = ASC(MID$(ret$, i%, 1)) IF ov% > %False THEN nv% = ov% - dy% IF nv% < %False THEN nv% = %False MID$(ret$, i%, 1) = CHR$(nv%) END IF END IF NEXT i% FUNCTION = ret$: EXIT FUNCTION END IF IF Ing$ = STRING$(128, 0) THEN ' nothing anymore to morphed from... fade in all missing H2() notes FOR i% = 1 TO 128 nv% = ASC(MID$(H2.vel, i%, 1)) IF nv% > %False THEN IF nv% < dy% THEN MID$(ret$, i%, 1) = CHR$(dy%) ELSE MID$(ret$, i%, 1) = CHR$(nv%) END IF END IF NEXT i% FUNCTION = ret$: EXIT FUNCTION END IF FUNCTION = ret$: EXIT FUNCTION Pimorf: stap% = SGN(nt2% - nt1%) ' search next step for mode and tc... nn% = NxNt(modus%, tc%, nt1%, stap%) IF nn% = nt1% THEN nn% = nn% + stap% IF stap% > 0 THEN IF nn% > nt2% THEN nn% = nt2% ELSE IF nn% < nt2% THEN nn% = nt2% END IF ' now we have the new note. Check for dynamic morphing... SELECT CASE vt2% - vt1% CASE < 0: nv% = vt1% - dy%: IF nv% < vt2% THEN nv% = vt2% CASE 0: nv% = vt2% CASE > 0: nv% = vt1% + dy%: IF nv% > vt2% THEN nv% = vt2% END SELECT ' write returnstring: MID$(ret$, nt1% + 1, 1) = CHR$(0) MID$(Ing$, nt1% + 1, 1) = CHR$(0): 'needed??? ' if the new note was present, sum volumes vo% = ASC(MID$(H2.vel, nn% + 1, 1)) IF vo% > %False THEN nv% = SumVelo(nv%, vo%) MID$(ret$, nn% + 1, 1) = CHR$(nv%) MID$(Ing$, nt1% + 1, 1) = CHR$(0) IF nn% = nt2% THEN MID$(tmpgoal$, nt2% + 1, 1) = CHR$(0) RETURN END FUNCTION FUNCTION SolveHar$ (Har AS HarmType, BYVAL note%, BYVAL norm!) EXPORT LOCAL tmp AS HarmType tmp.vel = SolveTrit$(Har, note%, norm!) tmp.vel = SolveMin2$(tmp, note%, norm!) tmp.vel = SolveMaj2$(tmp, note%, norm!) ' now we should have solved everything... FUNCTION = tmp.vel END FUNCTION FUNCTION SolveMaj2$ (Har AS HarmType, BYVAL note%, BYVAL norm!) EXPORT STATIC Toggle% LOCAL n% , il%, Solv1%, bnote%, Solv2%, Snote%, ok%, vel%, v% LOCAL m0!, m3!, m4!, m11!, m10!, largest!, Min3!, Maj31!, Maj32! DIM Hl AS HarmType GetPsiChord Har Hl.vel = Har.vel n% = GetNrInt%(Har, 2, norm!) SELECT CASE n% CASE 1 TO 11 FOR il% = 0 TO 11 IF Har.c(il%) > norm! AND Har.c((il% + 2) MOD 12) > norm! THEN Snote% = il%: EXIT FOR NEXT il% ' check whether the note given would solve the second... IF note% > -1 THEN bnote% = note% MOD 12 SELECT CASE bnote% CASE Snote% Solv1% = bnote% m3! = Har.c(bnote%) + Har.c((Snote% + 3) MOD 12) m4! = Har.c(bnote%) + Har.c((Snote% + 4) MOD 12) IF m3! > m4! THEN Solv2% = (Snote% + 3) MOD 12 ELSE Solv2% = (Snote% + 4) MOD 12 END IF CASE (Snote% + 2) MOD 12 Solv1% = bnote% m3! = Har.c(bnote%) + Har.c((Snote% + 11) MOD 12) m4! = Har.c(bnote%) + Har.c((Snote% + 10) MOD 12) IF m3! > m4! THEN Solv2% = (Snote% + 11) MOD 12 ELSE Solv2% = (Snote% + 10) MOD 12 END IF CASE (Snote% + 1) MOD 12 Solv1% = bnote% Solv2% = bnote% CASE (Snote% + 3) MOD 12 m0! = Har.c(bnote%) + Har.c(Snote%) m11! = Har.c(bnote%) + Har.c((Snote% + 11) MOD 12) m10! = Har.c(bnote%) + Har.c((Snote% + 10) MOD 12) largest! = 0 Solv1% = bnote% IF m0! > largest! THEN m0! = largest!: Solv2% = Snote% IF m11! > largest! THEN m11! = largest!: Solv2% = (Snote% + 11) MOD 12 IF m10! > largest! THEN m10! = largest!: Solv2% = (Snote% + 10) MOD 12 IF largest! = 0 THEN Solv2% = (Snote% + 11) MOD 12 CASE (Snote% + 11) MOD 12 m0! = Har.c(bnote%) + Har.c(Snote% + 2) MOD 12 m11! = Har.c(bnote%) + Har.c((Snote% + 3) MOD 12) m10! = Har.c(bnote%) + Har.c((Snote% + 4) MOD 12) largest! = 0 Solv1% = bnote% IF m0! > largest! THEN m0! = largest!: Solv2% = (Snote% + 2) MOD 12 IF m11! > largest! THEN m11! = largest!: Solv2% = (Snote% + 3) MOD 12 IF m10! > largest! THEN m10! = largest!: Solv2% = (Snote% + 4) MOD 12 IF largest! = 0 THEN Solv2% = (Snote% + 3) MOD 12 CASE ELSE ' questionable... Solv1% = bnote% Solv2% = bnote% END SELECT ' write the solution... ELSE ' if note% is not specified, we solve by enlarging to minor major third min3! = Har.c((Snote% + 11) MOD 12) + Har.c((Snote% + 3) MOD 12) maj31! = Har.c((Snote% + 0) MOD 12) + Har.c((Snote% + 3) MOD 12) maj32! = Har.c((Snote% + 11) MOD 12) + Har.c((Snote% + 3) MOD 12) ' now we select the largest value as the best solution... largest! = 0 IF min3! > largest! THEN largest! = min3!: Solv1% = (Snote% + 11) MOD 12: Solv2% = (Snote% + 3) MOD 12 IF maj31! > largest! THEN largest! = maj31!: Solv1% = (Snote% + 0) MOD 12: Solv2% = (Snote% + 3) MOD 12 IF maj32! > largest! THEN largest! = maj32!: Solv1% = (Snote% + 11) MOD 12: Solv2% = (Snote% + 3) MOD 12 IF largest! = 0 THEN Solv1% = (Snote% + 11) MOD 12: Solv2% = (Snote% + 3) MOD 12 END IF ' write solution: ok% = 0 DO SubstNtInHar Hl, Snote% + ok%, Solv1% + ok% SubstNtInHar Hl, Snote% + 2 + ok%, Solv2% + ok% ok% = ok% + 12 LOOP UNTIL ok% > 120 CASE 12 ' reduce the density... IF note% > -1 THEN FOR il% = 0 TO 127 IF ((il% MOD 12) <> (note% MOD 12)) AND ((il% MOD 12) <> ((note% + 7) MOD 12)) THEN MID$(Hl.vel, il% + 1, 1) = CHR$(0) ELSE vel% = ASC(MID$(Hl.vel, il% + 1, 1)) v% = SumVelo(vel%, vel%) MID$(Hl.vel, il% + 1, 1) = CHR$(v%) END IF NEXT il% ELSE il% = Toggle% MOD 2: ' 0 or 1 DO MID$(Hl.vel, il% + 1, 1) = CHR$(0) il% = il% + 2 LOOP UNTIL il% > 127 Toggle% = (Toggle% + 1) AND &H0FF END IF END SELECT FUNCTION = Hl.vel END FUNCTION FUNCTION SolveMin2$ (Har AS HarmType, BYVAL note%, BYVAL norm!) EXPORT STATIC Toggle% LOCAL n%, il%, Snote%, bnote%, Solv1%, Solv2% , ok%, vel%, v% LOCAL m2!, m3!, m10!, m11!, min3!, maj31!, maj32!, largest! GetPsiChord Har DIM Hl AS HarmType Hl.vel = Har.vel n% = GetNrInt%(Har, 1, norm!) SELECT CASE n% CASE 1 TO 11 FOR il% = 0 TO 11 IF Har.c(il%) > norm! AND Har.c((il% + 1) MOD 12) > norm! THEN Snote% = il% EXIT FOR END IF NEXT il% ' check whether the note given would solve the second... IF note% > -1 THEN bnote% = note% MOD 12 SELECT CASE bnote% CASE (Snote% + 2) MOD 12 ' solve to bnote and Snote+11 OR to bnote and Snote +10 m11! = Har.c(bnote%) + Har.c((Snote% + 11) MOD 12) m10! = Har.c(bnote%) + Har.c((Snote% + 10) MOD 12) IF m11! > m10! THEN Solv1% = bnote% Solv2% = (Snote% + 11) MOD 12 ELSE Solv1% = bnote% Solv2% = (Snote% + 10) MOD 12 END IF CASE (Snote% + 11) MOD 12 ' solve to bnote and Snote%+2 OR solve to bnote and Snote +3 m2! = Har.c(bnote%) + Har.c((Snote% + 2) MOD 12) m3! = Har.c(bnote%) + Har.c((Snote% + 3) MOD 12) IF m2! > m3! THEN Solv1% = bnote% Solv2% = (Snote% + 2) MOD 12 ELSE Solv1% = bnote% Solv2% = (Snote% + 3) MOD 12 END IF CASE (Snote% + 3) MOD 12 ' solve to bnote and Snote% + 11 Solv1% = bnote% Solv2% = (Snote% + 3) MOD 12 CASE (Snote% + 10) MOD 12 ' solve to bnote and Snote + 2 Solv1% = bnote% Solv2% = (Snote% + 10) MOD 12 CASE ELSE ' dit moet onderzocht worden... Solv1% = bnote% IF bnote% <> (Snote% + 11) MOD 12 THEN Solv2% = (Snote% + 11) MOD 12 ELSE Solv2% = (Snote% + 2) MOD 12 END IF END SELECT ELSE ' if note% is not specified, we solve by enlarging to minor or major third ' the choice should depend on the composition of the har$ min3! = Har.c((Snote% + 11) MOD 12) + Har.c((Snote% + 2) MOD 12) maj31! = Har.c((Snote% + 11) MOD 12) + Har.c((Snote% + 3) MOD 12) maj32! = Har.c((Snote% + 10) MOD 12) + Har.c((Snote% + 2) MOD 12) ' now we select the largest value as the best solution... largest! = 0 IF min3! > largest! THEN largest! = min3!: Solv1% = (Snote% + 11) MOD 12: Solv2% = (Snote% + 2) MOD 12 IF maj31! > largest! THEN largest! = maj31!: Solv1% = (Snote% + 11) MOD 12: Solv2% = (Snote% + 3) MOD 12 IF maj32! > largest! THEN largest! = maj32!: Solv1% = (Snote% + 10) MOD 12: Solv2% = (Snote% + 2) MOD 12 IF largest! = 0 THEN Solv1% = (Snote% + 11) MOD 12: Solv2% = (Snote% + 2) MOD 12 END IF ' write solution... ok% = 0 DO SubstNtInHar Hl, Snote% + ok%, Solv1% + ok% SubstNtInHar Hl, Snote% + 1 + ok%, Solv2% + ok% ok% = ok% + 12 LOOP UNTIL ok% > 120 CASE 12 ' cluster - in this case we reduce the density... IF note% > -1 THEN FOR il% = 0 TO 127 IF ((il% MOD 12) <> (note% MOD 12)) AND ((il% MOD 12) <> ((note% + 7) MOD 12)) THEN MID$(Hl.vel, il% + 1, 1) = CHR$(0) ELSE vel% = ASC(MID$(Hl.vel, il% + 1, 1)) v% = SumVelo(vel%, vel%) MID$(Hl.vel, il% + 1, 1) = CHR$(v%) END IF NEXT il% ELSE il% = Toggle% MOD 2: ' 0 or 1 DO MID$(Hl.vel, il% + 1, 1) = CHR$(0) il% = il% + 2 LOOP UNTIL il% > 127 Toggle% = (Toggle% + 1) AND &H0FF END IF END SELECT FUNCTION = Hl.vel END FUNCTION FUNCTION SolveTrit$ (Har AS HarmType, BYVAL note%, BYVAL norm!) EXPORT STATIC Tog AS LONG LOCAL ntrit%, il%, tn%, Solv1%, Solv2% ,i%, vel%, v% LOCAL enlarge!, diminut! GetPsiChord Har DIM Hl AS HarmType Hl.vel = Har.vel ntrit% = GetNrInt(Har, 6, norm!) SELECT CASE ntrit% CASE 1 TO 5 FOR il% = 0 TO 11 IF Har.c(il%) > norm! AND Har.c(il% + 6) > norm! THEN tn% = il%: EXIT FOR NEXT il% 'note given solves triton? IF note% > -1 THEN Solv1% = note% MOD 12 SELECT CASE ABS(Solv1% - tn%) CASE 1 'good solution possible...(dim or aug) IF (Solv1% = (tn% + 1) MOD 12) OR (Solv1% = ((tn% + 5) MOD 12)) THEN IF Solv1% = (tn% + 1) MOD 12 THEN Solv2% = (tn% + 5) MOD 12 ELSE Solv2% = (tn% + 1) MOD 12 END IF ELSE IF Solv1% = (tn% + 11) MOD 12 THEN Solv2% = (tn% + 7) MOD 12 ELSE Solv2% = (tn% + 11) MOD 12 END IF END IF CASE 2 'diatonic 'solution' IF (Solv1% = (tn% + 2) MOD 12) OR (Solv1% = ((tn% + 4) MOD 12)) THEN IF Solv1% = (tn% + 2) MOD 12 THEN Solv2% = (tn% + 5) MOD 12 ELSE Solv2% = (tn% + 7) MOD 12 END IF ELSE IF Solv1% = (tn% + 8) MOD 12 THEN Solv2% = (tn% + 11) MOD 12 ELSE Solv2% = (tn% + 7) MOD 12 END IF END IF CASE ELSE ' no good solution possible... Solv2% = Solv1% END SELECT ELSE ' if note% =-1, solve by aug or dim in function of har$ enlarge! = Har.c((tn% + 11) MOD 12) + Har.c((tn% + 7) MOD 12) diminut! = Har.c((tn% + 1) MOD 12) + Har.c((tn% + 5) MOD 12) IF enlarge! >= diminut! THEN Solv1% = (tn% + 11) MOD 12 Solv2% = (tn% + 7) MOD 12 ELSE Solv1% = (tn% + 1) MOD 12 Solv2% = (tn% + 5) MOD 12 END IF END IF ' write solution... i% = 0 DO SubstNtInHar Hl, tn% + i%, Solv1% + i% SubstNtInHar Hl, tn% + i% + 6, Solv2% + i% i% = i% + 12 LOOP UNTIL i% > 120 CASE 6 ' reduce density... IF note% > -1 THEN FOR i% = 0 TO 127 IF ((i% MOD 12) <> (note% MOD 12)) AND ((i% MOD 12) <> ((note% + 7) MOD 12)) THEN MID$(Hl.vel, i% + 1, 1) = CHR$(0) ELSE vel% = ASC(MID$(Hl.vel, i% + 1, 1)) v% = SumVelo(vel%, vel%) MID$(Hl.vel, i% + 1, 1) = CHR$(v%) END IF NEXT i% ELSE i% = Tog MOD 2 DO MID$(Hl.vel, i% + 1, 1) = CHR$(0) i% = i% + 2 LOOP UNTIL i% > 127 Tog = (Tog + 1) AND &H0FF END IF END SELECT FUNCTION = Hl.vel END FUNCTION FUNCTION StealNoteFromHar (H AS HarmType, BYVAL oldnoot AS INTEGER, BYVAL Lowtes AS INTEGER, BYVAL Hites AS INTEGER) EXPORT AS INTEGER LOCAL i, j, noot, boven, onder AS INTEGER ' this functions returns from a given Har-type the most suitable ' single note found in the type, for the 'instrument' given. ' Har.C() -the psychord- is filled within the function, so the user ' does not have to call FillChordType prior to calling this function. ' This function will always return the most melodic note from ' the possibilities presented in Har. ' The function will remove the note it returns from Har. ' Therefore it will reset the flag. ' The return value is either a midi-note (byte) or -1 of no note could be returned. IF oldnoot < 0 THEN oldnoot = (Lowtes + Hites) / 2 IF (Hites - Lowtes) < 12 THEN FUNCTION = -1: EXIT FUNCTION GetPsiChord H i = oldnoot MOD 12 j = %False noot = -1 DO boven = (i + 1) MOD 12 onder = (i + 13) MOD 12 IF H.c(boven) > 0 THEN noot = boven: EXIT DO IF H.c(onder) > 0 THEN noot = onder: EXIT DO INCR i INCR j LOOP UNTIL j = 6 IF noot > -1 THEN ' now place this note in the correct octave position... noot = noot + ((oldnoot \ 12) * 12) IF (noot - oldnoot) > 7 THEN noot = noot - 12 IF (oldnoot - noot) > 7 THEN noot = noot + 12 IF noot < Lowtes THEN noot = noot + 12 IF noot > Hites THEN noot = noot - 12 ' remove the note from H.vel and H.C() H.c(noot MOD 12) = %False DelShNo2Har H, noot H.flag = %False ELSE noot = -1 END IF FUNCTION = noot END FUNCTION FUNCTION GetNrInt (Har AS HarmType, BYVAL interval%, BYVAL norm!) EXPORT AS INTEGER LOCAL il AS DWORD LOCAL n AS DWORD LOCAL s AS DWORD LOCAL ln AS DWORD LOCAL ni% IF ISFALSE Har.flag THEN Getpsichord Har ' returns the number of a given interval stronger than norm! in the ' chord as specified in Har.C n = ABS(interval% MOD 12) IF n > 6 THEN n = 12 - n IF n = 6 THEN ln = 5 ELSE ln = 11 ni% = %False FOR il = 0 TO ln s = (il + n) MOD 12 IF Har.c(il) > norm! THEN IF Har.c(s) > norm! THEN INCR ni% END IF NEXT il FUNCTION = ni% END FUNCTION FUNCTION QHarProps (QHar AS QHarmtype,OPTIONAL BYVAL flag AS DWORD) EXPORT AS SINGLE ' returns a normalised value for the fundamental dissonance of the quartertone harstring passed. ' Calculates consonance at the same time. ' if the value of flag is non-zero, the function will disregard the value of the velocity bytes and use the ' value of the flag instead. (the same for all notes found). The range for flag is 1-127. ' if the flag is zero, or not passed as a parameter, the velo values found in the har-string will be used in the calculation. ' We did this because in Qt-strings the velo is not used for volume but for what it really means in midi: ' note attack speed. ' We could also use the value of flag derived from the ctrl(7) value, although it will allways be ' the same for all notes. ' coding by gwr 30.09.2006 - 20.01.2007 ' to be tested and evaluated. May be problematic in real-time. ' 28.03.2007 kl: several bugs killed. now it seems to work ok LOCAL dis AS SINGLE LOCAL kon AS SINGLE LOCAL d AS SINGLE LOCAL k AS SINGLE LOCAL dcnt AS LONG LOCAL kcnt AS LONG LOCAL n AS CUR LOCAL m AS CUR LOCAL n1 AS CUR LOCAL n2 AS CUR LOCAL v1 AS BYTE LOCAL v2 AS BYTE IF LEN(REMOVE$(Qhar.vel, CHR$(0))) < 2 THEN EXIT FUNCTION 'less then 2 notes in harstring harstring IF flag = %use_spectrum THEN QHar.dis = GetQAkuDis (QHar) ' call the internal spectral dissonance function ' Qhar.kon does not use the spectral data set, and is calculated further. END IF ' coding dissonance calculation for Qhar strings ' if the flag is non-zero, we will disregard the value of the velocities in the har-string, but use the flag value. ' if the flag is 128, we will use spectral data. ' vindt de eerste noot in de samenklank: n = 0 ' noten teller 0 - 255 DO 'lus voor de laagste noot DO INCR n IF n > 254 THEN GOTO weging LOOP UNTIL ASC(QHar.vel, n + 1) n1 = n / 2.0 ' n1 = fractional midi note SELECT CASE flag CASE %use_velo ' =%False v1 = ASC(MID$(Qhar.vel,n+1,1)) CASE 1 TO 127 IF ASC(MID$(Qhar.vel,n+1,1)) > 0 THEN v1 = flag CASE %use_spectrum '128 ' QHar.dis already done. For Qhar.kon we use v1: v1 = ASC(MID$(Qhar.vel,n+1,1)) END SELECT 'indien er een laagste noot is, vindt dan de eerstvolgende noot m = n DO DO INCR m ' IF m > 255 THEN GOTO weging 'dit was een bug waardoor alleen de combinatie tss de basnoot en de andere noten i overweging genomen werden.. IF m > 254 THEN EXIT: EXIT '255 was 254 - bug LOOP UNTIL ASC(MID$(Qhar.vel, m+1, 1)) n2 = m / 2.0 SELECT CASE flag CASE %use_velo '=%False v2 = ASC(MID$(Qhar.vel,m+1,1)) CASE 1 TO 127 IF ASC(MID$(Qhar.vel,m+1,1)) > 0 THEN v2 = flag CASE %use_spectrum '` =128 ' only for qhar.kon v2 = ASC(MID$(Qhar.vel,m+1,1)) END SELECT ' nu hebben we een tweeklank waarvoor we de dissonantie kunnen berekenen ' Noteer dat de dissonantie hier alleen voor sinussen (grondtoon) wordt berekend. 'dis = SQR(dis^2 + (GetDipoleDis (NF2F(n1),v1,NF2F(n2),v2)^2)) ' or use lookup: (faster) ' dis = SQR(dis^2 + (QDipDis(n1,v1,n2,v2) ^2)) / SQR(2) ' normalize 0-1 18.01.2007 ' kon = SQR(kon^2 + (QDipKon(n1,v1,n2,v2) ^2)) / SQR(2) ' normalize 0-1 ' better vector sum: IF flag <> 128 THEN d = QDipDis(n1,v1,n2,v2) ' n1 en n2 zijn fractional midi. IF d> 0 THEN dis = dis + ( d^2) : INCR dcnt END IF k = QDipKon(n1,v1,n2,v2) 'IF k <>0.5 THEN kon = kon + (k ^2) :INCR kcnt ' this is buggy !!! (median has to be 0.5) kon = kon + k ' permanent sum of values INCR kcnt LOOP UNTIL m > 254 'was 255 - bug LOOP UNTIL n > 254 weging: IF flag <> 128 THEN Qhar.dis = SQR(dis) / SQR(dcnt) Qhar.kon = kon / kcnt ' normalized average sum SQR(kon) / SQR(kcnt) FUNCTION = Qhar.dis END FUNCTION FUNCTION QHarMod (QHar AS QHarmtype,BYVAL param AS LONG, OPTIONAL BYVAL flag AS DWORD) EXPORT AS LONG ' returns %False if nothing could be changed to the input harmony ' changes the harmony string passed in place. ' recalculates the properties and sets the flag ' if param > 0 then the proc. will change the strongest dissonant dipole such as to become a consonant ' if param < 0 then the proc. will change the strongest consonant dipole such as to become a dissonant ' solvechord algorithm for quartertone harmony strings. ' 20070910 kl: cleaned up and killed some bugs (function changed since last time we looked at it..) ' some tryouts: for gradual progressions to a more consonant chord, this function is not very good yet ' - it allways solves the dissonant to the nearest octave or unison ' - sometimes this solution is more dissonant then the original, because we solve one dissonant, but the resulting notes can be dissonant with other notes in the chord again ' so we should take into account the rest of the chord and or the voicing, which is not a simple problem.. ' to be continued.. LOCAL maxdis AS SINGLE LOCAL maxkons AS SINGLE LOCAL i AS CUR LOCAL j AS CUR LOCAL vd1 AS LONG LOCAL vd2 AS LONG LOCAL v1 AS LONG LOCAL v2 AS LONG LOCAL d AS SINGLE LOCAL k AS SINGLE LOCAL n1 AS CUR LOCAL n2 AS CUR LOCAL nd1 AS CUR LOCAL nd2 AS CUR LOCAL nn1 AS CUR LOCAL nn2 AS CUR LOCAL interval AS LONG IF ISFALSE param THEN FUNCTION = %False : EXIT FUNCTION IF GetNrNotesInQHar(Qhar) < 2 THEN FUNCTION = %False : EXIT FUNCTION IF param > 0 THEN ' in this case we search the most dissononant dipole in the string and solve it for maximum consonance maxdis = 0 FOR i = 0 TO 254 v1 = ASC(Qhar.vel,i+1) IF ISFALSE(v1) THEN ITERATE FOR n1 = i FOR j = i+1 TO 255 v2 = ASC(Qhar.vel,j+1) IF ISFALSE(v2) THEN ITERATE FOR n2 = j SELECT CASE flag CASE %use_velo: d = QDipDis (n1/2,v1,n2/2,v2) CASE 1 TO 127: d = QDipDis (n1/2,flag,n2/2,flag) CASE %use_spectrum: d = GetDipAkuDis (n1/2,v1,n2/2,v2) CASE %use_fuzzypsy: d = QDipoles(n1).DIS(n2) ' no velo used, no fuzzysets for quartertones yet. CASE ELSE MSGBOX "Illegal flag in QHarMod",, FUNCNAME$ EXIT FUNCTION END SELECT IF d > maxdis THEN maxdis = d vd1 = v1 vd2 = v2 nd1 = n1 nd2 = n2 END IF NEXT j NEXT i IF ISFALSE(maxdis) THEN EXIT FUNCTION ' niks op te lossen... ' nu hebben we de sterkste dissonant uit de string in nd1,nd2,vd1,vd2 - dis= maxdis ' wanneer de afstand tussen nd1 en nd2 kleiner is dan de tritonus, lossen we op door vergroting ' anders door verkleining. interval = nd2 - nd1 ' in kwarttoonsstappen! - nd2 is steeds > nd1 ' maxkons = QDipKon (nd1,vd1,nd2,vd2) '0 'kl change 20070219 : QDipkon expects fractional midi as input!! maxkons = QDipKon (nd1/2,vd1,nd2/2,vd2) '0 IF interval <= 12 THEN FOR i = (nd1-1) TO 0 STEP -1 FOR j = (nd2+1) TO 255 k = QDipKon (i/2,vd1,j/2,vd2) ' hier zouden we ook kunnen nagaan of er geen aanvaardbare bult in de kurve zit. Nu ' zoeken we immers alleen het absolute maximum binnen het interval. IF k > maxkons THEN maxkons = k nn1 = i nn2 = j IF maxkons = 1 THEN EXIT FOR END IF NEXT j NEXT i IF (nn1 > %False) AND (nn2> %False) THEN ' nu hebben we de nieuwe dipool in nn1, nn2 en kunnen we subsitueren: SubstNtInQHar (Qhar,nd1/2,nn1/2) SubstNtInQHar (Qhar,nd2/2,nn2/2) FillQharType (Qhar, flag) FUNCTION = %True END IF ELSE ' verkleining van het interval FOR i = (nd1+1) TO 256 IF i >= nd2-1 THEN EXIT FOR ' -1 korrekt hier ??? FOR j = (nd2-1) TO nd1 STEP -1 k = QDipKon (i/2,vd1,j/2,vd2) IF k > maxkons THEN maxkons = k nn1 = i nn2 = j IF maxkons = 1 THEN EXIT FOR END IF NEXT j IF maxkons = 1 THEN EXIT FOR NEXT i IF (nn1 > %False) AND (nn2 > %False) THEN ' nu hebben we de nieuwe dipool in nn1, nn2 en kunnen we subsitueren: SubstNtInQHar (Qhar,nd1/2,nn1/2) SubstNtInQHar (Qhar,nd2/2,nn2/2) FillQharType (Qhar, flag) FUNCTION = %True END IF END IF logfile "more kons, subst:" + STR$(nd1/2) + "->" + STR$(nn1/2) + ", " + STR$(nd2/2) + "->" + STR$(nn2/2) ELSEIF param < 0 THEN ' in this case we serach for the most consonant dipole in the string and make it dissonant maxkons = 0 FOR i = 0 TO 254 v1 = ASC(Qhar.vel,i+1) IF ISFALSE(v1) THEN ITERATE FOR n1 = i FOR j = i+1 TO 255 v2 = ASC(Qhar.vel,j+1) IF ISFALSE(v2) THEN ITERATE FOR n2 = j SELECT CASE flag CASE %use_velo: k = QDipKon (n1/2,v1,n2/2,v2) CASE 1 TO 127: k = QDipKon (n1/2,flag,n2/2,flag) CASE %use_spectrum: k = QDipKon(n1/2,flag,n2/2,flag) CASE %use_fuzzypsy: k = QDipoles(n1).Kon(n2) ' no velo used, no fuzzysets yet. CASE ELSE MSGBOX "Illegal flag in QHarMod",, FUNCNAME$ EXIT FUNCTION END SELECT IF k > maxkons THEN maxkons = k vd1 = v1 vd2 = v2 nd1 = n1 nd2 = n2 END IF NEXT j NEXT i IF ISFALSE(maxkons) THEN EXIT FUNCTION ' niks dissonant te maken.... ' nu hebben we de sterkste konsonant uit de string in nd1,nd2,vd1,vd2 - k = maxkons ' wanneer de afstand tussen nd1 en nd2 kleiner is dan de tritonus, lossen we op door vergroting ' anders door verkleining. interval = nd2 - nd1 ' in kwarttoonsstappen! - nd2 is steeds > nd1 maxdis = QDipDis (nd1/2,vd1,nd2/2,vd2) '-> was bug: /2 forogotten: qdipdis expects fractional midi in input! IF interval <= 12 THEN 'vergroting van het interval FOR i = (nd1-1) TO 0 STEP -1 FOR j = (nd2+1) TO 255 d = QDipDis (i/2,vd1,j/2,vd2) IF d > maxdis THEN maxdis = d nn1 = i nn2 = j IF maxdis = 1 THEN EXIT FOR END IF NEXT j IF maxdis = 1 THEN EXIT FOR NEXT i IF (nn1 > %False) AND (nn2 > %False) THEN ' nu hebben we de nieuwe dipool in nn1, nn2 en kunnen we subsitueren: SubstNtInQHar (Qhar,nd1/2,nn1/2) SubstNtInQHar (Qhar,nd2/2,nn2/2) FillQharType (Qhar, flag) FUNCTION = %True END IF ELSE ' verkleining van het interval FOR i = (nd1+1) TO 256 IF i >= nd2-1 THEN EXIT FOR ' -1 korrekt hier ??? FOR j = (nd2-1) TO nd1 STEP -1 d = QDipDis (i/2,vd1,j/2,vd2) IF d > maxdis THEN maxdis = d nn1 = i nn2 = j IF maxdis = 1 THEN EXIT FOR END IF NEXT j IF maxdis = 1 THEN EXIT FOR NEXT i IF (nn1 > %False) AND (nn2 > %False) THEN ' nu hebben we de nieuwe dipool in nn1, nn2 en kunnen we subsitueren: SubstNtInQHar (Qhar,nd1/2,nn1/2) SubstNtInQHar (Qhar,nd2/2,nn2/2) FillQharType (Qhar, flag) FUNCTION = %True END IF END IF logfile "more dis, subst:" + STR$(nd1/2) + "->" + STR$(nn1/2) + ", " + STR$(nd2/2) + "->" + STR$(nn2/2) END IF END FUNCTION FUNCTION Har2Qhar (h AS harmtype, qh AS Qharmtype, OPTIONAL BYVAL trans AS LONG) EXPORT AS LONG ' 01.10.2006 'translates a harmstring to the qharmstring format and optionally shifts the result a number 'of quartertone steps as passed in the parameter trans 'The return value of the function is the number of notes contained in the qh string. '19.01.2007 : dis en kon field are copied if found. (maybe not correct if transposed) ' recalculates also the psychord. LOCAL i AS DWORD LOCAL n AS DWORD FOR i = 0 TO 255 IF ISFALSE i MOD 2 THEN IF (i+1+trans > 0) AND (i+1+trans < 255) THEN MID$(Qh.vel,i+1+ trans,1) = MID$(h.vel,(i\2)+1, 1) IF ASC(MID$(Qh.vel,i+1+trans,1)) THEN INCR n 'note counter END IF END IF NEXT i qh.dis = h.dis ' not correct on transposes. qh.kon = h.kon GetPsiQChord (qh) GetQIntProp (qh) qh.flag = h.flag ' with restrictions... FUNCTION = n END FUNCTION SUB GetPsiQChord (QHar AS QHarmType) EXPORT ' not exported! - for fillhartype ' exported since 05.09.2007 - gwr LOCAL pH AS BYTE PTR LOCAL i AS LONG LOCAL bn AS LONG LOCAL nv%, ov%, sumV% i = VARPTR(QHar.vel) pH = i FOR i=0 TO 23 QHar.c(i)= %False NEXT i FOR i = 0 TO 255 bn = i MOD 24 IF @pH > %False THEN IF ISFALSE i MOD 2 THEN nv% = GetShepVal(i/2) * @pH ELSE nv% = (GetShepVal(i/2) + GetShepVal((i/2) + 1)) * @pH / 2 ' so for quartertones we interpolate in the existing shepard lookup. END IF ov% = QHar.c(bn) * 127 sumV% = SumVelo(nv%, ov%) QHar.c(bn) = sumV% / 127! END IF INCR pH NEXT i END SUB SUB GetPsiChord (Har AS HarmType) ' not exported anymore. used for fillhartype LOCAL pH AS BYTE PTR LOCAL i AS LONG LOCAL bn AS LONG LOCAL nv%, ov%, sumV% i = VARPTR(Har.vel) ' new 10.03.2000 pH = i 'ERASE Har.c ' worked only in PB3.5 'reset (Har.c()) ' should work after the manual... but it does not work either. (21.01.2007) FOR i=0 TO 11 Har.c(i)= %False NEXT i 'MAT Har.c = ZER ' does not work FOR i = 0 TO 127 'v% = ASC(MID$(Har.vel, i + 1, 1)) bn = i MOD 12 IF @pH > %False THEN nv% = GetShepVal(i) * @pH ov% = Har.c(bn) * 127 sumV% = SumVelo(nv%, ov%) Har.c(bn) = sumV% / 127! END IF INCR pH NEXT i END SUB SUB GetQIntProp (QHar AS QHarmType) ' not exported used for fillQHartype LOCAL n AS DWORD LOCAL ln AS DWORD LOCAL ni AS DWORD LOCAL il AS DWORD LOCAL s AS DWORD FOR n = 0 TO 12 QHar.Iprop(n)= %False NEXT n ' requires GetPsichord prior ta call !!! FOR n = 0 TO 12 'IF n = 6 THEN ln = 5 ELSE ln = 11 IF n = 12 THEN ln = 11 ELSE ln = 23 ni = %False FOR il = 0 TO ln s = (il + n) MOD 24 IF QHar.c(il) > 0 AND QHar.c(s) > 0 THEN QHar.Iprop(n) = QHar.Iprop(n) + QHar.c(il) + QHar.c(s) ni = ni + 2 END IF NEXT il IF ni > 0 THEN QHar.Iprop(n) = QHar.Iprop(n) / ni ELSE QHar.Iprop(n) = %False END IF NEXT n END SUB SUB FillQHarType (QHar AS QHarmType, OPTIONAL BYVAL flag AS DWORD) EXPORT ' flag = %use_fuzzypsy is invalid here, since we did not implement it for quartertones yet. LOCAL i AS LONG LOCAL d! FOR i = 0 TO 23 QHar.c(i)= %False NEXT i GetPsiQChord QHar ' fills Har.C(0 TO 23) d! = QHarProps (QHar, flag) ' returns Qhar.dis - and Qhar.kon FOR i = 0 TO 12 QHar.Iprop(i)= %False NEXT i GetQIntProp QHar ' fills Har.Iprop(0 to 12) QHar.flag = NOT(flag) ' new 22.01.2007 END SUB SUB FillHarType (Har AS HarmType,OPTIONAL BYVAL flag AS DWORD) EXPORT ' redesigned 20.01.2007 . This should now become the general function to call. LOCAL i AS LONG LOCAL d! FOR i = 0 TO 11 Har.c(i)= %False NEXT i GetPsiChord Har ' fills Har.C(0 TO 11) - rewritten 10.03.2000 GetAkuCons (Har, flag) ' supports all flags now. GetAkuDis (Har, flag) ' id. FOR i = 0 TO 6 Har.Iprop(i)= %False NEXT i GetIntProp Har ' fills Har.Iprop(0 to 6) Har.flag = NOT(flag) END SUB FUNCTION IsNoteInQHar (Qh AS QHarmtype, BYVAL n AS CUR) EXPORT AS LONG 'added 18.01.2007 ' the return value is the velo as found in the har-string. ' n = fractional midi note LOCAL p AS INTEGER IF (n < 0) OR (n > 127.5) THEN FUNCTION = %False : EXIT FUNCTION p = n * 2 ' 0-127 wordt 0 - 254 INCR p IF MID$(Qh.vel,p,1) = CHR$(0) THEN FUNCTION = %False ELSE FUNCTION =ASC(MID$(Qh.vel,p,1)) END FUNCTION FUNCTION IsNoteInHar (h AS Harmtype, BYVAL n AS BYTE) EXPORT AS LONG 'added 11.06.2001 'returns the velo of the note. n = n AND &H7F INCR n ' important, as MID$ starts counting with 1 IF MID$(h.vel,n+1,1) = CHR$(0) THEN FUNCTION = %False ELSE FUNCTION = ASC(MID$(h.vel,n+1,1)) END FUNCTION FUNCTION IsNoteInOktHar (h AS Harmtype, BYVAL n AS BYTE) EXPORT AS WORD 'added 28.11.2012 - gwr 'checks whether or not a note exists in the har string passed, in any octave position. 'it returns the occurence of that note with the highest velocity value, in case the note occurs more than one time. 'returns the note in hibyte.word and the velo in lobyte.word LOCAL vel, note AS BYTE n = n MOD 12 INCR n DO IF MID$(h.vel,n,1) = CHR$(0) THEN ' noot komt niet voor ELSE IF vel < ASC(MID$(h.vel,n,1)) THEN vel = ASC(MID$(h.vel, n, 1)) note = n-1 END IF END IF n += 12 IF n > 128 THEN EXIT LOOP LOOP FUNCTION = (note * 256)+ vel END FUNCTION FUNCTION SumQHar$ (H1 AS QHarmType, H2 AS QHarmType) EXPORT ' 18.01.2007 - similar to the chromatic function LOCAL pH1 AS BYTE PTR LOCAL pH2 AS BYTE PTR LOCAL pH3 AS BYTE PTR LOCAL H3 AS QHARMTYPE LOCAL j AS LONG pH1 = VARPTR(H1.vel) pH2 = VARPTR(H2.vel) pH3 = VARPTR(H3.vel) FOR j = 0 TO 255 @pH3 = SumVelo(@pH1,@pH2) ' in g_mus.dll INCR pH1 INCR pH2 INCR pH3 NEXT j FUNCTION = H3.vel END FUNCTION FUNCTION SumHar$ (H1 AS HarmType, H2 AS HarmType) EXPORT ' recoded 14.03.2000 LOCAL pH1 AS BYTE PTR LOCAL pH2 AS BYTE PTR LOCAL pH3 AS BYTE PTR LOCAL H3 AS HARMTYPE LOCAL j AS LONG pH1 = VARPTR(H1.vel) pH2 = VARPTR(H2.vel) pH3 = VARPTR(H3.vel) FOR j = 0 TO 127 @pH3 = SumVelo(@pH1,@pH2) INCR pH1 INCR pH2 INCR pH3 NEXT j FUNCTION = H3.vel END FUNCTION FUNCTION GetHighestNote (h AS Harmtype, BYVAL low AS BYTE, BYVAL high AS BYTE) EXPORT AS INTEGER ' new 07.06.2001 ' returns -1 if no highest note was found. ' otherwize, returns note in the high byte of the return value and the corresponding velo value in the low byte LOCAL i AS LONG LOCAL v AS BYTE LOCAL note AS INTEGER note = -1 IF low > high THEN SWAP low, high FOR i = high TO low STEP -1 v = ASC(MID$(h.vel, i+1, 1)) ' the +1 was missing up to 02.08.2003 !!!! gwr. IF v THEN note = i SHIFT LEFT note,8 note = note OR v EXIT FOR END IF NEXT i FUNCTION = note END FUNCTION FUNCTION GetLowestNote (h AS Harmtype, BYVAL low AS BYTE, BYVAL high AS BYTE) EXPORT AS INTEGER ' return value: note = HI(BYTE, retval) ' velo = LO(BYTE, retval) LOCAL i AS LONG LOCAL v AS BYTE LOCAL note AS INTEGER note = -1 IF low > high THEN SWAP low, high FOR i = low TO high v = ASC(MID$(h.vel, i+1, 1)) ' the +1 was missing up to 02.08.2003 !!!! gwr. IF v THEN note = i SHIFT LEFT note,8 note = note OR v EXIT FOR END IF NEXT i FUNCTION = note END FUNCTION FUNCTION MirHar$ (h AS HarmType, BYVAL n%)EXPORT LOCAL ret$, i%, v%, nn% ret$ = STRING$(128, 0) FOR i% = 1 TO 128 v% = ASC(MID$(h.vel, i%, 1)) IF v% > 0 THEN nn% = (n% + n%) - (i% - 1) IF (nn% > -1) AND (nn% < 128) THEN MID$(ret$, nn% + 1, 1) = CHR$(v%) END IF NEXT i% FUNCTION = ret$ END FUNCTION SUB QHar2LinSpec (h AS QHarmType, Sp!()) EXPORT ' convert a qhar string to a spectrum array ' uitbreiding van de Har2LinSpec funktie in g_mus.dll ' to be checked. gwr LOCAL nrp%, einde%, n%, mv% LOCAL i AS CUR LOCAL oldf!, f! nrp% = UBOUND(Sp!) + 1 IF nrp% <= 1 THEN FOR i = 256 TO 1 STEP -1 IF ASC(MID$(h.vel, i, 1)) > 0 THEN nrp% = NF2F(i/2): 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 (F2NF(f!) * 2) <= 255 THEN einde% = 2 * F2NF(f!) ELSE einde% = 255 FOR n% = 0 TO einde%: 'F2N%(f!) f! = NF2F(n% / 2) 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 QHar2Samp (h AS QHarmType, Samp!()) EXPORT ' similar to the chromatic procedure 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 QHar2LinSpec 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 LinSpec2QHar (Sp!(), h AS QHarmType, BYVAL unitbandwidth AS SINGLE) EXPORT ' analog to the chromatic function. Xlat 18.01.2007 - to be evaluated. gwr ' 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(255) AS STATIC SINGLE 'NoteFreq(i) = ubound of freq. range for note i FOR i = 0 TO 255 NoteFreq(i)= NF2F(i/2) / (2 ^ (1/24) ) '/ was * NEXT ' Topfrq = N2F%(127) ' midi note 127 Tog = %True END IF h.vel = NUL$(256) ' =STRING$(256, 0) i = 1 DO f! = i * unitbandwidth IF f! >= Botfrq THEN FOR noot = MAX(oldn, 1) TO 255 '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 > 255 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 ' 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 SUB Samp2QHar (Samp!(), h AS QHarmType) EXPORT ' 18.01.2007 - analog to chromatic function. 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 LinSpec2QHar for conversion to quartertone spectrum... LinSpec2QHar Sp!(), h, 1 h.flag = %False ERASE Sp! END SUB SUB SplitQhar (qh AS QharmType, hl AS harmtype, hh AS harmtype) EXPORT ' new 18.01.2007 ' this procedure puts all 'normal' notes in hl.vel and the quartertones in hh.vel ' can be used to write har-seq files as well as for playing on Qt. LOCAL i AS DWORD LOCAL j AS DWORD LOCAL k AS DWORD j = 1 k = 1 FOR i = 1 TO 256 IF (i-1) MOD 2 THEN ' quartertones MID$(hh.vel, k, 1) = MID$(qh.vel,i,1) INCR k ELSE ' chromatic tones MID$(hl.vel, j, 1) = MID$(qh.vel,i,1) INCR j END IF NEXT i hl.flag = %False hh.flag = %False END SUB FUNCTION F2QT (BYVAL f!) EXPORT AS SINGLE ' converts frequency to the nearest quartertone - existed already in this library since 2004 ' maybe we should change it to return a cur type. LOCAL q AS SINGLE IF f! < 8 THEN FUNCTION = 0: EXIT FUNCTION q = (12! * (LOG(f!) - LOG(GrondDo)) / (LOG(2))) SELECT CASE FRAC(q) CASE < 0.250 FUNCTION = FIX(q) CASE < 0.75 FUNCTION = FIX(q) + 0.5# CASE ELSE FUNCTION = FIX(q) + 1! END SELECT END FUNCTION FUNCTION GetAkuCons (Har AS HarmType, OPTIONAL BYVAL flag AS DWORD) EXPORT AS SINGLE ' not exported. ' was to be done 'FUNCTION = 1! - GetAkuDis(Har) - was patch up to 17.01.2007 'now we do it correctly: [18.01.2007] 'here we do not use the spectrum. ' %use_velo = %False ' use velos from the harmstring ' ' values 1-127 reserved for velo constant '%use_spectrum = 128 '%use_fuzzypsy = 256 ' uses chordnumbers and the fuzzy data sets for psychords ' exported again on request by kl. ' vectorsum corrected 19.01.2007 LOCAL i%, v1%, v2%, j% LOCAL kons AS SINGLE LOCAL pkons AS SINGLE LOCAL nkons AS SINGLE LOCAL nrpos AS LONG LOCAL nrneg AS LONG LOCAL psum AS SINGLE LOCAL nsum AS SINGLE IF flag = %use_fuzzypsy THEN ' fast legacy fuzzy function kons =GetConPsy(Har) FUNCTION = kons EXIT FUNCTION END IF FOR i% = 1 TO 127 v1% = ASC(MID$(Har.vel, i%, 1)) IF v1% > 0 THEN SELECT CASE flag CASE 1 TO 127 v1% = flag END SELECT FOR j% = (i% + 1) TO 128 v2% = ASC(MID$(Har.vel, j%, 1)) IF v2% > 0 THEN SELECT CASE flag CASE 1 TO 127 v2% = flag END SELECT ' use the quartertone lookup function for this dipole: ' kons = QDipKon((i%-1)*2,v1%,(j%-1)*2,v2%) '!!!!!!!!!QDIpkons verwacht fractional midi!!! kons = QDipKon((i%-1),v1%,(j%-1),v2%) IF kons >= 0.5 THEN pkons = (kons - 0.5) * 2 ELSE pkons = 0 ' pkons = 0-1 IF kons < 0.5 THEN nkons = (kons * 2) ELSE nkons = 0 ' nkons = 0-1 ' algorithm must preserve 0.5 as median value !!! IF pkons > 0 THEN psum = psum + (pkons^2) INCR nrpos END IF IF nkons > 0 THEN nsum = nsum + (nkons^2) INCR nrneg END IF END IF NEXT j% END IF NEXT i% IF nrneg + nrpos < 1 THEN FUNCTION = 0.5 '%False ELSE psum = SQR(psum) / SQR(nrpos) ' 0-1 nsum = SQR(nsum) / SQR(nrneg) ' 0-1 IF ISFALSE nrneg THEN FUNCTION = 0.5 + (psum/ 2) EXIT FUNCTION END IF IF ISFALSE nrpos THEN FUNCTION = nsum / 2 EXIT FUNCTION END IF ' psum = 0.5 + (psum/2) ' restore offset - now 0.5 - 1 ' nsum = nsum / 2 ' now 0 - 0.5 FUNCTION = (psum + nsum) / 2 END IF END FUNCTION FUNCTION GetAkuDis (Har AS HarmType, OPTIONAL BYVAL flag AS DWORD) EXPORT AS SINGLE ' flags: %use_velo : uses the velo values in the harmstring passed ' 1-127 : uses the value of the flag for the velo weighting ' %use_spectrum : uses spectrum description from data set on spectral dipoles ' %use_fuzzypsy : uses fuzzy sets from psychoacoustics library. ' not exported . Called by other procs. (fillHarType) ' also uses the spectrum !!! ' modified and corrected 18.01.2007 - vectorsum bug solved 19.01.2007 ' exported again on request by kl. one caveat: when used with %use_fuzzypsy the user should make sure that the fuzzy shepard chord descriptor isa filled in! 'kl debug: before 20070302 this function was only working correctly with flag 127! ' cause: QDipDis expects (fractional) midinotes, it recalculates the notes itself to a position in the QDipoles array ' now there is still an inconsistency: flag 126 gives slightly higher dissonances then 127. we suspect because of rounding errors.. LOCAL nrnotes%, i%, v1%, v2%, j% LOCAL retval! LOCAL dis AS SINGLE IF flag = %use_fuzzypsy THEN FUNCTION = GetDisPsy(Har) ' fills Har.Dis EXIT FUNCTION END IF nrnotes% = %False retval! = 0 FOR i% = 1 TO 127 v1% = ASC(MID$(Har.vel, i%, 1)) IF v1% > 0 THEN FOR j% = (i% + 1) TO 128 v2% = ASC(MID$(Har.vel, j%, 1)) IF v2% > 0 THEN SELECT CASE Flag CASE %use_velo ' use the quartertone dipole lookup table. ' dis = QDipDis ((i%-1)*2, v1%,(j%-1)*2, v2%) 'this was wrong.. dis = QDipDis ((i%-1), v1%,(j%-1), v2%) '*2 DONE IN qDIPDIS?? CASE 1 TO 126 ' dis = QDipDis ((i%-1)*2, flag,(j%-1)*2, flag) dis = QDipDis ((i%-1), flag,(j%-1), flag) CASE 127 ' use the lookup directly - no weighting dis = QDipoles((i%-1) *2).DIS((j%-1)*2) CASE %use_spectrum ' use the function for this spectral dipole: ' was: 'retval! = SQR((retval! ^ 2) + (GetDipAkuDis!(i%, v1%, j%, v2%) ^ 2)) 'IF retval! >= 1 THEN ' FUNCTION = 1 ' EXIT FUNCTION 'END IF '------ this could get larger than 1. So we coded it correctly as: dis = GetDipAkuDis!(i%-1,v1%,j%-1,v2%) ' case %use_fuzzypsy ' not to be handled here... END SELECT IF dis > 0 THEN retval! = retval! + (dis ^2) 'permanent sum of squares INCR nrnotes% ' counts diads with dissonance property END IF END IF NEXT j% END IF NEXT i% IF nrnotes% < 1 THEN FUNCTION = %False ELSE FUNCTION = SQR(retval!) / SQR(nrnotes%) ' correct vectorsum ' was = retval! END IF END FUNCTION FUNCTION GetQAkuDis (Har AS QHarmType) AS SINGLE ' not exported, ' note that this function is not analogous to GetAkuDis! called only by GetQIntProp when flag = %use_spectrum (128) ' GetQIntProp deals with the other flags ' uses the spectrum, but now for Qhar strings. ' added 19.01.2007 - does not need an export, since we can use the flag with GetQIntProps and/or fillQhartype ' 20.01.2007 i% note counter bug removed ! LOCAL nrnotes%, i%, v1%, v2%, j% LOCAL retval! LOCAL dis AS SINGLE nrnotes% = %False retval! = 0 FOR i% = 1 TO 255 v1% = ASC(MID$(Har.vel, i%, 1)) IF v1% > 0 THEN FOR j% = (i% + 1) TO 256 v2% = ASC(MID$(Har.vel, j%, 1)) IF v2% > 0 THEN ' use the function for this spectral dipole: dis = GetDipAkuDis((i%-1)/2,v1%,(j%-1)/2,v2%) IF dis > 0 THEN retval! = retval! + (dis ^2) 'permanent sum of squares INCR nrnotes% ' counts diads with dissonance property END IF END IF NEXT j% END IF NEXT i% IF nrnotes% < 1 THEN FUNCTION = %False ELSE FUNCTION = SQR(retval!) / SQR(nrnotes%) ' correct vectorsum END IF END FUNCTION FUNCTION GetDipAkuDis (BYVAL n1 AS CUR, BYVAL v1%, BYVAL n2 AS CUR, BYVAL v2%) EXPORT AS SINGLE ' dipole function ' uses the spectral composition according to the data in the ini file. ' has normalisation bug !!! ' normalisation bug killed 19.01.2006 ' now takes fractional midi as inputs also. ' can be improved for speed if we use the lookups for quartertones, but at the detriment of precision. STATIC Tog AS LONG ', Spec!() LOCAL NrHarmonics%, f1%, f2%, i% ,j%, fhi% , vhi%, fh2i%, vh2% LOCAL retval!, vh!, disson! LOCAL fh&, fh2& LOCAL cnt AS DWORD IF ISFALSE Tog THEN ' check for a decription file..., if none, use default... DIM Spec(0,0) AS GLOBAL SINGLE CALL GetSpecDefault(Spec(), 8): ' explicit call - in g_mus.dll Tog = %True END IF IF n1 = n2 THEN FUNCTION = 0: EXIT FUNCTION IF v1% + v2% <= 1 THEN FUNCTION = 0: EXIT FUNCTION NrHarmonics% = UBOUND(Spec, 2) f1% = NF2F(n1) f2% = NF2F(n2) IF f1% > f2% THEN SWAP f1%, f2%: SWAP v1%, v2% retval! = 0 FOR i% = 0 TO NrHarmonics% fh& = f1% * Spec(0, i%) vh! = Spec(1, i%) IF vh! > 0 THEN IF fh& < 6000 THEN ' was 20000, but we could take an even much lower limit here... fhi% = fh& vhi% = v1% * vh! '(v1%, NormVol2Midi%(vh!)) IF vhi% > 0 THEN FOR j% = 0 TO NrHarmonics% fh2& = f2% * Spec(0, j%) IF fh2& < 6000 THEN ' was 20000, but we could take an even much lower limit here... fh2i% = fh2& IF fh2i% <> fhi% THEN vh2% = v2% * Spec(1, j%) IF vh2% > 0 THEN disson! = GetDipoleDis(fhi%, vhi%, fh2i%, vh2%) ' freq. funktie. IF disson! > 0 THEN retval! = retval! + (disson!^2) INCR cnt END IF END IF END IF END IF NEXT j% END IF END IF END IF NEXT i% IF cnt THEN FUNCTION = SQR(retval!) / SQR(cnt) ELSE FUNCTION = %False END IF END FUNCTION SUB AddShNo2Har (Har AS HarmType, BYVAL n AS BYTE, BYVAL v AS BYTE) EXPORT LOCAL bn AS DWORD LOCAL sv AS DWORD LOCAL ov AS DWORD LOCAL nv AS DWORD IF v > 127 THEN v = 127 bn = n MOD 12 DO sv = GetShepVal(bn) * v ov = ASC(MID$(Har.vel, bn + 1, 1)) nv = SumVelo(ov, sv) MID$(Har.vel, bn + 1, 1) = CHR$(nv) bn = bn + 12 LOOP UNTIL bn > 127 Har.flag = %False END SUB FUNCTION CommonHar$ (H1 AS HarmType, H2 AS HarmType) EXPORT LOCAL i AS DWORD LOCAL ret$ ret$ = STRING$(128, 0) FOR i = 1 TO 128 IF (ASC(MID$(H1.vel, i, 1)) > %False) AND (ASC(MID$(H2.vel, i, 1)) > %False) THEN MID$(ret$, i, 1) = MID$(H1.vel, i, 1) NEXT i FUNCTION = ret$ END FUNCTION FUNCTION ConvergeHar$ (h AS HarmType, BYVAL refn%, BYVAL fak!) EXPORT AS STRING LOCAL ret$, v%, n%, delta%, nn%, vn% , i% IF refn% < %False THEN refn% = %False IF refn% > 127 THEN refn% = 127 IF fak! = 1! THEN ConvergeHar$ = h.vel: EXIT FUNCTION ret$ = STRING$(128, 0) FOR i% = %d0 TO %d7 v% = ASC(MID$(h.vel, i%, 1)) IF v% > %False THEN n% = i% - 1 delta% = fak! * (n% - refn%) nn% = refn% + delta% IF n% <> refn% THEN IF nn% = n% THEN nn% = n% + (SGN(fak! - 1) * (delta% - 1)) IF nn% = n% THEN nn% = refn% ELSE nn% = n% END IF IF (nn% < 128) AND (nn% > %NotFalse) THEN vn% = ASC(MID$(ret$, nn% + 1, 1)) vn% = SumVelo(vn%, v%) MID$(ret$, nn% + 1, 1) = CHR$(vn%) END IF END IF NEXT i% FUNCTION = ret$ END FUNCTION FUNCTION LimitHar (h AS harmtype, BYVAL lowlimit AS BYTE, BYVAL highlimit AS BYTE) EXPORT AS STRING ' returns a harmony string containing only the notes within the range specified ' added to library 06.09.2003 - used in SQE-STO LOCAL bn AS DWORD STATIC ret AS STRING * 128 ret = NUL$(128) IF highlimit < lowlimit THEN SWAP highlimit, lowlimit bn = lowlimit DO MID$(ret, bn+1,1) = MID$(h.vel, bn+1,1) INCR bn LOOP UNTIL bn > highlimit FUNCTION = ret END FUNCTION FUNCTION ReScaleHarvel (h AS harmtype, faktor AS SINGLE) EXPORT AS STRING ' added 05.11.2004 ' rescales all the velo values in the harmstring passed. ' used for real time dynamic controll using the PlayHar function. ' faktor must be a positive value 0-4 bvb. ' it is possible to use and write: h.vel = ReScaleHarvel h, faktor LOCAL ret AS STRING * 128 LOCAL i AS DWORD LOCAL n AS DWORD ret = STRING$(128, 0) FOR i = 1 TO 128 n = ASC(MID$(h.vel, i,1)) IF n > %False THEN n = MAX(MIN(n * faktor, 127),1) MID$(ret,i,1) = CHR$(n) END IF NEXT i FUNCTION = ret END FUNCTION FUNCTION Fit2Mode$ (h AS HarmType, BYVAL mode%, BYVAL tc%) EXPORT LOCAL i%, ret$, Dif$, vd%, ju%, jd%, nn%, ov%, nv% DIM Scal AS HarmType Scal.vel = STRING$(128, 0) Scal.vel = GetScaleHar$(mode%, tc%, 127) ret$ = STRING$(128, 0) ret$ = CommonHar$(h, Scal) Dif$ = AbsDifHar$(h, Scal) FOR i% = %d0 TO %d7 vd% = ASC(MID$(Dif$, i%, 1)) IF vd% THEN ju% = i% jd% = i% nn% = -1 DO IF ASC(MID$(Scal.vel, ju%, 1)) > 0 THEN nn% = ju%: EXIT DO IF ASC(MID$(Scal.vel, jd%, 1)) > 0 THEN nn% = jd%: EXIT DO INCR ju% IF ju% > %d7 THEN ju% = %d7 DECR jd% IF jd% < %d0 THEN jd% = %d0 LOOP UNTIL (jd% = %d0) AND (ju% = %d7) IF nn% > -1 THEN ov% = ASC(MID$(ret$, nn%, 1)) nv% = SumVelo(ov%, vd%) MID$(ret$, nn%, 1) = CHR$(nv%) END IF END IF NEXT i% FUNCTION = ret$ END FUNCTION SUB AddNote2Har (Har AS HarmType, BYVAL n AS BYTE, BYVAL v AS BYTE) EXPORT LOCAL ov AS DWORD LOCAL nv AS DWORD IF n > 127 THEN EXIT SUB IF v > 127 THEN v = 127 ov = ASC(MID$(Har.vel, n + 1, 1)) IF ISFALSE ov THEN MID$(Har.vel, n + 1, 1) = CHR$(v) ELSE nv = SumVelo(ov, v) MID$(Har.vel, n + 1, 1) = CHR$(nv) END IF Har.flag = %False END SUB SUB AddNote2QHar (Har AS QHarmType, BYVAL n AS SINGLE, BYVAL v AS BYTE) EXPORT '20070322 debugged: LOCAL ov AS DWORD LOCAL nv AS DWORD LOCAL nn AS DWORD IF n < 0 THEN EXIT SUB IF n > 127.5 THEN EXIT SUB IF v > 127 THEN v = 127 nn = n * 2 ov = ASC(MID$(Har.vel, nn + 1, 1)) 'nn was n -> was bug! IF ISFALSE ov THEN MID$(Har.vel, nn + 1, 1) = CHR$(v) 'nn was n -> was bug! ELSE nv = SumVelo(ov, v) MID$(Har.vel, nn + 1, 1) = CHR$(nv) END IF Har.flag = %False END SUB SUB DelNote2Qhar (Har AS Qharmtype, BYVAL n AS SINGLE) EXPORT ' added 05.09.2007 - gwr LOCAL nn AS DWORD IF n < 0 THEN EXIT SUB IF n > 127.5 THEN EXIT SUB nn = n * 2 MID$(Har.vel,nn+1,1)= NUL$(1) Har.flag = %False END SUB SUB ShiftDownStrongest (H1 AS HarmType, H2 AS HarmType) EXPORT LOCAL i, j, b AS DWORD LOCAL n, tog AS LONG H2.vel = STRING$(128, 0) FillHarType H1, %use_velo ' required, since we need H1.C() n = GetStrongest(H1, 1) IF n < %False THEN EXIT SUB ' return a zero string n = n MOD 12 ' not realy required. Tog = %False j = %d0 FOR i = %d0 TO %d7 b = ASC(MID$(H1.vel, i, 1)) IF Tog = %False THEN IF b > 0 THEN IF (i - 1) MOD 12 = n THEN MID$(H2.vel, j, 1) = CHR$(b) j = j + 1 Tog = %NotFalse END IF END IF ELSE MID$(H2.vel, j, 1) = CHR$(b) INCR j END IF NEXT i H2.flag = %False END SUB SUB ShiftHar (H1 AS HarmType, H2 AS HarmType, BYVAL minval%) EXPORT ' returns the result of the shift operation in H2 ' minval% is the minimum threshold level for the velos in order to undergo the shift operation ' 20.01.2007: after revisiting this code, I dont see the reason of it anymore... ' was it a step in conversions to rhythm??? ' shifts H1 down such that it starts at midi-note 0 in H2. (gwr, 08.08.2020) LOCAL b AS LONG LOCAL j AS DWORD LOCAL i AS DWORD LOCAL tog AS LONG H2.vel = NUL$(128) ' STRING$(128, 0) j = %d0 FOR i = %d0 TO %d7 b = ASC(MID$(H1.vel, i, 1)) IF Tog = %False THEN IF b > minval% THEN MID$(H2.vel, j, 1) = CHR$(b) ' seems to transpose downwards... INCR j Tog = %NotFalse END IF ELSE MID$(H2.vel, j, 1) = CHR$(b) INCR j END IF NEXT i H2.flag = %False END SUB FUNCTION HH_DipDis (BYVAL n1 AS SINGLE, BYVAL n2 AS SINGLE, OPTIONAL BYVAL w AS LONG) EXPORT AS SINGLE ' n1, n2 : fractional midi notes. ' optional parameter: 0 = pure dipoles ' %OCTAVE_WEIGHTED = return result weighted for octave distance between notes ' now weighting will be performed as soon as the parameter is non zero ' based on Hemholtz lehre, p. 332 ' with linear interpolation. Basically this is a lookup table. ' returns a normalized value 0-1 for dissonance ('roughness') after Helmholtz ' optional compensation for octave distances. LOCAL cents AS INTEGER LOCAL dis AS SINGLE LOCAL oct AS INTEGER ' first we calculate the interval in cents: cents = 100 * ABS(n1 - n2) IF cents >= 1200 THEN DO cents = cents -1200 INCR oct ' count the number of octaves between the notes LOOP UNTIL cents < 1200 END IF IF cents = 0 THEN FUNCTION = 0 : EXIT FUNCTION SELECT CASE cents CASE < 100 ' 0 to 100 ' d= 100 dis = 76 * (cents / 100) ' 100 => 76 CASE < 112 '100 to 112 ' d=12 dis = 76 - (((cents-100)/12) * 6) ' 112 => 70 CASE < 182 ' 112 to 182 ' d = 70 dis = 70 - (((cents-112)/70) * 32) ' 182 => 38 CASE < 200 '182 to 200 dis = 38 - (((cents - 182) / 18) * 13) ' 200 => 25 CASE < 204 ' 200 to 204 dis = 25 + (((cents - 200) / 4) * 7) ' 204 => 32 CASE < 224 '204 to 224 dis = 32 - (((cents - 204) / 20) * 2) ' 224 => 30 CASE < 274 '224 to 274 dis = 30 - (((cents - 224) / 50) * 6) ' 273 => 24 CASE < 294 '274 to 294 ' d = 20 dis = 24 + (((cents - 274) / 20) * 2) ' 294 => 26 CASE < 300 '294 to 300 ' d = 6 dis = 26 - (((cents - 294) / 6) * 2) ' 300 => 24 CASE < 316 '300 to 316 ' d = 16 dis = 24 - (((cents - 300) / 16) * 4) ' 316 => 20 CASE < 386 ' 316 to 386 ' d = 70 dis = 20 - (((cents - 316) / 70) * 12) ' 386 => 8 CASE < 400 '386 to 400 ' d = 14 dis = 8 + (((cents - 386) / 14) * 10) ' 400 => 18 CASE < 428 '400 to 428 ' d = 28 dis = 18 + (((cents - 400) / 28) * 7) ' 428 => 25 CASE < 498 '429 to 498 ' d = 69 dis = 25 - (((cents - 429) / 69) * 23) ' 498 => 2 CASE < 500 '498 to 500 ' d = 2 dis = 2 + (((cents - 498) / 2) * 1) ' 500 =>3 CASE < 520 '500 to 520 ' d = 20 dis = 3 + (((cents - 500) / 20) * 24) ' 520 => 27 CASE < 568 '520 to 568 ' d = 48 dis = 27 + (((cents - 520) / 48) * 5) ' 568 => 32 CASE < 590 '568 to 590 ' d = 22 dis = 32 - (((cents - 568) / 22) * 12) ' 590 => 20 CASE < 600 '590 to 600 ' d = 10 dis = 20 - (((cents - 590) / 10) * 2) ' 600 =>18 CASE < 610 '600 to 610 ' d = 10 dis = 18 + (((cents - 600) / 10) * 10) ' 610 => 28 CASE < 632 '610 to 632 ' d = 22 dis = 28 + (((cents - 610) / 22) * 7) ' 632 => 35 CASE < 680 '632 to 680 ' d = 48 dis = 35 + (((cents - 632) / 48) * 9) ' 680 => 44 CASE < 700 '680 to 700 ' d = 20 dis = 44 - (((cents - 680) / 20) * 43) ' 700 => 1 CASE < 702 '700 to 702 ' d = 2 dis = 1 - (((cents - 700) / 2) * 1 ) ' 702 => 0 CASE < 772 '702 to 772 ' d = 70 dis = 0 + (((cents - 702) / 70) * 39) ' 772 =>39 CASE < 800 '772 to 800 ' d = 28 dis = 39 - (((cents - 772)/ 28) * 17) ' 800 => 22 CASE < 814 '800 to 814 ' d = 14 dis = 22 - (((cents - 800) / 14) * 2) ' 814 =>20 CASE < 884 '814 to 884 ' d = 70 dis = 20 - (((cents - 814) / 70) * 17) ' 884 => 3 CASE < 900 '884 to 900 ' d = 16 dis = 3 + (((cents - 884) / 16) * 19) ' 900 => 22 CASE < 906 '900 to 906 ' d = 6 dis = 22 + (((cents - 900) / 6) * 2) ' 906 =>24 CASE < 926 '906 to 926 ' d = 20 dis = 24 + (((cents - 906) / 20) * 0) ' 926 =>24 CASE < 976 '926 to 976 ' d = 50 dis = 24 - (((cents - 926) / 50) * 9) ' 976 =>15 CASE < 996 '976 to 996 ' d = 20 dis = 15 + (((cents - 976) / 20) * 8) ' 996 => 23 CASE < 1000 '996 to 1000 ' d = 4 dis = 23 + (((cents - 996) / 4) * 1) ' 1000 => 24 CASE < 1018 '1000 to 1018 ' d = 18 dis = 24 + (((cents - 1000) / 18) * 1) ' 1018 => 25 CASE < 1088 '1018 to 1088 ' d = 70 dis = 25 + (((cents - 1018) / 70) * 17) ' 1088 => 42 CASE < 1100 '1088 to 1100 ' d = 12 dis = 42 + (((cents - 1088) / 12) * 6) ' 1100 =>48 CASE < 1200 '1100 to 1200 ' d = 100 dis = 48 - (((cents - 1100) / 100) * 48) ' 1200 => 0 END SELECT ' now normalize. The largest value in the lookup is 76, thus: dis = dis / 76 ' we do weighting for octave distance only if requested by the optional parameter IF w THEN dis = dis * (10-oct / 10) FUNCTION = dis END FUNCTION FUNCTION HH_Diad (BYVAL cents AS DWORD, BYVAL n1 AS CUR, BYREF n2 AS CUR, BYVAL d AS SINGLE)EXPORT AS SINGLE ' This function builds diads with a dissonance passed in d within the pitch resolution ' constraints given. It will search for the closest match for the ' dissonance parameter. It makes use of the Herman Helmholtz theory on consonance and uses his data sets. ' cents = 0-100 if 0, semitone resolution will be used ' n1 = first given note for the chord. Range is limited to 0-115, in fractional midi ' n2 = a value for n2 will be returned in n2 ' the return value of the function is the normalized dissonance of the diad (0-1) ' xof update: errormessage on invalid input (Bass < 12) , removed superfluous ABS inf FRAC(ABS()) LOCAL Ctns AS CUR LOCAL ddr AS SINGLE LOCAL i AS CUR LOCAL ds AS SINGLE LOCAL dif AS SINGLE IF ISFALSE n1 THEN n1 = 60 IF n1 < 12 THEN n1 = n1 + 12 ddr = 1 Ctns = cents / 100 IF Ctns < 0.01 THEN Ctns = 1 ' default to semitones EQ IF n1 < 12 THEN MSGBOX "Invalid input in " + FUNCNAME$ + $CRLF + "base note of chord should be >= 12" EXIT FUNCTION END IF ' zoek optimale n2 (in enge ligging) FOR i = n1 + Ctns TO (n1 + 12) - Ctns STEP Ctns IF FRAC((i-n1)/12) <> %False THEN ' no octaves! ds = HH_dipdis (n1, i) dif = ABS(ds - d) IF dif < ddr THEN ddr = dif : n2 = i: FUNCTION = ds END IF NEXT i END FUNCTION FUNCTION HH_Triad (BYVAL cents AS DWORD, BYVAL n1 AS CUR, BYREF n2 AS CUR, BYREF n3 AS CUR, BYVAL d AS SINGLE) EXPORT AS SINGLE ' This function builds triads with a dissonance passed in d within the pitch resolution ' constraints given. It will search for the closest match for the ' dissonance parameter. It makes use of the Herman Helmholtz theory on consonance and uses his data sets. ' cents = 0-100 if 0, semitone resolution will be used ' n1 = first given note for the chord. Range is limited to 0-115, in fractional midi ' n2 = if this value is zero, a value for n2 will be returned in n2 ' if it is non zero, the n1-n2 diad will be used as a base to calculate n3 ' n3 = this note will always be calculated by the function. It will always be above n1. ' the return value of the function is the combined normalized dissonance of the chord (0-1) ' If on entry, all values for n1,n2,n3 are non zero, the function will return the dissonance of the chord, ' disregarding the value for d and taking into account octaves between the notes. ' xof update: errormessage on invalid input (Bass < 12) , removed superfluous ABS inf FRAC(ABS()) ' 14.02.2008 now can't return an octave anymore (before this was still possible between n1 and n3) ' tested 06.02.2008 gwr. ' 19.08.2020: used in Linac piece, gwr. LOCAL Ctns AS CUR LOCAL ddr AS SINGLE LOCAL i AS CUR LOCAL j AS CUR LOCAL ds AS SINGLE LOCAL d1 AS SINGLE LOCAL d2 AS SINGLE LOCAL d3 AS SINGLE LOCAL oct AS LONG LOCAL dif AS SINGLE ddr = 1 Ctns = cents / 100 IF Ctns < 0.01 THEN Ctns = 1 ' default to semitones EQ IF n1 < 12 THEN MSGBOX "Invalid input in " + FUNCNAME$ + $CRLF + "base note of chord should be > 12" EXIT FUNCTION END IF IF n3 THEN ' just return the dissonance of the triad, with octaves. d1 = HH_DipDis (n1,n2,1) d2 = HH_DipDis (n1,n3,1) d3 = HH_DipDis (n2,n3,1) FUNCTION = SQR((d1^2) + (d2^2) + (d3^2))/ SQR(3) EXIT FUNCTION END IF IF ISFALSE n2 THEN ' zoek optimale n2 en n3 (in enge ligging) FOR i = n1 + Ctns TO (n1 + 12) - Ctns STEP Ctns d1 = HH_Dipdis (n1, i) 'FOR j = n1 + cts + cts TO (n1 + 12) - (cts * 2) STEP cts FOR j = i + Ctns TO (n1 + 12) - (Ctns * 2) STEP Ctns ' a lot faster... '- (ctns * 2)?? IF (j MOD 12) = (n1 MOD 12) THEN ITERATE FOR IF FRAC((i-j)/12) <> %False THEN IF FRAC( (i-n1)/12) <> %False THEN ' no octaves! IF FRAC((j-n1)/12) <> %False THEN d2 = HH_Dipdis (n1,j) d3 = HH_Dipdis (i,j) 'ds = d1 + d2 + d3 ' gemiddelde 'ds = max(d1,d2,d3) ' max ' sum of squares (vectorsum) - gives best results. ds = SQR((d1^2) + (d2^2) + (d3^2))/ SQR(3) 'IF ds < d THEN d = ds : n2 = i: n3 = j dif = ABS(ds - d) IF dif < ddr THEN ddr = dif : n2 = i: n3 = j : FUNCTION = ds END IF END IF END IF NEXT j NEXT i 'FUNCTION = d ELSE ' in dit geval is n2 ook gegeven ' we zoeken alleen de ideale n3 ' we make octave weighting active only if the interval n1-n2 exceeds the octave IF ABS(n1-n2) > 12 THEN oct = %True ELSE oct = %False d3 = HH_Dipdis (n1, n2, oct) FOR i = n1 + Ctns TO (n1+12) - Ctns STEP Ctns IF (i <> n1) AND (i <> n2) THEN IF FRAC((i-n1)/12) <> %False THEN IF FRAC((i-n2)/12) <> %False THEN d1 = HH_Dipdis (n1,i,oct) d2 = HH_Dipdis (n2,i, oct) 'ds = d1 + d2 + d3 'ds = max(d1,d2) ds = SQR((d1^2) + (d2^2)) / SQR(2) 'IF ds < d THEN d = ds : n3 = i : FUNCTION = SQR((d1^2)+(d2^2)+(d3^2))/ SQR(3) dif = ABS(ds-d) IF dif < ddr THEN ddr = dif: n3 = i : FUNCTION = SQR((d1^2)+(d2^2)+(d3^2))/ SQR(3) END IF END IF END IF NEXT i END IF FUNCTION = ds END FUNCTION FUNCTION HH_Tetrad (BYVAL cents AS DWORD, BYVAL n1 AS CUR, BYREF n2 AS CUR, BYREF n3 AS CUR, BYREF n4 AS CUR, BYVAL d AS SINGLE) EXPORT AS SINGLE ' generalized parametric function. ' n1 is the base note whereupon the chord will be build. ' cents = resolution of the tuning system used ' d = requested degree of dissonance. If 0, the most consonant chord will be returned. ' if a value for n4 is given on entry, the function will return the dissonance of the chord taking into ' account octave distances. ' xof update: errormessage on invalid input (Bass < 12) , removed superfluous ABS inf FRAC(ABS()) ' 14.02.2008 now allways returns 4 different pitches. note that (depending on resolution) it may be impossible to return a chord ' for lower dissonances then the lowest dissonant chord with given params will be returned ' now returns actual dissonance of the chord it creates ' 13.08.2020: Revisited and checked for Rational Melodies and Linac piece. LOCAL Ctns AS CUR LOCAL i, j , k AS CUR LOCAL dif, ds, d1, d2, d3, d4, d5, d6, ddr AS SINGLE LOCAL oct AS LONG dif = 1 ddr = 1 Ctns = cents / 100 IF Ctns < 0.01 THEN Ctns = 1 ' default to semitones EQ IF n1 < 12 THEN MSGBOX "Invalid input in " + FUNCNAME$ + $CRLF + "base note of chord should be > 12" EXIT FUNCTION END IF IF n4 THEN ' in this case we just return the calculated value for the dissonance. ' taking into account octaves! d1 = HH_DipDis (n1,n2,1) d2 = HH_DipDis (n1,n3,1) d3 = HH_DipDis (n1,n4,1) d4 = HH_DipDis (n2,n3,1) d5 = HH_DipDis (n2,n4,1) d6 = HH_DipDis (n3,n4,1) FUNCTION = SQR((d1^2) + (d2^2) + (d3^2) + (d4^2) + (d5^2) + (d6^2))/ SQR(6) EXIT FUNCTION END IF IF ISFALSE n2 THEN ' in this case we have to calculate the entire tetrad. ' zoek optimale n2, n3, n4 (in enge ligging) FOR i = n1 + Ctns TO (n1 + 12) - Ctns STEP Ctns IF FRAC((i-n1)/12) <> %False THEN d1 = HH_Dipdis (n1, i) FOR j = i + Ctns TO (n1 + 12) - (Ctns * 2) STEP Ctns ' a lot faster... IF (j MOD 12) = (n1 MOD 12) THEN ITERATE FOR 'octave.. IF FRAC((j-n1)/12) <> %False THEN IF FRAC((i-j)/12) <> %False THEN d2 = HH_Dipdis (n1, j) d3 = HH_Dipdis (i, j) FOR k = j + Ctns TO (n1 + 12) - (Ctns * 3) STEP Ctns 'octave protection IF (k MOD 12) = (n1 MOD 12) THEN ITERATE FOR IF (k MOD 12) = (i MOD 12) THEN ITERATE FOR IF FRAC((n1-k)/12) <> %False THEN IF FRAC((i-k)/12) <> %False THEN IF FRAC((j-k)/12) <> %False THEN d4 = HH_Dipdis (n1,k) d5 = HH_Dipdis (j,k) d6 = HH_Dipdis (i,k) ' sum of squares (vectorsum) - gives best results. ds = SQR((d1^2) + (d2^2) + (d3^2) + (d4^2) + (d5^2) + (d6^2))/ SQR(6) 'IF ds < d THEN d = ds : n2 = i: n3 = j : n4 = k dif = ABS(ds - d) IF dif < ddr THEN ddr = dif: n2 = i: n3 = j : n4 = k : FUNCTION = ds END IF END IF END IF NEXT k END IF END IF NEXT j END IF NEXT i FUNCTION = ds EXIT FUNCTION END IF IF ISFALSE n3 THEN ' in this case we have to calculate 2 extra notes ' zoek optimale n3, n4 (in enge ligging) d1 = HH_DipDis (n1,n2,oct) FOR i = n1 + Ctns TO (n1 + 12) - Ctns STEP Ctns IF FRAC((i-n1)/12) <> %False THEN IF FRAC((i-n2)/12) <> %False THEN d2 = HH_Dipdis (n1, i, oct) d3 = HH_Dipdis (n2, i, oct) FOR j = i + Ctns TO (n1 + 12) - (Ctns * 2) STEP Ctns ' a lot faster... IF FRAC((j-n1)/12) <> %False THEN IF FRAC((i-j)/12) <> %False THEN IF FRAC((j-n2)/12) <> %False THEN d4 = HH_Dipdis (n1, j, oct) d5 = HH_Dipdis (i, j) d6 = HH_Dipdis (n2,j,oct) ' sum of squares (vectorsum) - gives best results. ds = SQR((d1^2) + (d2^2) + (d3^2) + (d4^2) + (d5^2) + (d6^2))/ SQR(6) dif = ABS(ds - d) IF dif < ddr THEN ddr = dif : n3 = i: n4 = j : FUNCTION = ds END IF END IF END IF NEXT j END IF END IF NEXT i FUNCTION = ds EXIT FUNCTION END IF IF ISFALSE n4 THEN ' in this case we have to calculate a single extra note ' zoek optimale n4 (in enge ligging) d1 = HH_DipDis (n1,n2,oct) d2 = HH_DipDis (n1,n3,oct) d3 = HH_DipDis (n2,n3,oct) FOR i = n1 + Ctns TO (n1 + 12) - Ctns STEP Ctns IF FRAC((ABS(i-n1))/12) <> %False THEN IF FRAC((ABS(i-n2))/12) <> %False THEN IF FRAC((ABS(i-n3))/12) <> %False THEN d4 = HH_Dipdis (n1, i, oct) d5 = HH_Dipdis (n2, i, oct) d6 = HH_Dipdis (n3 ,i, oct) ' sum of squares (vectorsum) - gives best results. ds = SQR((d1^2) + (d2^2) + (d3^2) + (d4^2) + (d5^2) + (d6^2))/ SQR(6) dif = ABS(ds-d) IF dif < ddr THEN ddr = dif : n4 = i : FUNCTION = ds END IF END IF END IF NEXT i FUNCTION = ds EXIT FUNCTION END IF END FUNCTION FUNCTION HH_Chord_Progres (BYVAL cents AS DWORD, BYREF ni()AS CUR, BYREF no() AS CUR, BYVAL d AS SINGLE)EXPORT AS SINGLE ' input chordal notes: ni() , can contain 1,2,3 or 4 notes in fractional midi ' output chordal notes: no(), can contain no notes, or up to the number of notes in ni() minus one. ' d = requested dissonance for the output chord ' cents = resolution of the tuning system in use. (set to 50 for quartertone harmony) ' This function will try to return a chord taking into account the best possible voicing. ' the function returns the obtained dissonance for the output chord in no(). ' Written gwr 11.02.2008 - still to be further examined and debugged. ' 08.02.2012: paar tekenfouten geelimineerd (Ervan uitgaand dat stemkruisingen niet de bedoeling zijn (?)) (cfr regel 4041 en verder) ' 12.08.2020: applied in rational counterpoint and Linac piece. LOCAL n AS DWORD LOCAL nrnotes AS DWORD LOCAL i AS LONG LOCAL ddr AS SINGLE LOCAL n0, n1, n2, n3 AS CUR n = UBOUND(ni) ' this can contain 1,2,3 or 4 notes FOR i = 0 TO n IF ni(i) THEN INCR nrnotes ' now we know how many notes where in the previous chord. NEXT i IF UBOUND(no) < n THEN REDIM PRESERVE no(0 TO n) AS CUR ' input and output must have at least the same size. END IF SELECT CASE nrnotes 'aantal noten in ni() CASE 0 EXIT FUNCTION ' fault condition CASE 1 ' retourneer gewoon een melodische opvolger in no(0) ... n0 = ni(0) ddr = HH_Diad (cents, n0, n1, d) no(0) = n1 FUNCTION = ddr CASE 2 'ni(0) en ni(1) zijn geset 'was up to 04.07.2010: ' n0 = no(0) ' ' n1 = no(1) '!!!!! xof remark: n1 will be filled in by HH_Diad in the following line - what's the use of assigning it here?? ' replaced with: IF no(0) THEN n0 = no(0) ELSE n0 = ni(0) 'n0 mag niet %False zijn! END IF ddr = HH_Diad (cents, n0, n1, d) 'returns n1 IF no(0) THEN ' in this case we can only revoice n1 IF ABS(ni(1) - n1) > 6.0 THEN IF n1 > ni(1) THEN n1 = n1 - 12 IF n1 < ni(1) THEN n1 = n1 + 12 END IF ELSE '!!!! als ik goed volg is dan n0 nog steeds 0 (wordt niet veranderd door HH_diad) en n1 ingevuld met een noot ' die de gewenste dissonantie heeft ivgl met die do ' (do) ' now optimize the voicing for n0 and n1 ' first we removed jumps larger than 6, by octaving: IF ni(1) - n1 > 6 THEN n1 = n1 + 12 IF ni(0) - n0 > 6 THEN n0 = n0 + 12 IF ni(1) - n1 < -6 THEN n1 = n1 - 12 IF ni(0) - n0 < -6 THEN n0 = n0 - 12 IF ABS(ni(0) - n1) < ABS(ni(1) - n0) THEN SWAP n0,n1 '?? END IF ' return result: no(0) = n0 no(1) = n1 FUNCTION = HH_DipDis (n0, n1, 1) ' with octave correction CASE 3 IF no(0) THEN n0 = no(0) ELSE n0 = ni(0) 'korrektie gwr 04.07.2010 'n0 = no(0) n1 = no(1) 'mag %False zijn ' n2 = no(2) ddr = HH_Triad (cents, n0, n1, n2, d) 'returns n2 always and n1 if it was false on input. IF (no(0) > %False) AND (no(1)) > %False THEN ' in dit geval waren die beide noten door de gebruiker opgegeven en ' moeten we hun stemligging respekteren... ' alleen n2 kan worden aangepast... IF ni(2) - n2 > 6 THEN n2 = n2 + 12 ' kan altijd. IF ni(2) - n2 < -6 THEN IF n2 - 12 > n1 THEN n2 = n2 - 12 ' was IF n2 - 12 > n1 THEN n2 = n2 - 12 END IF ELSEIF no(0) > %False THEN ' alleen n1 en n2 kunnen veranderd worden. IF ni(2) - n2 > 6 THEN n2 = n2 + 12 ' kan altijd. IF ni(2) - n2 < -6 THEN IF n2 - 12 > n1 THEN n2 = n2 - 12 END IF IF ni(1) - n1 > 6 THEN IF (n1 + 12) < n2 THEN n1 = n1 + 12 END IF IF ni(1) - n1 < -6 THEN IF (n1 - 12) > n0 THEN n1 = n1 - 12 END IF ELSE ' geval geheel nieuw akkoord: IF ni(0) - n0 > 6 THEN IF (n0 + 12) < n1 THEN n0 = n0 + 12 END IF IF ni(0) - n0 < -6 THEN n0 = n0 - 12 ' basstem kan altijd omlaag IF ni(1) - n1 > 6 THEN IF (n1 + 12) < n2 THEN n1 = n1 + 12 END IF IF ni(1) - n1 < -6 THEN IF (n1-12) > n0 THEN n1 = n1 - 12 END IF IF ni(2) - n2 > 6 THEN n2 = n2 + 12 ' sopraan kan altijd omhoog IF ni(2) - n2 < -6 THEN IF n2 - 12 > n1 THEN n2 = n2 - 12 END IF END IF ' beveiliging: IF n0 < 0 THEN n0 = n0 + 12 IF n1 < 0 THEN n1 = n1 + 12 IF n2 < 0 THEN n2 = n2 + 12 IF n0 > 127 THEN n0 = n0 - 12 IF n1 > 127 THEN n1 = n1 - 12 IF n2 > 127 THEN n2 = n2 - 12 no(0) = n0 no(1) = n1 no(2) = n2 FUNCTION = HH_Triad (cents, n0,n1,n2, 1) 'dd CASE 4 IF no(0) THEN n0 = no(0) ELSE n0 = ni(0) 'gwr korrektie 04.07.2010 n1 = no(1) n2 = no(2) n3 = no(3) ddr = HH_Tetrad (cents, n0, n1, n2, n3, d) 'n3 always recalculated IF (no(0) > %False) AND (no(1) > %False) AND (no(2) > %False) THEN ' in dit geval waren drie noten door de gebruiker opgegeven en ' moeten we hun stemligging respekteren... ' alleen n3 kan worden aangepast... IF ni(3) - n3 > 6 THEN n3 = n3 + 12 ' kan altijd. IF ni(3) - n3 < -6 THEN IF n3 - 12 < n2 THEN n3 = n3 - 12 END IF ELSEIF (no(0) > %False) AND (no(1) > %False) THEN ' alleen n2 en n3 kunnen veranderd worden. IF ni(3) - n3 > 6 THEN n3 = n3 + 12 ' kan altijd. IF ni(3) - n3 < -6 THEN IF n3 - 12 > n2 THEN n3 = n3 - 12 'was IF n3 - 12 < n2 THEN n3 = n3 - 12 END IF IF ni(2) - n2 > 6 THEN IF n2+ 12 < n3 THEN n2= n2 + 12 END IF IF ni(2) - n2 < -6 THEN IF n2 - 12 > n1 THEN n2 = n2 - 12 END IF ELSEIF no(0) > %False THEN IF ni(3) - n3 > 6 THEN n3 = n3 + 12 ' kan altijd. IF ni(3) - n3 < -6 THEN IF n3 - 12 > n2 THEN n3 = n3 - 12 'IF n3 - 12 < n2 THEN n3 = n3 - 12 END IF IF ni(2) - n2 > 6 THEN IF n2+ 12 < n3 THEN n2= n2 + 12 END IF IF ni(2) - n2 < -6 THEN IF n2 - 12 > n1 THEN n2 = n2 - 12 END IF IF ni(1) - n1 > 6 THEN IF (n1 + 12) < n2 THEN n1 = n1 + 12 END IF IF ni(1) - n1 < -6 THEN IF (n1 - 12) > n0 THEN n1 = n1 - 12 END IF ELSE 'mag niet - HH_Tetrad weigert als basnoot niet ingevuld is ' geval geheel nieuw akkoord: IF ni(3) - n3 > 6 THEN n3 = n3 + 12 ' kan altijd. IF ni(3) - n3 < -6 THEN IF n3 - 12 > n2 THEN n3 = n3 - 12 'was IF n3 - 12 < n2 THEN n3 = n3 - 12 END IF IF ni(2) - n2 > 6 THEN IF n2+ 12 < n3 THEN n2= n2 + 12 END IF IF ni(2) - n2 < -6 THEN IF n2 - 12 > n1 THEN n2 = n2 - 12 END IF IF ni(1) - n1 > 6 THEN IF (n1 + 12) < n2 THEN n1 = n1 + 12 END IF IF ni(1) - n1 < -6 THEN IF (n1 - 12) > n0 THEN n1 = n1 - 12 END IF IF ni(0) - n0 > 6 THEN IF (n0 + 12) < n1 THEN n0 = n0 + 12 END IF IF ni(0) - n0 < -6 THEN n0 = n0 - 12 ' basstem kan altijd omlaag END IF 'beveiliging: IF n0 < 0 THEN n0 = n0 + 12 IF n1 < 0 THEN n1 = n1 + 12 IF n2 < 0 THEN n2 = n2 + 12 IF n3 < 0 THEN n3 = n3 + 12 IF n0 > 127 THEN n0 = n0 - 12 IF n1 > 127 THEN n1 = n1 - 12 IF n2 > 127 THEN n2 = n2 - 12 IF n3 > 127 THEN n3 = n3 - 12 FUNCTION = HH_Tetrad (cents,n0, n1, n2, n3, 1) no(0) = n0 no(1) = n1 no(2) = n2 no(3) = n3 CASE ELSE EXIT FUNCTION ' fault condition, unless we implement pentads... END SELECT END FUNCTION FUNCTION Par5thInQHar (h1 AS Qharmtype, h2 AS Qharmtype) EXPORT AS LONG ' stemvoeringsprocedure voor Qhar strings. ' removes or minimizes parallel 5ths in h2. ' strategie: omzetten in twee noten arrays en dan Par5ths(50, ni(), no()) gebruiken LOCAL cnti AS LONG LOCAL cnto AS LONG LOCAL i AS CUR LOCAL v1 AS BYTE DIM ni(0) AS STATIC CUR DIM no(0) AS STATIC CUR DIM vo(0) AS LOCAL BYTE FOR i = 0 TO 255 v1 = ASC(MID$(h1.vel,i+1,1)) IF v1 THEN REDIM PRESERVE ni(cnti) AS STATIC CUR ni(cnti) = i/ 2 INCR cnti END IF v1 = ASC(MID$(h2.vel,i+1,1)) IF v1 THEN REDIM PRESERVE no(cnto) AS STATIC CUR REDIM PRESERVE vo(cnto) AS LOCAL BYTE ' hier zouden we oktaaf-verdubbelingen op voorhand kunnen wegfilteren... no(cnto) = i/ 2 vo(cnto) = v1 INCR cnto END IF NEXT i ' remove octaves: ' for i = 0 to ubound(no) ' n = no(i) ' for j = i+ 1 to ubound(no) ' d = no(j) - no(i) ' select case d ' case 12,24,36,48,60,72,84,96,108, 120 ' ; hier moeten we array delete gebruiken, maar dan veranderd de ubound... ' end select ' next j ' next i MinPar5ths (50, ni(), no()) ' and now put them back in the output har string h2.vel = NUL$(256) FOR i = 0 TO UBOUND(no) AddNote2Qhar h2, no(i), vo(i) 'op deze manier krijgen omgewisselde noten elkaars velocity.. NEXT i END FUNCTION FUNCTION CountPar5ths (BYVAL cents AS DWORD, ni() AS CUR, no() AS CUR) EXPORT AS LONG ' this function returns the number of parallel moving fifths between the two chords given ' the arrays can have different sizes and may contain zero's LOCAL i AS LONG LOCAL j AS LONG LOCAL n AS LONG LOCAL dkwint AS LONG LOCAL skwint AS LONG LOCAL interval AS CUR IF ISFALSE cents THEN cents = 100 ' default to semitones dkwint = -1 skwint = -1 FOR i = 0 TO UBOUND(ni) IF ni(i) THEN FOR j = 0 TO UBOUND(no) 'was FOR j = i TO UBOUND(no), correctie xof 20080213: ni(4) en ni(5) kunnen perfect in parallel kwinten bewegen aan no(0) en no(1).. IF no(j) THEN interval = ni(i) - no(j) ' negatief is stijgend, positief is dalend ' IF interval >= 12 THEN ' DO ' interval = interval -12 ' LOOP UNTIL interval < 12 ' END IF ' IF interval <= -12 THEN ' DO ' interval = interval + 12 ' LOOP UNTIL interval > -12 ' END IF interval = interval MOD 12 'optimalisatie: doet hetzelfde als het geremde blok hierboven - mod werkt ook op currency (-12.5 mod 12 = -.5) - getest xof IF interval > 0 THEN IF (interval < (7 + (cents/100))) AND (interval > (7 - (cents/100))) THEN INCR dkwint END IF END IF IF interval < 0 THEN IF (interval > - (7 +(cents/100))) AND (interval < - (7 - (cents/100))) THEN INCR skwint END IF END IF END IF NEXT j END IF NEXT i i = 0 IF skwint > 0 THEN i = skwint IF dkwint > 0 THEN i = i + dkwint FUNCTION = i END FUNCTION FUNCTION MinPar5ths (BYVAL cents AS DWORD, ni() AS CUR, BYREF no() AS CUR) EXPORT AS LONG 'byref added xof 20080213 ' minimalize the number of parallel fifths in no() ' 20080213 deed nog niet wat het moest.. poging door xof - niet zeker of we gwr's bedoelingen 100% vatten, maar dit zou het moeten doen ' ' keuze welke kwint we laten staan is nog arbitrair: laagste ' de pitchclass die vervangen wordt kan verloren gaan in het akkoord.. switchen met de stem waarvan we een noot pikken? ' STILL TO BE CHECKED LOCAL p AS LONG LOCAL n AS LONG LOCAL m AS LONG LOCAL i AS LONG LOCAL k AS LONG LOCAL j AS LONG LOCAL firstfifth AS LONG LOCAL interval AS SINGLE DIM nt(0) AS LOCAL CUR DIM nb(UBOUND(no)) AS LOCAL CUR 'octaafplaatsing DIM ndef(UBOUND(no)) AS LOCAL CUR 'waar dient deze voor?? logfile FUNCNAME$ + STR$(ni(0))+ STR$(ni(1))+ STR$(ni(2))+ STR$(ni(3)) + "->" + STR$(no(0))+ STR$(no(1))+ STR$(no(2))+ STR$(no(3)) p = 10000 ' onderzoek alle mogelijke swaps van no() m = CountPar5ths (cents, ni(), no()) ' logfile " parallel:" + STR$(m) IF m < p THEN p = m FUNCTION = %False IF ISFALSE m THEN EXIT FUNCTION 'initialise ndef 'if we don't initialsise it here, and we don't find a better solution the result would be an empty chord.. FOR j = 0 TO UBOUND(no) ndef(j) = no(j) 'backup voor als volgende stap geen verbetering is.. NEXT j ' reduceer de noten in no() naar hun basisligging REDIM nt(UBOUND(no)) AS LOCAL CUR 'pitchclass FOR i = 0 TO UBOUND(no) IF no(i) THEN nt(i) = no(i) MOD 12 'optimalisatie: de mod 12 maakt onderstaande loop overbodig ' IF nt(i) > 12 THEN ' DO ' nt(i) = nt(i) - 12 ' LOOP UNTIL nt(i) < 12 ' END IF END IF NEXT i ' nu kunnen we alle permutaties onderzoeken FOR i = 0 TO UBOUND(no) nb(i) = 12 * (ni(i)\12) ' behoud de basis oktaafligging 'eerste poging om kwinten te elimineren.. ' FOR k = i TO UBOUND(nt) 'als we een parallele kwint hebben, vervang nt(i) door een andere nt() voor de berekning van no(i) ' ndef(i) = no(i) 'kan hieronder overschreven worden interval = ABS(no(i) - ni(i)) MOD 12 IF (interval < (7 + (cents/100))) AND (interval > (7 - (cents/100))) THEN IF ISFALSE(firstfifth) THEN '1 kwint mogen we toestaan - zo laten we de laagste.. mogelijkheid tot vebetering = slimme selectie van welke kwint mag blijven firstfifth = 1 ITERATE FOR END IF k = i DO INCR k k = k MOD UBOUND(nt) IF k = i THEN EXIT LOOP interval = ABS(ni(i) - (nb(i) + nt(k))) MOD 12 IF (interval < (7 + (cents/100))) AND (interval > (7 - (cents/100))) THEN ITERATE LOOP ' logfile " replace" + STR$(no(i)) + " with" + STR$(nb(i)) + STR$(nt(k)) no(i) = nb(i) + nt(k) EXIT LOOP 'deze ontbrak! 20080214 LOOP END IF 'if i <> k then ' no(i) = nb(i) + nt(k) 'end if ' NEXT k ' korrigeer eventuele stemkruisingen: ' IF no(0) > no(1) THEN no(0) = no(0) - 12 ' IF no(UBOUND(nt)) < no(UBOUND(nt)-1) THEN no(UBOUND(nt)) = no(UBOUND(nt)) + 12 ' FOR k = 0 TO UBOUND(nt) -1 ' IF no(k) > no(k+1) THEN no(k) = no(k)-12 ' NEXT k ARRAY SORT no(), ASCEND m = CountPar5ths (cents, ni(), no()) ' logfile " parallels now:" + STR$(m) IF ISFALSE m THEN EXIT FUNCTION IF m < p THEN p = m ' logfile " store" 'MAT ndef() = no() - gaat niet FOR j = 0 TO UBOUND(no) ndef(j) = no(j) 'backup voor als volgende stap geen verbetering is.. NEXT j END IF NEXT i 'MAT no() = ndef() ' logfile "reload ndef" + STR$(ndef(0)) + STR$(ndef(1)) + STR$(ndef(2)) + STR$(ndef(3)) FOR j = 0 TO UBOUND(no) no(j) = ndef(j) NEXT j FUNCTION = m END FUNCTION FUNCTION ReduceQHar (h1 AS Qharmtype, OPTIONAL BYREF n() AS CUR) EXPORT AS LONG ' reduceert het akkoord in Qh.vel door er alle oktaafverdubbelingen uit te verwijderen. ' return value = number of different notes in the chord. ' the n() array, if passed will contain the notes as an currency array of fractional midi notes. ' the size can never be larger than 24 notes. LOCAL i AS CUR LOCAL j AS CUR LOCAL k AS LONG LOCAL v1 AS BYTE LOCAL cnt AS LONG IF ARRAYATTR (n(),%VARCLASS_CUR) THEN REDIM n(0) AS CUR ELSE DIM n(0) AS LOCAL CUR END IF 'DIM vo(0) AS LOCAL BYTE FOR i = 0 TO 255 v1 = ASC(MID$(h1.vel,i+1,1)) IF v1 THEN ' is het een nieuwe noot? IF ISFALSE cnt THEN n(cnt) = i/2 ' vo(cnt) = v1 ' da's de eerste noot INCR cnt ELSE FOR k = 0 TO UBOUND(n) IF ((i/2)MOD 12) <> (n(k) MOD 12) THEN ' noot toevoegen... REDIM PRESERVE no(cnt) AS CUR n(cnt) = i / 2 ' vo(cnt) = v1 INCR cnt EXIT FOR END IF NEXT k END IF ' wissen van hogere oktaafnoten: FOR j = i + 24 TO 255 STEP 24 ' if (i MOD 12) = j mod 12) then IF ASC(MID$(h1.vel,j+1,1)) THEN MID$(h1.vel,j+1,1) = CHR$(0) ' end if NEXT j END IF NEXT i END FUNCTION ' GMT Harmony Library ----------------------- ' Tone Clock related functions and procedures FUNCTION ToneClockChord (BYVAL tc AS WORD, BYVAL velo AS WORD, BYVAL hour AS WORD, BYVAL omkering AS WORD, OPTIONAL BYVAL ligging AS WORD) EXPORT AS STRING 'export HarmType PTR ' added by Godfried-Willem Raes, 29.11.2011 - for harmlib ' chord constructor after Peter Schat - triads ' hour: 1-12 ' tc = base note 12 - 115 ' omkering: 0, 1 of 2 ' ligging: minor/major (smallest chord interval first of last) 0,1 - higher values (2,3) enlarge the intervals LOCAL n1,n2,n3 AS BYTE STATIC h AS harmtype h.vel = NUL$(128) ' input beveiliging: IF tc < 12 THEN DO tc +=12 LOOP UNTIL tc >= 12 END IF IF tc > 115 THEN DO tc -=12 LOOP UNTIL tc <= 115 END IF omkering = omkering MOD 3 ' 0= het akkoord wordt gebouwd stijgend vanuit tc ' 1= het akkoord wordt gebouwd met een stijgend en een dalend interval rond tc ' 2= het akkoord wordt gebouwd met tc als hoogste noot ligging = ligging MOD 5 velo = MAX(MIN(127,velo),0) hour = MAX(1, hour) DECR hour ' must be > 0 hour = hour MOD 12 ' so that we can circle around the clock INCR hour ' konstruktie van de akkoorden volgens de toonklok SELECT CASE hour CASE 1 ' kromatisch / symmetrisch SELECT CASE omkering CASE 0 n1 = Tc : n2 = Tc + 1 : n3 = Tc + 2 SELECT CASE ligging CASE 2 n2 = Tc + 10 : n3 = Tc + 11 CASE 3 n2 = Tc + 1 : n3 = Tc + 11 END SELECT CASE 1 n1 = Tc -1 : n2 = Tc : n3 = Tc + 1 SELECT CASE ligging CASE 2 n1 = Tc - 1 : n3 = Tc + 10 CASE 3 n1 = Tc - 10 : n3 = Tc + 1 END SELECT CASE 2 n1 = Tc -2 : n2 = Tc - 1 : n3 = Tc SELECT CASE ligging CASE 2 n1 = Tc-1 : n2 = Tc - 11 CASE 3 n1 = Tc- 10 : n2 = Tc - 11 END SELECT END SELECT CASE 2 ' assymetrisch SELECT CASE omkering CASE 0 n1 = Tc : n3 = Tc + 3 'if isfalse ligging then n2 = Tc + 1 else n2 = Tc + 2 SELECT CASE ligging CASE 0 n2 = Tc +1 CASE 1 n2 = Tc + 2 CASE 2 n2 = Tc + 1 : n3 = Tc + 10 CASE 3 n2 = Tc + 9 : n3 = Tc + 10 END SELECT CASE 1 n2 = Tc 'if isfalse ligging then n1 = Tc-1 : n3 = Tc + 2 else n1 = Tc -2 : n3 = Tc + 1 SELECT CASE ligging CASE 0 n1 = Tc -1 : n3 = Tc + 2 CASE 1 n1 = Tc -2 : n3 = Tc + 1 CASE 2 n1 = Tc -9 : n3 = Tc + 1 CASE 3 n1 = Tc -9 : n3 = Tc + 2 END SELECT CASE 2 n3 = Tc : n1 = Tc - 3 'if isfalse ligging then n2 = Tc -1 else n2 = Tc - 2 SELECT CASE ligging CASE 0 n2 = Tc -1 CASE 1 n2 = Tc -2 CASE 2 n2 = Tc -1 : n1 = Tc - 10 CASE 3 n2 = Tc - 2: n1 = Tc - 11 END SELECT END SELECT CASE 3 ' asymmetrisch - blues SELECT CASE omkering CASE 0 n1 = Tc : n3 = Tc + 4 'IF ISFALSE ligging THEN n2 = Tc + 1 ELSE n2 = Tc + 3 SELECT CASE ligging CASE 0 n2 = Tc + 1 'c cis e CASE 1 n2 = Tc + 3 'c dis e CASE 2 n2 = Tc + 1 : n3 = Tc + 8 'c cis aes CASE 3 n2 = Tc + 8 : n3 = Tc + 9 'c aes a END SELECT CASE 1 n2 = Tc 'IF ISFALSE ligging THEN n1 = Tc-1 : n3 = Tc + 3 ELSE n1 = Tc -3 : n3 = Tc + 1 SELECT CASE ligging CASE 0 n1 = Tc -1 : n3 = Tc + 3 'b c ees CASE 1 n1 = Tc -3 : n3 = Tc + 1 'a c cis CASE 2 n1 = Tc - 9 : n3 = Tc + 4 'ees c e CASE 3 n1 = Tc - 8 : n3 = Tc + 3 'e c ees END SELECT CASE 2 n3 = Tc : n1 = Tc - 4 'IF ISFALSE ligging THEN n2 = Tc -1 ELSE n2 = Tc - 3 SELECT CASE ligging CASE 0 n2 = Tc -1 CASE 1 n2 = Tc - 3 CASE 2 n2 = tc - 1 : n1 = Tc - 8 CASE 3 n2 = Tc - 8 : n1 = Tc - 9 END SELECT END SELECT CASE 4 ' asymmetrisch - kwart +1 +4 SELECT CASE omkering CASE 0 n1 = Tc : n3 = Tc + 5 SELECT CASE ligging CASE 0: n2 = tc + 1 ' c cis f CASE 1: n2 = tc + 4 ' c e f CASE 2: n2 = tc + 1: n3 = tc + 7 ' c cis g CASE 3: n2 = tc + 7: n3 = tc + 8 ' c g gis END SELECT ' IF ISFALSE ligging THEN n2 = Tc + 1 ELSE n2 = Tc + 4 CASE 1 n2 = Tc SELECT CASE ligging CASE 0: n1 = tc - 1: n3 = tc + 4 CASE 1: n1 = tc - 4: n3 = tc + 1 CASE 2: n1 = tc - 8: n3 = tc + 5 'xof doesn't get this (possibly due to my flue-like state). just continuing analogous to hour 3 CASE 3: n1 = tc - 7: n3 = tc + 4 END SELECT ' IF ISFALSE ligging THEN n1 = Tc-1 : n3 = Tc + 4 ELSE n1 = Tc -4 : n3 = Tc + 1 CASE 2 n3 = Tc : n1 = Tc - 5 SELECT CASE ligging CASE 0: n2 = tc - 1 CASE 1: n2 = tc - 4 CASE 2: n2 = tc - 1: n1 = tc - 7 CASE 3: n2 = tc - 7: n1 = tc - 8 END SELECT ' IF ISFALSE ligging THEN n2 = Tc -1 ELSE n2 = Tc - 4 END SELECT CASE 5 ' asymmetrisch - tritonus +1 +5 SELECT CASE omkering CASE 0 n1 = Tc : n3 = Tc + 6 SELECT CASE ligging CASE 0: n2 = tc + 1 CASE 1: n2 = tc + 5 CASE 2: n2 = tc + 1: n3 = tc + 6 CASE 3: n2 = tc + 6: n3 = tc + 7 END SELECT ' IF ISFALSE ligging THEN n2 = Tc + 1 ELSE n2 = Tc + 5 CASE 1 n2 = Tc SELECT CASE ligging CASE 0: n1 = tc - 1: n3 = tc + 5 CASE 1: n1 = tc - 5: n3 = tc + 1 CASE 2: n1 = tc - 7: n3 = tc + 6 CASE 3: n1 = tc - 6: n3 = tc + 5 END SELECT ' IF ISFALSE ligging THEN n1 = Tc-1 : n3 = Tc + 5 ELSE n1 = Tc -5 : n3 = Tc + 1 CASE 2 n3 = Tc : n1 = Tc - 6 SELECT CASE ligging CASE 0: n2 = tc - 1 CASE 1: n2 = tc + 5 CASE 2: n2 = tc - 1: n1 = tc - 6 CASE 3: n2 = tc - 6: n1 = tc - 7 END SELECT ' IF ISFALSE ligging THEN n2 = Tc -1 ELSE n2 = Tc - 5 END SELECT CASE 6 ' symmetrisch - heletoons '+2 +2 SELECT CASE omkering CASE 0 n1 = Tc : n2 = Tc + 2 : n3 = Tc + 4 SELECT CASE ligging CASE 0, 1 'zoals hierboven CASE 2: n3 = tc + 8 CASE 3: n2 = tc + 8: n3 = tc + 10 END SELECT CASE 1 n1 = Tc -2 : n2 = Tc : n3 = Tc + 2 SELECT CASE ligging CASE 0, 1 CASE 2: n1 = tc - 10: n3 = n3 + 4 CASE 3: n1 = tc - 8: n3 = tc + 2 END SELECT CASE 2 n1 = Tc -4 : n2 = Tc -2 : n3 = Tc SELECT CASE ligging CASE 0, 1 CASE 2: n2 = tc - 2: n1 = tc - 8 CASE 3: n2 = tc - 8: n1 = tc - 10 END SELECT END SELECT CASE 7 ' asymmetrisch - kwart '+2 +3 SELECT CASE omkering CASE 0 n1 = Tc : n3 = Tc + 5 SELECT CASE ligging CASE 0: n2 = tc + 2 CASE 1: n2 = tc + 3 CASE 2: n2 = tc + 2: n3 = tc + 7 CASE 3: n2 = tc + 7: n3 = tc + 9 END SELECT ' IF ISFALSE ligging THEN n2 = Tc + 2 ELSE n2 = Tc + 3 CASE 1 n2 = Tc SELECT CASE ligging CASE 0: n1 = tc - 2: n3 = tc + 3 CASE 1: n1 = tc - 3: n3 = tc + 2 CASE 2: n1 = tc - 9: n3 = tc + 5 CASE 3: n1 = tc - 7: n3 = tc + 3 END SELECT ' IF ISFALSE ligging THEN n1 = Tc-2 : n3 = Tc + 3 ELSE n1 = Tc -3 : n3 = Tc + 2 CASE 2 n3 = Tc : n1 = Tc - 5 SELECT CASE ligging CASE 0: n2 = tc - 2 CASE 1: n2 = tc - 3 CASE 2: n2 = tc - 2: n1 = tc - 7 CASE 3: n2 = tc - 7: n1 = tc - 9 END SELECT ' IF ISFALSE ligging THEN n2 = Tc -2 ELSE n2 = Tc - 3 END SELECT CASE 8 ' asymmetrisch - tritonus '+2 +4 SELECT CASE omkering CASE 0 n1 = Tc : n3 = Tc + 6 SELECT CASE ligging CASE 0: n2 = tc + 2 CASE 1: n2 = tc + 4 CASE 2: n2 = tc + 2: n3 = tc + 6 CASE 3: n2 = tc + 6: n3 = tc + 8 END SELECT ' IF ISFALSE ligging THEN n2 = Tc + 2 ELSE n2 = Tc + 4 CASE 1 n2 = Tc SELECT CASE ligging CASE 0: n1 = tc - 2: n3 = tc + 4 CASE 1: n1 = tc - 4: n3 = tc + 2 CASE 2: n1 = tc - 8: n3 = tc + 2 CASE 3: n1 = tc - 10: n3 = tc + 4 END SELECT ' IF ISFALSE ligging THEN n1 = Tc-2 : n3 = Tc + 4 ELSE n1 = Tc -4 : n3 = Tc + 2 CASE 2 n3 = Tc : n1 = Tc - 6 SELECT CASE ligging CASE 0: n2 = tc - 2 CASE 1: n2 = tc - 4 CASE 2: n2 = tc - 2: n1 = tc - 6 CASE 3: n2 = tc- 6: n1 = tc - 8 END SELECT ' IF ISFALSE ligging THEN n2 = Tc -2 ELSE n2 = Tc - 4 END SELECT CASE 9 ' asymmetrisch - kwint '+2 +5 SELECT CASE omkering CASE 0 n1 = Tc : n3 = Tc + 7 SELECT CASE ligging CASE 0: n2 = tc + 2 CASE 1: n2 = tc + 5 CASE 2: n2 = tc + 7: n3 = tc + 10 CASE 3: n2 = tc + 10: n3 = tc + 17 END SELECT ' IF ISFALSE ligging THEN n2 = Tc + 2 ELSE n2 = Tc + 5 CASE 1 n2 = Tc SELECT CASE ligging CASE 0: n1 = tc - 2: n3 = tc + 5 CASE 1: n1 = tc - 5: n3 = tc + 2 CASE 2: n1 = tc - 7: n3 = tc + 2 CASE 3: n1 = tc - 10: n3 = tc + 5 END SELECT ' IF ISFALSE ligging THEN n1 = Tc-2 : n3 = Tc + 5 ELSE n1 = Tc -5 : n3 = Tc + 2 CASE 2 n3 = Tc : n1 = Tc - 7 SELECT CASE ligging CASE 0: n2 = tc - 2 CASE 1: n2 = tc - 5 CASE 2: n2 = tc - 7: n1 = tc - 10 CASE 3: n2 = tc - 10: n1 = tc - 17 END SELECT ' IF ISFALSE ligging THEN n2 = Tc -2 ELSE n2 = Tc - 5 END SELECT CASE 10 ' symmetrisch - tritonus - kleine tertsen +3 +3 SELECT CASE omkering CASE 0 n1 = Tc : n2 = Tc + 3 : n3 = Tc + 6 SELECT CASE ligging CASE 0, 1 CASE 2, 3: n2 = tc + 6: n3 = tc + 9 END SELECT CASE 1 n1 = Tc -3 : n2 = Tc : n3 = Tc + 3 SELECT CASE ligging CASE 0, 1 CASE 2: n1 = tc - 9 CASE 3: n2 = tc + 9 END SELECT CASE 2 n1 = Tc -6 : n2 = Tc -3 : n3 = Tc SELECT CASE ligging CASE 0, 1 CASE 2, 3: n2 = tc - 6: n1 = tc - 9 END SELECT END SELECT CASE 11 ' asymmetrisch - mineur/majeur '+3 +4 SELECT CASE omkering CASE 0 n1 = Tc : n3 = Tc + 7 SELECT CASE ligging CASE 0: n2 = tc + 3 CASE 1: n2 = tc + 4 CASE 2: n2 = tc + 3: n3 = tc + 8 CASE 3: n2 = tc + 4: n3 = tc + 9 END SELECT ' IF ISFALSE ligging THEN n2 = Tc + 3 ELSE n2 = Tc + 4 CASE 1 n2 = Tc SELECT CASE ligging CASE 0: n1 = tc - 3: n3 = tc + 4 CASE 1: n1 = tc - 4: n3 = tc + 3 CASE 2: n1 = tc - 8: n3 = tc + 3 CASE 3: n1 = tc - 9: n3 = tc + 4 END SELECT ' IF ISFALSE ligging THEN n1 = Tc-3 : n3 = Tc + 4 ELSE n1 = Tc -4 : n3 = Tc + 3 CASE 2 n3 = Tc : n1 = Tc - 7 SELECT CASE ligging CASE 0: n2 = tc - 3 CASE 1: n2 = tc - 4 CASE 2: n2 = tc - 3: n1 = tc - 9 CASE 3: n2 = tc - 4 : n1 = tc - 9 END SELECT ' IF ISFALSE ligging THEN n2 = Tc -3 ELSE n2 = Tc - 4 END SELECT CASE 12 ' symmetrisch - grote tertsen SELECT CASE omkering CASE 0 n1 = Tc : n2 = Tc + 4 : n3 = Tc + 8 CASE 1 n1 = Tc -4 : n2 = Tc : n3 = Tc + 4 SELECT CASE ligging CASE 0, 1 CASE 2: n1 = tc - 8 CASE 3: n3 = tc + 8 END SELECT CASE 2 n1 = Tc -8 : n2 = Tc -4 : n3 = Tc END SELECT END SELECT AddNote2Har h, n1, velo AddNote2Har h, n2, velo AddNote2Har h, n3, velo FillHartype h ' this is irrelevant at we only return the h.vel field of the har structure... ' for debug: FUNCTION = h.vel END FUNCTION FUNCTION Har2Hour (h AS harmtype, OPTIONAL treshold AS SINGLE) EXPORT AS INTEGER ' returns the hour of the tone clock for any triad found in the harmtype ' octave doublings are taken into account, hence the setting of the prime ' If no hour can be assigned, the function returns false. ' This function links our harmony library to the tone clock world. LOCAL i AS INTEGER LOCAL test AS BYTE FillHarType h ' now we check h.Iprop() to classify. Note that this contains normalised interval strenghts FOR i = 0 TO 6 IF h.Iprop(i) > treshold THEN BIT SET test, 6-i ' make crisp values NEXT i SELECT CASE test CASE &B0110000, &B1110000 FUNCTION = 1 CASE &B0111000, &B1111000 FUNCTION =2 CASE &B0101100, &B1101100 FUNCTION = 3 CASE &B0100110, &B1100110 FUNCTION = 4 CASE &B0100011, &B1100011 FUNCTION = 5 CASE &B0010100, &B1010100 FUNCTION = 6 CASE &B0011010, &B1011010 FUNCTION = 7 CASE &B0010101, &B1010101 FUNCTION = 8 CASE &B0010010, &B1010010 FUNCTION = 9 CASE &B0001001, &B1001001 FUNCTION = 10 CASE &B0001110, &B1001110 FUNCTION = 11 CASE &B0000100, &B1000100 FUNCTION = 12 END SELECT END FUNCTION FUNCTION ToneClockSeries (BYVAL tc AS INTEGER, BYVAL uur AS INTEGER, BYVAL vari AS INTEGER, BYREF n() AS INTEGER) EXPORT AS WORD ' returns the 12 note series corresponding to the hour ' each group of 3 notes is a triad, except for the 10th hour, where it is a tetrad (4 notes) ' tc is the transposition, such that the series returned always starts with tc ' the octave position will be preserved. ' As a function, we let it return the number of possible (or implemented) variations. ' so the vari parameter must be <= retval -1 ' 30.11.2011: first sketch by gwr. To be completed! Many more variations to be added. ' 01.12.2011: additions by KRL. ' 05.12.2011: t.e.m 6 geraakt met zigzag's.. nog to do: gwr's eerste invoer ook met array asign vertalen, zodat ook die makkelijk naar zigzag om te zetten zijn (doublecheck: dat lijkt op eerst zicht niet voor alle zinvol) ' 06.12.2011: verder bijgevuld.. bemerking: zou het geen goed idee zijn om ook een flag te voorzien voor gewoon/dalend/zigzag? ' 09.12.2011: added to harmlib. LOCAL i AS WORD ' REDIM n(11) AS INTEGER 'is this causing the crash? ' limit input param's to safe values: ' logfile FUNCNAME$ + STR$(tc) + STR$(uur) + STR$(vari) + STR$(VARPTR(n())) ' EXIT FUNCTION IF tc < 24 THEN DO : tc += 12 : LOOP UNTIL tc >= 24 END IF IF tc > 108 THEN DO : tc -= 12 : LOOP UNTIL tc <= 108 END IF n(0) = Tc ' let this always be the starting note uur = MAX(1, uur) DECR uur ' must be > 0 uur = uur MOD 12 ' so that we can circle around the clock INCR uur SELECT CASE uur CASE 1 ' minor second intervals only SELECT CASE vari CASE 0 ' kromatisch stijgend FOR i = 0 TO 11 n(i) = n(0) + i NEXT i CASE 1 ' kromatisch dalend FOR i = 0 TO 11 n(i) = n(0) - i NEXT i CASE 2 ' zigzag stijgend n(1) = n(0) +1 : n(2) = n(0) -1 n(3) = n(0) + 3: n(4) = n(3) + 1 : n(5) = n(3) - 1 n(6) = n(0) + 6: n(7) = n(6) + 1 : n(8) = n(6) - 1 n(9) = n(0) + 9: n(10) = n(9) + 1 : n(11) = n(9) - 1 CASE 3 ' zigzag dalend n(1) = n(0) -1 : n(2) = n(0) +1 n(3) = n(0) - 3: n(4) = n(3) - 1 : n(5) = n(3) + 1 n(6) = n(0) - 6: n(7) = n(6) - 1 : n(8) = n(6) + 1 n(9) = n(0) - 9: n(10) = n(9) - 1 : n(11) = n(9) + 1 END SELECT FUNCTION = 4 CASE 2 ' alternating minor and major seconds SELECT CASE vari CASE 0 ' stijgend n(1) = n(0) + 1 : n(2) = n(1) + 2 n(3) = n(0) + 2 : n(4) = n(3) + 2 : n(5) = n(4) + 1 n(6) = n(0) + 6 : n(7) = n(6) + 1 : n(8) = n(7) + 2 n(9) = n(0) + 8 : n(10) = n(9) + 2 : n(11) = n(10) + 1 CASE 1 ' dalend n(1) = n(0) - 1 : n(2) = n(1) - 2 n(3) = n(0) - 2 : n(4) = n(3) - 2 : n(5) = n(4) - 1 n(6) = n(0) - 6 : n(7) = n(6) - 1 : n(8) = n(7) - 2 n(9) = n(0) - 8 : n(10) = n(9) - 2 : n(11) = n(10) - 1 CASE 2 'zig\zag stijgend A ARRAY ASSIGN n() = tc, tc - 1 , tc + 2,_ tc + 3, tc + 1, tc + 4,_ tc + 6, tc + 5, tc + 8,_ tc + 9, tc + 7, tc + 10 CASE 3 'zig\zag stijgend B ARRAY ASSIGN n() = tc, tc + 2, tc - 1,_ tc + 3, tc + 4, tc + 1,_ tc + 6, tc + 8, tc + 5,_ tc + 9, tc + 10, tc + 7 CASE 4 'zigzag dalend A ARRAY ASSIGN n() = tc, tc + 1, tc - 2,_ tc - 3, tc - 1, tc - 4,_ tc - 6, tc - 5, tc - 8,_ tc - 9, tc - 7, tc - 10 CASE 5 'zigzag dalend B ARRAY ASSIGN n() = tc, tc - 2, tc + 1,_ tc - 3, tc - 4, tc - 1,_ tc - 6, tc - 8, tc - 5,_ tc - 9, tc - 10, tc - 7 END SELECT FUNCTION = 6 CASE 3 ' alternating minor seconds and minor thirths SELECT CASE vari CASE 0 n(1) = n(0) + 3 : n(2) = n(1) + 1 n(3) = n(0) +2 : n(4) = n(3) + 3 : n(5) = n(4) + 1 n(6) = n(0) +7 : n(7) = n(6) + 1 : n(8) = n(7) + 3 n(9) = n(0) +9 : n(10) = n(9) +1 : n(11)= n(10)+ 3 CASE 1 'next two are the forms mentioned on Schat's own website.. 'http://www.peterschat.nl/clockwise.html '(gwr's version above is not, although it seems correct..) ' a less headeache-provoking way to fill the array; ARRAY ASSIGN n()= tc, tc + 1, tc + 4, _ tc + 5, tc + 8, tc + 9, _ tc + 6, tc + 7, tc + 10, _ tc + 11, tc + 14, tc + 15 'sic - gaat over het octaaf CASE 2 ARRAY ASSIGN n()= tc, tc + 1, tc + 4, _ tc + 2, tc + 3, tc + 6, _ tc + 5, tc + 8, tc + 9, _ tc + 7, tc + 10, tc + 11 CASE 3 ' 0 dalend n(1) = n(0) - 3 : n(2) = n(1) - 1 n(3) = n(0) -2 : n(4) = n(3) - 3 : n(5) = n(4) - 1 n(6) = n(0) -7 : n(7) = n(6) - 1 : n(8) = n(7) - 3 n(9) = n(0) -9 : n(10) = n(9) -1 : n(11)= n(10)- 3 CASE 4 '1 dalend ARRAY ASSIGN n()= tc, tc - 1, tc - 4, _ tc - 5, tc - 8, tc - 9, _ tc - 6, tc - 7, tc - 10, _ tc - 11, tc - 14, tc - 15 '-15 is safe - tc is at least 24.. CASE 5 '2 dalend ARRAY ASSIGN n()= tc, tc + 1, tc + 4, _ tc + 2, tc + 3, tc + 6, _ tc + 5, tc + 8, tc + 9, _ tc + 7, tc + 10, tc + 11 CASE 6 '0 zigzag A ARRAY ASSIGN n()= tc, tc - 3, tc + 1,_ tc + 2, tc - 1, tc + 3,_ tc + 5, tc + 4, tc + 8, _ tc + 7, tc + 6, tc + 10 CASE 7 '0 zigzag B ARRAY ASSIGN n()= tc, tc + 1, tc - 1,_ tc + 2, tc + 3, tc - 1,_ tc + 5, tc + 8, tc + 4, _ tc + 7, tc + 10, tc + 6 CASE 8 ARRAY ASSIGN n()= tc, tc - 1, tc + 3,_ '2 naar zigzag A (getransponeerd zodat 2e element tc wordt, rij 1 & 2 omwisselen tc + 7, tc + 4, tc + 8, _ tc + 6, tc + 5, tc + 9,_ tc + 13, tc + 10, tc + 14 CASE 9 '2 zigzag b '2 naar zigzag B (getransponeerd, rij 2-> 1, 3-> 2, 1-> 3 ARRAY ASSIGN n()= tc, tc + 3, tc - 1,_ tc + 7, tc + 8, tc + 4,_ tc + 6, tc + 9, tc + 5,_ tc + 13, tc + 14, tc + 10 CASE 10 '3 zigzag A ARRAY ASSIGN n()=tc, tc + 3, tc - 1,_ tc - 2, tc + 1, tc - 3,_ tc - 5, tc - 4, tc - 8, _ tc - 7, tc - 6, tc - 10 CASE 11 '3 zigzag B ARRAY ASSIGN n()=tc, tc - 1, tc + 3,_ tc - 2, tc - 3, tc + 1,_ tc - 5, tc - 8, tc - 4, _ tc - 7, tc - 10, tc - 6 CASE 12 ' 4 zigzag A ARRAY ASSIGN n()= tc, tc - 1, tc + 3,_ tc + 2, tc + 1, tc + 5,_ tc + 7, tc + 4, tc + 8,_ tc + 9, tc + 6, tc + 10 CASE 13 '4 zigzag B ARRAY ASSIGN n()= tc, tc + 3, tc - 1,_ tc + 2, tc + 5, tc + 1,_ tc + 7, tc + 8, tc + 4,_ tc + 9, tc + 10, tc + 6 CASE 14 '5 zigzag A T=+1 ARRAY ASSIGN n()= tc, tc + 1, tc - 4, _ tc - 7, tc - 4, tc - 8, _ tc - 6, tc - 5, tc - 9, _ tc - 13, tc - 10, tc - 14 CASE 15 '5 zigzag B T=+1 ARRAY ASSIGN n()= tc, tc - 4, tc + 1, _ tc - 7, tc - 8, tc - 4, _ tc - 6, tc - 9, tc - 5, _ tc - 13, tc - 14, tc - 10 END SELECT FUNCTION = 16 CASE 4 ' alternating minor seconds and major thirths SELECT CASE vari CASE 0 n(1) = n(0) +1 : n(2) = n(1) + 4 n(3) = n(0) +4 : n(4) = n(3) +4 : n(5) = n(4) + 1 n(6) = n(0) +6 : n(7) = n(6) +1 : n(8) = n(7) + 4 n(9) = n(0) +10 : n(10)= n(9) +4 : n(11) = n(10) +1 CASE 1 'next 3 from schat's website again.. ARRAY ASSIGN n()= tc, tc + 1, tc + 5, _ tc + 2, tc + 3, tc + 7, _ tc + 4, tc + 8, tc + 9, _ tc + 6, tc + 10, tc + 11 CASE 2 ARRAY ASSIGN n()= tc, tc + 4, tc + 5, _ tc + 2, tc + 3, tc + 7, _ tc + 6, tc + 10, tc + 11,_ tc + 8, tc + 9, tc + 13 CASE 3 ARRAY ASSIGN n()= tc, tc + 4, tc + 5, _ tc + 3, tc + 7, tc + 8, _ tc + 6, tc + 10, tc + 11, _ tc + 9, tc + 13, tc + 14 CASE 4 '0 dalend n(1) = n(0) -1 : n(2) = n(1) - 4 n(3) = n(0) -4 : n(4) = n(3) -4 : n(5) = n(4) - 1 n(6) = n(0) -6 : n(7) = n(6) -1 : n(8) = n(7) - 4 n(9) = n(0) -10 : n(10)= n(9) -4 : n(11) = n(10) -1 CASE 5 '1 dalend ARRAY ASSIGN n()= tc, tc - 1, tc - 5, _ tc - 2, tc - 3, tc - 7, _ tc - 4, tc - 8, tc - 9, _ tc - 6, tc - 10, tc - 11 CASE 6 '2 dalend ARRAY ASSIGN n()= tc, tc - 4, tc - 5, _ tc - 2, tc - 3, tc - 7, _ tc - 6, tc - 10, tc - 11,_ tc - 8, tc - 9, tc - 13 CASE 7 '3 dalend ARRAY ASSIGN n()= tc, tc - 4, tc - 5, _ tc - 3, tc - 7, tc - 8, _ tc - 6, tc - 10, tc - 11, _ tc - 9, tc - 13, tc - 14 CASE 8 '0 zigzag A ARRAY ASSIGN n()= tc, tc - 1, tc + 4,_ tc + 7, tc + 3, tc + 8,_ tc + 6, tc + 5, tc + 10,_ tc + 13, tc + 9, tc + 14 CASE 9 '0 zigzag B ARRAY ASSIGN n()= tc, tc + 4, tc - 1,_ tc + 7, tc + 8, tc + 3,_ tc + 6, tc + 10, tc + 5,_ tc + 13, tc + 14, tc + 9 CASE 10 '1 zigzag A ARRAY ASSIGN n()= tc, tc - 1, tc + 4, _ tc + 2, tc + 1, tc + 6, _ tc + 7, tc + 3, tc + 8, _ tc + 9, tc + 5, tc + 10 CASE 11 '1 zigzag B ARRAY ASSIGN n()= tc, tc + 4, tc - 1, _ tc + 2, tc + 6, tc + 1, _ tc + 7, tc + 8, tc + 3, _ tc + 9, tc + 10, tc + 5 CASE 12 '2 zigzag A T=-4 ARRAY ASSIGN n()= tc, tc - 4, tc + 1, _ tc - 1, tc - 2, tc + 3, _ tc + 6, tc + 2, tc + 7,_ tc + 5, tc + 4, tc + 9 CASE 13 '2 zigzag B T=-4 ARRAY ASSIGN n()= tc, tc + 1, tc - 4, _ tc - 1, tc + 3, tc - 2, _ tc + 6, tc + 7, tc + 2,_ tc + 5, tc + 9, tc + 4 CASE 14 '3 zigzag A T=-4 ARRAY ASSIGN n()= tc, tc - 4, tc + 1, _ tc + 3, tc - 1, tc + 4, _ tc + 6, tc + 2, tc + 7, _ tc + 9, tc + 5, tc + 10 CASE 15 '3 zigzag B T=-4 ARRAY ASSIGN n()= tc, tc + 1, tc - 4, _ tc + 3, tc + 4, tc - 1, _ tc + 6, tc + 7, tc + 2, _ tc + 9, tc + 10, tc + 5 CASE 16 '4 zigzag A ARRAY ASSIGN n()= tc, tc + 1, tc - 4,_ tc - 7, tc - 3, tc - 8,_ tc - 6, tc - 5, tc - 10,_ tc - 13, tc - 9, tc - 14 CASE 17 '4 zigzag B ARRAY ASSIGN n()= tc, tc - 4, tc + 1,_ tc - 7, tc - 8, tc - 3,_ tc - 6, tc - 10, tc - 5,_ tc - 13, tc - 14, tc - 9 CASE 18 '5 zigzag A T = +1 ARRAY ASSIGN n()= tc, tc + 1, tc - 4, _ tc - 2, tc - 1, tc - 6, _ tc - 7, tc - 3, tc - 8, _ tc - 9, tc - 5, tc - 10 CASE 19 '5 zigzag B T = +1 ARRAY ASSIGN n()= tc, tc - 4, tc + 1, _ tc - 2, tc - 6, tc - 1, _ tc - 7, tc - 8, tc - 3, _ tc - 9, tc - 10, tc - 5 CASE 20 '6 zigzag A T=4 ARRAY ASSIGN n()= tc, tc + 4, tc - 1, _ tc + 1, tc + 2, tc - 3, _ tc - 6, tc - 2, tc - 7,_ tc - 5, tc - 4, tc - 9 CASE 21 '6 zigzag B T=4 ARRAY ASSIGN n()= tc, tc - 1, tc + 4, _ tc + 1, tc - 3, tc + 2, _ tc - 6, tc - 7, tc - 2,_ tc - 5, tc - 9, tc - 4 END SELECT FUNCTION = 21 CASE 5 ' alternating minor seconds and fourths SELECT CASE vari CASE 0 'deze komt overeen met Schat.. n(1) = n(0) + 1 : n(2) = n(1) + 5 n(3) = n(0) + 2 : n(4) = n(3) + 5 : n(5) = n(4) + 1 n(6) = n(0) + 3 : n(7) = n(6) + 1 : n(8) = n(7) + 5 n(9) = n(0) + 5 : n(10) = n(9) +5 : n(11) = n(10) + 1 CASE 1 n(1) = n(0) - 1 : n(2) = n(1) - 5 n(3) = n(0) - 2 : n(4) = n(3) - 5 : n(5) = n(4) - 1 n(6) = n(0) - 3 : n(7) = n(6) - 1 : n(8) = n(7) - 5 n(9) = n(0) - 5 : n(10) = n(9) -5 : n(11) = n(10) - 1 CASE 2 'zigzag A T-1 ARRAY ASSIGN n()= tc, tc + 1, tc + 5,_ tc + 6, tc + 1, tc + 7,_ tc + 3, tc + 2, tc + 8,_ tc + 9, tc + 4, tc + 10 CASE 3 'zigzag B T-1 ARRAY ASSIGN n()= tc, tc + 5, tc + 1,_ tc + 6, tc + 7, tc + 1,_ tc + 3, tc + 8, tc + 2,_ tc + 9, tc + 10, tc + 4 CASE 4 ARRAY ASSIGN n()= tc, tc + 1, tc - 4,_ tc - 6, tc - 1, tc - 7,_ tc - 3, tc - 2, tc - 8,_ tc - 9, tc - 4, tc - 10 CASE 5 ARRAY ASSIGN n()= tc, tc - 4, tc + 1,_ tc - 6, tc - 7, tc - 1,_ tc - 3, tc - 8, tc - 2,_ tc - 9, tc - 10, tc - 4 END SELECT FUNCTION = 6 CASE 6 ' major seconds only ' hele-toons toonladder SELECT CASE vari CASE 0 ' stijgend (2 sekties) n(1) = n(0) + 2 : n(2) = n(0) + 4 n(3) = n(0) + 6 : n(4) = n(0) + 8 : n(5) = n(0) + 10 n(6) = n(0) + 1 : n(7) = n(6) + 2 : n(8) = n(6) + 4 n(9) = n(6) + 6 : n(10) = n(6) + 8 : n(11) = n(6) + 10 'schat's eigen versies: CASE 1 ARRAY ASSIGN n()= tc, tc + 2, tc + 4, _ tc + 1, tc + 3, tc + 5, _ tc + 6, tc + 8, tc + 10, _ tc + 7, tc + 9, tc + 11 CASE 2 ARRAY ASSIGN n()= tc, tc + 4, tc + 6, _ tc + 3, tc + 5, tc + 7, _ tc + 6, tc + 8, tc + 10, _ tc + 9, tc + 11, tc + 13 CASE 3 '0 dalend n(1) = n(0) - 2 : n(2) = n(0) - 4 n(3) = n(0) - 6 : n(4) = n(0) - 8 : n(5) = n(0) - 10 n(6) = n(0) - 1 : n(7) = n(6) - 2 : n(8) = n(6) - 4 n(9) = n(6) - 6 : n(10) = n(6) - 8 : n(11) = n(6) - 10 CASE 4 '1 dalend ARRAY ASSIGN n()= tc, tc - 2, tc - 4, _ tc - 1, tc - 3, tc - 5, _ tc - 6, tc - 8, tc - 10, _ tc - 7, tc - 9, tc - 11 CASE 5 '2 dalend ARRAY ASSIGN n()= tc, tc - 4, tc - 6, _ tc - 3, tc - 5, tc - 7, _ tc - 6, tc - 8, tc - 10, _ tc - 9, tc - 11, tc - 13 CASE 6 '0 zig zag stijgend n(1) = n(0) + 2 : n(2) = n(0) - 2 n(3) = n(0) + 6 : n(4) = n(3) + 2 : n(5) = n(3) -2 n(6) = n(0) + 1 : n(7) = n(6) + 2 : n(8) = n(6) -2 n(9) = n(0) + 7 : n(10) = n(9) + 2 : n(11) = n(9) -2 CASE 7 '0 zig zag dalend n(1) = n(0) - 2 : n(2) = n(0) + 2 n(3) = n(0) - 6 : n(4) = n(3) - 2 : n(5) = n(3) +2 n(6) = n(0) - 1 : n(7) = n(6) - 2 : n(8) = n(6) +2 n(9) = n(0) - 7 : n(10) = n(9) - 2 : n(11) = n(9) +2 CASE 8 '1 zigzag A, T-2 ARRAY ASSIGN n()= tc, tc - 2, tc + 2, _ tc + 1, tc - 1, tc + 3, _ tc + 6, tc + 4, tc + 8, _ tc + 7, tc + 5, tc + 9 CASE 9 '1 zigzag B, T-2 ARRAY ASSIGN n()= tc, tc + 2, tc - 2, _ tc + 1, tc + 3, tc - 1, _ tc + 6, tc + 8, tc + 4, _ tc + 7, tc + 9, tc + 5 CASE 10 '2 zigzag A T = -4 ARRAY ASSIGN n()= tc, tc - 4, tc + 2, _ tc + 1, tc - 1, tc + 3, _ tc + 4, tc + 2, tc + 6, _ tc + 7, tc + 5, tc + 9 CASE 11 '2 zigzag B T = -4 ARRAY ASSIGN n()= tc, tc + 2, tc - 4, _ tc + 1, tc + 3, tc - 11, _ tc + 4, tc + 6, tc + 2, _ tc + 7, tc + 9, tc + 5 CASE 12 '4 zigzag A T=2 ARRAY ASSIGN n()= tc, tc + 2, tc - 2, _ tc - 1, tc + 1, tc - 3, _ tc - 6, tc - 4, tc - 8, _ tc - 7, tc - 5, tc - 9 CASE 13 '4 zigzag B T=2 ARRAY ASSIGN n()= tc, tc - 2, tc + 2, _ tc - 1, tc - 3, tc + 1, _ tc - 6, tc - 8, tc - 4, _ tc - 7, tc - 9, tc - 5 CASE 14 '5 zigzag A T=4 ARRAY ASSIGN n()= tc, tc + 4, tc - 2, _ tc - 1, tc + 1, tc - 3, _ tc - 4, tc - 2, tc - 6, _ tc - 7, tc - 5, tc - 9 CASE 15 '5 zigzag B T=4 ARRAY ASSIGN n()= tc, tc - 2, tc + 4, _ tc - 1, tc - 3, tc + 2, _ tc - 4, tc - 6, tc - 2, _ tc - 7, tc - 9, tc - 5 END SELECT FUNCTION = 16 CASE 7 ' alternating major seconds and minor thirths SELECT CASE vari 'komt overeen met Schats voorbeeld CASE 0 n(1) = n(0) + 2 : n(2) = n(1) + 3 n(3) = n(0) + 4 : n(4) = n(3) + 3 : n(5) = n(4) + 2 n(6) = n(0) + 6 : n(7) = n(6) + 2 : n(8) = n(7) + 3 n(9) = n(0) + 10: n(10)= n(9) + 3 : n(11)= n(10)+ 2 CASE 1 n(1) = n(0) - 2 : n(2) = n(1) - 3 n(3) = n(0) - 4 : n(4) = n(3) - 3 : n(5) = n(4) - 2 n(6) = n(0) - 6 : n(7) = n(6) - 2 : n(8) = n(7) - 3 n(9) = n(0) - 10: n(10)= n(9) - 3 : n(11)= n(10)- 2 CASE 2 '0 zigzag A ARRAY ASSIGN n() = tc, tc - 2, tc + 1,_ tc + 5, tc + 2, tc + 7,_ tc + 6, tc + 4, tc + 9,_ tc + 11, tc + 8, tc + 13 CASE 3 '0 zigzag B ARRAY ASSIGN n() = tc, tc + 1, tc - 2,_ tc + 5, tc + 7, tc + 2,_ tc + 6, tc + 9, tc + 4,_ tc + 11, tc + 13, tc + 8 CASE 4 ARRAY ASSIGN n() = tc, tc + 2, tc - 1,_ tc - 5, tc - 2, tc - 7,_ tc - 6, tc - 4, tc - 9,_ tc - 11, tc - 8, tc - 13 CASE 5 ARRAY ASSIGN n() = tc, tc - 1, tc + 2,_ tc - 5, tc - 7, tc - 2,_ tc - 6, tc - 9, tc - 4,_ tc - 11, tc - 13, tc - 8 END SELECT FUNCTION = 6 CASE 8 ' alternating major seconds and major thirths SELECT CASE vari CASE 0 ' komt overeen met Schats eerste voorbeeld n(1) = n(0) + 2 : n(2) = n(1) + 4 n(3) = n(0) + 1 : n(4) = n(3) + 2 : n(5) = n(4) + 4 n(6) = n(0) + 4 : n(7) = n(6) + 4 : n(8) = n(7) + 2 n(9) = n(0) + 5 : n(10)= n(9) + 4 : n(11)= n(10)+ 2 CASE 1 ARRAY ASSIGN n()= tc, tc + 2, tc + 6, _ tc + 3, tc + 5, tc + 9, _ tc + 4, tc + 8, tc + 10, _ tc + 7, tc + 11, tc + 13 CASE 2 ARRAY ASSIGN n()= tc, tc + 2, tc + 6 , _ tc + 4, tc + 8, tc + 10,_ tc + 5, tc + 7, tc + 11,_ tc + 9, tc + 13, tc + 15 CASE 3 '0 dalend n(1) = n(0) - 2 : n(2) = n(1) - 4 n(3) = n(0) - 1 : n(4) = n(3) - 2 : n(5) = n(4) - 4 n(6) = n(0) - 4 : n(7) = n(6) - 4 : n(8) = n(7) - 2 n(9) = n(0) - 5 : n(10)= n(9) - 4 : n(11)= n(10)- 2 CASE 4 '1 dalend ARRAY ASSIGN n()= tc, tc - 2, tc - 6, _ tc - 3, tc - 5, tc - 9, _ tc - 4, tc - 8, tc - 10, _ tc - 7, tc - 11, tc - 13 CASE 5 '2 dalend ARRAY ASSIGN n()= tc, tc - 2, tc - 6 , _ tc - 4, tc - 8, tc - 10,_ tc - 5, tc - 7, tc - 11,_ tc - 9, tc - 13, tc - 15 CASE 6 '0 zigzag ARRAY ASSIGN n()= tc, tc - 2, tc + 4, _ tc + 1, tc - 1, tc + 5, _ tc + 6, tc + 2, tc + 8, _ tc + 7, tc + 3, tc + 9 CASE 7 '0 zigzag ARRAY ASSIGN n()= tc, tc + 4, tc - 2, _ tc + 1, tc + 5, tc - 1, _ tc + 6, tc + 8, tc + 2, _ tc + 7, tc + 9, tc + 3 CASE 8 '1 zigzag A T=-2 ARRAY ASSIGN n()= tc, tc - 2, tc + 4, _ tc + 3, tc + 1, tc + 7, _ tc + 6, tc + 2, tc + 8, _ tc + 9, tc + 5, tc + 11 CASE 9 '1 zigzag B T=-2 ARRAY ASSIGN n()= tc, tc + 4, tc - 2, _ tc + 3, tc + 7, tc + 1, _ tc + 6, tc + 8, tc + 2, _ tc + 9, tc + 11, tc + 5 CASE 10 '2 zigzag A T=-2 ARRAY ASSIGN n()= tc, tc - 2, tc + 4 , _ tc + 6, tc + 2, tc + 8,_ tc + 5, tc + 3, tc + 9,_ tc + 11, tc + 17, tc + 13 CASE 11 '2 zigzag B T=-2 ARRAY ASSIGN n()= tc, tc + 4, tc - 2 , _ tc + 6, tc + 8, tc + 2,_ tc + 5, tc + 9, tc + 3,_ tc + 11, tc + 13, tc + 7 CASE 12 ARRAY ASSIGN n()= tc, tc + 2, tc - 4, _ tc - 1, tc + 1, tc - 5, _ tc - 6, tc - 2, tc - 8, _ tc - 7, tc - 3, tc - 9 CASE 13 ARRAY ASSIGN n()= tc, tc - 4, tc + 2, _ tc + 1, tc - 1, tc - 5, _ tc - 2, tc - 6, tc - 8, _ tc - 3, tc - 7, tc - 9 CASE 14 '4 zigzag A T=2 ARRAY ASSIGN n()= tc, tc + 2, tc - 4, _ tc - 1, tc - 7, tc - 3, _ tc - 2, tc - 8, tc - 6, _ tc - 5, tc - 11, tc - 9 CASE 15 '4 zigzag B T=2 ARRAY ASSIGN n()= tc, tc - 4, tc + 2, _ tc - 3, tc - 7, tc - 1, _ tc - 6, tc - 8, tc - 2, _ tc - 9, tc - 11, tc - 5 CASE 16 '5 zigzag A T=2 ARRAY ASSIGN n()= tc, tc + 2, tc - 4 , _ tc - 6, tc - 2, tc - 8,_ tc - 5, tc - 3, tc - 9,_ tc - 11, tc - 7, tc - 13 CASE 17 '5 zigzag A T=2 ARRAY ASSIGN n()= tc, tc - 4, tc + 2 , _ tc - 6, tc - 8, tc - 2,_ tc - 5, tc - 9, tc - 3,_ tc - 11, tc - 13, tc - 7 END SELECT FUNCTION = 18 CASE 9 ' alternating major seconds and fourths SELECT CASE vari CASE 0 'komt overeen met Schats eerste voorbeeld n(1) = n(0) + 2 : n(2) = n(1) + 5 n(3) = n(0) + 1 : n(4) = n(3) + 5 : n(5) = n(4) + 2 n(6) = n(0) + 3 : n(7) = n(6) + 2 : n(8) = n(7) + 5 n(9) = n(0) + 4 : n(10)= n(9) + 5 : n(11)= n(10)+ 2 CASE 1 ARRAY ASSIGN n()= tc, tc + 5, tc + 7, _ tc + 2, tc + 4, tc + 9, _ tc + 6, tc + 11, tc + 13, _ tc + 8, tc + 10, tc + 15 CASE 2 ARRAY ASSIGN n()= tc, tc + 2, tc + 6 , _ tc + 3, tc + 5, tc + 10, _ tc + 6, tc + 8, tc + 13, _ tc + 9, tc + 11, tc + 16 CASE 3 n(1) = n(0) - 2 : n(2) = n(1) - 5 n(3) = n(0) - 1 : n(4) = n(3) - 5 : n(5) = n(4) - 2 n(6) = n(0) - 3 : n(7) = n(6) - 2 : n(8) = n(7) - 5 n(9) = n(0) - 4 : n(10)= n(9) - 5 : n(11)= n(10)- 2 CASE 4 '2 dalend ARRAY ASSIGN n()= tc, tc - 5, tc - 7, _ tc - 2, tc - 4, tc - 9, _ tc - 6, tc - 11, tc - 13, _ tc - 8, tc - 10, tc - 15 CASE 5 '3 dalend ARRAY ASSIGN n()= tc, tc - 2, tc - 6 , _ tc - 3, tc - 5, tc - 10, _ tc - 6, tc - 8, tc - 13, _ tc - 9, tc - 11, tc - 16 CASE 6 '0 zigzag A ARRAY ASSIGN n() = tc, tc - 2, tc + 5,_ tc + 4, tc - 1, tc + 6,_ tc + 3, tc + 1, tc + 8,_ tc + 7, tc + 2, tc + 9 CASE 7 '0 zigzag B ARRAY ASSIGN n() = tc, tc + 5, tc - 2,_ tc + 4, tc + 6, tc - 1,_ tc + 3, tc + 8, tc + 1,_ tc + 7, tc + 9, tc + 2 CASE 8 '1 zigzag A T=-5 ARRAY ASSIGN n()= tc, tc - 5, tc + 2, _ tc - 1, tc - 3, tc + 4, _ tc + 6, tc + 1, tc + 8, _ tc + 5, tc + 3, tc + 10 CASE 9 '1 zigzag B T=-5 ARRAY ASSIGN n()= tc, tc + 2, tc - 5, _ tc - 1, tc + 4, tc - 3, _ tc + 6, tc + 8, tc + 1, _ tc + 5, tc + 10, tc + 3 CASE 10 '2 zigazag A T = -2 ARRAY ASSIGN n()= tc, tc - 2, tc + 4 , _ tc + 3, tc + 1, tc + 8, _ tc + 6, tc + 4, tc + 11, _ tc + 9, tc + 7, tc + 14 CASE 11 '2 zigazag B T = -2 ARRAY ASSIGN n()= tc, tc + 4, tc - 2 , _ tc + 3, tc + 8, tc + 1, _ tc + 6, tc + 11, tc + 4, _ tc + 9, tc + 14, tc + 7 CASE 12 '3 zigzag A ARRAY ASSIGN n() = tc, tc + 2, tc - 5,_ tc - 4, tc + 1, tc - 6,_ tc - 3, tc - 1, tc - 8,_ tc - 7, tc - 2, tc - 9 CASE 13 '3 zigzag B ARRAY ASSIGN n() = tc, tc - 5, tc + 2,_ tc - 4, tc - 6, tc + 1,_ tc - 3, tc - 8, tc - 1,_ tc - 7, tc - 9, tc - 2 CASE 14 '4 zigzag A T=5 ARRAY ASSIGN n()= tc, tc + 5, tc - 2, _ tc + 1, tc + 3, tc - 4, _ tc - 6, tc - 1, tc - 8, _ tc - 5, tc - 3, tc - 10 CASE 15 '4 zigzag B T=5 ARRAY ASSIGN n()= tc, tc - 2, tc + 5, _ tc + 1, tc - 4, tc + 3, _ tc - 6, tc - 8, tc - 1, _ tc - 5, tc - 10, tc - 3 CASE 16 '5 zigzag A T=2 ARRAY ASSIGN n()= tc, tc + 2, tc - 4 , _ tc - 3, tc - 1, tc - 8, _ tc - 6, tc - 4, tc - 11, _ tc - 9, tc - 7, tc - 14 CASE 17 '5 zigzagB T=2 ARRAY ASSIGN n()= tc, tc - 4, tc + 2 , _ tc - 3, tc - 8, tc - 1, _ tc - 6, tc - 11, tc - 4, _ tc - 9, tc - 14, tc - 7 END SELECT FUNCTION = 18 CASE 10 ' hier kan de reeks alleen met 3 vierklanken volledig zijn. ' minor thirths only SELECT CASE vari CASE 0 ' stijgend n(1) = n(0) + 3 : n(2) = n(0) + 6 : n(3) = n(0) + 9 n(4) = n(0) + 2 : n(5) = n(4) + 3 : n(6) = n(4) + 6 : n(7) = n(4) + 9 n(8) = n(0) + 1 : n(9) = n(8) + 3 : n(10)= n(8) + 6 : n(11) = n(8) +9 CASE 1 ' dalend n(1) = n(0) - 3 : n(2) = n(0) - 6 : n(3) = n(0) - 9 n(4) = n(0) - 2 : n(5) = n(4) - 3 : n(6) = n(4) - 6 : n(7) = n(4) - 9 n(8) = n(0) - 1 : n(9) = n(8) - 3 : n(10)= n(8) - 6 : n(11) = n(8) -9 CASE 2 ' zig zag stijgend n(1) = n(0) + 3 : n(2) = n(0) - 3 : n(3) = n(0) + 6 n(4) = n(0) + 1 : n(5) = n(4) + 3 : n(6) = n(4) - 3 : n(7) = n(4) + 6 n(8) = n(0) + 2 : n(9) = n(8) + 3 : n(10) = n(8) - 3 : n(11) = n(8) + 6 CASE 3 ' zig zag dalend n(1) = n(0) - 3 : n(2) = n(0) + 3 : n(3) = n(0) - 6 n(4) = n(0) - 1 : n(5) = n(4) - 3 : n(6) = n(4) + 3 : n(7) = n(4) - 6 n(8) = n(0) - 2 : n(9) = n(8) - 3 : n(10) = n(8) + 3 : n(11) = n(8) - 6 END SELECT FUNCTION = 4 CASE 11 ' alternating minor and major thirths: almost the tonal system SELECT CASE vari CASE 0 ' mineur stijgend n(1) = n(0) + 3 : n(2) = n(1) + 4 n(3) = n(0) + 4 : n(4) = n(3) + 4 : n(5) = n(4) + 3 n(6) = n(0) + 2 : n(7) = n(6) + 3 : n(8) = n(7) + 4 n(9) = n(0) + 6 : n(10) = n(9) + 4 : n(9) = n(11) + 3 ARRAY ASSIGN n() = tc, tc + 3, tc + 7,_ tc + 4, tc + 8, tc + 11,_ tc + 2, tc + 5, tc + 9,_ tc + 6, tc + 10, tc + 13 CASE 1 ARRAY ASSIGN n()= tc, tc + 3, tc + 7, _ tc + 2, tc + 5, tc + 9, _ tc + 4, tc + 7, tc + 11, _ tc + 6, tc + 10, tc + 13 CASE 2 ARRAY ASSIGN n()= tc, tc + 4, tc + 7, _ tc + 2, tc + 5, tc + 9, _ tc + 6, tc + 10, tc + 13,_ tc + 8, tc + 11, tc + 15 CASE 3 ' mineur dalend n(1) = n(0) - 3 : n(2) = n(1) - 4 n(3) = n(0) - 4 : n(4) = n(3) - 4 : n(5) = n(4) - 3 n(6) = n(0) - 2 : n(7) = n(6) - 3 : n(8) = n(7) - 4 n(9) = n(8) - 6 : n(10) = n(9) - 4 : n(11) = n(10) - 3 CASE 4 '1 dalend ARRAY ASSIGN n()= tc, tc - 3, tc - 7, _ tc - 2, tc - 5, tc - 9, _ tc - 4, tc - 7, tc - 11, _ tc - 6, tc - 10, tc - 13 CASE 5 '2 dalend ARRAY ASSIGN n()= tc, tc - 4, tc - 7, _ tc - 2, tc - 5, tc - 9, _ tc - 6, tc - 10, tc - 13,_ tc - 8, tc - 11, tc - 15 CASE 6 '0 zigzag A ARRAY ASSIGN n() = tc, tc - 3, tc + 4,_ tc + 5, tc + 1, tc + 8,_ tc + 2, tc - 1, tc + 6,_ tc + 7, tc + 3, tc + 10 CASE 7 '0 zigzag B ARRAY ASSIGN n() = tc, tc + 4, tc - 3,_ tc + 5, tc + 8, tc + 1,_ tc + 2, tc + 6, tc - 1,_ tc + 7, tc + 10, tc + 3 CASE 8 '1 zigzag A T=-3 ARRAY ASSIGN n()= tc, tc - 3, tc + 4, _ tc + 2, tc - 1, tc + 6, _ tc + 4, tc + 1, tc + 8, _ tc + 7, tc + 3, tc + 10 CASE 9 '1 zigzag B T=-3 ARRAY ASSIGN n()= tc, tc + 4, tc - 3, _ tc + 2, tc + 6, tc - 1, _ tc + 4, tc + 8, tc + 1, _ tc + 7, tc + 10, tc + 3 CASE 10 '2 zigzag A T=-4 ARRAY ASSIGN n()= tc, tc - 4, tc + 3, _ tc + 1, tc - 2, tc + 5, _ tc + 6, tc + 2, tc + 9,_ tc + 7, tc + 4, tc + 11 CASE 11 '2 zigzag B T=-4 ARRAY ASSIGN n()= tc, tc + 3, tc - 4, _ tc + 1, tc + 5, tc - 2, _ tc + 6, tc + 9, tc + 2,_ tc + 7, tc + 11, tc + 4 CASE 12 '3 zigzag A ARRAY ASSIGN n() = tc, tc + 3, tc - 4,_ tc - 5, tc - 1, tc - 8,_ tc - 2, tc + 1, tc - 6,_ tc - 7, tc - 3, tc - 10 CASE 13 '3 zigzag B ARRAY ASSIGN n() = tc, tc - 4, tc + 3,_ tc - 5, tc - 8, tc - 1,_ tc - 2, tc - 6, tc + 1,_ tc - 7, tc - 10, tc - 3 CASE 14 '4 zigzag A T = 3 ARRAY ASSIGN n()= tc, tc + 3, tc - 4, _ tc - 2, tc + 1, tc - 6, _ tc - 4, tc - 1, tc - 8, _ tc - 7, tc - 3, tc - 10 CASE 15 '4 zigzag A T = 3 ARRAY ASSIGN n()= tc, tc - 4, tc + 3, _ tc - 2, tc - 6, tc + 1, _ tc - 4, tc - 8, tc - 1, _ tc - 7, tc - 10, tc - 3 CASE 16 '5 zigzag A T=4 ARRAY ASSIGN n()= tc, tc + 4, tc - 3, _ tc - 1, tc + 2, tc - 5, _ tc - 6, tc - 2, tc - 9,_ tc - 7, tc - 4, tc - 11 CASE 17 '5 zigzag A T=4 ARRAY ASSIGN n()= tc, tc - 3, tc + 4, _ tc - 1, tc - 5, tc + 2, _ tc - 6, tc - 9, tc - 2,_ tc - 7, tc - 11, tc - 4 ' further cases to be done END SELECT FUNCTION = 18 CASE 12 ' major thirths only ' this is actually a diad, taking into account inversions. SELECT CASE vari CASE 0 'komt overeen met schats eerste n(1) = n(0) + 4 : n(2) = n(0) + 8 n(3) = n(0) + 1 : n(4) = n(3) + 4 : n(5) = n(3) + 8 n(6) = n(0) + 2 : n(7) = n(6) + 4 : n(8) = n(6) + 8 n(9) = n(0) + 3 : n(10) = n(9) + 4 : n(11) = n(9) + 8 ARRAY ASSIGN n() = tc, tc + 4, tc + 8 , _ tc + 1, tc + 5, tc + 9,_ tc + 2, tc + 6, tc + 10,_ tc + 3, tc + 7, tc + 15 CASE 1 ARRAY ASSIGN n()= tc, tc + 4, tc + 8 , _ tc + 2, tc + 6, tc + 10, _ tc + 3, tc + 7, tc + 11, _ tc + 5, tc + 9, tc + 13 CASE 2 ARRAY ASSIGN n()= tc, tc + 4, tc + 8 , _ tc + 5, tc + 9, tc + 13,_ tc + 6, tc + 10, tc + 14,_ tc + 11, tc + 15, tc + 19 CASE 3 ARRAY ASSIGN n()= tc, tc + 4, tc + 8 , _ tc + 2, tc + 6, tc + 10, _ tc + 5, tc + 9, tc + 13, _ tc + 7, tc + 11, tc + 15 CASE 4 n(1) = n(0) - 4 : n(2) = n(0) - 8 n(3) = n(0) - 1 : n(4) = n(3) - 4 : n(5) = n(3) - 8 n(6) = n(0) - 2 : n(7) = n(6) - 4 : n(8) = n(6) - 8 n(9) = n(0) - 3 : n(10) = n(9) - 4 : n(11) = n(9) - 8 CASE 5 '1 dalend ARRAY ASSIGN n()= tc, tc - 4, tc - 8 , _ tc - 2, tc - 6, tc - 10, _ tc - 3, tc - 7, tc - 11, _ tc - 5, tc - 9, tc - 13 CASE 6 '2 dalend ARRAY ASSIGN n()= tc, tc - 4, tc - 8 , _ tc - 5, tc - 9, tc - 13,_ tc - 6, tc - 10, tc - 14,_ tc - 11, tc - 15, tc - 19 CASE 7 ARRAY ASSIGN n()= tc, tc - 4, tc - 8 , _ tc - 2, tc - 6, tc - 10, _ tc - 5, tc - 9, tc - 13, _ tc - 7, tc - 11, tc - 15 CASE 8 '0 zigzag ARRAY ASSIGN n() = tc, tc - 4, tc + 4 , _ tc + 1, tc - 3, tc + 5,_ tc + 2, tc - 2, tc + 6,_ tc + 3, tc - 11, tc + 11 CASE 9 '0 zigzag ARRAY ASSIGN n() = tc, tc + 4, tc - 4 , _ tc + 1, tc + 5, tc - 3,_ tc + 2, tc + 6, tc - 2,_ tc + 3, tc + 11, tc - 1 CASE 10 '1 zigzag A T = -4 ARRAY ASSIGN n()= tc, tc - 4, tc + 4 , _ tc + 2, tc - 2, tc + 6, _ tc + 3, tc - 1, tc + 7, _ tc + 5, tc + 1, tc + 9 CASE 11 '1 zigzag A T = -4 ARRAY ASSIGN n()= tc, tc + 4, tc - 4 , _ tc + 2, tc + 6, tc - 2, _ tc + 3, tc + 7, tc - 1, _ tc + 5, tc + 9, tc + 1 CASE 12 '2 zigzag A T = -4 ARRAY ASSIGN n()= tc, tc - 4, tc + 4 , _ tc + 5, tc + 1, tc + 9,_ tc + 6, tc + 2, tc + 10,_ tc + 11, tc + 7, tc + 15 CASE 13 '2 zigzag B T = -4 ARRAY ASSIGN n()= tc, tc + 4, tc - 4 , _ tc + 5, tc + 9, tc + 1,_ tc + 6, tc + 10, tc + 2,_ tc + 11, tc + 15, tc + 7 CASE 14 '3 zigzag A T = -4 ARRAY ASSIGN n()= tc, tc, - 4, tc + 4 , _ tc + 2, tc - 2, tc + 6, _ tc + 5, tc + 1, tc + 9, _ tc + 7, tc + 3, tc + 11 CASE 15 '3 zigzag B T = -4 ARRAY ASSIGN n()= tc, tc + 4, tc - 4 , _ tc + 2, tc + 6, tc - 2, _ tc + 5, tc + 9, tc + 1, _ tc + 7, tc + 11, tc + 3 CASE 16 '4 zigzag ARRAY ASSIGN n() = tc, tc + 4, tc - 4 , _ tc - 1, tc + 3, tc - 5,_ tc - 2, tc + 2, tc - 6,_ tc - 3, tc + 11, tc - 11 CASE 17 '4 zigzag ARRAY ASSIGN n() = tc, tc - 4, tc + 4 , _ tc - 1, tc - 5, tc + 3,_ tc - 2, tc - 6, tc + 2,_ tc - 3, tc - 11, tc + 1 CASE 18 '5 zigzag A T = 4 ARRAY ASSIGN n()= tc, tc + 4, tc - 4 , _ tc - 2, tc + 2, tc - 6, _ tc - 3, tc + 1, tc - 7, _ tc - 5, tc - 1, tc - 9 CASE 19 '5 zigzag B T = 4 ARRAY ASSIGN n()= tc, tc - 4, tc + 4 , _ tc - 2, tc - 6, tc + 2, _ tc - 3, tc - 7, tc + 1, _ tc - 5, tc - 9, tc - 1 CASE 20 '6 zigzag A T = 4 ARRAY ASSIGN n()= tc, tc + 4, tc - 4 , _ tc - 5, tc - 1, tc - 9,_ tc - 6, tc - 2, tc - 8,_ tc - 11, tc - 7, tc - 14 CASE 21 '6 zigzag B T = 4 ARRAY ASSIGN n()= tc, tc - 4, tc + 4 , _ tc - 5, tc - 9, tc - 1,_ tc - 6, tc - 8, tc - 2,_ tc - 11, tc - 14, tc - 7 CASE 22 '7 zigzag A T = 4 ARRAY ASSIGN n()= tc, tc + 4, tc - 4 , _ tc - 2, tc + 2, tc - 6, _ tc - 5, tc - 1, tc - 9, _ tc - 7, tc - 3, tc - 11 CASE 23 '7 zigzag B T = 4 ARRAY ASSIGN n()= tc, tc - 4, tc + 4 , _ tc - 2, tc - 6, tc + 2, _ tc - 5, tc - 9, tc - 1, _ tc - 7, tc - 11, tc - 3 END SELECT FUNCTION = 24 END SELECT 'logfile FUNCNAME$ + " finished" END FUNCTION FUNCTION SteeringHour (uur AS INTEGER) EXPORT AS STRING ' returns the hours that are considered the steering hour for the uur passed. 'returns string where each byte is one of the steering hours ' backwards uur = MAX(1, uur) DECR uur ' must be > 0 uur = uur MOD 12 ' so that we can circle around the clock INCR uur SELECT CASE uur CASE 1: FUNCTION = CHR$(10) CASE 2: FUNCTION = CHR$(8) CASE 3: FUNCTION = CHR$(5,7,9) 'nb, according to gwr. in Schat's own oversight, 9 is not mentioned.. CASE 4: FUNCTION = CHR$(6,8,10) CASE 5: FUNCTION = CHR$(2) CASE 6: FUNCTION = CHR$(5,10) CASE 7: FUNCTION = CHR$(8) CASE 8: FUNCTION = CHR$(3,4,11) CASE 9: FUNCTION = CHR$(2,8,10) CASE 10: FUNCTION = CHR$(1) CASE 11: FUNCTION = CHR$(6,8) CASE 12: FUNCTION = CHR$(1,2,5,7) END SELECT END FUNCTION FUNCTION SteeredHour (uur AS INTEGER) EXPORT AS STRING ' returns the hour that is considered the hour steered for the uur passed. ' Forwards uur = MAX(1, uur) DECR uur ' must be > 0 uur = uur MOD 12 ' so that we can circle around the clock INCR uur SELECT CASE uur CASE 1: FUNCTION = CHR$(10, 12) CASE 2: FUNCTION = CHR$(5,9,12) CASE 3: FUNCTION = CHR$(8) CASE 4: FUNCTION = CHR$(8) CASE 5: FUNCTION = CHR$(3,6,12) CASE 6: FUNCTION = CHR$(4,11) CASE 7: FUNCTION = CHR$(3,12) CASE 8: FUNCTION = CHR$(2,4,9,11) CASE 9: FUNCTION = CHR$(3) 'see remark in Steerinhour() CASE 10: FUNCTION = CHR$(1,4,6,9) CASE 11: FUNCTION = CHR$(8) CASE 12: FUNCTION = "" 'not steering any hour.. END SELECT END FUNCTION ' some functions for jazz-harmony, after Georges Russell ' 15th chords, lydian. , with minor scale added by gwr. FUNCTION BuildJazzchord (BYREF Tc AS INTEGER, BYVAL melnote AS BYTE, BYVAL v AS BYTE, OPTIONAL BYVAL span AS BYTE) EXPORT AS STRING ' 28.11.2012: first coding gwr. ' 29.11.2012: some debug by Kristof Lauwers ' it's best to pass Tc in the octave position wanted by the user. ' 30.11.2012: span 1-5 support added. Span is the octaves spanwidth of the chord. ' application example: Namuda Study #29, dozens ' 01.12.2012: bug with statics in recursivity solved. LOCAL tmp AS HarmType LOCAL bas, i, note,notem AS INTEGER LOCAL majeur, mineur AS HarmType STATIC modus AS LONG ', oTc, tog AS LONG ' sticky!, so we preserve the mode if possible since the previous call ' modus = 0 ==> major (default) ' modus = 1 ==> minor ' if isfalse tog then ' oTc = -1 ' tog = %True ' end if IF ISFALSE span THEN span = 2 ' ligging van het geretourneerde akkoord span = MIN(span,5) ' begrenzing, 1,2,3,4,5 oktaven spanbreedte ' if Tc <> oTc then AddShNo2Har majeur, Tc MOD 12, 127 'v note = Tc MOD 12 AddShNo2Har mineur, Tc MOD 12, 127 'v notem = Tc MOD 12 FOR i = 0 TO 5 note = note + 4 - (i MOD 2) AddShNo2Har majeur, note, 127 'v notem = notem + 3 + (i MOD 2) AddShNo2Har mineur, notem, 127 'v NEXT i 'oTc = Tc ' end if ' safety limits: IF Tc > 120 - (span * 12) THEN Logfile "Tc out of range in " & FUNCNAME$ 'repair it: Tc = 120 - (span * 12) + (Tc MOD 12) END IF ' eerst nagaan of de melnote tot de modus behoort: IF IsNoteInOktHar (majeur, melnote) > 0 THEN modus = %False ' majeur IF Tc < 24 THEN SELECT CASE span CASE 1 bas = 60 + (Tc MOD 12) CASE 2 bas = 48 + (Tc MOD 12) CASE 3 bas = 36 + (Tc MOD 12) CASE 4,5 bas = 24 + (Tc MOD 12) END SELECT ELSE IF melnote > Tc + (span * 12) THEN bas = ((melnote \ 12) * 12) - (span * 12) + (Tc MOD 12) ELSE IF melnote >= Tc THEN bas = Tc ' wat als melnote < Tc ??? ELSE bas = ((melnote \ 12) * 12) + (Tc MOD 12) ' melnote ligt onder de bas.... END IF END IF END IF AddNote2Har tmp, bas, v note = bas SELECT CASE span CASE 1 note = note +2 IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note +2 IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note +2 IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note +1 IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note +2 IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note +2 IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v CASE 2 FOR i = 0 TO 5 note = note + 4 - (i MOD 2) IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v NEXT i CASE 3 note = note + 7 ' sol IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 9 ' mi IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' si IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' fa# IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 3 ' la IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 5 ' re IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v CASE 4 note = note + 7 ' sol IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 9 ' mi IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' si IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' fa# IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 8 ' re IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' la IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v CASE 5 note = note + 16 ' mi IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' si IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 8 ' sol IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' re IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' la IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 9 ' fa# IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v END SELECT AddNote2Har tmp, melnote, v ' ook als ze onder de bas ligt! FUNCTION = tmp.vel EXIT FUNCTION ELSE ' de noot behoort niet tot de majeur toonladder IF IsnoteInOktHar (mineur, melnote) > 0 THEN ' behoort ze tot de mineur ladder? modus = %True ' mineur IF Tc < 24 THEN SELECT CASE span CASE 1 bas = 60 + (Tc MOD 12) CASE 2 bas = 48 + (Tc MOD 12) CASE 3 bas = 36 + (Tc MOD 12) CASE 4, 5 bas = 24 + (Tc MOD 12) END SELECT ELSE IF melnote > Tc + (span * 12) THEN bas = ((melnote \ 12) * 12) - (span * 12) + (Tc MOD 12) ELSE IF melnote >= Tc THEN bas = Tc ' wat als melnote < Tc ??? ELSE bas = ((melnote \ 12) * 12) + (Tc MOD 12) ' melnote ligt onder de bas.... END IF END IF END IF AddNote2Har tmp, bas, v note = bas ' we forgot this!, was bug!!! SELECT CASE span CASE 1 note = note +2 ' re IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note +1 ' mib IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note +2 ' fa IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note +2 ' sol IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note +2 ' la IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note +1 ' sib IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v CASE 2 FOR i = 0 TO 5 note = note + 3 + (i MOD 2) ' mineur 3,4,3,4,3,4 IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v NEXT i CASE 3 note = note + 7 ' sol IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 8 ' mib IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' sib IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' fa IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 4 ' la IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 5 ' re IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v CASE 4 note = note + 7 ' sol IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 8 ' mib IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' sib IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' fa IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 9 ' re IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' la IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v CASE 5 note = note + 15 ' mib IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' sib IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 9 ' sol IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' re IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 7 ' la IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v note = note + 9 ' fa# IF (note MOD 12) <> (melnote MOD 12) THEN AddNote2Har tmp, note, v END SELECT AddNote2Har tmp, melnote, v ' ook als ze onder de bas ligt! FUNCTION = tmp.vel EXIT FUNCTION END IF END IF ' wanneer we hier zijn, hebben we een melnote die niet tot de modus behoort! ' er kunnen zich slechts 2 mogelijkheden voordoen, namelijk ' melnote MOD 12 = (Tc MOD 12) + 1 ==> kwintmodulatie in majeur (-> Tc + 7) ofwel grote terts modulatie (->Tc + 4) in mineur ' melnote MOD 12 = (Tc MOD 12) + 8 ==> hele toonsmodulatie in majeur (-> Tc + 2) ofwel halve toons modulatie omlaag (-> Tc -1) in mineur SELECT CASE modus CASE %False ' major SELECT CASE (melnote MOD 12) CASE ((Tc MOD 12) + 1) MOD 12 Tc += 7 ' try recursive call to the same function: 'logfile "+7 Major Tc= " & STR$(Tc) & Funcname$ FUNCTION = BuildJazzChord (Tc, melnote, v, span) EXIT FUNCTION CASE ((Tc MOD 12) + 8) MOD 12 Tc += 2 'logfile "+2 Major Tc= " & STR$(Tc) & FUNCNAME$ FUNCTION = BuildJazzChord (Tc, melnote, v, span) EXIT FUNCTION END SELECT CASE %True ' minor SELECT CASE (melnote MOD 12) CASE ((Tc MOD 12) + 1) MOD 12 Tc += 4 'logfile "+4 Minor Tc= " & STR$(Tc) & FUNCNAME$ FUNCTION = BuildJazzChord (Tc, melnote, v, span) EXIT FUNCTION CASE ((Tc MOD 12) + 8) MOD 12 IF Tc >= 1 THEN Tc = Tc -1 ELSE Tc = 11 'logfile "+11 Minor Tc= " & STR$(Tc) & FUNCNAME$ FUNCTION = BuildJazzChord (Tc, melnote, v, span) EXIT FUNCTION END SELECT END SELECT ' nu moeten alle mogelijke gevallen opgelost zijn logfile "Not handled case bug in " & FUNCNAME$ 'warning "Bug in Jazz-chord function!", 5000 FUNCTION = tmp.vel END FUNCTION SUB GetJazzHarScale (Tc AS INTEGER, n AS INTEGER, BYVAL pl AS INTEGER PTR) EXPORT ' 03.12.2012 gwr ' n must be part of the scale on Tc, otherwize the procedure will change Tc! LOCAL har AS harmtype LOCAL m AS INTEGER DIM ladder(6) AS LOCAL INTEGER AT pl 'm = Tc + (n mod 12) m = n IF n < Tc THEN 'm = n DO m +=12 LOOP UNTIL m >= Tc END IF IF n > (Tc + 11) THEN DO m -= 12 LOOP UNTIL m <= (Tc + 11) END IF har.vel = BuildJazzChord (Tc,m ,127,1) ' in nauwste ligging ladder(0) = Tc IF IsNoteInOktHar (Har, Tc + 3) THEN ' must be minor mode ladder(1)=Tc + 2 ladder(2)=Tc + 3 ladder(3)=Tc + 5 ladder(4)=Tc + 7 ladder(5)=Tc + 9 ladder(6)=Tc + 10 EXIT SUB END IF IF IsnoteInOktHar (Har, Tc + 4) THEN ' must be major mode ladder(1)=Tc + 2 ladder(2)=Tc + 4 ladder(3)=Tc + 6 ladder(4)=Tc + 7 ladder(5)=Tc + 9 ladder(6)=Tc + 11 EXIT SUB END IF ' wanneer we hier komen is er een onopgelost geval en dus een bug... Logfile "Bug in jazzscale procedure " & FUNCNAME$ & " g_har.dll" END SUB 'SUB GetJazzScale (Tc AS INTEGER, BYVAL modus AS LONG, BYREF ladder() AS INTEGER) EXPORT SUB GetJazzScale (Tc AS INTEGER, BYVAL modus AS LONG, BYVAL pl AS INTEGER PTR) EXPORT ' just a lookup utility... ' 29.11.2012 gwr ' 03.12.2012: modified to take pointer to ladder array as parameter. ' only 7-note scales build from 15th chords DIM ladder(6) AS LOCAL INTEGER AT pl ' should work with arrays within types! ' no check for size!, must be 6 IF Tc > 115 THEN Tc = 120 + (Tc MOD 12) SELECT CASE (modus MOD 2) CASE %False ' major - lydisch ladder(0)= Tc ladder(1)=Tc + 2 ladder(2)=Tc + 4 ladder(3)=Tc + 6 ladder(4)=Tc + 7 ladder(5)=Tc + 9 ladder(6)=Tc + 11 CASE %True ' minor ladder(0)= Tc ladder(1)=Tc + 2 ladder(2)=Tc + 3 ladder(3)=Tc + 5 ladder(4)=Tc + 7 ladder(5)=Tc + 9 ladder(6)=Tc + 10 END SELECT END SUB