This is a fairly complex problem and I don't expect anyone to follow it
all, but I thought I would just post it and see if anyone can immediately
identify unidiomatic Haskell.
The problem is this: I'm writing a program that does backtrack search to
determine musical counterpoint. I begin by laying out a series of "cells"
which are notes of *as yet undetermined* pitch but do have determined begin
time and duration (and also the instrument playing them is known). The
algorithm will find pitches for each cell in order to maximize a fitness
function. Cells can overlap in time.
The search algorithm is allowed to make some cells silent if that improves
the final result.
So each cell has a status which is one of the following "undecided,"
"determined a specific pitch," and "determined to be silent".
data CellStatus = CellUndecided -- Undecided whether this cell will be a
-- pitch or silent
| CellSilent -- It has been decided that this cell will
be
-- silent
| CellPitch Pitch -- This cell will be a specific pitch
deriving(Show)
The following code deals with only one aspect of the fitness function. When
there are patterns in the music called "octave relations," it makes the
solution a bad one that should be avoided. An octave relation is when some
note, say a C, appears as a following C in a different octave and fclose in
time. It's okay to repeat the same C, just not in a different octave. In
some atonal styles of music octave relations need to be specially handled
or avoided altogether.
So this is an algorithm that determines if any octave relations are
present. There are two kinds of octave relations between a cell A and a
cell B (containing an octave relation). One happens when A and B overlap in
time. Clearly that represent a very close juxtaposition of A and B and it's
illegal. The next kind of octave relation happens when B follows A some
time later, but there are very few intervening notes of other pitches. The
idea is that if *a lot of notes* intervene, it distracts the ear and the
octave relation is not audible. But if only a few intervene between A and
B, the octave relation will really stand out.
Another bit of trickery. Consider the cells that intervene between A and B;
that is, notes that start *after the end of A* and *before the beginning of
B*. Some of those might have a status of CellUndecided. Those notes count
as helping to distract the ear because we know we are eventually going to
fill them in. But cells with a status of CellSilent don't count. And of
course, notes of CellPitch status count as distracting the ear (unless they
represent an octave relation).
Here's the code. If anyone actually wants to run this, I can email you some
test data.
import Data.Maybe
import Data.Map(Map)
import qualified Data.Map as M
import qualified Data.List as L
type Time = Int
type Pitch = Int
data Cell = Cell
{ endTime :: Time
, cellStatus :: CellStatus
} deriving(Show)
data CellStatus = CellUndecided -- Undecided whether this cell will be a
-- pitch or silent
| CellSilent -- It has been decided that this cell will
be
-- silent
| CellPitch Pitch -- This cell will be a specific pitch
deriving(Show)
-- maps a given Time to a list of Cells that *begin* at that time
type TimeMap = Map Time [Cell]
-- checkOctaveRelations
--
-- Int :: all octave relations must be have at least this many
-- intervening notes
-- TimeMap :: map of Time to list of Cells at that time
--
-- Result True if satisfies the condition that all octave relations
-- have at least proper number of intervening notes (or there are no
-- octave relations), False otherwise.
--
checkOctaveRelations :: Int -> TimeMap -> Bool
checkOctaveRelations condition timeMap =
all checkOneTime . M.keys $ timeMap
where
-- check all notes at one begin time to verify they satisfy the
condition.
-- note that we assume this function is called with 'beginTime' in
ascending
-- time order, so we only check notes at or following 'beginTime'
checkOneTime :: Int -> Bool
checkOneTime beginTime
| checkBunch cellsAtBeginTime = False -- this is the case that among
-- all cells at 'beginTime',
there
-- are octave relations within
-- them
| otherwise = all checkOneCell cellsAtBeginTime
where
cellsAtBeginTime = fromJust . M.lookup beginTime $ timeMap
checkOneCell :: Cell -> Bool
checkOneCell cell
-- the line below checks the case that any overlapping cells have
-- octave relations
| any (any (isOctRel cell)) overlappingCells = False
-- otherwise count the number of intervening cells until the
-- next octave relation
| otherwise = case countFollowingNonOctRel cell followingCells of
Nothing -> True -- no octave relatios were found following
-- 'cell' - so condition is met
Just count -> count >= condition
where
(Cell endTime _) = cell
followingCells = M.elems . snd . M.split (endTime-1) $ timeMap
overlappingCells =
M.elems .
M.filterWithKey (\k _ -> k > beginTime && k < endTime) $
timeMap
-- countFollowingNonOctRel
--
-- count the number N of cells that do not have an octave relation
-- with input 'c' before encountering an octave relation. Result is Just
N.
-- if no octave relations are found at all, result is Nothing.
countFollowingNonOctRel :: Cell -> [[Cell]] -> Maybe Int
countFollowingNonOctRel c cellGroups =
case L.findIndex (\cells -> any (isOctRel c) cells) cellGroups of
Nothing -> Nothing
Just idx -> Just . sum . map countCells . take idx $ cellGroups
where
countCells :: [Cell] -> Int
countCells cells = sum . map countFn $ cells
countFn (Cell _ CellSilent) = 0 -- silent cells are not
distracting; don't count as any
countFn _ = 1 -- other cells count as
distracting
-- checkBunch
--
-- Check a group of cells that all occur at the same time for any octave
-- relations in any pair of cells
checkBunch :: [Cell] -> Bool
checkBunch [] = False
checkBunch (c:cs) = (any (\c' -> isOctRel c c') cs) || checkBunch cs
isOctRel :: Cell -> Cell -> Bool
isOctRel cell1 cell2
| isCellPitch cell1 && isCellPitch cell2 = isOctRel' cell1 cell2
| otherwise = False
where
isOctRel' (Cell _ (CellPitch p1)) (Cell _ (CellPitch p2)) =
p1 /= p2 && p1 `mod` 12 == p2 `mod` 12
isCellPitch (Cell _ (CellPitch _)) = True
isCellPitch _ = False
isCellSilent (Cell _ CellSilent) = True
isCellSilent _ = False
