' ************************************************** ' * include file for g_har.bas * ' * contains all procs related to * ' * chord-number harmony in GMT * ' * Godfried-Willem Raes 1983 - 2012 * ' ************************************************** ' file created on 22.01.2007 ' declarations are in g_har.bi FUNCTION AddChords (BYVAL crd1%, BYVAL crd2%) EXPORT AS INTEGER LOCAL ton1%, ton2%,crd0% ton1% = GetTc(crd1%) ton2% = GetTc(crd2%) crd0% = (crd1% AND &H0FFF) OR (crd2% AND &H0FFF) IF ton1% > %NotFalse THEN crd0% = SetTc(crd0%, ton1%) ELSE IF ton2% > %NotFalse THEN FUNCTION = SetTc(crd0%, ton2%) ELSE FUNCTION = crd0% OR &H0F000 END IF END IF END FUNCTION FUNCTION AddNoteInChord (BYVAL ChordNum%, BYVAL note AS BYTE) EXPORT AS INTEGER BIT SET ChordNum%,note MOD 12 FUNCTION = ChordNum% END FUNCTION FUNCTION Cnr2Ctp (BYVAL c%, BYVAL tc%) EXPORT AS LONG LOCAL nn%, crd%, a$, b$, cs$,i%, j%, il%, ChordVal& nn% = GetNrNotes(c%) crd% = c% IF tc% < %False THEN tc% = %False IF tc% THEN crd% = TransChordNum(crd%, -tc%) IF nn% = 0 THEN FUNCTION = %False EXIT FUNCTION ' illegal END IF IF nn% > 7 THEN crd% = Neg(crd%) cs$ = "" DO ' was : IF crd% AND (2 ^ ((i% + tc%) MOD 12)) THEN cs$ = cs$ + HEX$((i% + tc%) MOD 12) IF BIT(crd%, (i%+tc%) MOD 12) THEN cs$ = cs$ + HEX$((i% + tc%) MOD 12, 1) ' was 4digits before 26.03.2005 i% = (i% + 1) MOD 12 LOOP UNTIL ISFALSE i% ' sorting... il% = LEN(cs$) FOR i% = 1 TO il% FOR j% = (i% + 1) TO il% IF i% <> j% THEN a$ = MID$(cs$, i%, 1) b$ = MID$(cs$, j%, 1) IF a$ < b$ THEN MID$(cs$, i%, 1) = b$ MID$(cs$, j%, 1) = a$ END IF END IF NEXT j% NEXT i% IF nn% > 7 THEN DO cs$ = "0" + cs$ LOOP UNTIL LEN(cs$) = 8 Chordval& = VAL("&H0" + cs$ + "&") OR &H80000000 'cs$ = HEX$(Chordval&) ELSE Chordval& = VAL("&H0" + cs$ + "&") 'cs$ = HEX$(Chordval&) END IF FUNCTION = Chordval& END FUNCTION FUNCTION ComChords (BYVAL crd1%, BYVAL crd2%) EXPORT AS INTEGER LOCAL ton1%, ton2%, crd0% ton1% = GetTc(crd1%) ton2% = GetTc(crd2%) crd0% = (crd1% AND &H0FFF) AND (crd2% AND &H0FFF) IF ton1% > -1 THEN FUNCTION = SetTc(crd0%, ton1%) ELSE IF ton2% > -1 THEN FUNCTION = SetTc(crd0%, ton2%) ELSE FUNCTION = crd0% OR &H0F000 END IF END IF END FUNCTION FUNCTION Ctp2Cnr (BYVAL n&, BYVAL tc%) EXPORT AS INTEGER LOCAL Tmp$, l%, oldnm%, crd%, nm% ,cr% ' converts chordtype to chordnumber 'Tmp$ = HEX$(n&, 8) ' maximum 8 digits Tmp$ = LTrimZero (HEX$(n&,8)) 'modif. and function added 26.03.2005 l% = LEN(Tmp$) SELECT CASE l% CASE < 1 crd% = %False CASE < 8 crd% = %False oldnm% = -1 DO nm% = VAL("&H0" + (MID$(Tmp$, l%, 1))) IF (nm% > oldnm%) AND (nm% < 12) THEN 'was : crd% = crd% OR (2 ^ nm%) BIT SET crd%,nm% oldnm% = nm% END IF DECR l% LOOP UNTIL ISFALSE l% CASE ELSE crd% = &H0FFF oldnm% = -1 DO nm% = VAL("&H0" + (MID$(Tmp$, l%, 1))) IF (nm% > oldnm%) AND (nm% < 12) THEN crd% = crd% AND (NOT (2 ^ nm%)) oldnm% = nm% END IF DECR l% LOOP UNTIL l% = 1 END SELECT IF tc% > -1 THEN Cr% = TransChordNum(crd%, tc%) ELSE Cr% = TransChordNum(crd%, 0) END IF FUNCTION = SetTc(Cr%, tc%) END FUNCTION FUNCTION DelNoteInChord (BYVAL ChordNum%, BYVAL note AS BYTE) EXPORT AS INTEGER BIT RESET Chordnum%, note MOD 12 FUNCTION = Chordnum% END FUNCTION FUNCTION DifChords(BYVAL crd1%, BYVAL crd2%) EXPORT AS INTEGER LOCAL ton1%, ton2%, crd0% ton1% = GetTc(crd1%) ton2% = GetTc(crd2%) crd0% = (crd1% AND &H0FFF) XOR (crd2% AND &H0FFF) IF ton1% > -1 THEN FUNCTION = SetTc(crd0%, ton1%) ELSE IF ton2% > -1 THEN FUNCTION = SetTc(crd0%, ton2%) ELSE FUNCTION = crd0% OR &H0F000 END IF END IF END FUNCTION FUNCTION Get3Kadens (BYVAL cn1%, BYVAL cn2%, BYVAL cn3%, BYVAL cn4%) EXPORT AS SINGLE ' this function returns full-%NotFalse if the succession of chords in the ' argument, is a classical cadens. (Thirds-based harmony) ' The arguments must be chordnumbers, in temporal order. LOCAL Toonaard%, cnn1&,cnn2&,cnn3&,cnn4&, ok1!,ok2!,ok3!,ok4! Get3Kadens! = %False Toonaard% = GetTc(cn4%) cnn1& = Cnr2Ctp(cn1%, Toonaard%) cnn2& = Cnr2Ctp(cn2%, Toonaard%) cnn3& = Cnr2Ctp(cn3%, Toonaard%) cnn4& = Cnr2Ctp(cn4%, Toonaard%) ' het laatste akkoord moet in de grondtoonaard zijn: IF RIGHT$(HEX$(cnn4&,8), 1) > "0" THEN EXIT FUNCTION ' het voorlaatste akkoord moet een dominant zijn: ' fout: IF RIGHT$(HEX$(cnn3&), 1) <> "7" THEN EXIT FUNCTION ' laatste akkoord moet een tonika drieklank zijn: SELECT CASE RIGHT$(HEX$(cnn4&,8), 3) CASE "740", "730" ok4! = 1 CASE ELSE SELECT CASE RIGHT$(HEX$(cnn4&,8), 2) CASE "70" ok4! = .8 CASE "30", "40" ok4! = .7 CASE "B0" ok4! = .5 CASE "20" ok4! = .2 CASE "90" ok4! = .3 CASE "50" ok4! = .4 CASE "A0" ok4! = .7 CASE ELSE ok4! = %False END SELECT END SELECT ' voorlaatste akkoord moet dominant zijn: SELECT CASE RIGHT$(HEX$(cnn3&,8), 3) CASE "B72" ok3! = 1 CASE "B52" ' niet klassiek 7e graad-akkoord - gwr. ok3! = 1 CASE "A72" ' niet klassiek - mineur dominant ok3! = .9 CASE "B73", "B74" ' gwr ok3! = .6 CASE ELSE ok3! = %False END SELECT ' tweede akkoord heeft meer variatiemogelijkheden: SELECT CASE RIGHT$(HEX$(cnn2&,8), 3) CASE "950" ok2! = 1: ' IV-V-I CASE "952" ok2! = 1: ' II-V-I CASE "930" ok2! = 1: ' VIm-V-I CASE "940" ok2! = 1: ' VI-V-I CASE "852" ok2! = 1: ' IIb-V-I CASE "840" ok2! = 1: ' VIb-V-I CASE "830" ok2! = 1: ' VIb-V-I CASE "962" ok2! = .8 CASE "A62" ok2! = .7 CASE "B62" ok2! = .5 CASE ELSE ok2! = 0 END SELECT ' het eerste akkoord moet een tonika drieklank zijn: SELECT CASE RIGHT$(HEX$(cnn1&,8), 3) CASE "740", "730" ok1! = 1 CASE ELSE SELECT CASE RIGHT$(HEX$(cnn1&,8), 2) CASE "70" ok1! = .9 CASE "30", "40" ok1! = .8 CASE "B0" ok1! = .7 CASE "20" ok1! = .3 CASE "90" ok1! = .4 CASE "50" ok1! = .5 CASE "A0" ok1! = .6 CASE ELSE ok1! = %False END SELECT END SELECT FUNCTION = (ok1! + ok2! + ok3! + ok4!) / 4! END FUNCTION FUNCTION GetNrNotes (BYVAL k%) EXPORT AS INTEGER LOCAL n AS DWORD LOCAL i AS DWORD FOR i = 0 TO 11 IF BIT(k%,i) THEN INCR n NEXT i FUNCTION = n END FUNCTION FUNCTION GetRndNote (BYVAL m%, BYVAL tc%) EXPORT AS INTEGER LOCAL Sc%, n%, i% IF m% < 12 THEN Sc% = GetScaleCnr(m%, tc%) ELSE Sc% = m% DO i% = %False n% = RND(1) * 11 BIT SET i%, n% LOOP UNTIL Sc% AND i% FUNCTION = n% END FUNCTION FUNCTION GetScaleCnr (BYVAL modus%, BYVAL tc%) EXPORT AS INTEGER LOCAL ScaleCrd% SELECT CASE modus% CASE 0: ScaleCrd% = %md0 CASE 1: ScaleCrd% = %md1 CASE 2: ScaleCrd% = %md2 CASE 3: ScaleCrd% = %md3 CASE 4: ScaleCrd% = %md4 CASE 5: ScaleCrd% = %md5 CASE 6: ScaleCrd% = %md6 CASE 7: ScaleCrd% = %md7 CASE 8: ScaleCrd% = %md8 CASE 9: ScaleCrd% = %md9 CASE 10: ScaleCrd% = %md10 CASE 11: ScaleCrd% = %md11 END SELECT IF tc% > 0 THEN ScaleCrd% = TransChordNum(ScaleCrd%, tc%) FUNCTION = SetTc(ScaleCrd%, tc%) END FUNCTION FUNCTION GetTc (BYVAL k%) EXPORT AS INTEGER LOCAL tm AS INTEGER 'tm = HIBYT(k%) ' should become tm = HI(BYTE,k%) - problem with sign however! tm = k% AND &H0F000 'SHIFT RIGHT tm,4 ' is'nt this a bug? - shifts only 4 bit positiions! SHIFT RIGHT tm, 12 ' changed 25.03.2005 - may affect many pieces!!! IF tm > 11 THEN FUNCTION = -1 ELSE FUNCTION = tm END IF END FUNCTION FUNCTION IsNoteInChord (BYVAL nr%, BYVAL note%)EXPORT AS INTEGER FUNCTION = %False IF BIT(nr%,note% MOD 12) THEN FUNCTION = %NotFalse END FUNCTION FUNCTION Make3ChordNum (BYVAL n1%, BYVAL n2%, BYVAL n3%)EXPORT AS INTEGER LOCAL num% IF n1% > 0 THEN BIT SET num%,n1% MOD 12 IF n2% > 0 THEN BIT SET num%,n2% MOD 12 IF n3% > 0 THEN BIT SET num%,n3% MOD 12 FUNCTION = num% END FUNCTION FUNCTION Make4ChordNum (BYVAL n1%, BYVAL n2%, BYVAL n3%, BYVAL n4%)EXPORT AS INTEGER LOCAL num% IF n1% > 0 THEN BIT SET num%, n1% MOD 12 IF n2% > 0 THEN BIT SET num%, n2% MOD 12 IF n3% > 0 THEN BIT SET num%, n3% MOD 12 IF n4% > 0 THEN BIT SET num%, n4% MOD 12 FUNCTION = num% END FUNCTION FUNCTION MakeChordNum (BYVAL n1%, BYVAL n2%, BYVAL n3%, BYVAL n4%, BYVAL n5%, BYVAL n6%,_ BYVAL n7%, BYVAL n8%, BYVAL n9%, BYVAL n10%, BYVAL n11%, BYVAL n12%) EXPORT AS INTEGER LOCAL num% IF n1% > 0 THEN BIT SET num%,n1% MOD 12 IF n2% > 0 THEN BIT SET num%,n2% MOD 12 IF n3% > 0 THEN BIT SET num%,n3% MOD 12 IF n4% > 0 THEN BIT SET num%,n4% MOD 12 IF n5% > 0 THEN BIT SET num%,n5% MOD 12 IF n6% > 0 THEN BIT SET num%,n6% MOD 12 IF n7% > 0 THEN BIT SET num%,n7% MOD 12 IF n8% > 0 THEN BIT SET num%,n8% MOD 12 IF n9% > 0 THEN BIT SET num%,n9% MOD 12 IF n10% > 0 THEN BIT SET num%,n10% MOD 12 IF n11% > 0 THEN BIT SET num%,n11% MOD 12 IF n12% > 0 THEN BIT SET num%,n12% MOD 12 FUNCTION = num% END FUNCTION FUNCTION MakeHarmChord (BYVAL crd%, BYVAL mode%, BYVAL ht%) EXPORT AS INTEGER LOCAL nrnotes%, ton%, Utcrd%, graad%, locpt%, i%,j%, ScaleCrd%, ok%, NewCrd% LOCAL modus$, Grade$(),UtCrdn$, UtCrdTp&, a$,b$, tst$ LOCAL NewCtp& IF (ht% < 2) OR (ht% > 4) THEN ht% = 3 ' harmony-type (2nd, 3th, 4th) nrnotes% = GetNrNotes(crd%) IF nrnotes% > 6 THEN FUNCTION = crd%: EXIT FUNCTION ton% = GetTc(crd%) ' may return -1 !!! (26.03.2005) ' transpose crd% to C: IF ton% > 0 THEN ' new condition 26.03.2005 UtCrd% = TransChordNum((crd%), -ton%) END IF UtCrd% = SetTc(UtCrd%, 0) ' get the scale-string for the given mode IF mode% < 12 THEN ScaleCrd% = GetScaleCnr(mode%, 0) ELSE ScaleCrd% = mode% modus$ = LTrimZero (HEX$(Cnr2Ctp(ScaleCrd%, 0),8)) ' 8 digits - new added 26.03.2005 - trim function 26.03.2005 ' make sure all notes in Crd% belong to the scale: IF (UtCrd% AND ScaleCrd%) <> UtCrd% THEN FUNCTION = crd%: EXIT FUNCTION ' build chord: DIM Grade$(1 TO LEN(modus$)) FOR graad% = 1 TO LEN(modus$) locpt% = LEN(modus$) + 1 - graad% DO Grade$(graad%) = MID$(modus$, locpt%, 1) + Grade$(graad%) locpt% = locpt% - (ht% - 1) IF locpt% < 1 THEN locpt% = LEN(modus$) - locpt% LOOP UNTIL LEN(Grade$(graad%)) = nrnotes% + 1 FOR i% = 1 TO nrnotes% + 1 FOR j% = i% + 1 TO nrnotes% + 1 a$ = MID$(Grade$(graad%), i%, 1) b$ = MID$(Grade$(graad%), j%, 1) IF a$ < b$ THEN MID$(Grade$(graad%), i%, 1) = b$ MID$(Grade$(graad%), j%, 1) = a$ END IF NEXT j% NEXT i% NEXT graad% UtCrdTp& = Cnr2Ctp(UtCrd%, 0) UtCrdn$ = LTrimZero (HEX$(UtCrdTp&, 8)) ' 8 digits added 26.03.2005 ' nu moet dit akkoord waarin alle noten van het input-akkoord ook voorkomen ' het goede antwoord zijn. Dit akkoord bevat de toegevoegde noot. FOR i% = 1 TO UBOUND(Grade$) ok% = 0 FOR j% = 1 TO nrnotes% tst$ = MID$(UtCrdn$, j%, 1) IF INSTR(Grade$(i%), tst$) > 0 THEN ok% = ok% + 1 NEXT j% IF ok% = nrnotes% THEN EXIT FOR NEXT i% IF ok% = nrnotes% THEN NewCtp& = VAL("&H0" + Grade$(i%) + "&") NewCrd% = Ctp2Cnr(NewCtp&, 0) NewCrd% = TransChordNum(NewCrd%, ton%) FUNCTION = SetTc(NewCrd%, ton%) ELSE FUNCTION = crd% END IF END FUNCTION FUNCTION MirCnr (BYVAL Crn%, BYVAL n%) EXPORT AS INTEGER LOCAL m%, Cret%, i% IF n% < %False THEN m% = GetTc(Crn%) IF m% = %NotFalse THEN m% = %False ELSE m% = n% AND &H7F END IF m% = m% + m% + 12 FOR i% = 0 TO 11 'IF (Crn% AND (2 ^ i%)) THEN IF BIT (Crn%,i%) THEN 'nr% = (m% - i%) MOD 12 'Cret% = Cret% OR (2 ^ nr%) BIT SET Cret%,(m% -i%) MOD 12 END IF NEXT i% FUNCTION = Cret% OR (Crn% AND &H0F000) END FUNCTION FUNCTION Neg (BYVAL k%) EXPORT AS INTEGER LOCAL HiNib%, LowNibs% HiNib% = k% AND &H0F000 LowNibs% = k% AND &H0FFF LowNibs% = NOT LowNibs% LowNibs% = LowNibs% AND &H0FFF FUNCTION = HiNib% OR LowNibs% END FUNCTION FUNCTION NxNt (BYVAL m%, BYVAL tc%, BYVAL n%, BYVAL sg%) EXPORT AS INTEGER LOCAL Sc%, nn% IF m% < 12 THEN Sc% = GetScaleCnr(m%, tc%) ELSE Sc% = m% nn% = n% + SGN(sg%) IF (nn% = n%) OR (nn% < 0) OR (nn% > 127) THEN FUNCTION = n%: EXIT FUNCTION DO IF IsNoteInChord(Sc%, nn%) THEN EXIT DO nn% = nn% + SGN(sg%) LOOP UNTIL (nn% < %False) OR (nn% > 127) IF (nn% < %False) OR (nn% > 127) THEN FUNCTION = n% ELSE FUNCTION = nn% END IF END FUNCTION FUNCTION ParaChord (BYVAL tonic%, BYVAL d!, BYVAL c!, BYVAL tolerance!) EXPORT AS INTEGER LOCAL crd%, n%, lcnt%, startval%, test% LOCAL Dis!, Kon! ' was Con! but this is refused in PB IF tolerance! < 0 THEN tolerance! = 0 IF tolerance! > 1 THEN tolerance! = 1 IF d! < 0 THEN d! = 0 IF c! < 0 THEN c! = 0 IF d! > 1 THEN d! = 1 IF c! > 1 THEN c! = 1 DO IF d! = 1 THEN FUNCTION = SetTc(&H0FFF, tonic%): EXIT FUNCTION FOR n% = 3 TO 11 ' nrnotes counter startval% = (RND(1) * 4095) ' begin met een willekeurig ' akkoord. lcnt% = startval% DO IF GetNrNotes(lcnt%) = n% THEN crd% = SetTc(lcnt%, tonic%) Dis! = GetDissonance(crd%) Kon! = GetConsonance(crd%) IF ABS(Dis! - d!) <= tolerance! THEN test% = 1 ELSE test% = 0 IF ABS(Kon! - c!) <= tolerance! THEN test% = test% + 1 IF test% = 2 THEN FUNCTION = crd%: EXIT FUNCTION END IF lcnt% = (lcnt% + 1) AND &H0FFF IF lcnt% = startval% THEN EXIT DO LOOP NEXT n% tolerance! = tolerance! + .1 LOOP UNTIL tolerance! >= 1 FUNCTION = %False END FUNCTION FUNCTION ParConChord (BYVAL tonic%, BYVAL c!, BYVAL tolerance!) EXPORT AS INTEGER LOCAL n%, startval%, lcnt%, crd% LOCAL Kon! IF tolerance! > 1 THEN tolerance! = 1 IF tolerance! < 0 THEN tolerance! = 0 IF c! > 1 THEN c! = 1 IF c! < 0 THEN c! = 0 DO FOR n% = 3 TO 12 ' nrnotes counter startval% = (RND(1) * 4095) ' begin met een willekeurig akkoord. lcnt% = startval% DO IF GetNrNotes(lcnt%) = n% THEN crd% = SetTc(lcnt%, tonic%) Kon! = GetConsonance(crd%) IF ABS(Kon! - c!) <= tolerance! THEN FUNCTION = crd% EXIT FUNCTION END IF END IF lcnt% = (lcnt% + 1) AND &H0FFF IF lcnt% = startval% THEN EXIT DO LOOP NEXT n% tolerance! = tolerance! + .05 IF tolerance! > 1 THEN tolerance! = 1 LOOP UNTIL tolerance! >= 1 FUNCTION = %False END FUNCTION FUNCTION ParDisChord (BYVAL tonic%, BYVAL d!, BYVAL tolerance!) EXPORT AS INTEGER LOCAL crd%, n%, lcnt%, startval%, Dis! IF d! > 1 THEN d! = 1 IF d! < 0 THEN d! = 0 IF tolerance! > 1 THEN tolerance! = 1 IF tolerance! < 0 THEN tolerance! = 0 DO IF d! = 1 THEN FUNCTION = SetTc(&H0FFF, tonic%) EXIT FUNCTION END IF FOR n% = 3 TO 11 ' nrnotes counter startval% = (RND(1) * 4095) ' begin met een willekeurig akkoord. lcnt% = startval% DO IF GetNrNotes(lcnt%) = n% THEN crd% = SetTc(lcnt%, tonic%) Dis! = GetDissonance(crd%) IF ABS(Dis! - d!) <= tolerance! THEN FUNCTION = crd% EXIT FUNCTION END IF END IF lcnt% = (lcnt% + 1) AND &H0FFF IF lcnt% = startval% THEN EXIT DO LOOP NEXT n% tolerance! = tolerance! + .05 IF tolerance! > 1 THEN tolerance! = 1 LOOP UNTIL tolerance! >= 1 FUNCTION = %False END FUNCTION FUNCTION Rol (BYVAL k%, BYVAL n%) EXPORT AS INTEGER ' 29.12.1998 LOCAL cnt AS BYTE LOCAL retval AS WORD retval = k% AND &H0FFF DO ROTATE LEFT retval, 1 IF BIT(retval,12) THEN BIT SET retval, 0: BIT RESET retval,12 END IF INCR cnt LOOP UNTIL cnt = n% FUNCTION = (k% AND &H0F000) OR retval END FUNCTION FUNCTION Ror (BYVAL k%, BYVAL n%) EXPORT AS INTEGER LOCAL cnt AS BYTE LOCAL ln AS WORD ln = k% AND &H0FFF ' isolate the chord from tc DO ROTATE RIGHT ln, 1 IF BIT(ln,15) THEN BIT SET ln,11: BIT RESET ln,15 INCR cnt LOOP UNTIL cnt = n% FUNCTION = ln OR (k% AND &H0F000) ' was buggy before version 4.05, 29.11.1999 END FUNCTION FUNCTION SetTc (BYVAL Crn%, BYVAL k%) EXPORT AS INTEGER LOCAL ton AS WORD IF k% > -1 THEN ton = k% MOD 12 ELSE ton = &H0F END IF SHIFT LEFT ton, 12 FUNCTION = (Crn% AND &H0FFF) OR ton END FUNCTION FUNCTION SameChord (BYVAL Cnr1 AS INTEGER, BYVAL Cnr2 AS INTEGER) EXPORT AS WORD LOCAL i AS DWORD i = %False DO IF (Cnr1 AND &H0FFF) = (Cnr2 AND &H0FFF) THEN FUNCTION = %true EXIT FUNCTION END IF Cnr2 = Ror(Cnr2, 1) INCR i LOOP UNTIL i = 12 FUNCTION = %False END FUNCTION FUNCTION TransChordNum (BYVAL crd%, BYVAL n%) EXPORT AS INTEGER LOCAL bl AS BYTE, ln AS INTEGER, hn AS WORD, cnt AS BYTE IF n% = %Null THEN FUNCTION = crd% : EXIT FUNCTION bl = ABS(n% MOD 12) ' nr of steps to shift/transpoze ln = crd% AND &H0FFF hn = crd% AND &H0F000 ' save the high nibble IF n% > 0 THEN cnt = %False DO ROTATE LEFT ln, 1 IF BIT(ln,12) THEN BIT SET ln, 0: BIT RESET ln,12 INCR cnt LOOP UNTIL cnt = bl ELSE cnt = %False DO ROTATE RIGHT ln, 1 IF BIT(ln,15) THEN BIT SET ln,11: BIT RESET ln,15 INCR cnt LOOP UNTIL cnt = bl END IF FUNCTION = hn OR ln END FUNCTION FUNCTION TransChordType (BYVAL Crt&, BYVAL n%) EXPORT AS LONG ' since PB8.1 version this may have many bugs caused by the new implementation of the HEX$ command. ' solved 26.03.2005 with addition of Ltrimzero function in g_indep.dll LOCAL OldCrt& ,vl& LOCAL NegFlag% , ile%, nl%, ic%, nv%, jc% LOCAL il$ , nl$() IF Crt& = &HFFFFFFFF THEN FUNCTION = -1: EXIT FUNCTION IF Crt& < 0 THEN ' in dit geval hebben we te maken met een 'negatief' akkoord bestaande ' uit ontbrekende noten in een kluster! ' In dit geval transponeren we de 'gaten'. OldCrt& = Crt& Crt& = Crt& + &H7FFFFFFF NegFlag% = -1 ELSE NegFlag% = %False END IF il$ = LtrimZero(HEX$(Crt&,8)) ' may now contain a bug, we have to trim leading zero's [26.03.2005] ' hance, we added the LtrimZero function ile% = LEN(il$) nl% = n% MOD 12 IF nl% < 0 THEN nl% = nl% + 12 DIM nl$(8) FOR ic% = 1 TO ile% nl$(ic% - 1) = MID$(il$, ic%, 1) nv% = VAL("&H0" + nl$(ic% - 1)) nv% = (nv% + nl%) MOD 12 nl$(ic% - 1) = HEX$(nv%, 1) ' was , 4 - must be wrong) ' check this carefullly 26.03.2005 NEXT ic% IF ile% > 1 THEN ' now sort the digits from low to high: FOR ic% = 0 TO ile% - 2 FOR jc% = ic% + 1 TO ile% - 1 IF VAL("&H0" + nl$(ic%)) > VAL("&H0" + nl$(jc%)) THEN SWAP nl$(ic%), nl$(jc%) NEXT jc% NEXT ic% END IF IF NegFlag% THEN vl& = VAL("&H" + nl$(7) + nl$(6) + nl$(5) + nl$(4) + nl$(3) + nl$(2) + nl$(1) + nl$(0) + "&") Crt& = OldCrt& FUNCTION = vl& OR &H80000000 ELSE FUNCTION = VAL("&H" + nl$(7) + nl$(6) + nl$(5) + nl$(4) + nl$(3) + nl$(2) + nl$(1) + nl$(0) + "&") END IF END FUNCTION FUNCTION VarChord (BYVAL crd%, BYVAL modus%) EXPORT AS INTEGER STATIC retval%, prevcrd% LOCAL ton%, l%, tst%, a% , newchord%, r%, crit1%, crit2% LOCAL discrit!, Dis!, Dis2! ton% = GetTc(crd%) l% = GetNrNotes(crd%) SELECT CASE l% CASE 0 FUNCTION = %False retval% = %False EXIT FUNCTION CASE 1 TO 3 tst% = %False: discrit! = 0 IF crd% = prevcrd% THEN a% = retval% ELSE a% = 0 Dis! = GetDissonance(crd%) DO ' search note NOT in chord DO r% = GetRndNote(modus%, ton%) LOOP WHILE BIT(crd%,r%) '(crd% AND (2 ^ r%)) ' was ISTRUE ' add this note newchord% = crd% OR (2 ^ r%) ' get a note DO r% = GetRndNote(11, -1) LOOP UNTIL BIT(crd%,r%) 'crd% AND (2 ^ r%) ' remove it newchord% = newchord% AND NOT (2 ^ r%) dis2! = GetDissonance(newchord%) ' check conditions: IF newchord% <> a% THEN crit1% = %NotFalse ELSE crit1% = %False crit2% = %False IF Dis! > 0 THEN IF dis2! < Dis! + discrit! THEN crit2% = %NotFalse ELSE IF dis2! < discrit! THEN crit2% = %NotFalse END IF tst% = crit1% AND crit2% discrit! = discrit! + .0001 LOOP UNTIL tst% retval% = newchord% prevcrd% = crd% FUNCTION = newchord% CASE 4 TO 5 discrit! = 0 tst% = %False IF crd% = prevcrd% THEN a% = retval% ELSE a% = %False Dis! = GetDissonance(crd%) DO DO r% = GetRndNote(modus%, ton%) LOOP WHILE BIT(crd%,r%) '(crd% AND (2 ^ r%)) ' was istrue... bug newchord% = crd% OR (2 ^ r%) DO r% = GetRndNote(11, -1) LOOP UNTIL BIT(crd%,r%) 'crd% AND (2 ^ r%) newchord% = newchord% AND NOT (2 ^ r%) dis2! = GetDissonance(newchord%) crit1% = %False IF Dis! > 0 THEN IF dis2! < Dis! + discrit! THEN crit1% = %NotFalse ELSE IF dis2! <= discrit! THEN crit1% = %NotFalse END IF IF newchord% <> a% THEN crit2% = %NotFalse ELSE crit2% = %False tst% = crit1% AND crit2% discrit! = discrit! + .001 LOOP UNTIL tst% retval% = newchord% prevcrd% = crd% FUNCTION = newchord% CASE 6 discrit! = 0 tst% = %False IF crd% = prevcrd% THEN a% = retval% ELSE a% = %False Dis! = GetDissonance(crd%) DO DO r% = GetRndNote(modus%, -1) LOOP WHILE BIT(crd%,r%) '(crd% AND (2 ^ r%) ) ' was istrue bug newchord% = crd% OR (2 ^ r%) DO r% = GetRndNote(11, -1) LOOP UNTIL BIT(crd%,r%) 'crd% AND (2 ^ r%) newchord% = newchord% AND NOT (2 ^ r%) dis2! = GetDissonance(newchord%) crit1% = %False IF Dis! > 0 THEN IF dis2! < Dis! + discrit! THEN crit1% = %NotFalse ELSE IF dis2! <= discrit! THEN crit1% = %NotFalse END IF IF newchord% <> a% THEN crit2% = %NotFalse ELSE crit2% = %False tst% = crit1% AND crit2% discrit! = discrit! + .001 LOOP UNTIL tst% retval% = newchord% prevcrd% = crd% FUNCTION = newchord% CASE 7 TO 12 ' return a chord with less notes, less dissonant. Dis! = GetDissonance(crd%) DO DO r% = GetRndNote(11, -1) LOOP UNTIL BIT(crd%,r%) 'crd% AND (2 ^ r%) newchord% = crd% AND NOT (2 ^ r%) dis2! = GetDissonance(newchord%) LOOP UNTIL dis2! < Dis! FUNCTION = newchord% END SELECT END FUNCTION FUNCTION SolveCnr (BYVAL Cnr AS INTEGER, BYVAL tc AS INTEGER) EXPORT AS INTEGER ' voorlopige kode. 07.12.99 - dit is een grote omweg! ' beetje verbeterd 24.10.2004, nog niet af. LOCAL H AS HarmType LOCAL n AS WORD LOCAL ctp AS LONG LOCAL i AS DWORD n = GetNrNotes(Cnr) IF tc > -1 THEN tc = tc MOD 12 ELSE tc = -1 END IF SELECT CASE n CASE < 1 ' geenklank FUNCTION = Cnr EXIT FUNCTION CASE 1 ' eenklank IF tc > -1 THEN IF BIT(cnr,(tc+11)MOD 12) THEN BIT RESET Cnr,(tc+11) MOD 12 : BIT SET Cnr,tc MOD 12 IF BIT(cnr,(tc+6)MOD 12) THEN BIT RESET Cnr,(tc+6) MOD 12 : BIT SET Cnr,(tc+7) MOD 12 IF BIT(cnr,(tc+1)MOD 12) THEN BIT RESET Cnr,(tc+1) MOD 12 : BIT SET Cnr,tc MOD 12 IF BIT(cnr,(tc+8)MOD 12) THEN BIT RESET Cnr,(tc+8) MOD 12 : BIT SET Cnr,(tc+7) MOD 12 IF BIT(cnr,(tc+10)MOD 12) THEN BIT RESET Cnr,(tc+10) MOD 12 : BIT SET Cnr,(tc+9) MOD 12 END IF FUNCTION = Cnr EXIT FUNCTION CASE 2 ' tweeklanken IF tc > -1 THEN ' omzetten naar chordnummer en transponeren naar C ' oplossen, TC terugplaatsen en retourneren. FOR i = 0 TO 11 ' kleine secunden/ gr. septiemen worden vergroot tot kleine terts: IF BIT(Cnr,i) AND BIT(Cnr, (i+1) MOD 12) THEN SELECT CASE tc 'case (i + 11) MOD 12 ' leidtoon CASE i , (i + 7) MOD 12 ' we laten i liggen BIT RESET Cnr, (i+1) MOD 12 BIT SET Cnr, (i+3) MOD 12 FUNCTION = cnr EXIT FUNCTION CASE (i+1) MOD 12 ' we laten i+ 1 liggen - de leidtoon lossen we op BIT RESET Cnr, (i) MOD 12 BIT SET Cnr, (i + 9) MOD 12 FUNCTION = cnr EXIT FUNCTION CASE ELSE BIT RESET Cnr, (i+1) MOD 12 BIT RESET Cnr, i BIT SET Cnr, (i+2) MOD 12 BIT SET Cnr, (i+11) MOD 12 ' IF i > 0 THEN ' BIT SET Cnr,i-1 ' = i+ 11 mod 12 ' ELSE ' BIT SET Cnr,11 ' END IF FUNCTION = cnr EXIT FUNCTION END SELECT END IF IF BIT(cnr,i) AND BIT(cnr,(i+4) MOD 12) THEN SELECT CASE tc CASE (i + 5) MOD 12 BIT RESET cnr,(i+4) MOD 12 BIT SET cnr,(i+5) MOD 12 BIT SET cnr,(i+2) MOD 12 BIT RESET cnr,i FUNCTION = cnr EXIT FUNCTION CASE ELSE ' niks voorlopig END SELECT END IF NEXT i ELSE ' vrije tonaliteit FOR i = 0 TO 11 ' kleinde secunden/ gr. septiemen worden vergroot tot kleine terts: IF BIT(Cnr,i) AND BIT(Cnr, (i+1) MOD 12) THEN BIT RESET Cnr, (i+1) MOD 12 BIT RESET Cnr, i BIT SET Cnr, (i+2) MOD 12 IF i > 0 THEN BIT SET Cnr,i-1 ELSE BIT SET Cnr,11 END IF FUNCTION = cnr EXIT FUNCTION END IF ' grote sekunden/kl. sept worden vergroot tot grote terts IF BIT(cnr,i) AND BIT(Cnr, (i+2) MOD 12) THEN BIT RESET Cnr, (i+2) MOD 12 BIT SET Cnr, (i+4) MOD 12 FUNCTION = cnr EXIT FUNCTION END IF ' tritonussen worden verkleind tot grote terts IF BIT (cnr,i) AND BIT(cnr, (i+6) MOD 12) THEN BIT RESET Cnr,i BIT RESET Cnr,(i+6) MOD 12 BIT SET Cnr, (i+1) MOD 12 BIT SET Cnr, (i+5) MOD 12 FUNCTION = cnr EXIT FUNCTION END IF ' alle andere gevallen moeten niet opgelost worden. NEXT i FUNCTION = cnr EXIT FUNCTION END IF CASE 3 ' drieklanken. IF tc > -1 THEN ctp = cnr2ctp(cnr,tc) SELECT CASE ctp ' gevallen zonder laddervreemde noten: CASE &H0730, &H0740, &H0940, &H0930 '(I , VI) FUNCTION = cnr EXIT FUNCTION CASE &H0950, &H0850 ' kwart sixt gaat naar dominant ( IV) cnr = 0 BIT SET cnr,(tc+7) MOD 12: BIT SET cnr, (tc + 11) MOD 12: BIT SET cnr, (tc+ 2) MOD 12 SetTc cnr, tc EXIT FUNCTION CASE &H0B72 , &HB52 ' dominant , trit. (V, VII) cnr = 0 BIT SET cnr,tc MOD 12: BIT SET cnr, (tc + 4) MOD 12: BIT SET cnr, (tc+ 7) MOD 12 SetTc cnr, tc EXIT FUNCTION CASE &H0B74 ' III maj. => I cnr = 0 BIT SET cnr, tc MOD 12 : BIT SET cnr, ( tc+4) MOD 12 : BIT SET cnr,(tc+7) MOD 12 SetTc cnr, tc EXIT FUNCTION CASE &H0B73 ' III min => I cnr = 0 BIT SET cnr, tc MOD 12: BIT SET cnr, (tc+3) MOD 12 : BIT SET cnr,(tc+7) MOD 12 SetTc cnr, tc EXIT FUNCTION CASE &H0952, &H0852 ' II - > V cnr = 0 BIT SET cnr,(tc+7) MOD 12: BIT SET cnr, (tc + 11) MOD 12: BIT SET cnr, (tc+ 2) MOD 12 SetTc cnr, tc EXIT FUNCTION 'gevallen met laddervreemde noten: (modulerend) CASE &H0852 ' naar mineur cnr = 0 Tc = (Tc + 9) MOD 12 BIT SET cnr, tc MOD 12 : BIT SET cnr, (tc + 3) MOD 12: BIT SET cnr,(tc+7) MOD 12 setTc cnr, tc EXIT FUNCTION CASE &H0960, &H0962 ' naar dominant cnr = 0 Tc = (Tc + 7) MOD 12 BIT SET cnr, tc MOD 12: BIT SET cnr, (tc+4) MOD 12: BIT SET cnr,(tc+7) MOD 12 SetTc cnr, tc EXIT FUNCTION END SELECT END IF END SELECT AddCnr2Har H,cnr,60,71,127 IF tc > -1 THEN tc = tc MOD 12 ELSE tc = -1 END IF H.vel = SolveHar$(H,tc,0) IF tc = -1 THEN tc = &H0F000 ELSE SHIFT LEFT tc, 12 END IF FUNCTION = ((Har2Cnr(H,0)) OR tc) END FUNCTION ' --------------------------end of module Harm_gen.bas -----------------------