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.
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