' ************************************************************************** ' * Studies in Harmony * ' * Godfried-Willem RAES * ' ************************************************************************** ' code for Fuzzy-harmony study nr.7 ' ********************************* ' start with QBX FUZSTUD8 /Ah/L MAIN_LIB REM $DYNAMIC '$INCLUDE: 'KONSTANT.BI' :' shared constants '$INCLUDE: 'COM_TYPE.BI' :' declaration of common typed variables. ' Type HarmType needed for harm_psy ' procedure declaration for library: '$INCLUDE: 'HARMONY.BI' '$INCLUDE: 'HARM_ANA.BI' '$INCLUDE: 'HARM_FUZ.BI' '$INCLUDE: 'HARM_PSY.BI' COMMON SHARED p%() COMMON SHARED Stem() AS St DECLARE SUB MpuUart () DECLARE SUB ResetMpu () DECLARE SUB Uit (byte%) DECLARE SUB WrFil (Q$) DECLARE SUB MKTestFile () DECLARE SUB MKTestFile2 () REDIM SHARED p%(0 TO 4000, 0 TO 8): ' voorlopige dim. REDIM SHARED Stem(0 TO 4) AS St STACK (16000) SCREEN 12 WIDTH 80, 60 MpuUart ' force initialisation of values from fuzzy data file HAR_FUZ.DAT: d! = Dishar!(60, 61) d! = Dismel!(60, 61) LOCATE 10, 10: PRINT "WAIT... calculating raw score for Fuzzy Study Nr.7"; ' suppose we have a P(i,j) MKTestFile2 DIM Stem1(0) AS INTEGER DIM Stem2(0) AS INTEGER DIM Stem3(0) AS INTEGER DIM crd%(0 TO 1) Ltes2 = 55: Htes2 = 73 Ltes3 = 44: Htes3 = 59 RANDOMIZE TIMER norm! = .9 cnt% = -1: ' notecounter FOR i& = 0 TO UBOUND(p%, 1) IF p%(i&, 1) > 0 THEN IF p%(i&, 2) > 0 THEN cnt% = cnt% + 1 LOCATE 50, 10: PRINT "Noot="; p%(i&, 1); " "; REDIM PRESERVE Stem1(0 TO cnt%) AS INTEGER REDIM PRESERVE Stem2(0 TO cnt%) AS INTEGER REDIM PRESERVE Stem3(0 TO cnt%) AS INTEGER Stem1(cnt%) = p%(i&, 1) IF cnt% > 0 THEN fm1! = MelFrameQual!(Stem1(), 3) ELSE fm1! = 1 END IF 'LOCATE 54, 1: PRINT "Cnt="; cnt%; "Sop="; P%(i&, 1); fm1!; " "; hcrit! = norm! lphcnt% = 0 DO lphcnt% = lphcnt% + 1 IF lphcnt% > 20 THEN hcrit! = hcrit! - .05: lphcnt% = 0 IF hcrit! < 0 THEN hcrit! = 0: ' no sollution found... lpcnt% = 0 crit! = .1 DO lpcnt% = lpcnt% + 1 IF lpcnt% > 100 THEN crit! = crit! + .05: lpcnt% = 0 IF crit! > 1 THEN crit! = 1: ' no solution found n1% = Stem1(cnt%) MOD 12 DO n% = Ltes2 + (RND(1) * (Htes2 - Ltes2)) n2% = n% MOD 12 LOOP UNTIL n1% <> n2% Stem2(cnt%) = n% IF cnt% > 0 THEN fm2! = MelFrameQual!(Stem2(), 3) ELSE fm2! = 1 END IF LOOP UNTIL (ABS(fm2! - fm1!) < crit!) OR (fm2! >= fm1!) lpcnt% = 0 crit! = .1 DO lpcnt% = lpcnt% + 1 IF lpcnt% > 100 THEN crit! = crit! + .05: lpcnt% = 0 IF crit! > 1 THEN crit! = 1: ' no solution n2% = Stem2(cnt%) MOD 12 DO n% = Ltes3 + (RND(1) * (Htes3 - Ltes3)) n3% = n% MOD 12 LOOP UNTIL (n2% <> n3%) AND (n1% <> n3%) Stem3(cnt%) = n% IF cnt% > 0 THEN fm3! = MelFrameQual!(Stem3(), 3) ELSE fm3! = 1 END IF LOOP UNTIL (ABS(fm3! - fm1!) < crit!) OR (fm3! >= fm1!) REDIM PRESERVE crd%(0 TO cnt%) Chord% = Make3ChordNum%(Stem1(cnt%), Stem2(cnt%), Stem3(cnt%)) crd%(cnt%) = Chord% IF cnt% > 0 THEN fh! = HarmFrameQual!(crd%(), 3) ELSE fh! = Cons%(Chord%) END IF LOCATE 55, 10: PRINT "HarmFrameQual="; fh!; " "; HEX$(Chord%); " "; LOOP UNTIL fh! >= hcrit!: 'norm! ' if the new note is different, write it in the score... IF oldj% <> Stem2(cnt%) THEN p%(i&, 3) = Stem2(cnt%) oldj% = p%(i&, 3) p%(i&, 4) = p%(i&, 2) END IF IF oldk% <> Stem3(cnt%) THEN p%(i&, 5) = Stem3(cnt%) oldk% = p%(i&, 5) p%(i&, 6) = p%(i&, 2) END IF LOCATE 56, 1: PRINT "sop="; Stem1(cnt%); LOCATE 57, 1: PRINT "alt="; Stem2(cnt%); LOCATE 58, 1: PRINT "bas="; Stem3(cnt%); ELSE ' note off p%(i&, 3) = oldj%: oldj% = 0 p%(i&, 5) = oldk%: oldk% = 0 END IF END IF LOCATE 40, 10: PRINT i&; NEXT i& p%(UBOUND(p%, 1), 3) = oldj% p%(UBOUND(p%, 1), 4) = 0 p%(UBOUND(p%, 1), 5) = oldk% p%(UBOUND(p%, 1), 6) = 0 WrFil "FuzHar7.bin" END REM $STATIC SUB MKTestFile ' makes a P(i,j) testfile in memory i& = 0 FOR n1% = 60 TO 72 FOR n2% = 60 TO 72 IF n1% <> n2% THEN p%(i&, 1) = n1% p%(i&, 2) = 64 i& = i& + 2 p%(i&, 1) = n2% p%(i&, 2) = 64 i& = i& + 2 END IF NEXT n2% NEXT n1% END SUB SUB MKTestFile2 ' makes a P(i,j) testfile in memory REDIM p%(0 TO 500, 0 TO 15) i& = 0 FOR n1% = 60 TO 72 FOR n2% = 60 TO n1% IF n1% <> n2% THEN p%(i&, 1) = n1% p%(i&, 2) = 64 i& = i& + 2 p%(i&, 1) = n2% p%(i&, 2) = 64 i& = i& + 2 END IF NEXT n2% NEXT n1% END SUB REM $DYNAMIC SUB MpuUart UART% = &H3F Cp% = Madr% + 1 InitUART: IF INP(Cp%) AND 128 THEN WAIT Cp%, 64, 64 OUT Cp%, UART% ELSE DO dummy% = INP(Madr%) LOOP UNTIL INP(Cp%) AND 128 GOTO InitUART END IF END SUB SUB ResetMpu ResMpu% = &HFF: ' = 1111 1111 (255)= Reset-command Cp% = Madr% + 1 DO dummy% = INP(Madr%) LOOP UNTIL INP(Cp%) AND 128 WAIT Cp%, 64, 64 OUT Cp%, ResMpu% END SUB REM $STATIC SUB TestMeloQual ' test for the MeloQual function FrameSize% = 7: ' size of history buffer for melodies DIM MelBuf0%(0 TO FrameSize%) DIM MelBuf1%(0 TO FrameSize%) DIM MelBuf2%(0 TO FrameSize%) MelBuf0%(0) = 50: MelBuf0%(1) = 57: MelBuf0%(2) = 62: MelBuf0%(3) = 61 MelBuf0%(4) = 59: MelBuf0%(5) = 64: MelBuf0%(6) = 65: MelBuf0%(7) = 60 LOCATE 31, 10 PRINT "Melodic quality="; MeloQual!(MelBuf0%()): ' ok. LOCATE 32, 10 PRINT "Weighted= "; LOCATE 32, 25: PRINT MelQualWeight!(MelBuf0%()) LOCATE 34, 10 PRINT "Framed="; LOCATE 34, 25: PRINT MelFrameQual!(MelBuf0%(), 7) END SUB REM $DYNAMIC SUB Uit (byte%) Cp% = Madr% + 1 IF INP(Cp%) AND 128 THEN WAIT Cp%, 64, 64: OUT Madr%, byte% ELSE WHILE INP(Cp%) < 128: dummy% = INP(Madr%): WEND WAIT Cp%, 64, 64: OUT Madr%, byte% END IF END SUB SUB WrFil (Q$) SHARED p%() NUL% = 0: k& = 1 OPEN Q$ FOR BINARY AS #1 FOR i& = 0 TO UBOUND(p%, 1) FOR j% = 0 TO 15 IF j% <= UBOUND(p%, 2) THEN PUT #1, k&, p%(i&, j%) k& = k& + 1 ELSE PUT #1, k&, NUL% k& = k& + 1 END IF NEXT j% NEXT i& CLOSE #1 END SUB