"
tdb x = td $ "" ++ x ++ ""
showi :: Interval -> String
showi (a,b) = (show a) ++ ":" ++ (show b)
mapi f xs =
go xs 0
where
go [] _ = []
go (x:xs) i = (f x i) : go xs (i+1)
tr intervals bolds =
"
" ++ (unwords $ mapi f intervals) ++ "
"
where
f x i | i `elem` bolds = tdb $ showi x
| otherwise = td $ showi x
textify :: Interval -> String
textify (a,b) = printf "%4s:%-3s" (show a) (show b)
textify_color :: Interval -> Int -> String
textify_color (a,b) i = printf "\x1b[%dm%4s:%-3s\x1b[0m" i (show a) (show b)
--textify (a,b) = (show a) ++ ":" ++ (show b) ++ " "
texttr intervals = concat (map textify intervals)
tables intervals strings = tablesBolds intervals strings [0,17]
tablesBolds intervals strings bolds =
unlines $ map (\x-> tr (map (stack x) intervals) bolds) (reverse strings)
texttables intervals strings =
unlines $ map (\x-> texttr (map (stack x) intervals)) strings
--limitfilter (a,b) = a <= 45 && b <= 15
limitfilter :: Interval -> Bool
limitfilter (a,b) = (not $ mod a 81 == 0) && (not $ mod b 27 == 0)
rotatepc :: [Interval] -> Interval -> [Interval]
rotatepc xs ival =
map (\x -> pitchclass $ stack x ival) xs
scalefilter :: [Interval] -> Interval -> Bool
scalefilter pcs ival =
elem (pitchclass ival) pcs
genstringscale :: [Interval] -> [Interval] -> [Interval]
genstringscale scale strings =
let swap (a,b) = (b,a)
candidates = [candidate | string <- strings,
note <- scale,
let candidate = stack note (swap string),
-- scalefilter scale candidate,
compareIval (1,1) candidate /= GT,
compareIval candidate (2,1) /= GT
]
in
nub $ sortBy compareIval candidates
chapmanfrets = genstringscale just16 chapman_strings
scaledouble :: [Interval] -> [Interval]
scaledouble xs =
nub $ xs ++ (map (stack (2,1)) xs)
pitchclass (a,b)
| a < b = pitchclass (2*a, b)
| a >= 2*b = pitchclass (a, 2*b)
| otherwise = normalize (a,b)
texttr_color intervals greysp highlights =
concat (map f intervals)
where
f note = if not $ greysp note
then printf "%4s-%3s" "" "" --textify_color note 32
else
if elem (pitchclass note) highlights
then textify_color note 1
else textify_color note 0
texttables_color intervals strings greysp highlights =
unlines $ reverse $ map (\x -> texttr_color (map (stack x) intervals) greysp (map pitchclass highlights)) (reverse strings)
showln x = (show x) ++ "\n"
stack :: Interval -> Interval -> Interval
stack (a1,b1) (a2,b2) = normalize (a1*a2, b1*b2)
unstack :: Interval -> Interval -> Interval
unstack (a1,b1) (a2,b2) = normalize (a1*b2, b1*a2)
majortriad :: Interval -> [Interval]
majortriad x = map (stack x) [unison, majthird, fifth]
major7 :: Interval -> [Interval]
major7 x = map (stack x) [unison, majthird, fifth, (15,8)]
majordom7 :: Interval -> [Interval]
majordom7 x = map (stack x) [unison, majthird, fifth, (7,4)]
minortriad :: Interval -> [Interval]
minortriad x = [x, stack x minthird, stack x fifth]
superchord :: Interval -> [Interval]
superchord x = map (stack x) [(1,1), (3,2), (5,2), (7,4), (15,8), (2,1), (9,4), (11,8), (13,8), (17,8), (19,16)]
msuperchord x = map (stack x) [majthird, fifth, (15,8), (7,4), (9,8), (11,8), (13,8), (17,8), (19,16)]
type Interval = (Int,Int)
{-
instance Ord Interval where
compare a b = compare (fretpos a) (fretpos b)
-}
data Ival = Ival Int Int deriving (Eq, Ord, Show)
intervalToIval (a,b) = Ival a b
ivalToInterval (Ival a b) = (a,b)
--instance Eq Interval where
-- (==) a b = same a b
-- Instance doesn't work, because it overlaps with Ord definition in prelude.
-- compareIval a b = compare (fretpos a) (fretpos b)
compareIval :: Interval -> Interval -> Ordering
compareIval (a1, b1) (a2, b2) = compare (a1*b2) (a2*b1)
unison = (1,1) :: Interval
minsecond = (16,15) :: Interval
submajsecond = (10,9) :: Interval
majsecond = (9,8) :: Interval
minthird = (6,5) :: Interval
majthird = (5,4) :: Interval
fourth = (4,3) :: Interval
tritone = (7,5) :: Interval
fifth = (3,2) :: Interval
minsixth = (8,5) :: Interval
majsixth = (5,3) :: Interval
minseventh = (16,9) :: Interval
gminseventh = (9,5) :: Interval
majseventh = (15,8) :: Interval
octave = (2,1) :: Interval
majscale = [unison, majsecond, majthird, fourth, fifth, majsixth, majseventh, octave]
chromscale = [unison, minsecond, submajsecond, majsecond, minthird, majthird, fourth, tritone, fifth, minsixth, majsixth, minseventh, gminseventh, majseventh, octave]
invert (1,1) = (1,1)
invert (a,b) = normalize (2*b,a)
minscale = map invert (reverse majscale)
nthharmonic n (a,b) = normalize (n*a, b)
harmonics x = map (\n -> nthharmonic n x) [1..]
sumtone (a1,a2) (b1,b2) = normalize (a1*b2 + b1*a2, a2*b2)
diftone (a1,a2) (b1,b2) = normalize (abs $ a1*b2 - b1*a2, a2*b2)
sumtones xs = nub $ allpairs sumtone xs
diftones xs = nub $ allpairs diftone xs
sumdiftones xs = nub $ (sumtones xs) ++ (diftones xs)
allpairs f [] = []
allpairs f (x:xs) = (map (f x) xs) ++ (allpairs f xs)
-- Keyboard stuff.
semitone = 2 ** (1/12)
cent = semitone ** (1/100)
emufine = semitone ** (1/64) -- emu proteus 2000 fine adjustment
emucn2 = 0 -- c-2
emucn1 = 12 -- c-1
emuc0 = 24 -- c0
emuc1 = 36 -- c1
emuc2 = 48 -- c2 is midi key 48
emuc3 = 60 -- c3
emuc4 = 72 -- c4 or middle c
emud3 = 62 -- we'll define this as 1:1; we choose d over middle c so that
-- we'll have a symmetrical keyboard.
midiNoteName n =
show $ (midiPitchClass n) ++ (show $ midiOctave n)
midiOctave n = (n `div` 12) - 2
midiPitchClass n =
case n `mod` 12 of
0 -> " C"
1 -> "C#"
2 -> " D"
3 -> "D#"
4 -> " E"
5 -> " F"
6 -> "F#"
7 -> " G"
8 -> "G#"
9 -> " A"
10 -> "A#"
11 -> " B"
_ -> error "shouldn't happen -- mod in haskell is sane"
-- Scale designed for keyboard, using 24 notes as the octave.
justKeyboard = (map (stack (1,8)) keyboard24) ++ keyboard24 ++ (map (stack (2,1)) keyboard24)
justKeyboardMidiNotes = [emud3..]
-- Produce a tuning table for EMU Proteus 2000.
genKeyboard =
let keys = zip justKeyboard justKeyboardMidiNotes
in
forM_
keys
(\(note, number) ->
putStrLn $ (show number) ++ " " ++ (midiNoteName number) ++ " " ++ (show $ noteToEmu note) ++ " -- " ++ (show note)
)
-- The EMU Proteus 2000 has a tuning table that expects pitch to be specified
-- as the 12-TET note + 64ths of a semitone.
noteToEmu :: Interval -> (Int, Int)
noteToEmu (a,b) =
go noteval 0 0
where
noteval = ((fromIntegral a) * (2**6)) / (fromIntegral b)
go (nv::Double) coarse fine
| nv < (1*emufine) = (coarse, fine)
| nv < (1*semitone) = go (nv/emufine) coarse (fine+1)
| otherwise = go (nv/semitone) (coarse+1) fine
-- Guess a ratio that best approximates a Doubleing point value.
notepicker :: Double -> Int -> Interval
notepicker freq max
| freq <= 0 = error "invalid frequency"
| freq > 2 = stack (2,1) (notepicker (freq/2) max)
| freq < 0.5 = stack (1,2) (notepicker (freq*2) max)
| otherwise = go (1,1) (1,1) 1
where
go (a,b) best leasterr =
if a > max || b > max
then best
else
let ratiofreq = notefreq (a,b)
err = (ratiofreq - freq) / freq
abserr = abs err
in
if err > 0
then if abserr < leasterr
then go (a, b+1) (a,b) abserr
else go (a, b+1) best leasterr
else if abserr < leasterr
then go (a+1, b) (a,b) abserr
else go (a+1, b) best leasterr
notefreq :: Interval -> Double
notefreq (a,b) = (fromIntegral a) / (fromIntegral b)
notecents :: Interval -> Double
notecents (a,b) = 1200 * (logBase 2 (fromIntegral a / fromIntegral b))
-- Svg representation of note locations in a scale.
-- Ghci likes to escape all the quotes, so to get a proper file,
-- you'll want to do: writeFile "foo" $ drawscale xs
drawscale :: [(String, Double)] -> String
drawscale xs =
"\n" ++
"\n" ++
"\n"
where
render (s, cents) =
let x = cents * (1000/1200)
in "\n"
styleWhite = "fill:rgb(255,255,255); stroke-width:1; stroke:rgb(255,255,255)"
styleBlack = "stroke:rgb(0,0,0); stroke-width:0.10"
styleGrey = "stroke:rgb(200,200,200); stroke-width:0.10"
styleRed = "stroke:rgb(255,0,0); stroke-width:0.10"
styleBlue = "stroke:rgb(0,0,100); stroke-width:0.10"
styleGreyFill = "stroke-width:0; fill:rgb(200,200,200)"
styleGreyOutline = "stroke-width:0.10; stroke:rgb(200,200,200); fill:rgb(255,255,255)"
styleColorFill w (sr,sg,sb) (fr,fg,fb) =
"stroke-width:" ++ (show w) ++ ";" ++
" stroke:rgb(" ++ (show sr) ++ "," ++ (show sg) ++ "," ++ (show sb) ++ ")" ++ ";" ++
" fill:rgb(" ++ (show fr) ++ "," ++ (show fg) ++ "," ++ (show fb) ++ ")" ++ ";"
white = (255,255,255)
lightgrey = (230,230,230)
grey = (200,200,200)
darkgrey = (100,100,100)
black = (0,0,0)
blue = (0,0,255)
red = (255,0,0)
green = (0,255,0)
magenta = (255,0,255)
cyan = (0,255,255)
styleKey = styleColorFill 0.1 red white
styleKeyCircle = styleColorFill 0.1 cyan white
styleSection = styleColorFill 0.1 blue lightgrey
styleConnection = styleColorFill 0.1 green white
styleOuterBorder = styleColorFill 0.1 magenta grey
type Pt2D = (Double, Double)
svgLine :: Pt2D -> Pt2D -> String -> String
svgLine (x1, y1) (x2, y2) style =
"\n"
svgLinePoly :: [Pt2D] -> String -> String
svgLinePoly xs style =
let lines = zip xs ((tail xs) ++ [head xs])
in concatMap (\(a,b) -> svgLine a b style) lines
svgCircle :: Pt2D -> Double -> String -> String
svgCircle (x, y) r style =
"\n"
svgLabel :: Interval -> Pt2D -> String
svgLabel (a,b) (x,y) =
"" ++
(show a) ++ "/" ++ (show b) ++ " " ++
"\n"
svgLabel2 :: Interval -> Pt2D -> String
svgLabel2 (a,b) (x,y) =
"" ++
(show a) ++ "/" ++ (show b) ++ " " ++
"\n"
centerText :: String -> Pt2D -> String
centerText s (x,y) =
"" ++
s ++ " " ++
"\n"
svgTag :: Interval -> Pt2D -> String
svgTag (a,b) (x,y) =
centerText ((show a) ++ "/" ++ (show b)) (x,y)
svgFraction :: Interval -> Pt2D -> String
svgFraction (a,b) (x,y) =
concat
[centerText (show a) (x, y-0.6),
svgLine (x-5,y) (x+5,y) styleKeyCircle,
centerText (show b) (x, y+3.5)]
svgPoly :: [Pt2D] -> String -> String
svgPoly pts style =
""
where
f (x,y) = (show x) ++ "," ++ (show y) ++ " "
ptAdd :: Pt2D -> Pt2D -> Pt2D
ptAdd (ax, ay) (bx, by) = (ax+bx, ay+by)
ptAdd3 :: Pt2D -> Pt2D -> Pt2D -> Pt2D
ptAdd3 (ax, ay) (bx, by) (cx, cy) = (ax+bx+cx, ay+by+cy)
ptScale :: Pt2D -> Double -> Pt2D
ptScale (x, y) scale = (x*scale, y*scale)
ptDiv :: Pt2D -> Double -> Pt2D
ptDiv pt x = ptScale pt (1/x)
ptMul :: Pt2D -> Pt2D -> Pt2D
ptMul (x1, y1) (x2, y2) = (x1*x2, y1*y2)
ptInterp :: Pt2D -> Double -> Pt2D -> Pt2D
ptInterp a scale b
| scale < 0 = error "ptInterp scale less than 0"
| scale > 1 = error "ptInterp: scale greater than 1"
| otherwise = ptAdd (ptScale a (1-scale)) (ptScale b scale)
ptMax :: Pt2D -> Pt2D -> Pt2D
ptMax (ax, ay) (bx, by) = (max ax bx, max ay by)
ptMin :: Pt2D -> Pt2D -> Pt2D
ptMin (ax, ay) (bx, by) = (min ax bx, min ay by)
ptLen :: Pt2D -> Double
ptLen (x,y) = sqrt $ (x*x) + (y*y)
ptLenSqr :: Pt2D -> Double
ptLenSqr (x,y) = (x*x) + (y*y)
ptSub :: Pt2D -> Pt2D -> Pt2D
ptSub (x1,y1) (x2,y2) = (x1-x2, y1-y2)
ptDist :: Pt2D -> Pt2D -> Double
ptDist a b = ptLen $ ptSub b a
ptDistX :: Pt2D -> Pt2D -> Double
ptDistX (x1,_) (x2,_) = abs $ x2-x1
ptDistY :: Pt2D -> Pt2D -> Double
ptDistY (_,y1) (_,y2) = abs $ y2-y1
ptNormalize :: Pt2D -> Pt2D
ptNormalize pt = ptScale pt (1 / ptLen pt)
ptDot :: Pt2D -> Pt2D -> Double
ptDot (x1,y1) (x2,y2) = x1*x2 + y1*y2
ptCross :: Pt2D -> Pt2D -> Double
ptCross (ax,ay) (bx, by) =
ax*by - ay*bx
clamp :: Double -> Double -> Double -> Double
clamp a b c
| a > b = a
| b > c = c
| otherwise = b
ptAngle :: Pt2D -> Pt2D -> Pt2D -> Double
ptAngle a b c =
let ba = ptNormalize $ ptSub a b
bc = ptNormalize $ ptSub c b
result = acos $ clamp (-1) (ptDot ba bc) 1
in
if result < 0 || result > pi
then error "something wrong"
else result
ptAngleCw :: Pt2D -> Double
ptAngleCw pt' =
let (x,y) = ptNormalize pt'
in atan2 x y
lineShrink :: Pt2D -> Pt2D -> Double -> Maybe (Pt2D, Pt2D)
lineShrink p1 p2 amnt =
if len <= amnt*2
then
Nothing
else
Just ((ptAdd p1 vscaled), (ptSub p2 vscaled))
where
v = ptSub p2 p1
len = ptLen v
vscaled = ptScale v (amnt/len)
delta :: Double
delta = 0.0000001
almostEq :: Pt2D -> Pt2D -> Bool
almostEq (x1,y1) (x2,y2) =
abs (x1-x2) < delta && abs (y1-y2) < delta
almostEqD :: Double -> Double -> Bool
almostEqD a b = abs (b - a) < delta
data Intersect = Intersect Pt2D | Miss | Parallel | ColinearDisjoint | Colinear | Same deriving (Eq, Ord, Show)
segmentIntersection' :: Bool -> (Pt2D, Pt2D) -> (Pt2D, Pt2D) -> Intersect
segmentIntersection' infinite (p,pr) (q,qs) =
let r = ptSub pr p
s = ptSub qs q
rxs = ptCross r s
sxr = -rxs
pq = ptSub q p
qp = ptSub p q
pqxs = ptCross pq s
qpxr = ptCross qp r
in
if almostEqD rxs 0
then
--paralel
if almostEqD qpxr 0
then
let t0 = ptDot pq r / ptDot r r
t1 = ptDot (ptSub (ptAdd q s) p) r / ptDot r r
in
if infinite || (t0 < 1 && t1 > 0) || (t1 < 1 && t0 > 0)
then
if (almostEq p q && almostEq pr qs) ||
(almostEq p qs && almostEq pr q)
then Same
else Colinear
else ColinearDisjoint
else
Parallel
else
let t = pqxs / rxs
u = qpxr / sxr
in
if infinite || (t > delta && t < (1-delta) && u > delta && u < (1-delta))
then
Intersect (ptAdd p (ptScale r t))
else
Miss
segmentIntersection = segmentIntersection' False
lineIntersection = segmentIntersection' True
ptInside :: Pt2D -> [Pt2D] -> Bool
ptInside pt poly =
let ray = (pt, ptAdd pt (0, 1000000.0))
sides = zip poly (tail poly ++ [head poly])
intersections = length $ mapMaybe (\x -> f $ segmentIntersection ray x) sides
f (Intersect i) = Just i
f _ = Nothing
in
(mod intersections 2) == 1
ptInsideCvx :: Pt2D -> [(Pt2D, Pt2D)] -> Bool
ptInsideCvx p sides =
foldl' (&&) True (map inside sides)
where
inside (p1, p2) =
let p1p2 = ptSub p2 p1
p1p = ptSub p p1
in
ptCross p1p2 p1p < delta
ptInterpN :: [(Pt2D, Double)] -> Pt2D
ptInterpN pts =
let wsum = sum (map snd pts)
in foldl1 ptAdd [ptScale pt (w/wsum) | (pt, w) <- pts]
ptInterp2 :: (Pt2D, Double) -> (Pt2D, Double) -> Pt2D
ptInterp2 a b = ptInterpN [a,b]
ptInterp3 :: (Pt2D, Double) -> (Pt2D, Double) -> (Pt2D, Double) -> Pt2D
ptInterp3 a b c = ptInterpN [a,b,c]
filternth :: (Int -> Bool) -> [a] -> [a]
filternth f xs =
go 0 [] xs
where
go n acc [] = reverse acc
go n acc (x:xs) =
if (f n)
then go (n+1) (x:acc) xs
else go (n+1) acc xs
pairwise :: [a] -> [(a,a)]
pairwise xs =
let len = length xs
pairs = [(a,b) | a <- xs, b <- xs]
in
filternth (\n -> not $ (mod n len) <= (div n len)) pairs
-- O(N^8) or so
delaunaySolver :: (Show a, Ord a) => Double -> [(a, Pt2D)] -> [(a,a)]
delaunaySolver maxlen cells =
let allpairs = filter (\((_,a),(_,b)) -> ptDist a b < maxlen) (pairwise cells)
allpairpairs = pairwise allpairs
longcrossings =
concatMap
(\lines@(((a1, apt1), (a2, apt2)), ((b1, bpt1), (b2, bpt2))) ->
case segmentIntersection (apt1, apt2) (bpt1, bpt2) of
Miss -> []
Parallel -> []
ColinearDisjoint -> []
Same -> trace "same" []
Intersect isect ->
let apt1angle = ptAngle bpt1 apt1 bpt2
apt2angle = ptAngle bpt1 apt2 bpt2
bpt1angle = ptAngle apt1 bpt1 apt2
bpt2angle = ptAngle apt1 bpt2 apt2
in
if abs ((apt1angle + apt2angle + bpt1angle + bpt2angle) - (2*pi)) > delta*10
then error $ printf "interior angles don't add up %f %f %f %f %s %s\n" apt1angle apt2angle bpt1angle bpt2angle (show lines) (show isect)
else
if isNaN apt1angle || isNaN apt2angle || isNaN bpt1angle || isNaN bpt2angle
then
if isNaN apt1angle || isNaN apt2angle
then trace "nan a" [] -- $ Just (a1,a2)
else trace "nan b" [] -- $ Just (b1,b2)
else
if apt1angle + apt2angle <= pi
then [(a1,a2)]
else if bpt1angle + bpt2angle <= pi + delta
then [(b1,b2)]
else error $ printf "shouldn't happen %f %f %f %f %s\n" apt1angle apt2angle bpt1angle bpt2angle (show lines)
Colinear ->
let len1 = ptLenSqr (ptSub apt1 apt2)
len2 = ptLenSqr (ptSub bpt1 bpt2)
in if len1 > len2
then [(a1,a2)]
else if len2 > len1
then [(b1,b2)]
else trace ("ovelapping equal-length segments " ++ (show lines)) [(a1,a2),(b1,b2)]
)
allpairpairs
--remainingpairs = deleteFirstsBy pairsame (map innerfst allpairs) longcrossings
innerfst ((a,_), (b,_)) = (a,b)
--pairsame (a,b) (c,d) = (samef a c) && (samef b d)
convert (a,b) = (intervalToIval a, intervalToIval b)
unconvert (a,b) = (ivalToInterval a, ivalToInterval b)
longCrossingsSet = S.fromList longcrossings
remainingpairs = filter (\x -> S.notMember x longCrossingsSet) (map innerfst allpairs)
in
remainingpairs
-- Given a list of points tagged points, return the delauney neighbors of
-- each point sorted clockwise.
delaunay :: (Show a, Ord a) => Double -> [(a, Pt2D)] -> [(a, Pt2D, [(a, Pt2D)])]
delaunay maxlen cells =
let del = delaunaySolver maxlen cells
ptMap = M.fromList cells
neighbors =
[(a, pt, sortBy (comparing (cw pt)) (mapMaybe
(\(b,c) ->
if a==b
then Just (c, fromJust $ M.lookup c ptMap)
else
if a==c
then Just (b, fromJust $ M.lookup b ptMap)
else Nothing
)
del)) | (a,pt) <- cells]
-- clockwise angle relative to vertical
cw center (_, pt) = ptAngleCw (ptSub pt center)
in
neighbors
delaunayKeys :: Double -> [(Interval, Pt2D)] -> [(Interval, Pt2D, [(Interval, Pt2D)])]
delaunayKeys maxlen cells =
map
(\(c, pt, ns) ->
(ivalToInterval c, pt, (map (\(n, npt) ->
(ivalToInterval n, npt)) ns)))
(delaunay maxlen (map (\(a,pt) -> (intervalToIval a, pt)) cells))
{-
voronoiKeys :: [(Interval, Pt2D)] -> [(Interval, Pt2D, [Interval])]
voronoiKeys cells =
let unconvert (a,b) = (ivalToInterval a, ivalToInterval b)
in map unconvert $ delaunay 1.5 (map (\(a,pt) -> (intervalToIval a, pt)) cells)
-}
-- 90 degrees clockwise normal vector to line
linePerp :: (Pt2D, Pt2D) -> Pt2D
linePerp (p1@(x1, y1), p2@(x2, y2)) =
ptNormalize $ ptSub (y2,(-x2)) (y1,(-x1))
polygonShrink :: [Pt2D] -> Double -> [Pt2D]
polygonShrink pts border =
let lines = pairs pts
adjustedLines =
[let perp = ptScale (linePerp (p1, p2)) border
in (ptAdd p1 perp, ptAdd p2 perp)
| (p1, p2) <- lines]
newPts =
mapMaybe
(\(l1,l2) -> f $ lineIntersection l1 l2)
(zip adjustedLines ((tail adjustedLines) ++ [head adjustedLines]))
f (Intersect i) = Just i
f _ = Nothing
in
polygonFix newPts
avgPt :: [Pt2D] -> Pt2D
avgPt pts = ptScale (foldl ptAdd (0,0) pts) (1/(fromIntegral $ length pts))
polygonFix :: [Pt2D] -> [Pt2D]
polygonFix pts =
let center = avgPt pts
segs =
filter
(\(a,b) -> ptCross (ptSub b a) (ptSub center a) < 0)
(pairs pts)
in polygonClip center segs []
pairs :: [a] -> [(a,a)]
pairs xs = zip xs ((tail xs) ++ [head xs])
polygonClip :: Pt2D -> [(Pt2D, Pt2D)] -> [(Pt2D, Pt2D)] -> [Pt2D]
polygonClip center poly1 poly2 =
let crossings = [ lineIntersection l1 l2 | (l1,l2) <- pairwise (poly1 ++ poly2)]
verts =
mapMaybe (\x -> case x of
Intersect isect ->
if ptInsideCvx isect poly1 && ptInsideCvx isect poly2
then Just isect
else Nothing
_ -> Nothing) crossings
cw pt = ptAngleCw (ptSub pt center)
in sortBy (comparing cw) verts
interleave :: [a] -> [a] -> [a]
interleave xs ys =
reverse $ go1 xs ys []
where
go1 [] _ acc = acc
go1 (x:xs) ys acc = go2 xs ys (x:acc)
go2 _ [] acc = acc
go2 xs (y:ys) acc = go1 xs ys (y:acc)
voronoiCell :: (a, Pt2D, [(a, Pt2D)]) -> (a -> Double) -> Double -> ((Pt2D -> Pt2D), (Pt2D -> Pt2D)) -> [Pt2D] -> [Pt2D]
voronoiCell (cval, center, neighbors') weightf margin (xfm,invxfm) clip =
let scalev = (1,1)
cweight = weightf cval
neighbors = map (\(nval, n) -> ptInterp2 (center, cweight) (n, weightf nval) ) neighbors'
outline = map (\x -> (x, ptAdd x (ptMul (linePerp (center, x)) scalev))) neighbors
npairs = pairs neighbors'
triads = [ ptInterp3
(center, cweight)
(n1, weightf nval1)
(n2, weightf nval2) | ((nval1, n1), (nval2, n2)) <- npairs ]
in
polygonShrink (map xfm (polygonClip center outline (pairs (map invxfm clip)))) margin
svgWrap :: String -> Pt2D -> String -> String
svgWrap contents (w,h) units =
"\n" ++
"\n" ++
"\n"
noteOctave :: Interval -> Interval
noteOctave note =
unstack note (pitchclass note)
-- Find all the notes within a range of notes that have the
-- same pitch classes as in the scale.
noteSequence :: Interval -> Interval -> [Interval] -> [Interval]
noteSequence min max notes' = reverse $ go min []
where
notes = nub $ sortBy compareIval $ map pitchclass notes'
go min acc
| fretpos min > fretpos max = acc
| elem (pitchclass min) notes = go (next min) (min:acc)
| otherwise = go (next min) acc
next note =
let oct = noteOctave note
pc = pitchclass note
mnext = find (\x -> compareIval pc x == LT) notes
in
case mnext of
Nothing -> stack oct (stack (2,1) (head notes))
Just a -> stack oct a
drawfingerboard :: [Interval] -> [Interval] -> Interval -> Double -> Double -> (Pt2D, Pt2D, Pt2D, Pt2D) -> Double -> String
drawfingerboard strings scale maxnote scalelenl scalelenr (nl, nr, bl', br') margin =
svgWrap (concat (outline ++ stringFrets)) (width,height) "mm"
where
(maxx,maxy) = ptMax (ptMax nl nr) (ptMax bl' br')
(minx,miny) = ptMin (ptMin nl nr) (ptMin bl' br')
width = maxx - minx + (margin*2)
height = maxy - miny + (margin*2)
offset = (margin,margin)
offset2 = (margin,-margin)
svgLine' a b s = svgLine (ptAdd a offset) (ptAdd b offset) s
svgLabel' i p = svgLabel i (ptAdd p offset)
svgLabel2' i p = svgLabel2 i (ptAdd p offset2)
renderString :: Interval -> Int -> String
renderString string stringnum =
concatMap
(\note -> renderFret (unstack note string) note stringnum)
(noteSequence string (stack string maxnote) scale)
renderFret :: Interval -> Interval -> Int -> String
renderFret note pitch stringNum =
(svgLine' a b styleBlack) ++
(svgLabel' pitch (ptInterp a 0.5 b)) ++
(svgLabel2' pitch (ptInterp a 0.5 b))
where
stringNumF = fromIntegral stringNum
anmid = ptInterp nl (stringNumF / numStrings) nr
abmid = ptInterp bl (stringNumF / numStrings) br
a = ptInterp anmid (fretpos note) abmid
bnmid = ptInterp nl ((stringNumF+1) / numStrings) nr
bbmid = ptInterp bl ((stringNumF+1) / numStrings) br
b = ptInterp bnmid (fretpos note) bbmid
nmid = ptInterp nl 0.5 nr
bmid = ptInterp bl 0.5 br
centerV = ptSub bmid nmid
centerVN = ptScale centerV (1 / ptLen centerV)
lsideV = ptSub bl' nl
rsideV = ptSub br' nr
bl = ptAdd nl (ptScale lsideV (scalelenl / ptLen lsideV))
br = ptAdd nr (ptScale rsideV (scalelenr / ptLen rsideV))
stringFrets =
mapi (\s i -> renderString s i) strings
numStrings = fromIntegral $ length strings
ols = styleGrey
outline = [svgLine' nl nr ols, svgLine' nr br' ols,
svgLine' br' bl' ols, svgLine' bl' nl ols]
archtoneFBDim = ((7.5,0), (51.5,0), (0,438), (59,438))
stellaFBDim = ((8,0), (52,0), (0,423), (60,423))
-- 637mm scale length
acousticFBDim = ((7.5,0),(53.5,0),(0,438),(61,438))
renderAcousticFB = writeFile "data/fingerboard_ac_g.svg" $ drawfingerboard eadgbe_g just14 (3,1) 637 637 acousticFBDim 10
renderArchtoneFB = writeFile "data/fingerboard.svg" $ drawfingerboard eadgbe_a just16 (3,1) 636 636 archtoneFBDim 10
drawFingerboards =
do let scale = just20
writeFile "data/fingerboard_at_e.svg" $ drawfingerboard eadgbe_e scale (3,1) 636 636 archtoneFBDim 10
writeFile "data/fingerboard_at_a.svg" $ drawfingerboard eadgbe_a scale (3,1) 636 636 archtoneFBDim 10
writeFile "data/fingerboard_at_d.svg" $ drawfingerboard eadgbe_d scale (3,1) 636 636 archtoneFBDim 10
writeFile "data/fingerboard_st_e.svg" $ drawfingerboard eadgbe_e scale (3,1) 612 612 stellaFBDim 10
writeFile "data/fingerboard_st_a.svg" $ drawfingerboard eadgbe_a scale (3,1) 612 612 stellaFBDim 10
writeFile "data/fingerboard_st_d.svg" $ drawfingerboard eadgbe_d scale (3,1) 612 612 stellaFBDim 10
keypos :: Interval -> [Double] -> Pt2D
keypos ival primeshift =
let x = notecents ival / 1200
y = sum $ map (\(shift, prime) -> (fromIntegral $ factorcount prime ival) * shift)
(zip primeshift (tail primes))
in (x-1,y)
-- How many times does "prime" appear as a factor?
-- (a counts as positive, b negative)
factorcount :: Int -> Interval -> Int
factorcount prime (a,b)
| prime <= 1 = error "factorcount requires prime of 2 or more"
| otherwise = (go a 0) - (go b 0)
where
go x acc =
if mod x prime == 0
then go (div x prime) (acc+1)
else acc
drawKey :: Interval -> Pt2D -> String
drawKey ival@(a,b) pos =
(svgCircle pos r styleGreyOutline) ++ " " ++ (svgFraction ival pos)
where
r = 3
drawKeyCircle :: Interval -> Pt2D -> String
drawKeyCircle ival@(a,b) pos =
(svgCircle pos r styleKeyCircle)
where
r = 5
drawKeyLabel :: Interval -> Pt2D -> String
drawKeyLabel ival@(a,b) pos =
(svgFraction ival pos)
octaveShift :: Interval -> Int -> Interval
octaveShift (a,b) oct
| oct >= 0 = normalize $ (a * (2^oct), b)
| oct < 0 = normalize $ (a, b * (2^(-oct)))
same :: Interval -> Interval -> Bool
same n1 n2 =
let (a1, b1) = normalize n1
(a2, b2) = normalize n2
in
(a1 == a2) && (b1 == b2)
vstretch :: Double -> (Pt2D -> Pt2D, Pt2D -> Pt2D)
vstretch scale = (\(x, y) -> (x, y*scale), \(x, y) -> (x, y/scale))
renderKeyboard :: [Interval] -> (Pt2D -> Pt2D, Pt2D -> Pt2D) -> Int -> Pt2D -> Double -> [Double] -> Double -> String
renderKeyboard scale' (xfm, invxfm) span (octw, h) voffset shift vspacing =
let spanf = fromIntegral span
margin = 60
spacing = 0.0 -- spacing between sections
spacing2 = 2 * spacing
w = octw*octaves
fullh = h + margin*2
fullw = w + margin*2
sideExtra = 7
sideEdge = sideExtra + 13
octaves = spanf*2 + 1
scale =
(2^(span+1),1) : [octaveShift note oct
| note <- scale',
oct <- [(-span) .. span]]
kr = 4
--shift = [x/10 | x <- [-0.1, -1.22, 2.0, 6.0]]
--shift = [x/8.5 | x <- [-0.0, -1.25, 2.0, 6.0]]
--shift = [x/8.5 | x <- [-0.0, -1.1, 2.0, 6.0]]
--shift = [x/8.2 | x <- [-0.0, -0.6, 3.1, 6.0]]
--shift = [x/8.9 | x <- [-0.0, -0.6, 3.3, 6.95, -2.55, 1.5, 1.95, 1.45]] -- 3 was -0.5, 5 was 3.2, 7 was 6.7
position pt =
ptAdd
(ptMul pt (w/octaves, -h/2))
((fullw/2)+(w/(octaves*2)), (fullh/2) + voffset)
kp note = position (keypos note shift)
keysBack =
concatMap
(\note ->
drawKeyCircle
note
(kp note)
)
scale
keysFront =
concatMap
(\note ->
drawKeyLabel
note
(kp note)
)
scale
connections =
concat
[ let a' = kp a
b' = kp b
line = lineShrink a' b' 5
in case line of
Nothing -> ""
Just (a'', b'') -> svgLine a'' b'' styleConnection
| a <- scale,
b <- scale,
not (same a b),
foldl (||) False [same (stack a ival) b | ival <- [(3,2), (5,4)]]]
del = delaunayKeys 100 (map (\note -> (note, invxfm $ kp note)) scale)
cellWeight ival =
if elem ival majscale
then 1
else if ival == (10,9)
then 1
else 1
delLines =
concat [svgLine (xfm pt1) (ptScale (ptAdd (xfm pt1) (xfm pt2)) 0.5) styleBlue
| (note1, pt1, neighbors) <- del,
(note2, pt2) <- neighbors]
pseudomargin = margin - spacing
border = [(pseudomargin - sideExtra, pseudomargin),
(pseudomargin - sideExtra, fullh - pseudomargin),
(fullw + sideExtra - pseudomargin, fullh - pseudomargin),
(fullw + sideExtra - pseudomargin, pseudomargin)]
vorLines =
concatMap
(\p -> svgPoly p styleKey)
[voronoiCell (xfmCell c) cellWeight vspacing (xfm, invxfm) border | c <- del]
xfmCell (c, p, ns) =
(c, id p, (map (\(nc, np) -> (nc, id np)) ns) )
sectionTop = 50
bbcutoutwidth = 88
bbcutoutheight = 30 -- 20
sectionBottom = 10
holeMarginX = 10 - spacing
holeMarginY = 6
holeMiddleY = sectionTop - holeMarginY
holeR = 1.2
rectangleWithHoles (x1,y1) (x2,y2) style cutout =
let xmid = (x1+x2)/2
bbxl = xmid-(bbcutoutwidth/2)
bbxr = xmid+(bbcutoutwidth/2)
bbyb = y1+bbcutoutheight
in
(if cutout
then
(svgPoly [(x1, y1), (bbxl, y1), (bbxl, bbyb), (bbxr, bbyb),
(bbxr,y1), (x2, y1), (x2, y2), (x1, y2)] style)
else
(svgPoly [(x1, y1), (x2, y1), (x2, y2), (x1, y2)] style)) ++
(svgCircle (x1+holeMarginX, y1+holeMarginY) holeR style) ++
(svgCircle (x1+holeMarginX, y2-holeMarginY) holeR style) ++
(svgCircle (x2-holeMarginX, y2-holeMarginY) holeR style) ++
(svgCircle (x2-holeMarginX, y1+holeMarginY) holeR style) ++
(svgCircle (x1+holeMarginX, y1+holeMiddleY) holeR style) ++
(svgCircle (x2-holeMarginX, y1+holeMiddleY) holeR style)
sections =
concat
[ let xl = (octw * (oct-0.5) + (fullw/2)) + spacing
xr = (octw * (oct+0.5) + (fullw/2)) - spacing
yb = (fullh-(margin-sectionBottom)) - spacing2
yt = (margin-sectionTop) + spacing2
s = styleSection
in rectangleWithHoles (xl, yt) (xr, yb) s True
| oct <- [(-spanf) .. spanf]]
lend =
let xl = (margin - sideEdge) + spacing2
xr = margin - spacing
yb = (fullh-(margin-sectionBottom)) - spacing2
yt = (margin-sectionTop) + spacing2
in rectangleWithHoles (xl, yt) (xr, yb) styleSection False
rend =
let xl = (fullw - margin) + spacing
xr = ((fullw - margin) + sideEdge) - spacing2
yb = (fullh-(margin-sectionBottom)) - spacing2
yt = (margin-sectionTop) + spacing2
in rectangleWithHoles (xl, yt) (xr, yb) styleSection False
outerBorder =
let xl = (margin - sideEdge)
xr = ((fullw - margin) + sideEdge)
yb = (fullh-(margin-sectionBottom))
yt = (margin-sectionTop)
in svgPoly [(xl,yt), (xr,yt), (xr,yb), (xl, yb)] styleOuterBorder
--delLines = concat $ map (\(note1, pt, nbs) -> svgLine (kp note1)
-- (kp note2) styleBlue) del
in
svgWrap (lend ++ sections ++ rend ++ vorLines ++ {-delLines -} keysBack ++ keysFront ++ connections) (fullw, fullh) "mm"
drawKeyboard =
do let scale = just31
writeFile
"data/keyboard.svg" $
renderKeyboard
scale (vstretch 3.1) 2 (128, 192) 32
[x/8.9 | x <- [-0.0, -0.6, 3.3, 6.95, -2.55, 1.5, 1.95, 1.45]]
0.7
drawKeyboardSmall =
do let scale = just22leanr
writeFile
"data/keyboard-5-3.svg" $
renderKeyboard
scale (vstretch 2.4) 1 (128, 128) 12
[x/8.9 | x <- [-0.0, -0.6, 4.0, 6.95]]
1.0
{-
texttables_color intervals strings greysp highlights =
unlines $ reverse $ map (\x -> texttr_color (map (stack x) intervals) greysp (map pitchclass highlights)) (reverse strings)
-}
drawlattice :: Int -> Int -> String
drawlattice xfactor yfactor =
let n = 4
cellval r c =
let a = (xfactor ^ (r+n))
b = (yfactor ^ (c+n))
in stack (a,b) (yfactor ^ n, xfactor ^n)
cell r c = "
" ++ (showi (cellval r c)) ++ "
"
row r = "
" ++ (concatMap (cell r) [(-n)..n]) ++ "
\n"
rows = concatMap row [(-n)..n]
in
"
\n" ++ rows ++ "
\n"
drawlattice_normal :: Int -> Int -> String
drawlattice_normal xfactor yfactor =
let n = 4
cellval r c =
let a = (xfactor ^ (r+n))
b = (yfactor ^ (c+n))
in pitchclass $ stack (a,b) (yfactor ^ n, xfactor ^n)
cell r c = "