03-18-2025, 01:26 AM
(03-17-2025, 07:18 PM)madscijr Wrote:I play flute by ear, having a decent ear to pick up a melody, but find guitar more challenging. Flute is somewhat linear while guitar fret boards pose an extra dimension to try to wrap my head around.(03-15-2025, 01:58 PM)OldMoses Wrote: I've been learning it for 30+ years and still haven't figured it out.Thanks for sharing. I play guitar by ear and don't know music theory at all. A program like this could be helpful with learning the different concepts, if it lets you visualize a concept and hear it at the same time.
Here's a little visual aid I came up with to help with scales, modes, chords, etc.
One of the primary reasons I wrote this was to help me quickly translate chord voicings for different capo positions.
I found a more updated version of this. A tad better polished code which now incorporates @grymmjack's embed fix. It adds a visual cue in the circle of fifths of scale roots in green, which indicates which scales can be either sharp or flat without breaking the note pattern. I wasn't going to try programming absurd things like double sharps/flats.
Code: (Select All)
OPTION _EXPLICIT
'Fretboard IV
'Coding in QB64 Phoenix edition ver. 3.13.1
'by Richard Wessel
$EMBED:'./sharp2.png','emsharp'
$EMBED:'./flat.png','emflat'
$EMBED:'./clef pair.png','emclefp'
$COLOR:32
_TITLE "Fret Board 4.4.1 <esc> or <Q> to Quit"
TYPE V2 ' < X, Y > pair
x AS INTEGER
y AS INTEGER
END TYPE
TYPE region ' rectangular region defined by two diagonal < X, Y > pairs
ul AS V2 ' upper left point
lr AS V2 ' lower right point
END TYPE
TYPE button
hn AS LONG ' button image handle
l AS STRING * 20 ' label
r AS region ' position
c AS _UNSIGNED LONG ' color
h AS INTEGER ' hotkey position
END TYPE
TYPE tone
nt AS STRING * 1 ' natural name
bs AS STRING * 2 ' sharp name
bf AS STRING * 2 ' flat name
ac AS _BYTE ' natural(0) / accidental(-1)
oc AS _BYTE ' octave assignment
sd AS _BYTE ' scale degree
ft AS STRING * 2 ' fret name
c AS _UNSIGNED LONG ' color
hz AS SINGLE ' base cycles
indx AS INTEGER ' array index
END TYPE
'PROGRAM STATE VARIABLES
DIM SHARED AS V2 mous
DIM SHARED AS button bt(59)
DIM SHARED AS tone note(56), tonic
DIM SHARED AS INTEGER frets(5, 25) ' frets( string, fret) value = note(index)
DIM SHARED AS _BYTE masterscale(11), scale(11)
DIM SHARED AS _UNSIGNED LONG defcol, sclcol
DIM SHARED AS LONG togs ' TOGGLES
' 0= Ionian/Major scale
' 1= Dorian scale
' 2= Phrygian scale
' 3= Lydian scale
' 4= Mixolydian scale
' 5= Aeolian/Minor scale
' 6= Locrian scale
' 7= Chord I
' 8= Chord II
' 9= Chord III
' 10= Chord IV
' 11= Chord V
' 12= Chord VI
' 13= Chord VII
' ...
CONST chordset = 21 ' 21= chord clear(0)/chord set(1)
CONST mode_lock = 22 ' 22= mode lock off(0)/on(1)
CONST key_show = 23 ' 23= keyboard hide(0)/keyboard show(1)
CONST col_chg = 24 ' 24= color unchanged(0)/color changed(1)
CONST slnt_snd = 25 ' 25= silent(0)/sound(1)
CONST scale_on = 26 ' 26= scale absent(0)/scale present(1)
CONST picked = 27 ' 27= no notes(0)/picked notes(1)
CONST all_nat = 28 ' 28= all notes(0)/naturals only(1)
CONST hide_show = 29 ' 29= hide notes(0)/show notes(1)
CONST oct_sing = 30 ' 30= single(0)/octave(1)
CONST shrp_flt = 31 ' 31= sharp(0)/flat(1)
CONST TRUE = -1
CONST FALSE = 0
CONST outring = .8
CONST inring = .6
'DISPLAY LIMIT VARIABLES
DIM SHARED scrw%, scrh%, neckdown%, nut%, bridge%, fretmax%
DIM SHARED capo%, capotop%, capobot%
DIM SHARED frlimit%
'IMAGE HANDLES
DIM SHARED fb&, st&, sttmp&, sharp&, flat&, clefp&
'INITIAL VALUES
IF _DESKTOPHEIGHT - 80 * 1.82 > _DESKTOPWIDTH - 80 THEN
scrh% = _DESKTOPHEIGHT - 80
scrw% = scrh% * 1.82
ELSE
scrw% = _DESKTOPWIDTH - 80
scrh% = scrw% * .55
END IF
'DISPLAY LIMIT VALUES
neckdown% = scrh% * .05
capotop% = scrh% * .37
capobot% = scrh% * .4
nut% = scrw% * .15 ' nut position
bridge% = scrw% * .95 ' beyond here is only the bridge
fretmax% = 14 ' maximum # of frets shown
togs = &HE0000001 '&B11100000000000000000000000000001
defcol = Blue
'SCREENS & IMAGES
fb& = _NEWIMAGE(scrw%, scrh% * .3, 32)
st& = _NEWIMAGE(scrw% * .25, scrh% * .4, 32) ' grand staff underlayment image
sttmp& = _NEWIMAGE(scrw% * .25, scrh% * .4, 32) ' grand staff working image
sharp& = _LOADIMAGE(_EMBEDDED$("emsharp"), 32, "memory") ' key signature sharp image
flat& = _LOADIMAGE(_EMBEDDED$("emflat"), 32, "memory") ' key signature flat image
clefp& = _LOADIMAGE(_EMBEDDED$("emclefp"), 32, "memory") ' grand staff clef image
SCREEN _NEWIMAGE(scrw%, scrh%, 32)
DO: LOOP UNTIL _SCREENEXISTS
_SCREENMOVE 0, 0
masterscale(0) = TRUE ' tonic create master scale array
masterscale(2) = TRUE ' whole step
masterscale(4) = TRUE ' whole step
masterscale(5) = TRUE ' half step
masterscale(7) = TRUE ' dominant whole step
masterscale(9) = TRUE ' whole step
masterscale(11) = TRUE 'leading whole step -> half step back to 0
ResetScale ' copy master scale to scale
SetNote note() ' create main tone UDT array
Init_Strings 24 ' populate string values to 24 frets
Fret_Board ' draw fretboard
Make_Buttons ' draw control images
Staff ' Create clean grand staff image
Stafftmp 0, note(0) ' overlay un-notated temp staff image
MainLoop '
END
'---------------------------------------------------------------END MAIN MODULE---------------------
'---------------------------------------------------------------SUBROUTINES-------------------------
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ CONBLOK BUTTON BEVEL
SUB BevelB (xsiz AS INTEGER, ysiz AS INTEGER, col AS _UNSIGNED LONG)
DIM brdr, rd&, gn&, bl&, bb, c
brdr = ABS(_SHR(ysiz, 2) * (ysiz <= xsiz) + _SHR(xsiz, 2) * (ysiz > xsiz)) 'select smaller 1/4 size border axis
rd& = _RED32(col) - 100: gn& = _GREEN32(col) - 100: bl& = _BLUE32(col) - 100
FOR bb = 0 TO brdr
c = c + 100 / brdr
LINE (0 + bb, 0 + bb)-(xsiz - 1 - bb, ysiz - 1 - bb), _RGBA32(rd& + c, gn& + c, bl& + c, _ALPHA(col)), B
NEXT bb
END SUB 'BevelB
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ DISPLAY BUTTON AS <OFF>
SUB ButBlank (b AS INTEGER)
LINE (bt(b).r.ul.x, bt(b).r.ul.y)-(bt(b).r.lr.x, bt(b).r.lr.y), &H7F000000, BF
END SUB 'ButBlank
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ DISPLAY BUTTON
SUB ButPut (b AS INTEGER)
_PUTIMAGE (bt(b).r.ul.x, bt(b).r.ul.y)-(bt(b).r.lr.x, bt(b).r.lr.y), bt(b).hn
END SUB 'ButPut
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ DISPLAY CAPO BLANKING
SUB Capo_Track
DIM fw%, tps%, fr%, x%
fw% = Fret_Wide%
tps% = MidPt%(capotop%, capobot%) - 8
_PRINTSTRING (4, tps%), "Capo Position"
FOR fr% = 0 TO fretmax%
x% = nut% + fw% * fr%
LINE (x% - fw%, capotop%)-(x%, capobot%), , B
IF fr% = capo% THEN _PRINTSTRING (x% - (fw% / 2), tps%), _TRIM$(STR$(fr%))
NEXT fr%
IF capo% THEN ' fretboard blanking
LINE (nut%, neckdown%)-(nut% + fw% * capo%, neckdown% + _HEIGHT(fb&)), &H7F000000, BF
END IF
END SUB 'Capo_Track
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ DISPLAY UPPER LIMIT BLANKING
SUB Limit_Track
IF frlimit% THEN
LINE (nut% + Fret_Wide% * frlimit%, neckdown%)-(bridge%, neckdown% + _HEIGHT(fb&)), &H7F000000, BF
END IF
END SUB 'Limit_Track
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ CHORD INVERSE COLOR
SUB Chord (d AS INTEGER)
DIM chrd&, ch%, triad%, n%
chrd& = Negative~&(sclcol) ' negative inversion of scale color
ch% = d
FOR triad% = 1 TO 3 ' degree of triad
FOR n% = 0 TO 56
IF note(n%).sd = ch% THEN ' if note scale degree equals chord degree
note(n%).c = chrd& ' apply negative contrast color
END IF
NEXT n%
ch% = ch% + 2 ' advance to next chord degree
IF ch% > 7 THEN ch% = ch% - 7 ' scale wrap around
NEXT triad%
END SUB 'Chord
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ CLEAR MOUSEBUTTON BUFFER
SUB Clear_MB (var AS INTEGER)
DO UNTIL NOT _MOUSEBUTTON(var)
_LIMIT 30
WHILE _MOUSEINPUT: WEND
LOOP
END SUB 'Clear_MB
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ CREATE CONTROL BLOCK
SUB CtrlBlk (b AS button)
DIM xsiz%, ysiz%, dst&, x%, sx, sy, p%
xsiz% = b.r.lr.x - b.r.ul.x + 1
ysiz% = b.r.lr.y - b.r.ul.y + 1
dst& = _DEST ' save calling destination
b.hn = _NEWIMAGE(xsiz%, ysiz%, 32)
_DEST b.hn
COLOR , b.c
CLS
BevelB xsiz%, ysiz%, b.c
_PRINTMODE _KEEPBACKGROUND
x% = LEN(_TRIM$(b.l))
sx = xsiz% / 2 - x% * 4: sy = ysiz% / 2 - 8
FOR p% = 1 TO x% ' iterate through label characters
COLOR -4294901760 * (p% = b.h) - 4278190080 * (p% <> b.h) '&HFFFF0000 &HFF000000
IF b.c = &HFFC80000 THEN COLOR &HFFFFFFFF
_PRINTSTRING (sx + (p% - 1) * 8, sy), MID$(_TRIM$(b.l), p%, 1)
NEXT p%
_DEST dst&
END SUB 'CtrlBlk
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ SET DEFAULT COLORS
SUB Default_Color (x%)
SELECT CASE x% - 38
CASE 0: bt(x%).c = Blue
CASE 1: bt(x%).c = Green
CASE 2: bt(x%).c = Red
CASE 3: bt(x%).c = Purple
CASE 4: bt(x%).c = Aqua
CASE 5: bt(x%).c = Orange
CASE 6: bt(x%).c = Yellow
CASE 7: bt(x%).c = Coral
CASE 8: bt(x%).c = Cerulean
CASE 9: bt(x%).c = Lime
CASE 10: bt(x%).c = Teal
CASE 11: bt(x%).c = Timberwolf
END SELECT
END SUB 'Default_Color
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ PIE CHART DIVIDE SPOTS
SUB Divisions (x%, y%, r%, div%, col&)
DIM div!, ang!
IF div% = 1 THEN EXIT SUB
div! = _PI(2) / div% ' radians per division
DO
ang! = ang! + div!
LINE (x%, y%)-(x% + COS(ang!) * r%, y% + SIN(ang!) * r%), Negative~&(col&) 'White
LOOP UNTIL ang! >= _PI(2)
END SUB 'Divisions
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ SET AND DISPLAY FRETBOARD EDGE DOTS
SUB DotFret
DIM fw%, fw1%, fw2%, fw3%, x%, y%, r%
fw% = Fret_Wide%
fw1% = _SHR(fw%, 2) ' 1/4 fret width
fw2% = _SHR(fw%, 1) ' 1/2 fret width
fw3% = fw1% * 3 ' 3/4 fret width
y% = neckdown% + _HEIGHT(fb&) + ((capotop% - (neckdown% + _HEIGHT(fb&))) / 2)
r% = .1875 * (capotop% - (neckdown% + _HEIGHT(fb&)))
FOR x% = 3 TO fretmax%
SELECT CASE x%
CASE 3, 5, 7, 9, 15, 17, 19, 21 ' single dot positions
FCirc nut% + x% * fw% - fw2%, y%, r%, White
CASE 12, 24 ' double dot positions
FCirc nut% + x% * fw% - fw1%, y%, r%, White
FCirc nut% + x% * fw% - fw3%, y%, r%, White
END SELECT
NEXT x%
END SUB 'DotFret
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ INITIAL STRING NOTE VALUES
SUB Init_Strings (fm AS INTEGER)
DIM n%, s%, f%
n% = 33 ' Initialize strings to standard tuning
FOR s% = 0 TO 5 ' Strings 0 through 5 (eBGDAE)
n% = n% + 4 * (s% = 2) + 5 * (s% <> 2) ' 4 frets on G (maj 3rd), 5 frets all others (perf 4th)
frets(s%, 25) = n% ' base note of standard tuning
frets(s%, 0) = frets(s%, 25) ' open note of string s%
FOR f% = 1 TO fm
frets(s%, f%) = frets(s%, 0) + f% ' populate fret notes
NEXT f%
NEXT s%
END SUB 'Init_Strings
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ DRAW FILLED CIRCLES
SUB FCirc (CX AS LONG, CY AS LONG, RR AS LONG, C AS _UNSIGNED LONG) 'by Steve McNeill
DIM AS LONG R, RError, X, Y
R = ABS(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
IF R = 0 THEN PSET (CX, CY), C: EXIT SUB ' zero radius is point, not circle
LINE (CX - X, CY)-(CX + X, CY), C, BF ' draw equatorial line
WHILE X > Y
RError = RError + Y * 2 + 1
IF RError >= 0 THEN
IF X <> Y + 1 THEN
LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF ' draw line above equator
LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF ' draw line below equator
END IF
X = X - 1
RError = RError - X * 2
END IF
Y = Y + 1
LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF ' draw line north latitudes
LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF ' draw line south latitudes
WEND
END SUB 'FCirc
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ CREATE FRETBOARD IMAGE
SUB Fret_Board
DIM fr_rng%, fr_ps%, st_rng%, st_ps%, h%, fr%, st%
fr_rng% = Fret_Wide% ' fret range
h% = _HEIGHT(fb&)
_DEST fb&
CLS
LINE (nut%, 0)-(bridge%, h%), RawUmber, BF ' fretboard
LINE (nut% - 5, 0)-(nut% - 1, h%), Beige, BF ' nut
FOR fr% = 1 TO fretmax% ' frets
fr_ps% = nut% + fr_rng% * fr%
LINE (fr_ps%, 0)-(fr_ps% + 3, h%), PaleGoldenRod, BF
LINE (fr_ps% - 1, 0)-(fr_ps% - 1, h%), Black, BF
SELECT CASE fr% ' fretboard spots
CASE 3, 5, 7, 9, 15, 17, 19, 21
FCirc fr_ps% - _SHR(fr_rng%, 1), h% / 2, .05 * h%, BlueBell
CASE 12, 24
FCirc fr_ps% - _SHR(fr_rng%, 1), h% * (1 / 3), .05 * h%, BlueBell
FCirc fr_ps% - _SHR(fr_rng%, 1), h% * (2 / 3), .05 * h%, BlueBell
END SELECT
NEXT fr%
st_rng% = h% / 6
FOR st% = 0 TO 5 ' strings overlay
st_ps% = st_rng% * st% + (st_rng% / 2)
LINE (nut%, st_ps%)-(bridge%, st_ps% + (_CEIL((st% + 1) / 2))), Gold, BF
NEXT st%
_DEST 0
END SUB 'Fret_Board
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ WIDTH OF FRETS
FUNCTION Fret_Wide%
Fret_Wide% = (bridge% - nut%) / fretmax%
END FUNCTION 'Fret_Wide
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ FIT IMAGE TO DEFINED SPACE
SUB Image_Resize (xpos AS INTEGER, ypos AS INTEGER, xlim AS INTEGER, ylim AS INTEGER, i AS LONG, d AS LONG, xj AS STRING, yj AS STRING)
DIM AS INTEGER xs, ys, xp, yp, xl, yl ' ready for OPTION EXPLICIT programs
xp = xpos: yp = ypos: xl = xlim: yl = ylim ' isolate sent parameters from any changes
DIM AS SINGLE rt, xrt, yrt
xrt = (xl - xp) / _WIDTH(i) ' width of area divided by width of image
yrt = (yl - yp) / _HEIGHT(i) ' height of area divided by height of image
rt = -xrt * (xrt < yrt) - yrt * (yrt <= xrt) ' pick the smaller of the two ratios to fit area
xs = _WIDTH(i) * rt ' final image size ratio in x
ys = _HEIGHT(i) * rt ' final image size ratio in y
xp = -xp * (xj = "l") - (_SHR(xl - xp, 1) + xp - _SHR(xs, 1)) * (xj = "c") - (xl - xs) * (xj = "r")
xl = xp + xs
yp = -yp * (yj = "u") - (_SHR(yl - yp, 1) + yp - _SHR(ys, 1)) * (yj = "c") - (yl - ys) * (yj = "d")
yl = yp + ys
_PUTIMAGE (xp, yp)-(xl, yl), i, d
END SUB 'Image_Resize
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ BOOLEAN REGION DETECTION 1D
FUNCTION InRange% (var%, ll%, ul%) 'll% & ul% are order insensitive
InRange% = -((var% >= (-ll% * (ll% <= ul%) - ul% * (ll% > ul%))) * (var% <= (-ul% * (ll% <= ul%) - ll% * (ll% > ul%)))) 'in range? T/F
END FUNCTION 'InRange%
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ BOOLEAN REGION DETECTION 2D
FUNCTION InRegion% (p AS V2, r AS region)
InRegion% = -(InRange%(p.x, r.ul.x, r.lr.x) * InRange%(p.y, r.ul.y, r.lr.y)) 'in region? T/F
END FUNCTION 'InRegion%
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ DISPLAY SCALE INTERVALS
SUB Intervals
DIM I$25(12), D$14(8), x%, y%, d%, l%, dp%, hi&, lo&
I$25(0) = " root/tonic/unison": I$25(1) = " minor 2nd/semitone"
I$25(2) = " major 2nd/tone": I$25(3) = " minor 3rd"
I$25(4) = " major 3rd": I$25(5) = " perfect 4th"
I$25(6) = " aug 4/dim 5/tritone": I$25(7) = " perfect 5th/dominant"
I$25(8) = " minor 6th": I$25(9) = " major 6th"
I$25(10) = " minor 7th": I$25(11) = " major 7th": I$25(12) = " octave"
'D$14(1) = "I": D$14(2) = "II": D$14(3) = "III": D$14(4) = "IV"
'D$14(5) = "V": D$14(6) = "VI": D$14(7) = "VII": D$14(8) = "8'v"
D$14(1) = "I Tonic": D$14(2) = "II Supertonic": D$14(3) = "III Mediant": D$14(4) = "IV Subdominant"
D$14(5) = "V Dominant": D$14(6) = "VI Submediant": D$14(7) = "VII Leading": D$14(8) = "8'v Tonic"
hi& = sclcol
lo& = Gray
x% = bt(50).r.lr.x + 5
y% = bt(27).r.ul.y + 29
d% = 0
_PRINTSTRING (x%, y%), "LIST OF INTERVALS"
FOR l% = 0 TO 12 ' intervals unison thru octave
COLOR lo&
IF Vtog%(scale_on) THEN ' if scale chosen
IF l% = 12 THEN ' trap scale subscript error and set for octave
COLOR hi&: dp% = TRUE
d% = 8
ELSE
IF scale(l%) THEN
COLOR hi&: dp% = TRUE
d% = d% + 1
END IF
END IF
END IF
y% = y% + 16
_PRINTSTRING (x%, y%), I$25(l%) ' print interval name
_PRINTSTRING (x%, y%), _TRIM$(STR$(l%)) ' print interval number
IF dp% THEN
_PRINTSTRING (x% + 200, y%), "- " + D$14(d%) ' print scale degree
dp% = FALSE ' clear degree print
END IF
NEXT l%
COLOR White
END SUB 'Intervals
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ DRAW KEYBOARD AND SHOW CHOSEN NOTES
SUB Keyboard (kh%)
DIM kb&, p%, a%, a1%, d1%, ac%, ad%, p1%, fill&, ot&, x%
kb& = _NEWIMAGE(680, 100, 32) ' 34 white keys x 20
_DEST kb&
CLS , Ivory
DO 'first white keys (a%=0), then black (a%=-1) for proper overlay masking
p% = 0 ' key position- reset for each white/black run
a1% = -10 * (NOT a%) ' x offset of scale dots
d1% = 80 + 40 * a% ' base y displacement
ac% = -6 * a% ' accidentals offset (6 or 0)
ad% = _SHL(a1%, 1) ' right side +20 if not an accidental
FOR x% = 0 TO 56
p1% = p% * 20
IF a% = note(x%).ac THEN
fill& = -Black * a% - Ivory * (NOT a%) ' fill black keys with black and white keys with white
fill& = -fill& * (x% <> kh%) - Red * (x% = kh%) 'fill center mouse chosen key (if any) with red
LINE (p1% - ac%, 0)-(p1% + ac% + ad%, d1% + 20), fill&, BF 'fill key
LINE (p1% - ac%, 0)-(p1% + ac% + ad%, d1% + 20), Black, B 'outline key
IF note(x%).sd THEN '
FCirc p1% + a1%, d1%, 5, note(x%).c
IF a% THEN ot& = White ELSE ot& = Black
CIRCLE (p1% + a1%, d1%), 5, ot&
IF note(x%).sd = 1 THEN FCirc p1% + a1%, d1%, 2, White 'canter spot tonic note
END IF
IF x% = 12 THEN FCirc p% * 20 + 10, 97, 2, Black 'spot middle C
END IF
p% = p% - (NOT note(x%).ac) ' increment if not an accidental
NEXT x%
a% = a% - 1 ' decrement masking loop from white (0) to black (-1)
LOOP UNTIL a% < -1
_DEST 0
_PUTIMAGE (_WIDTH(0) - _WIDTH(kb&), scrh% * .41), kb&
_FREEIMAGE kb&
END SUB 'Keyboard
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ MAIN PROGRAM INPUT/DISPLAY JUNCTION
SUB MainLoop
DIM in%, done%, high%, singnt%, ntchs%, st%, fr%, x%, blk%, a%, ms
in% = TRUE: high% = 57 ' loop initial states
DO ' DISPLAY LOOP
DO ' INPUT LOOP
'key input
IF _KEYDOWN(8) THEN ' backspace' clear all
Note_Zero
_DELAY .2: in% = TRUE
END IF
IF _KEYDOWN(65) OR _KEYDOWN(97) THEN
Ttog all_nat ' a=all/naturals only
_DELAY .2: in% = TRUE
END IF
IF _KEYDOWN(66) OR _KEYDOWN(98) THEN
Ttog shrp_flt ' b=flat/sharp
_DELAY .2: in% = TRUE
END IF
IF _KEYDOWN(72) OR _KEYDOWN(104) THEN
Ttog hide_show ' h=hide/show notes
_DELAY .2: in% = TRUE
END IF
IF _KEYDOWN(75) OR _KEYDOWN(107) THEN
Ttog key_show ' k=hide/show keyboard
_DELAY .2: in% = TRUE
END IF
IF _KEYDOWN(83) OR _KEYDOWN(115) THEN
Ttog slnt_snd ' s=silent/sound
_DELAY .2: in% = TRUE
END IF
IF _KEYDOWN(81) OR _KEYDOWN(113) OR _KEYDOWN(27) THEN SYSTEM 'Quit
IF _KEYDOWN(19712) THEN ' forward arrow= increase fretboard
fretmax% = fretmax% - (fretmax% < 24)
Fret_Board
_DELAY .2
in% = TRUE
END IF
IF _KEYDOWN(19200) THEN ' back arrow= reduce fretboard
fretmax% = fretmax% + (fretmax% > 14)
Fret_Board
_DELAY .2: in% = TRUE
END IF
'mouse input
ms = MBS%
IF ms AND 1 THEN ' left mouse button press
Clear_MB 1
MB_Left mous
singnt% = 0: ntchs% = 0
in% = TRUE
END IF
IF ms AND 2 THEN ' right mouse button press
Clear_MB 2
MB_Right mous
singnt% = 0: ntchs% = 0
in% = TRUE
END IF
IF ms AND 4 THEN ' center/mousewheel button press on fretboard
IF InRegion%(mous, bt(19).r) THEN ' if on fretboard
st% = (mous.y - neckdown%) \ (_HEIGHT(fb&) / 6) 'string calc
fr% = INT((mous.x - nut%) / Fret_Wide%) + 1 'fret calc
IF fr% = 0 THEN a% = capo% ELSE a% = 0
high% = frets(st%, fr%) + a%
singnt% = TRUE: ntchs% = frets(st%, fr%) + a%
in% = TRUE
IF Vtog%(slnt_snd) THEN
SOUND note(frets(st%, fr%) + a%).hz, 18
END IF
END IF
Clear_MB 3
END IF
_LIMIT 30
LOOP UNTIL in% ' END: INPUT LOOP
in% = FALSE
CLS
'image refresh
_PUTIMAGE (0, neckdown%), fb&, 0 ' OVERLAY FRETBOARD
_PRINTSTRING (16, neckdown% - 20), "Tuners"
FOR x% = 0 TO 51 ' place buttons and toggles
IF x% > 17 AND x% < 21 THEN _CONTINUE ' skip capo track, fretboard & circle of fifths
ButPut x%
IF x% < 18 AND x% MOD 3 = 1 THEN ' if center tuner
IF frets(x% \ 3, 0) = frets(x% \ 3, 25) THEN
ButBlank x% ' blank if default tuned
ELSE
IF frets(x% \ 3, 0) > frets(x% \ 3, 25) THEN
RegionArrow bt(x%).r, "u", "half", &H6FFF0000 'tune arrow
ELSE
RegionArrow bt(x%).r, "d", "half", &H6FFF0000 'tune arrow
END IF
END IF
END IF
SELECT CASE x%
CASE 21 TO 27 ' Mode toggles
IF NOT Vtog%(x% - 21) THEN ButBlank x%
IF Vtog%(mode_lock) AND Vtog%(x% - 21) THEN
RegionRing bt(x%).r, Red, 3
END IF
CASE 28, 29 ' octave/single toggle
IF Vtog%(oct_sing) THEN blk% = 29 ELSE blk% = 28
IF x% = blk% THEN ButBlank x%
CASE 30, 31 ' all/natural toggle
IF Vtog%(all_nat) THEN blk% = 30 ELSE blk% = 31
IF x% = blk% THEN ButBlank x%
CASE 32, 33 ' show/hide notes toggle
IF Vtog%(hide_show) THEN blk% = 33 ELSE blk% = 32
IF x% = blk% THEN ButBlank x%
CASE 34, 35
IF Vtog%(shrp_flt) THEN blk% = 34 ELSE blk% = 35
IF x% = blk% THEN ButBlank x%
CASE 36, 37
IF Vtog%(slnt_snd) THEN blk% = 36 ELSE blk% = 37
IF x% = blk% THEN ButBlank x%
CASE 38 TO 49
IF defcol = bt(x%).c THEN ' negative border active color
RegionRing bt(x%).r, Negative~&(bt(x%).c), 6
END IF
CASE 50
IF NOT Vtog%(col_chg) THEN ButBlank x%
CASE 51
IF NOT Vtog%(key_show) THEN ButBlank x%
END SELECT
NEXT x%
SELECT EVERYCASE fretmax%
CASE 14 TO 23
RegionArrow bt(52).r, "r", "half", &H9FFF0000
CASE 15 TO 24
RegionArrow bt(52).r, "l", "half", &H9FFF0000
END SELECT
FOR x% = 53 TO 59
ButPut x%
IF NOT Vtog%(x% - 46) THEN ButBlank x%
NEXT x%
String_Notes
Stafftmp singnt%, note(ntchs%) '
_PUTIMAGE (scrw% * .75, scrh% * .6)-(scrw% - 1, scrh% - 1), sttmp& '
DotFret
Capo_Track
Limit_Track
Circle_of_Fifth
Intervals
NameChords
IF Vtog%(key_show) THEN Keyboard high%: high% = 57 '
_PRINTSTRING (0, _HEIGHT(0) - 64), "clockwise:"
_PRINTSTRING (0, _HEIGHT(0) - 48), "Father Charles Goes Down And Ends Battle"
_PRINTSTRING (0, _HEIGHT(0) - 32), "counter clockwise:"
_PRINTSTRING (0, _HEIGHT(0) - 16), "Battle Ends And Down Goes Charles Father"
'_PRINTSTRING (0, 0), aspect$
_DISPLAY
LOOP UNTIL done% ' END: DISPLAY LOOP
END SUB 'MainLoop
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ CREATE CONTROL BUTTONS & REGIONS
SUB Make_Buttons
DIM sz%, x%, xp%, y%, yp%, b%, ul%, f&, colorfile%, ho%, vo%
sz% = ((_HEIGHT(fb&) - 1) / 6) * .75 ' Tuners
FOR y% = 0 TO 5 ' iterating string tiers
yp% = neckdown% + y% * ((_HEIGHT(fb&) - 1) / 6) + sz% / 3
FOR x% = 0 TO 2
xp% = sz% / 2 + x% * sz% * 1.25
b% = x% + y% * 3
bt(b%).l = _TRIM$(MID$("-|+", x% + 1, 1))
bt(b%).r.ul.x = xp%
bt(b%).r.ul.y = yp%
bt(b%).r.lr.x = xp% + sz%
bt(b%).r.lr.y = yp% + sz%
bt(b%).c = &HFF00FF00
bt(b%).h = 0
CtrlBlk bt(b%)
NEXT x%
NEXT y%
bt(18).r.ul.x = nut% - Fret_Wide% '-------------------------capo track region
bt(18).r.ul.y = capotop%
bt(18).r.lr.x = bridge%
bt(18).r.lr.y = capobot%
bt(19).r.ul.x = bt(18).r.ul.x '-----------------------------fretboard region
bt(19).r.ul.y = neckdown%
bt(19).r.lr.x = bridge%
bt(19).r.lr.y = neckdown% + _HEIGHT(fb&) - 1
bt(20).r.ul.x = 0 '-----------------------------------------circle of fifths region
bt(20).r.ul.y = scrh% * .42
bt(20).r.lr.x = _HEIGHT(0) - scrh% * .5
bt(20).r.lr.y = bt(20).r.ul.y + bt(20).r.lr.x
FOR x% = 21 TO 27 '-----------------------------------------SCALES
bt(x%).r.ul.x = bt(20).r.lr.x + 1
bt(x%).r.ul.y = bt(20).r.ul.y + (24 * (x% - 21))
bt(x%).r.lr.x = bt(x%).r.ul.x + 128
bt(x%).r.lr.y = bt(x%).r.ul.y + 24
bt(x%).c = &HFF00FF00
SELECT CASE x%
CASE 21: bt(x%).l = "Ionian/Major"
CASE 22: bt(x%).l = "Dorian"
CASE 23: bt(x%).l = "Phrygian"
CASE 24: bt(x%).l = "Lydian"
CASE 25: bt(x%).l = "Mixolydian"
CASE 26: bt(x%).l = "Aeolian/Minor"
CASE 27: bt(x%).l = "Locrian"
END SELECT
CtrlBlk bt(x%)
NEXT x%
FOR x% = 28 TO 37 '-----------------------------------------TOP TOGGLES
IF x% = 28 THEN
ul% = nut%
ELSE
ul% = bt(x% - 1).r.lr.x - (x% MOD 2 <> 0) - (scrw% * .02) * (x% MOD 2 = 0)
END IF
bt(x%).r.ul.x = ul%
bt(x%).r.ul.y = scrh% * .007 'togtop%
bt(x%).r.lr.x = bt(x%).r.ul.x + 63
bt(x%).r.lr.y = scrh% * 0.04 'togbot%
SELECT CASE x%
CASE 28: bt(x%).l = "Octave"
CASE 29: bt(x%).l = "Single"
CASE 30: bt(x%).l = "All": bt(x%).h = 1
CASE 31: bt(x%).l = "Natural": bt(x%).h = 2
CASE 32: bt(x%).l = "Show": bt(x%).h = 2
CASE 33: bt(x%).l = "Hide": bt(x%).h = 1
CASE 34: bt(x%).l = "Sharp"
CASE 35: bt(x%).l = "Flat"
CASE 36: bt(x%).l = "Silent": bt(x%).h = 1
CASE 37: bt(x%).l = "Sound": bt(x%).h = 1
END SELECT
bt(x%).c = &HFF00FF00
CtrlBlk bt(x%)
NEXT x%
IF _FILEEXISTS("notecolor.ini") THEN
f& = FREEFILE
OPEN "notecolor.ini" FOR BINARY AS f&
colorfile% = TRUE
ELSE
colorfile% = FALSE
END IF
FOR x% = 38 TO 49 '-----------------------------------------Twelve 42 x 42 color buttons
ho% = (x% - 38) MOD 3
vo% = (x% - 38) \ 3
bt(x%).r.ul.x = bt(20).r.lr.x + 1 + (42 * ho%)
bt(x%).r.ul.y = bt(27).r.ul.y + 29 + (42 * vo%)
bt(x%).r.lr.x = bt(x%).r.ul.x + 42
bt(x%).r.lr.y = bt(x%).r.ul.y + 42
IF colorfile% THEN
GET f&, , bt(x%).c
ELSE
Default_Color x%
END IF
CtrlBlk bt(x%)
NEXT x%
CLOSE f&
bt(50).r.ul.x = bt(20).r.lr.x + 1 ' color save
bt(50).r.ul.y = bt(49).r.lr.y + 5
bt(50).r.lr.x = bt(50).r.ul.x + 128
bt(50).r.lr.y = bt(50).r.ul.y + 36
bt(50).c = &HFF00FF00
bt(50).l = "Save colors"
CtrlBlk bt(50)
bt(51).r.ul.x = bt(37).r.lr.x + (scrw% * .02) '-------------Keyboard
bt(51).r.ul.y = scrh% * .007 'togtop% 'bt(37).r.ul.y
bt(51).r.lr.x = bt(51).r.ul.x + 96
bt(51).r.lr.y = scrh% * 0.04 'togbot% 'bt(51).r.ul.y + 23
bt(51).c = &HFF00FF00
bt(51).h = 1
bt(51).l = "Keyboard"
CtrlBlk bt(51)
bt(52).r.ul.x = scrw% * .96 '-------------------------------Fret Size Control
bt(52).r.ul.y = neckdown%
bt(52).r.lr.x = scrw% * .99
bt(52).r.lr.y = neckdown% + _HEIGHT(fb&)
FOR x% = 53 TO 59 '-----------------------------------------Chord controls
bt(x%).r.ul.x = bt(x% - 32).r.lr.x + 5
bt(x%).r.ul.y = bt(x% - 32).r.ul.y
bt(x%).r.lr.x = bt(x%).r.ul.x + 96
bt(x%).r.lr.y = bt(x%).r.ul.y + 24
bt(x%).c = &HFF00FF00
SELECT CASE x%
CASE 53: bt(x%).l = "I"
CASE 54: bt(x%).l = "II"
CASE 55: bt(x%).l = "III"
CASE 56: bt(x%).l = "IV"
CASE 57: bt(x%).l = "V"
CASE 58: bt(x%).l = "VI"
CASE 59: bt(x%).l = "VII"
END SELECT
CtrlBlk bt(x%)
NEXT x%
_DEST 0
END SUB 'Make_Buttons
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ LEFT MOUSE BUTTON OPS
SUB MB_Left (ps AS V2)
DIM x%, valid%, s%, f%, st%, fr%, ang%, in%, t%, b%, rotar%, f&, c%
FOR x% = 0 TO 59
IF InRegion%(ps, bt(x%).r) THEN
valid% = TRUE: EXIT FOR
END IF
NEXT x%
IF NOT valid% THEN EXIT SUB
SELECT CASE x%
CASE 0 TO 17 ' TUNER REGIONS
IF x% MOD 3 = 0 THEN ' Detune
frets(x% \ 3, 0) = frets(x% \ 3, 0) + (frets(x% \ 3, 0) > 0)
ELSEIF x% MOD 3 = 1 THEN ' Base tuning
frets(x% \ 3, 0) = frets(x% \ 3, 25)
ELSEIF x% MOD 3 = 2 THEN ' Uptune
frets(x% \ 3, 0) = frets(x% \ 3, 0) - (frets(x% \ 3, 24) < 56)
END IF
FOR s% = 0 TO 5 ' re-tune strings
FOR f% = 1 TO 24
frets(s%, f%) = frets(s%, 0) + f%
NEXT f%
NEXT s%
CASE 18
capo% = _CEIL((ps.x - nut%) / Fret_Wide%)
IF capo% < 0 THEN capo% = 0
CASE 19 ' FRETBOARD REGION
st% = (ps.y - neckdown%) \ (_HEIGHT(fb&) / 6) ' string calc
fr% = INT((ps.x - nut%) / Fret_Wide%) + 1 ' fret calc
SearchNote -1, note(frets(st%, fr%))
CASE 20 ' CIRCLE OF FIFTHS REGION
DIM AS V2 cen, clk
DIM k(11) AS tone
DIM dst!
SetNote k()
CentRg cen, bt(20).r ' center of circle of fifths
clk = mous: R2_Add clk, cen, -1 ' clk relative to circle center
dst! = _HYPOT(clk.x, clk.y)
IF dst! < cen.x * .3 THEN ' within clear all circle
Note_Zero
ELSE
IF dst! > cen.x * inring AND dst! < cen.x * outring THEN 'within note ring
IF Vtog%(scale_on) THEN Note_Zero ' clear all for new scale
ang% = _R2D(_ATAN2(clk.y, clk.x) - .261799) 'get angle of mouse click _PI / 12 = .261799
IF SGN(ang%) < 0 THEN
ang% = ABS(ang%) \ 30
ELSE
ang% = (360 - ang%) \ 30 ' was: ang% = (180 + (180 - ang%)) \ 30
END IF
in% = 9
DO UNTIL ang% = 0
in% = Pfifth%(in%, 5)
ang% = ang% - 1
LOOP
Stog scale_on ' set scale mode
FOR x% = 0 TO 6 ' check all modal states
t% = t% + Vtog%(x%)
NEXT x%
IF t% = 0 THEN Stog 0 ' if no state set default to Ionian/Major
tonic = k(in%) ' set tonic ID
Signature in% ' adjust sharp/flat to appropriate key
Scale_Run ' construct scale note pointers
END IF
END IF
CASE 21 TO 27 ' SCALE MODES
ResetScale ' set back to Ionian scale
Note_Zero ' clear all note selections
FOR b% = 21 TO 27
IF b% = x% THEN
Ttog b% - 21 ' toggle selected bit on/off
ELSE
Rtog b% - 21 ' clear all non-selected bits
END IF
NEXT b%
SELECT CASE x% ' determine scale rotation factor - use shortest
CASE 21: rotar% = 0 ' ionian 0
CASE 22: rotar% = -2 ' dorian -2 10
CASE 23: rotar% = -4 ' phrygian -4 8
CASE 24: rotar% = -5 ' lydian -5 7
CASE 25: rotar% = 5 ' mixolydian -7 5
CASE 26: rotar% = 3 ' aeolian -9 3
CASE 27: rotar% = 1 ' locrian -11 1
END SELECT
RotArrayM scale(), rotar% ' rotate to mode from Ionian
CASE 28, 29 ' SINGLE/OCTAVE TOGGLE
Ttog oct_sing
CASE 30, 31
Ttog all_nat
CASE 32, 33
Ttog hide_show
CASE 34, 35
Ttog shrp_flt
CASE 36, 37
Ttog slnt_snd
CASE 38 TO 49
defcol = bt(x%).c ' default color
CASE 50
IF Vtog%(col_chg) THEN
IF _FILEEXISTS("notecolor.ini") THEN
KILL "notecolor.ini"
END IF
f& = FREEFILE
OPEN "notecolor.ini" FOR BINARY AS f&
FOR c% = 38 TO 49
PUT f&, , bt(c%).c
NEXT c%
CLOSE f&
Rtog col_chg
END IF
CASE 51 ' SHOW/HIDE KEYBOARD
Ttog key_show
CASE 52 ' INCREMENT/DECREMENT FRET COUNT
IF ps.x < MidPt%(bt(52).r.ul.x, bt(52).r.lr.x) THEN
fretmax% = fretmax% + (fretmax% > 14)
Fret_Board
ELSE
fretmax% = fretmax% - (fretmax% < 24)
Fret_Board
END IF
CASE 53 TO 59 ' CHORD BUTTONS
FOR t% = 7 TO 13
Rtog t%
NEXT t%
IF Vtog%(scale_on) THEN
UnChord
Stog chordset
Stog x% - 46
Chord x% - 52
END IF
CASE ELSE
END SELECT
END SUB 'MB_Left
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ RIGHT BUTTON MOUSE OPS
SUB MB_Right (ps AS V2)
DIM x%, valid%, st%, fr%, a%, pk%, srch%, ncolor&, m&
FOR x% = 0 TO 50
IF InRegion%(ps, bt(x%).r) THEN
valid% = TRUE: EXIT FOR
END IF
NEXT x%
IF NOT valid% THEN EXIT SUB
SELECT CASE x%
CASE 18
frlimit% = _CEIL((ps.x - nut%) / Fret_Wide%) - 1
IF frlimit% > fretmax% THEN frlimit% = 0
IF frlimit% < 0 THEN frlimit% = 0
CASE 19
st% = (ps.y - neckdown%) \ (_HEIGHT(fb&) / 6) ' string calc
fr% = INT((ps.x - nut%) / Fret_Wide%) + 1 ' fret calc
IF fr% = 0 THEN a% = capo% ELSE a% = 0 ' fret 0 alteration
SearchNote 0, note(frets(st%, fr%))
pk% = FALSE
FOR srch% = 0 TO 56 ' check for still picked notes
IF note(srch%).sd <> 0 THEN pk% = TRUE
NEXT srch%
IF NOT pk% THEN ' if none left then clear picked and scale modes
Rtog scale_on
Rtog picked
END IF
CASE 21 TO 27 ' MODE BUTTONS
Ttog mode_lock ' right click to lock in mode
CASE 38 TO 49 ' Color buttons
ncolor& = _COLORCHOOSERDIALOG("", 0)
IF ncolor& <> 0 THEN bt(x%).c = ncolor&
_DEST bt(x%).hn
CLS
CtrlBlk bt(x%)
Stog col_chg
_DEST 0
CASE 50 'right click on save button to restore default colors
m& = _MESSAGEBOX("Restore Default Colors", "Are you sure you wish to restore defualts?", "okcancel", "warning", 0)
IF m& THEN
FOR x% = 38 TO 49 ' Twelve 42 x 42 color buttons
Default_Color x%
_DEST bt(x%).hn
CLS
CtrlBlk bt(x%)
NEXT x%
_DEST 0
Stog col_chg
END IF
END SELECT
END SUB 'MB_Right
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ MOUSE BUTTON STATUS
FUNCTION MBS% 'Mouse Button Status by Steve McNeill
DIM tempMBS ', Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY
WHILE _MOUSEINPUT 'Remark out this block, if mouse main input/clear is going to be handled manually in main program.
SELECT CASE SGN(_MOUSEWHEEL)
CASE 1: tempMBS = tempMBS OR 512
CASE -1: tempMBS = tempMBS OR 1024
END SELECT
WEND
mous.x = _MOUSEX
mous.y = _MOUSEY
IF _MOUSEBUTTON(1) THEN tempMBS = tempMBS OR 1
IF _MOUSEBUTTON(2) THEN tempMBS = tempMBS OR 2
IF _MOUSEBUTTON(3) THEN tempMBS = tempMBS OR 4
MBS% = tempMBS
END FUNCTION 'MBS%
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ
SUB CentRg (re AS V2, send AS region)
re.x = MidPt%(send.ul.x, send.lr.x)
re.y = MidPt%(send.ul.y, send.lr.y)
END SUB 'CentRg
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ MIDDLE POINT BETWEEN TWO INTEGERS
FUNCTION MidPt% (start AS INTEGER, finish AS INTEGER)
MidPt% = start + _SHR((finish - start), 1)
END FUNCTION 'MidPt%
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ DISPLAY CHORD NAMES
SUB NameChords
DIM cn%, nt%, tri%, subtri%, n%, chrdnm$, third%, interval%, fifth%
IF Vtog%(scale_on) THEN
FOR cn% = 1 TO 7
nt% = 0
FOR tri% = cn% TO cn% + 4 STEP 2
subtri% = -(tri% - 7) * (tri% > 7) - (tri%) * (tri% <= 7)
FOR n% = nt% TO 56
SELECT CASE tri%
CASE cn%
IF note(n%).sd = subtri% THEN
chrdnm$ = _TRIM$(note(n% + 12).ft)
nt% = n%
EXIT FOR
END IF
CASE cn% + 2
IF note(n%).sd = subtri% THEN
third% = interval%
interval% = 0
nt% = n%
EXIT FOR
END IF
interval% = interval% + 1
CASE cn% + 4
IF note(n%).sd = subtri% THEN
fifth% = interval%
interval% = 0
EXIT FOR
END IF
interval% = interval% + 1
END SELECT
NEXT n%
NEXT tri%
IF third% = 4 THEN
chrdnm$ = chrdnm$ + "maj"
ELSEIF third% = 3 THEN
chrdnm$ = chrdnm$ + "min"
IF fifth% = 3 THEN chrdnm$ = chrdnm$ + CHR$(248)
END IF
_PRINTSTRING (bt(cn% + 52).r.lr.x + 2, bt(cn% + 52).r.ul.y + 4), chrdnm$
chrdnm$ = ""
NEXT cn%
END IF
END SUB 'NameChords
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ COLOR NEGATIVE
FUNCTION Negative~& (c AS _UNSIGNED LONG)
Negative~& = _RGBA32(127 - (_RED(c) - 127), 127 - (_GREEN(c) - 127), 127 - (_BLUE(c) - 127), _ALPHA(c))
END FUNCTION 'Negative~&
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ GET A NOTE NAME IN CONTEXT OF SHARP/FLAT
FUNCTION NoteName$ (n AS tone)
IF n.ac THEN ' If note enharmonic
IF Vtog%(shrp_flt) THEN ' If in flat mode
NoteName$ = n.bf
ELSE ' If in sharp mode
NoteName$ = n.bs
END IF
ELSE ' If note NOT enharmonic
NoteName$ = n.nt
END IF
END FUNCTION 'NoteName$
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ RETURN ARRAY POSITION OF A TARGET TONE
FUNCTION NotePosition% (arr() AS tone, tar AS tone)
DIM ft$, gt$, x%
ft$ = tar.nt + tar.bf + tar.bs
DO
gt$ = arr(x%).nt + arr(x%).bf + arr(x%).bs
IF ft$ = gt$ THEN
NotePosition% = x%: EXIT FUNCTION
END IF
x% = x% + 1
LOOP UNTIL x% = UBOUND(arr) + 1
END FUNCTION 'NotePosition
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ CLEAR ALL NOTE PICKS
SUB Note_Zero
DIM s%, x%, c%
Rtog picked ' no notes picked
Rtog scale_on ' scale absent
Rtog chordset ' no chords selected
FOR s% = 7 TO 13
Rtog s%
NEXT s%
IF NOT Vtog%(mode_lock) THEN ' if not scale locked
ResetScale ' reset to Ionian
FOR x% = 0 TO 6
IF Vtog%(x%) THEN Ttog x% ' clear all scale ID bits
NEXT x%
Stog 0 ' Reset to Ionian scale
END IF
tonic.nt = "" ' blank tonic note
tonic.bs = ""
tonic.bf = ""
FOR c% = 0 TO 56 ' blank all note choices
note(c%).sd = 0
note(c%).c = 0
note(c%).ft = NoteName(note(c%))
NEXT c%
END SUB 'Note_Zero
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ MOVE BY INTERVAL {ad}
FUNCTION Pfifth% (v AS INTEGER, ad AS INTEGER)
DIM v1
v1 = v + ad
Pfifth% = v1 + 12 * (v1 >= 12) - 12 * (v1 < 0)
END FUNCTION 'Pfifth%
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ ARROW INDICATOR
SUB RegionArrow (r AS region, ori AS STRING, fill AS STRING, col AS _UNSIGNED LONG)
DIM c&
DIM AS V2 pt, pl, pr, m
c& = _NEWIMAGE(1, 1, 32)
_DEST c&
CLS , col
_DEST 0
CentRg m, r
SELECT CASE LCASE$(ori)
CASE "u" ' Arrow UP
IF fill = "full" THEN m.y = r.lr.y
pt.x = m.x: pt.y = r.ul.y
pl.x = r.ul.x: pl.y = m.y
pr.x = r.lr.x: pr.y = m.y
CASE "r" ' Arrow RIGHT
IF fill = "full" THEN m.x = r.ul.x
pt.x = r.lr.x: pt.y = m.y
pl.x = m.x: pl.y = r.ul.y
pr.x = m.x: pr.y = r.lr.y
CASE "d" ' Arrow DOWN
IF fill = "full" THEN m.y = r.ul.y
pt.x = m.x: pt.y = r.lr.y
pl.x = r.lr.x: pl.y = m.y
pr.x = r.ul.x: pr.y = m.y
CASE "l" ' Arrow LEFT
IF fill = "full" THEN m.x = r.lr.x
pt.x = r.ul.x: pt.y = m.y
pl.x = m.x: pl.y = r.lr.y
pr.x = m.x: pr.y = r.ul.y
END SELECT
_MAPTRIANGLE (0, 0)-(0, 0)-(0, 0), c& TO(pl.x, pl.y)-(pt.x, pt.y)-(pr.x, pr.y)
_FREEIMAGE c&
END SUB 'RegionArrow
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ HIGHLIGHT BUTTON EDGE
SUB RegionRing (r AS region, col AS _UNSIGNED LONG, t AS INTEGER)
DIM b%, c%, clr&
b% = t \ 3
FOR c% = 0 TO t - 1
IF c% < b% OR c% = t - 1 THEN clr& = Black ELSE clr& = col
LINE (r.ul.x + c%, r.ul.y + c%)-(r.lr.x - c%, r.lr.y - c%), clr&, B
NEXT c%
END SUB 'RegionRing
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ RESET TO IONIAN/MAJOR SCALE
SUB ResetScale
$CHECKING:OFF
DIM AS _MEM m, s
m = _MEM(masterscale())
s = _MEM(scale())
_MEMCOPY m, m.OFFSET, m.SIZE TO s, s.OFFSET
_MEMFREE m: _MEMFREE s
$CHECKING:ON
END SUB 'ResetScale
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ RESET TOGS BIT b
SUB Rtog (b AS INTEGER)
togs = _RESETBIT(togs, b)
END SUB 'Rtog
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ SET TOGS BIT b
SUB Stog (b AS INTEGER)
togs = _SETBIT(togs, b)
END SUB 'Stog
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ TOGGLE TOGS BIT b
SUB Ttog (b AS INTEGER)
togs = _TOGGLEBIT(togs, b)
END SUB 'Ttog
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ VIEW TOGS BIT b
FUNCTION Vtog% (b AS INTEGER)
Vtog% = _READBIT(togs, b)
END FUNCTION 'Vtog%
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ ROTATE SCALE ARRAYS {MEM BASED}
SUB RotArrayM (arr() AS _BYTE, rt%)
DIM cr1%, cr2%, bl%&, sr%&, sl%&
IF rt% = 0 THEN EXIT SUB
cr1% = ABS(rt%): cr2% = 0
$CHECKING:OFF
DIM AS _MEM ar, t
ar = _MEM(arr()): t = _MEMNEW(cr1%)
bl%& = ar.SIZE - cr1%
sr%& = -(rt% > 0) * bl%& ' Rotate right=TRUE rotate left=FALSE {start right}
sl%& = -(rt% < 0) * bl%& ' Rotate right=FALSE rotate left=TRUE {start left}
_MEMCOPY ar, ar.OFFSET + sr%&, cr1% TO t, t.OFFSET ' pop right or left rt% bytes to temp storage
IF sr%& = 0 THEN SWAP cr1%, cr2% ' if left shift swap offsets
_MEMCOPY ar, ar.OFFSET + cr2%, bl%& TO ar, ar.OFFSET + cr1% 'shift remainder block right or left {if swapped}
IF sr%& = 0 THEN SWAP cr1%, cr2% ' if left shift re-swap offsets
_MEMCOPY t, t.OFFSET, cr1% TO ar, ar.OFFSET + sl%& ' push temp storage to opposite end from pop
_MEMFREE ar: _MEMFREE t
$CHECKING:ON
END SUB 'RotArrayM
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ CREATE NOTE SCALE
SUB Scale_Run
DIM d%, x%, p%, n%
DIM sc(11) AS _BYTE ' local scale array
DIM AS _MEM sg, sl
sg = _MEM(scale()): sl = _MEM(sc())
_MEMCOPY sg, sg.OFFSET, sg.SIZE TO sl, sl.OFFSET ' copy from global scale
_MEMFREE sg: _MEMFREE sl
sclcol = defcol
d% = 1 ' set initial degree counter to tonic
FOR x% = 0 TO 11 ' populate scale array with scale degrees {1-7} & index tonic
IF sc(x%) THEN sc(x%) = d%: d% = d% + 1 ' set scale degree & increment to next; supertonic, mediant, etc.
NEXT x%
RotArrayM sc(), NotePosition%(note(), tonic) ' rotate the local scale to align with tonic in note array
p% = 0
FOR n% = 0 TO 56 ' distribute local array across note array
IF sc(p%) THEN
note(n%).sd = sc(p%) ' set note scale degree
note(n%).c = sclcol ' and color
Stog picked ' set picked note TRUE
END IF
p% = p% + 1 ' advance scale with note array loop
IF p% = 12 THEN p% = 0 ' reset scale if beyond upper bound
NEXT n%
END SUB 'Scale_Run
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ SEARCH FOR MATCHING TONE SINGLY OR ALL OCTAVES
SUB SearchNote (mode AS INTEGER, t AS tone)
DIM s%
IF Vtog(oct_sing) THEN ' search all octave examples
s% = NotePosition%(note(), t) '
DO
IF mode THEN ' mode: add note = TRUE
IF note(s%).sd = 0 THEN note(s%).sd = TRUE ' only set if not in a scale (keep scale degrees)
note(s%).c = defcol ' change color regardless
Stog picked
ELSE ' mode: remove note = FALSE
note(s%).sd = FALSE ' clear this note
note(s%).c = 0 ' and reset its color
END IF
s% = s% + 12 ' jump to next octave
LOOP UNTIL s% > 56
ELSE ' search only matching octave
IF mode THEN
IF t.sd = 0 THEN t.sd = TRUE
t.c = defcol
Stog picked
ELSE
t.sd = FALSE
t.c = 0
END IF
END IF
END SUB 'SearchNote
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ CREATE CHROMATIC TONE ARRAY
SUB SetNote (q() AS tone)
DIM nt$, x%, deg%, ni%, H!, c%
DIM AS SINGLE Hz(11) ' base cycle array
Hz(0) = 32.7: Hz(1) = 34.65: Hz(2) = 36.71 ' C, C#, D
Hz(3) = 38.9: Hz(4) = 41.2: Hz(5) = 43.65 ' D#, E, F
Hz(6) = 46.25: Hz(7) = 49: Hz(8) = 51.91 ' F#, G, G#
Hz(9) = 55: Hz(10) = 58.27: Hz(11) = 61.74 ' A, A#, B
nt$ = "CDEFGAB" ' cardinal note string
FOR x% = 0 TO UBOUND(q) ' iterate full tone array
deg% = x% MOD 12 ' compute chromatic degree from C=0
SELECT EVERYCASE deg%
CASE 0, 2, 4, 5, 7, 9, 11 ' white key cardinal notes {C D E F G A B}
ni% = ni% + 1 ' increment note name index
IF ni% = 8 THEN ni% = 1 ' keep index in 1-7 range
q(x%).nt = MID$(nt$, ni%, 1) ' set natural note name
q(x%).ac = FALSE ' note is not an accidental
H! = Hz(deg%)
CASE 4, 11 ' E, B flats
c% = -(deg% = 11) - (ni% + 1) * (deg% = 4) ' B(11) sets a 1 : E(4) sets to next name index
q(x%).bf = MID$(nt$, c%, 1) + "b"
CASE 0, 5 ' C, F sharps
c% = -7 * (deg% = 0) - (ni% - 1) * (deg% = 5) ' C(0) sets last name index : F(5) sets previous index
q(x%).bs = MID$(nt$, c%, 1) + "#"
CASE 1, 3, 6, 8, 10 ' black key accidental notes {C# D# F# G# A#}
q(x%).nt = "*"
q(x%).bs = MID$(nt$, ni%, 1) + "#" ' sharp name
q(x%).bf = MID$(nt$, ni% + 1, 1) + "b" ' flat name
q(x%).ac = TRUE ' note is an accidental
H! = Hz(deg%)
END SELECT
q(x%).oc = x% \ 12 + 1
q(x%).hz = CINT(H! * (2 ^ q(x%).oc)) ' calculate tone cycles
q(x%).indx = x%
NEXT x%
END SUB 'SetNote
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ SELECT SHARP/FLAT KEY BIAS
SUB Signature (k%)
DIM x%
FOR x% = 0 TO 6
IF Vtog(x%) THEN EXIT FOR
NEXT x%
SELECT CASE x%
CASE 0:
SELECT CASE k% ' Ionian/Major
CASE 1, 3, 5, 6, 8, 10: Stog shrp_flt
CASE 0, 2, 4, 7, 9, 11: Rtog shrp_flt
END SELECT
CASE 1:
SELECT CASE k% ' Dorian
CASE 0, 1, 3, 5, 7, 8, 10: Stog shrp_flt
CASE 2, 4, 6, 9, 11: Rtog shrp_flt
END SELECT
CASE 2:
SELECT CASE k% ' Phrygian
CASE 0, 2, 3, 5, 7, 9, 10: Stog shrp_flt
CASE 1, 4, 6, 8, 11: Rtog shrp_flt
END SELECT
CASE 3:
SELECT CASE k% ' Lydian
CASE 1, 3, 6, 8, 10, 11: Stog shrp_flt
CASE 0, 2, 4, 5, 7, 9: Rtog shrp_flt
END SELECT
CASE 4:
SELECT CASE k% ' Mixolydian
CASE 0, 1, 3, 5, 6, 8, 10: Stog shrp_flt
CASE 2, 4, 7, 9, 11: Rtog shrp_flt
END SELECT
CASE 5:
SELECT CASE k% ' Aeolian/Minor
CASE 0, 2, 3, 5, 7, 8, 10: Stog shrp_flt
CASE 1, 4, 6, 9, 11: Rtog shrp_flt
END SELECT
CASE 6:
SELECT CASE k% ' Locrian
CASE 0, 2, 4, 5, 7, 9, 10: Stog shrp_flt
CASE 1, 3, 6, 8, 11: Rtog shrp_flt
END SELECT
END SELECT
END SUB 'Signature
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ HIGHLIGHT SCALE/NOTE FRET POSITIONS
FUNCTION SpotFret% (st AS INTEGER, fr AS INTEGER)
DIM sr%, y%, a%, x%, r%, ps%, c~&, rr%, f
sr% = _HEIGHT(fb&) / 6 ' string range
y% = neckdown% + st * sr% + (sr% / 2) ' string position
IF fr = 0 THEN
a% = capo%
x% = nut% - .5 * sr% ' open string position
r% = .4 * sr%
ELSEIF fr > capo% THEN
a% = 0
x% = nut% + fr * Fret_Wide% - ((bridge% - nut%) / 48) ' fret position
r% = .5 * sr%
END IF
ps% = frets(st, fr) + a%
IF note(ps%).sd <> 0 THEN ' note chosen either scale or individually
SpotFret% = TRUE
c~& = note(ps%).c
IF note(ps%).sd = 1 THEN ' note is a scale tonic
DIM AS _UNSIGNED LONG rred, grn, blu, alf
rred = _RED32(c~&): grn = _GREEN32(c~&): blu = _BLUE32(c~&)
alf = _ALPHA32(c~&)
FOR rr% = r% TO 0 STEP -1 ' draw hemi gradient for tonic note
f = 1 - SIN((rr% * .5) / r%)
IF f > 1 THEN f = 1
FCirc x%, y%, rr%, _RGBA32(rred * f, grn * f, blu * f, alf)
CIRCLE (x%, y%), r%, Black
NEXT
ELSE ' note single or scale degree 2-7
FCirc x%, y%, r%, c~&
CIRCLE (x%, y%), r%, Black ' add contrast border
IF note(ps%).sd <> -1 THEN ' note a non-root scale degree
Divisions x%, y%, r%, note(ps%).sd, note(ps%).c
END IF
END IF
ELSE
SpotFret% = FALSE
END IF
END FUNCTION 'SpotFret%
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ DEFINE CLEAN STAFF IMAGE
SUB Staff
DIM y%, sp%, gc$, fc$, x%
_DEST st&
CLS , PapayaWhip 'White
y% = _HEIGHT(st&) * .45
sp% = _HEIGHT(st&) * .05
gc$ = "FEDCBAGFE"
fc$ = "AGFEDCBAG"
COLOR Green
_PRINTMODE _KEEPBACKGROUND
FOR x% = 0 TO 4
IF x% < 4 THEN
LINE (_WIDTH * .01, y% + (sp% * x%))-(_WIDTH(st&) * .02, y% + sp% + (sp% * x%)), Black, BF
LINE (_WIDTH * .01, y% + (sp% * (x% + 6)))-(_WIDTH(st&) * .02, y% + sp% + (sp% * (x% + 6))), Black, BF
_PRINTSTRING (_WIDTH - 25, y% + (sp% * x%)), _TRIM$(MID$(gc$, (x% * 2) + 2, 1))
_PRINTSTRING (_WIDTH - 25, y% + (sp% * (x% + 6))), _TRIM$(MID$(fc$, (x% * 2) + 2, 1))
END IF
LINE (_WIDTH * .01, y% + (sp% * x%))-(_WIDTH(st&), y% + (sp% * x%)), Black, BF
LINE (_WIDTH * .01, y% + (sp% * (x% + 6)))-(_WIDTH(st&), y% + (sp% * (x% + 6))), Black, BF
_PRINTSTRING (_WIDTH - 15, y% + (sp% * x%) - 8), _TRIM$(MID$(gc$, (x% * 2) + 1, 1))
_PRINTSTRING (_WIDTH - 15, y% + (sp% * (x% + 6)) - 8), _TRIM$(MID$(fc$, (x% * 2) + 1, 1))
NEXT x%
COLOR White
FOR x% = -1 TO -8 STEP -1 ' short ledgers
LINE (_WIDTH / 2 - 20, y% + (sp% * x%))-(_WIDTH(st&) - 1, y% + (sp% * x%)), Gray, , &HFF00 ' gray dotted upper registers
NEXT x%
Image_Resize 0, _HEIGHT(st&) * .325, _WIDTH(st&) - 1, _HEIGHT(st&) * 1.075, clefp&, st&, "l", "c"
_FREEIMAGE clefp&
_DEST 0
END SUB 'Staff
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ NOTATE GRANDSTAFF
SUB Stafftmp (a%, t AS tone)
DIM radius%, sp$, ad%, nf%, k%, c&, fs$, ac$, s&, x%, acc%, wd%, ht%, foff%
DIM b%, sig$, sig%, np%, lp%, x1%, x2%, y1%, y2%
radius% = _HEIGHT(st&) * 0.025
IF a% THEN ' noted staff
_DEST sttmp&
_PUTIMAGE , st& ' grand staff underlay
sp$ = LEFT$(t.ft, 2)
IF sp$ = "Cb" THEN ad% = 0 ELSE ad% = 1 ' trap Cb1 wrong staff position
IF sp$ = "B#" THEN ad% = 2 ' trap B# octave lift
nf% = INSTR("CDEFGAB", LEFT$(sp$, 1)) - 1
k% = _HEIGHT(st&) * (.875 - (t.oc - ad%) * .176 - nf% * 0.025) + 1
IF MID$(sp$, 2, 1) <> "" THEN
c& = _DEFAULTCOLOR
COLOR Black
_PRINTMODE _KEEPBACKGROUND
_PRINTSTRING (_WIDTH / 2 - 16, k% - 16), MID$(sp$, 2, 1)
COLOR c&
END IF
FCirc _WIDTH / 2, k%, radius%, Black ' display chosen tone
IF t.indx = 12 AND sp$ <> "B#" THEN ' if middle C then draw line
LINE (_WIDTH / 2 - radius% * 1.5, k% - 1)-(_WIDTH / 2 + radius% * 1.5, k% + 1), Black, BF
END IF
ELSE ' clean staff
_DEST sttmp&
_PUTIMAGE , st& ' overlay clean staff image
END IF
IF Vtog(scale_on) THEN ' SCALE MODE- display key signature
COLOR Black
IF Vtog(shrp_flt) THEN ' add flats
fs$ = "Bb2Eb3Ab2Db3Gb2Cb3Fb2": ac$ = "b": s& = flat&
ELSE ' add sharps
fs$ = "F#3C#3G#3D#3A#2E#3B#2": ac$ = "#": s& = sharp&
END IF
DO
IF note(x% + 12).sd > 0 AND MID$(note(x% + 12).ft, 2, 1) = ac$ THEN acc% = acc% + 1
x% = x% + 1
LOOP UNTIL x% = 12
wd% = _HEIGHT(st&) * .05 ' let width equal line spacing
ht% = _SHL(wd%, 1) ' double that for height
foff% = _HEIGHT(st&) * .350 ' F clef offset
_PRINTMODE _KEEPBACKGROUND
FOR b% = 1 TO acc%
sig$ = MID$(fs$, 3 * (b% - 1) + 1, 3)
sig% = VAL(MID$(sig$, 3, 1))
np% = INSTR("CDEFGAB", LEFT$(sig$, 1)) - 1
lp% = _HEIGHT(st&) * (.875 - ((sig% - 1) * .176) - (np% * 0.025))
x1% = b% * (wd% * .75) + _WIDTH(st&) * .15
x2% = x1% + wd%
y1% = lp% - (ht% * .75)
y2% = lp% + (ht% * .25)
Image_Resize x1%, y1%, x2%, y2%, s&, sttmp&, "c", "c" 'place G clef signature
Image_Resize x1%, y1% + foff%, x2%, y2% + foff%, s&, sttmp&, "c", "c" 'place F clef signature
NEXT b%
COLOR White
END IF
_DEST 0
END SUB 'Stafftmp
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ APPLY FRETBOARD NOTE NAMES
SUB Fret_Name
DIM flat%, ntf%, onscl%, n%, look%, adj%, scale%, n$, t$
flat% = Vtog(shrp_flt): ntf% = NOT flat%
onscl% = Vtog(scale_on)
FOR n% = 0 TO 56 ' iterate the main note array
scale% = note(n%).sd > 0
n$ = NoteName(note(n%)) ' set a standard mode name until otherwise indicated
IF onscl% AND scale% THEN ' if scale mode on & note in scale
look% = (11 * (n% = 0) + (n% - 1) * (n% > 0)) * flat% + ((n% + 1) * (n% < 56) + (n% - 11) * (n% = 56)) * ntf%
adj% = note(look%).sd > 0
IF adj% AND LEFT$(n$, 1) = LEFT$(NoteName(note(look%)), 1) THEN 'check for duplicate note name if adjacent
IF flat% THEN t$ = note(n%).bf ELSE t$ = note(n%).bs 'set alternate note name
IF t$ <> "" THEN n$ = t$
END IF ' end: adjacent in scale & duplicate name test
END IF ' end: scale mode & note in scale test
note(n%).ft = n$ ' set fret display note name in array element
NEXT n%
END SUB 'Fret_Name
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ APPLY NOTES TO FRETBOARD
SUB String_Notes
DIM dfc&, fr_rng%, st_rng%, st_ps%, st%, fr%, az%, xp%, ps%, nf$, j%
dfc& = _DEFAULTCOLOR
COLOR Aqua
fr_rng% = Fret_Wide%
st_rng% = (_HEIGHT(fb&) - 1) / 6
Fret_Name
FOR st% = 0 TO 5 ' iterate through strings
st_ps% = st_rng% * st% + (_SHR(st_rng%, 1))
FOR fr% = 0 TO fretmax% ' iterate through frets of string st%
IF fr% = 0 THEN
az% = capo%: xp% = nut% - (_SHR(fr_rng%, 1)) - 8
ELSE
az% = 0: xp% = nut% + (fr% * fr_rng%) - (_SHR(fr_rng%, 1)) - 4
END IF
ps% = frets(st%, fr% + az%)
nf$ = _TRIM$(note(ps%).ft) + _TRIM$(STR$(note(ps%).oc)) 'add octave ID
IF Vtog%(picked) THEN j% = SpotFret%(st%, fr%) '
IF Vtog%(all_nat) AND note(ps%).ac THEN _CONTINUE
IF fr% = 0 OR fr% > capo% THEN ' print all not behind capo
IF Vtog%(hide_show) THEN _PRINTSTRING (xp% + (8 * Vtog%(scale_on)), st_ps% + neckdown% - 4), nf$
END IF
NEXT fr% ' next fret
NEXT st% ' next string
COLOR dfc&
END SUB 'String_Notes
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ DISPLAY SCALE INFO
SUB Circle_of_Fifth
DIM in%, rds%, rdf%, rdc%, rhf%, i%, tc!, ts!, pc, tx%, ty%, pi6!
DIM ps!, hi%, n$, ox%, oy%, ks$, dcl&, pin%(3), m%
DIM AS V2 cen
in% = 9 ' starting at 3 o'clock
dcl& = _DEFAULTCOLOR
CentRg cen, bt(20).r
rds% = cen.x * outring ' outer note ring
rdf% = cen.x * inring ' inner note ring
rdc% = cen.x * .3 ' clear all ring
rhf% = (rds% - rdf%) / 2 ' half ring offset
LINE (bt(20).r.ul.x, bt(20).r.ul.y)-(bt(20).r.lr.x, bt(20).r.lr.y), &H7F7F7F7F, B
CIRCLE (cen.x, cen.y), rdc%, Red
CIRCLE (cen.x, cen.y), rds%, Red: CIRCLE (cen.x, cen.y), rds% + 2, Blue
CIRCLE (cen.x, cen.y), rdf%, Red
pin%(0) = WhatMode% * 2 + (WhatMode% > 2)
pin%(1) = Pfifth%(pin%(0), 1)
pin%(2) = Pfifth%(pin%(1), 5)
pin%(3) = Pfifth%(pin%(2), 5)
FOR i% = 0 TO 11
pi6! = .523598 * i%
tc! = COS(pi6!): ts! = SIN(pi6!) ' text point angle _PI / 6 = .523598
pc! = COS(pi6! - .261799): ps! = SIN(pi6! - .261799) ' dividing line angle _PI / 12 = .261799
tx% = cen.x + (rhf% + rdf%) * tc! ' text center x
ty% = cen.y + (rhf% + rdf%) * ts! ' text center y
hi% = in% + 12
n$ = NoteName$(note(hi%))
IF Vtog%(scale_on) THEN ' if scale chosen
m% = 0
DO
IF pin%(m%) = in% THEN
COLOR Lime
EXIT DO
END IF
m% = m% + 1
LOOP UNTIL m% = 4
IF NoteName$(tonic) = n$ THEN ' if note is tonic
FCirc tx%, ty%, 15, Gray ' mark it
END IF
ox% = cen.x + (rdf% - rhf%) * tc! ' object center x
oy% = cen.y + (rdf% - rhf%) * ts! ' object center y
IF Vtog%(shrp_flt) THEN ks$ = "b" ELSE ks$ = "#"
IF note(hi%).sd > 0 THEN
IF note(hi%).nt = "*" OR note(hi%).ft = "Cb" OR note(hi%).ft = "E#" OR note(hi%).ft = "B#" OR note(hi%).ft = "Fb" THEN
IF note(hi%).ft = "Cb" THEN n$ = "Cb"
IF note(hi%).ft = "E#" THEN n$ = "E#"
IF note(hi%).ft = "B#" THEN n$ = "B#"
IF note(hi%).ft = "Fb" THEN n$ = "Fb"
FCirc ox%, oy%, 10, Red
ELSE
FCirc ox%, oy%, 10, Blue
END IF
Divisions ox%, oy%, 10, note(hi%).sd, Black
END IF
END IF
_PRINTSTRING (tx% - (4 * LEN(n$)), ty% - 8), n$ ' print note in note ring position
COLOR dcl&
LINE (cen.x + rdf% * pc!, cen.y + rdf% * ps!)-(cen.x + rds% * pc!, cen.y + rds% * ps!), Red
in% = Pfifth%(in%, -5)
NEXT i%
_PRINTSTRING (cen.x - 36, cen.y - 8), "Clear All"
IF Vtog%(mode_lock) THEN
COLOR Red
_PRINTSTRING (cen.x - 36, cen.y - (cen.x * .4)), "Mode Lock"
COLOR dcl&
END IF
END SUB 'Circle_of_Fifth
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ VECTOR ADDITION
SUB R2_Add (re AS V2, se AS V2, m AS INTEGER)
re.x = re.x + se.x * m
re.y = re.y + se.y * m
END SUB 'R2_Add
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ COMMENTS AND NOTES
SUB Theory
' I II III IV V VI VII I
'tonic, supertonic, mediant, subdominant, dominant, submediant, leading and tonic.
'KEY #SHARP/FLAT SHARP/FLAT LIST I ii iii IV V vi vii RELATIVE MINOR
'C# major 7 sharps F#-C#-G#-D#-A#-E#(F)-B#(C) C#- D#- E#(F)- F#- G#- A#- B#(C)
'F# major 6 F#-C#-G#-D#-A#-E#(F) F#- G#- A#- B- C#- D#- E#(F)
'B major 5 F#-C#-G#-D#-A# B- C#- D#- E- F#- G#- A# Ab minor
'E major 4 F#-C#-G#-D# E- F#- G#- A- B- C#- D# Db minor
'A major 3 F#-C#-G# A- B- C#- D- E- F#- G# Gb minor
'D major 2 F#-C# D- E- F#- G- A- B- C# B minor
'G major 1 F# G- A- B- C- D- E- F# E minor
'C major - C- D- E- F- G- A- B A minor
'F major 1 flat Bb F- G- A- Bb- C- D- E D minor
'Bb major 2 Bb-Eb Bb- C- D- Eb- F- G- A G minor
'Eb major 3 Bb-Eb-Ab Eb- F- G- Ab- Bb- C- D C minor
'Ab major 4 Bb-Eb-Ab-Db Ab- Bb- C- Db- Eb- F- G F minor
'Db major 5 Bb-Eb-Ab-Db-Gb Db- Eb- F- Gb- Ab- Bb- C Bb minor
'Gb major 6 Bb-Eb-Ab-Db-Gb-Cb(B) Gb Ab Bb Cb(B)- Db Eb F Eb minor
'Cb major 7 Bb-Eb-Ab-Db-Gb-Cb(B)-Fb(E) Cb(B)- Db- Eb- Fb(E)- Gb- Ab- Bb Ab minor
'INTERVALS
'0 perfect unison
'1 minor 2nd...............semitone
'2 major 2nd...............tone
'3 minor 3rd
'4 major 3rd
'5 perfect 4th
'6 aug 4th/dim 5th.........tritone
'7 perfect 5th
'8 minor 6th
'9 major 6th
'10 minor 7th
'11 major 7th
'12 octave
'MNEMONICS
'Father Charles Goes Down And Ends Battle
'Battle Ends And Down Goes Charles Father
END SUB 'Theory
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ CLEAR CHORD COLOR
SUB UnChord
DIM x%
FOR x% = 0 TO 56
IF note(x%).sd > 0 THEN
note(x%).c = sclcol
END IF
NEXT x%
END SUB 'UnChord
'ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ
FUNCTION WhatMode%
DIM x%
FOR x% = 0 TO 6
IF Vtog%(x%) THEN EXIT FOR
NEXT x%
WhatMode% = x%
END FUNCTION 'WhatMode%
DO: LOOP: DO: LOOP
sha_na_na_na_na_na_na_na_na_na:
sha_na_na_na_na_na_na_na_na_na: