{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Sound.MIDI.ALSA.Common where

import qualified Sound.ALSA.Sequencer as SndSeq
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo
import qualified Sound.ALSA.Sequencer.Queue as Queue
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer.RealTime as RealTime

import qualified Sound.MIDI.ALSA as MALSA
import qualified Sound.MIDI.Message.Channel as ChannelMsg
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.MIDI.Message.Channel.Mode as Mode

import Sound.MIDI.ALSA (normalNoteFromEvent, )
import Sound.MIDI.Message.Channel (Channel, )
import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, Controller, Program, )

import qualified Data.EventList.Relative.TimeBody as EventList
import Data.EventList.Relative.MixedBody ((/.), (./), )

import Data.Accessor.Basic ((^.), (^=), )

import qualified Data.List.Match as Match
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Maybe.HT (toMaybe, )
import Data.Tuple.HT (mapFst, mapSnd, )
import Data.Maybe (mapMaybe, )

import qualified System.Random as Rnd
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Data.Bits as Bits
import Data.Bits ((.&.), )

import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Reader as Reader
import Control.Monad.Trans.Reader (ReaderT, )
import Control.Monad (guard, replicateM, )

import qualified Numeric.NonNegative.Class as NonNeg

import qualified Data.Monoid as Mn
import Data.Ratio ((%), )
import Data.Word (Word8, )
import Data.Int (Int32, )

import Prelude hiding (init, filter, reverse, )


-- * helper functions

data Handle =
   Handle {
      sequ :: SndSeq.T SndSeq.DuplexMode,
      client :: Client.T,
      portPublic, portPrivate :: Port.T,
      queue :: Queue.T
   }

init :: IO Handle
init = do
   h <- SndSeq.open SndSeq.defaultName SndSeq.Block
   Client.setName h "Haskell-Filter"
   c <- Client.getId h
   ppublic <-
      Port.createSimple h "inout"
         (Port.caps [Port.capRead, Port.capSubsRead,
                     Port.capWrite, Port.capSubsWrite])
         Port.typeMidiGeneric
   pprivate <-
      Port.createSimple h "private"
         (Port.caps [Port.capRead, Port.capWrite])
         Port.typeMidiGeneric
   q <- Queue.alloc h
   let hnd = Handle h c ppublic pprivate q
   Reader.runReaderT setTimeStamping hnd
   return hnd

exit :: Handle -> IO ()
exit h = do
   _ <- Event.outputPending (sequ h)
   Queue.free (sequ h) (queue h)
   Port.delete (sequ h) (portPublic h)
   Port.delete (sequ h) (portPrivate h)
   SndSeq.close (sequ h)

with :: ReaderT Handle IO a -> IO a
with f =
   SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do
   Client.setName h "Haskell-Filter"
   c <- Client.getId h
   Port.withSimple h "inout"
         (Port.caps [Port.capRead, Port.capSubsRead,
                     Port.capWrite, Port.capSubsWrite])
         Port.typeMidiGeneric $ \ppublic -> do
   Port.withSimple h "private"
         (Port.caps [Port.capRead, Port.capWrite])
         Port.typeMidiGeneric $ \pprivate -> do
   Queue.with h $ \q ->
      flip Reader.runReaderT (Handle h c ppublic pprivate q) $
      setTimeStamping >> f

-- | make ALSA set the time stamps in incoming events
setTimeStamping :: ReaderT Handle IO ()
setTimeStamping = Reader.ReaderT $ \h -> do
   info <- PortInfo.get (sequ h) (portPublic h)
   PortInfo.setTimestamping info True
   PortInfo.setTimestampReal info True
   PortInfo.setTimestampQueue info (queue h)
   PortInfo.set (sequ h) (portPublic h) info


startQueue :: ReaderT Handle IO ()
startQueue = Reader.ReaderT $ \h -> do
   Queue.control (sequ h) (queue h) Event.QueueStart 0 Nothing
   _ <- Event.drainOutput (sequ h)
   return ()


connect :: String -> String -> ReaderT Handle IO ()
connect fromName toName = Reader.ReaderT $ \h -> do
   from <- Addr.parse (sequ h) fromName
   to   <- Addr.parse (sequ h) toName
   SndSeq.connectFrom (sequ h) (portPublic h) from
   SndSeq.connectTo (sequ h) (portPublic h) to

connectTimidity :: ReaderT Handle IO ()
connectTimidity =
   connect "E-MU Xboard61" "TiMidity"

connectLLVM :: ReaderT Handle IO ()
connectLLVM =
   connect "E-MU Xboard61" "Haskell-Synthesizer"

connectSuperCollider :: ReaderT Handle IO ()
connectSuperCollider =
   connect "E-MU Xboard61" "Haskell-Supercollider"



-- * send single events

sendNote :: Channel -> Time -> Velocity -> Pitch -> ReaderT Handle IO ()
sendNote chan dur vel pit =
   let note = simpleNote chan pit vel
       t = incTime dur 0
   in  do outputEvent 0 (Event.NoteEv Event.NoteOn note)
          outputEvent t (Event.NoteEv Event.NoteOff note)

sendKey :: Channel -> Bool -> Velocity -> Pitch -> ReaderT Handle IO ()
sendKey chan noteOn vel pit =
   outputEvent 0 $
      Event.NoteEv
         (if noteOn then Event.NoteOn else Event.NoteOff)
         (simpleNote chan pit vel)

sendController :: Channel -> Controller -> Int -> ReaderT Handle IO ()
sendController chan ctrl val =
   outputEvent 0 $
      Event.CtrlEv Event.Controller $
      MALSA.controllerEvent chan ctrl (fromIntegral val)

sendProgram :: Channel -> Program -> ReaderT Handle IO ()
sendProgram chan pgm =
   outputEvent 0 $
      Event.CtrlEv Event.PgmChange $
      MALSA.programChangeEvent chan pgm

sendMode :: Channel -> Mode.T -> ReaderT Handle IO ()
sendMode chan mode =
   outputEvent 0 $
      Event.CtrlEv Event.Controller $
      MALSA.modeEvent chan mode


-- * constructors

channel :: Int -> Channel
channel = ChannelMsg.toChannel

pitch :: Int -> Pitch
pitch = VoiceMsg.toPitch

velocity :: Int -> Velocity
velocity = VoiceMsg.toVelocity

controller :: Int -> Controller
controller = VoiceMsg.toController

program :: Int -> Program
program = VoiceMsg.toProgram


normalVelocity :: VoiceMsg.Velocity
normalVelocity =
   VoiceMsg.toVelocity VoiceMsg.normalVelocity



-- * time

{- |
The 'Time' types are used instead of floating point types,
because the latter ones caused unpredictable 'negative number' errors.
The denominator must always be a power of 10,
this way we can prevent unlimited grow of denominators.
-}
type TimeAbs = Rational
newtype Time = Time {deconsTime :: Rational}
   deriving (Show, Eq, Ord, Num, Fractional)

consTime :: String -> Rational -> Time
consTime msg x =
   if x>=0
     then Time x
     else error $ msg ++ ": negative number"

incTime :: Time -> TimeAbs -> TimeAbs
incTime dt t = t + deconsTime dt

nano :: Num a => a
nano = 1000^(3::Int)

instance Mn.Monoid Time where
   mempty = Time 0
   mappend (Time x) (Time y) = Time (x+y)

instance NonNeg.C Time where
   split = NonNeg.splitDefault deconsTime Time


-- * events

makeEvent :: Handle -> TimeAbs -> Event.Data -> Event.T
makeEvent h t e =
   Event.Cons
      { Event.highPriority = False
      , Event.tag = 0
      , Event.queue = queue h
      , Event.timestamp =
           Event.RealTime (RealTime.fromInteger (round (t*nano)))
      , Event.source = Addr.Cons (client h) (portPublic h)
      , Event.dest = Addr.subscribers
      , Event.body = e
      }

makeEcho :: Handle -> TimeAbs -> Event.Custom -> Event.T
makeEcho h t c =
   Event.Cons
      { Event.highPriority = False
      , Event.tag = 0
      , Event.queue = queue h
      , Event.timestamp =
           Event.RealTime (RealTime.fromInteger (round (t*nano)))
      , Event.source = Addr.Cons (client h) (portPrivate h)
      , Event.dest   = Addr.Cons (client h) (portPrivate h)
      , Event.body   = Event.CustomEv Event.Echo c
      }


outputEvent :: TimeAbs -> Event.Data -> ReaderT Handle IO ()
outputEvent t ev = Reader.ReaderT $ \h ->
   Event.output (sequ h) (makeEvent h t ev) >>
   Event.drainOutput (sequ h) >>
   return ()


simpleNote :: Channel -> Pitch -> Velocity -> Event.Note
simpleNote c p v =
   Event.simpleNote
      (MALSA.fromChannel c)
      (MALSA.fromPitch p)
      (MALSA.fromVelocity v)


{- |
The times are relative to the start time of the bundle
and do not need to be ordered.
-}
type Bundle a = [(Time, a)]
type EventDataBundle = Bundle Event.Data

singletonBundle :: a -> Bundle a
singletonBundle ev = [(0,ev)]

immediateBundle :: [a] -> Bundle a
immediateBundle = map ((,) 0)


timeFromStamp :: Event.TimeStamp -> Time
timeFromStamp t =
   case t of
      Event.RealTime rt ->
         consTime "time conversion" $
         RealTime.toInteger rt % nano
--      _ -> 0,
      _ -> error "unsupported time stamp type"




defaultTempoCtrl :: (Channel,Controller)
defaultTempoCtrl =
   (ChannelMsg.toChannel 0, VoiceMsg.toController 16)



-- * effects

{- |
Transpose a note event by the given number of semitones.
Non-note events are returned without modification.
If by transposition a note leaves the range of representable MIDI notes,
then we return Nothing.
-}
transpose ::
   Int -> Event.Data -> Maybe Event.Data
transpose d e =
   case e of
      Event.NoteEv notePart note ->
         fmap (\p ->
            Event.NoteEv notePart $
            (MALSA.notePitch ^= p) note) $
         increasePitch d $
         note ^. MALSA.notePitch
      _ -> Just e

{- |
Swap order of keys.
Non-note events are returned without modification.
If by reversing a note leaves the range of representable MIDI notes,
then we return Nothing.
-}
reverse ::
   Event.Data -> Maybe Event.Data
reverse e =
   case e of
      Event.NoteEv notePart note ->
         fmap (\p ->
            Event.NoteEv notePart $
            (MALSA.notePitch ^= p) note) $
         maybePitch $ (60+64 -) $ VoiceMsg.fromPitch $
         note ^. MALSA.notePitch
      _ -> Just e

setChannel ::
   Channel -> Event.Data -> Event.Data
setChannel chan e =
   case e of
      Event.NoteEv notePart note ->
         Event.NoteEv notePart $
         (MALSA.noteChannel ^= chan) note
      Event.CtrlEv ctrlPart ctrl ->
         Event.CtrlEv ctrlPart $
         (MALSA.ctrlChannel ^= chan) ctrl
      _ -> e

{- |
> > replaceProgram [1,2,3,4] 5 [10,11,12,13]
> (True,[10,11,2,13])
-}
replaceProgram :: [Int32] -> Int32 -> [Int32] -> (Bool, [Int32])
replaceProgram (n:ns) pgm pt =
   let (p,ps) =
          case pt of
             [] -> (0,[])
             (x:xs) -> (x,xs)
   in  if pgm<n
         then (True, pgm:ps)
         else mapSnd (p:) $
              replaceProgram ns (pgm-n) ps
replaceProgram [] _ ps = (False, ps)

programFromBanks :: [Int32] -> [Int32] -> Int32
programFromBanks ns ps =
   foldr (\(n,p) s -> p+n*s) 0 $
   zip ns ps

{- |
Interpret program changes as a kind of bank switches
in order to increase the range of instruments
that can be selected via a block of patch select buttons.

@programAsBanks ns@ divides the first @sum ns@ instruments
into sections of sizes @ns!!0, ns!!1, ...@.
Each program in those sections is interpreted as a bank in a hierarchy,
where the lower program numbers are the least significant banks.
Programs from @sum ns@ on are passed through as they are.
@product ns@ is the number of instruments
that you can address using this trick.
In order to avoid overflow it should be less than 128.

E.g. @programAsBanks [n,m]@ interprets subsequent program changes to
@a@ (@0<=a<n@) and @n+b@ (@0<=b<m@)
as a program change to @b*n+a@.
@programAsBanks [8,8]@ allows to select 64 instruments
by 16 program change buttons,
whereas @programAsBanks [8,4,4]@
allows to address the full range of MIDI 128 instruments
with the same number of buttons.
-}
programsAsBanks ::
   [Int32] ->
   Event.Data -> State.State [Int32] Event.Data
programsAsBanks ns e =
   case e of
      Event.CtrlEv Event.PgmChange ctrl -> State.state $ \ps0 ->
         let pgm = Event.ctrlValue ctrl
             (valid, ps1) = replaceProgram ns pgm ps0
         in  (Event.CtrlEv Event.PgmChange $
              ctrl{Event.ctrlValue =
                 if valid
                   then programFromBanks ns ps1
                   else pgm},
              ps1)
      _ -> return e


nextProgram :: Event.Note -> State.State [Program] [Event.Data]
nextProgram note =
   State.state $ \pgms ->
   case pgms of
      pgm:rest ->
        ([Event.CtrlEv Event.PgmChange $
          Event.Ctrl {
             Event.ctrlChannel = Event.noteChannel note,
             Event.ctrlParam = 0,
             Event.ctrlValue = MALSA.fromProgram pgm}],
          rest)
      [] -> ([],[])

{- |
Before every note switch to another instrument
according to a list of programs given as state of the State monad.
I do not know how to handle multiple channels in a reasonable way.
Currently I just switch the instrument independent from the channel,
and send the program switch to the same channel as the beginning note.
-}
traversePrograms ::
   Event.Data -> State.State [Program] [Event.Data]
traversePrograms e =
   fmap (++ [e]) $
   case e of
      Event.NoteEv notePart note ->
         (case fst $ normalNoteFromEvent notePart note of
             Event.NoteOn -> nextProgram note
             _ -> return [])
      _ -> return []

{- |
This function extends 'traversePrograms'.
It reacts on external program changes
by seeking an according program in the list.
This way we can reset the pointer into the instrument list.
However the search must be limited in order to prevent an infinite loop
if we receive a program that is not contained in the list.
-}
traverseProgramsSeek ::
   Int ->
   Event.Data -> State.State [Program] [Event.Data]
traverseProgramsSeek maxSeek e =
   fmap (++ [e]) $
   case e of
      Event.NoteEv notePart note ->
         case fst $ normalNoteFromEvent notePart note of
            Event.NoteOn -> nextProgram note
            _ -> return []
      Event.CtrlEv Event.PgmChange ctrl ->
         let pgm = ctrl ^. MALSA.ctrlProgram
         in  fmap (const []) $
             State.modify $
                uncurry (++) .
                mapFst (dropWhile (pgm/=)) .
                splitAt maxSeek
      _ -> return []

reduceNoteVelocity ::
   Word8 -> Event.Note -> Event.Note
reduceNoteVelocity decay note =
   note{Event.noteVelocity =
      let vel = Event.noteVelocity note
      in  if vel==0
            then 0
            else vel - min decay (vel-1)}

delayAdd ::
   Word8 -> Time -> Event.Data -> EventDataBundle
delayAdd decay d e =
   singletonBundle e ++
   case e of
      Event.NoteEv notePart note ->
         [(d, Event.NoteEv notePart $
              reduceNoteVelocity decay note)]
      _ -> []



{- |
Map NoteOn events to a controller value.
This way you may play notes via the resonance frequency of a filter.
-}
controllerFromNote ::
   (Int -> Int) ->
   VoiceMsg.Controller ->
   Event.Data -> Maybe Event.Data
controllerFromNote f ctrl e =
   case e of
      Event.NoteEv notePart note ->
         case fst $ normalNoteFromEvent notePart note of
            Event.NoteOn ->
               Just $
               Event.CtrlEv Event.Controller $
               MALSA.controllerEvent
                  (note ^. MALSA.noteChannel)
                  ctrl
                  (fromIntegral $ f $
                   fromIntegral $ VoiceMsg.fromPitch $
                   note ^. MALSA.notePitch)
            Event.NoteOff -> Nothing
            _ -> Just e
      _ -> Just e


type KeySet   = Map.Map (Pitch, Channel) Velocity
type KeyQueue = [((Pitch, Channel), Velocity)]

eventsFromKey ::
   Time -> ((Pitch, Channel), Velocity) -> 
   EventDataBundle
eventsFromKey dur ((pit,chan), vel) =
   (0,   Event.NoteEv Event.NoteOn  $ simpleNote chan pit vel) :
   (dur, Event.NoteEv Event.NoteOff $ simpleNote chan pit vel) :
   []

selectFromLimittedChord ::
   Int ->
   Time ->
   KeyQueue ->
   EventDataBundle
selectFromLimittedChord n dur =
   maybe [] (eventsFromKey dur) .
   (!!n) . (++ repeat Nothing) . map Just

{- |
Generate notes according to the key set,
where notes for negative and too large indices
are padded with keys that are transposed by octaves.
-}
selectFromOctaveChord ::
   Int ->
   Time ->
   KeyQueue ->
   EventDataBundle
selectFromOctaveChord d dur chord =
   maybe [] (eventsFromKey dur) $ do
      guard (not $ null chord)
      let (q,r) = divMod d (fromIntegral $ length chord)
          ((pit,chan), vel) = chord !! r
      transPitch <- increasePitch (12*q) pit
      return ((transPitch,chan), vel)

selectFromChord ::
   Integer ->
   Time ->
   KeyQueue ->
   EventDataBundle
selectFromChord d dur chord =
   if null chord
     then []
     else
       eventsFromKey dur $
       chord !! fromInteger d

selectFromChordRatio ::
   Double ->
   Time ->
   KeyQueue ->
   EventDataBundle
selectFromChordRatio d dur chord =
   if null chord
     then []
     else
       eventsFromKey dur $
       chord !! floor (d * fromIntegral (length chord))


maybePitch :: Int -> Maybe Pitch
maybePitch p =
   toMaybe
      (VoiceMsg.fromPitch minBound <= p  &&
       p <= VoiceMsg.fromPitch maxBound)
      (VoiceMsg.toPitch p)

increasePitch :: Int -> Pitch -> Maybe Pitch
increasePitch d p =
   maybePitch $ d + VoiceMsg.fromPitch p


selectInversion ::
   Double ->
   Time ->
   KeyQueue ->
   EventDataBundle
selectInversion d dur chord =
   let -- properFraction is useless for negative numbers
       splitFraction x =
          let n = floor x :: Int
          in  (n, x - fromIntegral n)
       makeNote octave ((pit,chan), vel) =
          maybe []
             (\pitchTrans -> eventsFromKey dur ((pitchTrans,chan), vel))
             (increasePitch (octave*12) pit)
       (oct,p) = splitFraction d
       pivot = floor (p * fromIntegral (length chord))
       (low,high) = splitAt pivot chord
   in  concatMap (makeNote oct) high ++
       concatMap (makeNote (oct+1)) low


updateChord ::
   Event.NoteEv -> Event.Note ->
   KeySet -> KeySet
updateChord notePart note =
   let key =
          (note ^. MALSA.notePitch,
           note ^. MALSA.noteChannel)
       (part, vel) =
          normalNoteFromEvent notePart note
   in  case part of
          Event.NoteOn  -> Map.insert key vel
          Event.NoteOff -> Map.delete key
          _ -> id


controllerMatch ::
   Channel -> Controller -> Event.Ctrl -> Bool
controllerMatch chan ctrl param =
   Event.ctrlChannel param == MALSA.fromChannel chan &&
   Event.ctrlParam   param == MALSA.fromController ctrl

updateDur ::
   Event.Ctrl -> (Time, Time) -> Time
updateDur = updateDurExponential

updateDurLinear ::
   Event.Ctrl -> (Time, Time) -> Time
updateDurLinear param (minDur, maxDur) =
   minDur + (maxDur-minDur)
      * fromIntegral (Event.ctrlValue param) / 127

updateDurExponential ::
   Event.Ctrl -> (Time, Time) -> Time
updateDurExponential param (minDur, maxDur) =
   minDur *
   Time
      (powerRationalFromFloat 10 3
         (fromRational $ deconsTime maxDur/deconsTime minDur :: Double)
         (fromIntegral (Event.ctrlValue param) / 127))

{- |
Compute @base ** expo@
approximately to result type 'Rational'
such that the result has a denominator which is a power of @digitBase@
and a relative precision of numerator of @precision@ digits
with respect to @digitBase@-ary numbers.
-}
powerRationalFromFloat ::
   (Floating a, RealFrac a) =>
   Int -> Int -> a -> a -> Rational
powerRationalFromFloat digitBase precision base expo =
   let digitBaseFloat = fromIntegral digitBase
       {-
       It would be nice, if properFraction would warrant @0<=x<1@.
       Actually it can be @-1<x<=0@ in which case we lose one digit of precision.
       -}
       (n,x) = properFraction (logBase digitBaseFloat base * expo)
       frac  = round (digitBaseFloat ** (x + fromIntegral precision))
   in  fromInteger frac *
       fromIntegral digitBase ^^ (n-precision)


type Selector i = i -> Time -> KeyQueue -> EventDataBundle

data PatternMono i = PatternMono (Selector i) [i]


data IndexNote i = IndexNote Int i
   deriving (Show, Eq, Ord)

item :: i -> Int -> IndexNote i
item i n = IndexNote n i

data PatternPoly i = PatternPoly (Selector i) (EventList.T Int [IndexNote i])



fraction :: RealFrac a => a -> a
fraction x =
   let n = floor x
   in  x - fromIntegral (n::Integer)


data SweepState =
   SweepState {
      sweepSpeed, sweepDepth, sweepCenter, sweepPhase :: Double
   }



{-
ctrlRange ::
   (RealFrac b) =>
   (b,b) -> (a -> b) -> (a -> Int)
ctrlRange (l,u) f x =
   round $
   limit (0,127) $
   127*(f x - l)/(u-l)
-}

-- * patterns

{- |
See Haskore/FlipSong

  flipSeq m !! n = cross sum of the m-ary representation of n modulo m.

  For m=2 this yields
  http://www.research.att.com/cgi-bin/access.cgi/as/njas/sequences/eisA.cgi?Anum=A010060
-}
flipSeq :: Int -> [Int]
flipSeq n =
   let incList m = map (\x -> mod (x+m) n)
       recourse y =
          let z = concatMap (flip incList y) [1 .. n-1]
          in  z ++ recourse (y++z)
   in  [0] ++ recourse [0]

{- |
@bruijn n k@ is a sequence with length n^k
where @cycle (bruijn n k)@ contains all n-ary numbers with k digits as infixes.
The function computes the lexicographically smallest of such sequences.
-}
bruijn :: Int -> Int -> [Int]
bruijn n k =
   head $ bruijnAllMap n k

{- |
All Bruijn sequences with a certain 
-}
bruijnAll :: Int -> Int -> [[Int]]
bruijnAll n k =
   let start = replicate k 0
       go _ str 0 = do
          guard $ str==start
          return []
       go set str c = do
          d <- [0 .. n-1]
          let newStr = tail str ++ [d]
          guard $ Set.notMember newStr set
          rest <- go (Set.insert newStr set) newStr (c-1)
          return $ d:rest
   in  map (ListHT.rotate (-k)) $
       go Set.empty start (n^k)

bruijnAllMap :: Int -> Int -> [[Int]]
bruijnAllMap n k =
   let start = replicate k 0
       delete d =
          Map.update (\set ->
             let newSet = Set.delete d set
             in  toMaybe (not $ Set.null newSet) newSet)
       go [] _ = error "infixes must have positive length"
       go (_:str) todo =
          case Map.lookup str todo of
             Nothing -> do
                guard $ Map.null todo
                return []
             Just set -> do
                d <- Set.toList set
                rest <- go (str ++ [d]) $ delete d str todo
                return $ d:rest
   in  map (take (n^k) . (start ++)) $
       go start $
       delete 0 (tail start) $
       Map.fromAscList $
       map (flip (,) $ Set.fromList [0 .. n-1]) $
       replicateM (k-1) [0 .. n-1]

testBruijn :: Int -> Int -> [Int] -> Bool
testBruijn n k xs =
   replicateM k [0 .. n-1]
   ==
   (List.sort $ Match.take xs $ map (take k) $ List.tails $ cycle xs)

testBruijnAll :: Int -> Int -> Bool
testBruijnAll n k =
   all (testBruijn n k) $ bruijnAllMap n k


bruijnAllTrie :: Int -> Int -> [[Int]]
bruijnAllTrie n k =
   let start = replicate k 0
       go [] _ = error "infixes must have positive length"
       go (_:str) todo =
          case lookupWord str todo of
             Nothing -> do
                guard $ nullTrie todo
                return []
             Just set -> do
                d <- set
                rest <- go (str ++ [d]) $ deleteWord d str todo
                return $ d:rest
   in  map (take (n^k) . (start ++)) $
       go start $
       deleteWord 0 (tail start) $
       fullTrie [0 .. n-1] [0 .. n-1] (k-1)

data Trie a b = Leaf b | Branch [(a, Trie a b)]
   deriving (Show)

fullTrie :: b -> [a] -> Int -> Trie a b
fullTrie b _ 0 = Leaf b
fullTrie b as n =
   Branch $
   map (\a -> (a, fullTrie b as (n-1))) as

nullTrie :: Trie a [b] -> Bool
nullTrie (Branch []) = True
nullTrie (Leaf []) = True
nullTrie _ = False

deleteWord :: (Eq a, Eq b) => b -> [a] -> Trie a [b] -> Trie a [b]
deleteWord b [] (Leaf bs) = Leaf (List.delete b bs)
deleteWord b (a:as) (Branch subTries) =
   Branch $ mapMaybe
      (\(key,trie) ->
         fmap ((,) key) $
            if key==a
              then let delTrie = deleteWord b as trie
                   in  toMaybe (not (nullTrie delTrie)) delTrie
              else Just trie)
      subTries
deleteWord _ _ _ = error "Trie.deleteWord: key and trie depth mismatch"

lookupWord :: (Eq a) => [a] -> Trie a b -> Maybe b
lookupWord [] (Leaf b) = Just b
lookupWord (a:as) (Branch subTries) =
   lookup a subTries >>= lookupWord as
lookupWord _ _ = error "Trie.lookupWord: key and trie depth mismatch"



bruijnAllBits :: Int -> Int -> [[Int]]
bruijnAllBits n k =
   let go code todo =
          let shiftedCode = mod (code*n) (n^k)
          in  case Bits.shiftR todo shiftedCode .&. (2^n-1) of
                 0 -> do
                    guard $ todo == 0
                    return []
                 set -> do
                    d <- [0 .. n-1]
                    guard $ Bits.testBit set d
                    rest <-
                       let newCode = shiftedCode + d
                       in  go newCode $ Bits.clearBit todo newCode
                    return $ d:rest
   in  map (take (n^k) . (replicate k 0 ++)) $
       go 0 $ (2^n^k-2 :: Integer)



cycleUp, cycleDown, pingPong, crossSum ::
   Int -> PatternMono Int
cycleUp   number =
   PatternMono selectFromLimittedChord (cycle [0..(number-1)])
cycleDown number =
   PatternMono selectFromLimittedChord (cycle $ List.reverse [0..(number-1)])
pingPong  number =
   PatternMono selectFromLimittedChord $
      cycle $ [0..(number-2)] ++ List.reverse [1..(number-1)]
crossSum  number =
   PatternMono selectFromLimittedChord (flipSeq number)

bruijnPat :: Int -> Int -> PatternMono Int
bruijnPat n k =
   PatternMono selectFromLimittedChord $ cycle $ bruijn n k

cycleUpAuto, cycleDownAuto, pingPongAuto, crossSumAuto ::
   PatternMono Integer
cycleUpAuto =
   PatternMono
      (\ d dur chord ->
          selectFromChord (mod d (fromIntegral $ length chord)) dur chord)
      [0..]
cycleDownAuto =
   PatternMono
      (\ d dur chord ->
          selectFromChord (mod d (fromIntegral $ length chord)) dur chord)
      [0,(-1)..]
pingPongAuto =
   PatternMono
      (\ d dur chord ->
          let s = 2 * (fromIntegral (length chord) - 1)
              m =
                if s<=0
                  then 0
                  else min (mod d s) (mod (-d) s)
          in  selectFromChord m dur chord)
      [0..]
crossSumAuto =
   PatternMono
      (\ d dur chord ->
          let m = fromIntegral $ length chord
              s =
                if m <= 1
                  then 0
                  else sum $ decomposePositional m d
          in  selectFromChord (mod s m) dur chord)
      [0..]

binaryStaccato, binaryLegato, binaryAccident :: PatternPoly Int
{-
binary number patternMono:
   0
   1
   0 1
   2
   0 2
   1 2
   0 1 2
   3
-}
binaryStaccato =
   PatternPoly
      selectFromLimittedChord
      (EventList.fromPairList $
       zip (0 : repeat 1) $
       map
          (map (IndexNote 1 . fst) .
           List.filter ((/=0) . snd) .
           zip [0..] .
           decomposePositional 2)
          [0..])

binaryLegato =
   PatternPoly
      selectFromLimittedChord
      (EventList.fromPairList $
       zip (0 : repeat 1) $
       map
          (\m ->
             map (uncurry IndexNote) $
             List.filter (\(p,_i) -> mod m p == 0) $
             takeWhile ((<=m) . fst) $
             zip (iterate (2*) 1) [0..])
          [0..])

{-
This was my first try to implement binaryLegato.
It was not what I wanted, but it sounded nice.
-}
binaryAccident =
   PatternPoly
      selectFromLimittedChord
      (EventList.fromPairList $
       zip (0 : repeat 1) $
       map
          (zipWith IndexNote (iterate (2*) 1) .
           map fst .
           List.filter ((/=0) . snd) .
           zip [0..] .
           decomposePositional 2)
          [0..])


-- cf. htam:NumberTheory
decomposePositional :: Integer -> Integer -> [Integer]
decomposePositional b =
   let recourse 0 = []
       recourse x =
          let (q,r) = divMod x b
          in  r : recourse q
   in  recourse

cycleUpOctave ::
   Int -> PatternMono Int
cycleUpOctave number =
   PatternMono selectFromOctaveChord (cycle [0..(number-1)])

random, randomInversions :: PatternMono Double
random =
   PatternMono selectFromChordRatio (Rnd.randomRs (0,1) (Rnd.mkStdGen 42))

randomInversions =
   inversions $
   map sum $
   ListHT.sliceVertical 3 $
   Rnd.randomRs (-1,1) $
   Rnd.mkStdGen 42

cycleUpInversions :: Int -> PatternMono Double
cycleUpInversions n =
   inversions $ cycle $ take n $
   map (\i -> fromInteger i / fromIntegral n) [0..]

inversions :: [Double] -> PatternMono Double
inversions rs =
   PatternMono selectInversion rs


{-
We cannot use cycle function here, because we need to cycle a Body-Time list
which is incompatible to a Body-Body list,
even if the end is never reached.
-}
examplePatternPolyTempo0 ::
   EventList.T Int [IndexNote Int]
examplePatternPolyTempo0 =
   let pat =
          [item 0 1] ./ 1 /. [item 1 1, item 2 1] ./ 2 /.
          [item 1 1, item 2 1] ./ 1 /. [item 0 1] ./ 2 /.
          pat
   in  0 /. pat

examplePatternPolyTempo1 ::
   EventList.T Int [IndexNote Int]
examplePatternPolyTempo1 =
   let pat =
          [item 0 1] ./ 1 /.
          [item 2 1, item 3 1, item 4 1] ./ 1 /.
          [item 2 1, item 3 1, item 4 1] ./ 1 /.
          [item 1 1] ./ 1 /.
          [item 2 1, item 3 1, item 4 1] ./ 1 /.
          [item 2 1, item 3 1, item 4 1] ./ 1 /.
          pat
   in  0 /. pat


-- * predicates

checkChannel ::
   (Channel -> Bool) ->
   (Event.Data -> Bool)
checkChannel p e =
   case e of
      Event.NoteEv _notePart note ->
         p (note ^. MALSA.noteChannel)
      Event.CtrlEv Event.Controller ctrl ->
         p (ctrl ^. MALSA.ctrlChannel)
      _ -> False

checkPitch ::
   (Pitch -> Bool) ->
   (Event.Data -> Bool)
checkPitch p e =
   case e of
      Event.NoteEv _notePart note ->
         p (note ^. MALSA.notePitch)
      _ -> False

checkController ::
   (Controller -> Bool) ->
   (Event.Data -> Bool)
checkController p e =
   case e of
      Event.CtrlEv Event.Controller ctrlMode ->
         case ctrlMode ^. MALSA.ctrlControllerMode of
            MALSA.Controller ctrl _ -> p ctrl
            _ -> False
      _ -> False

checkMode ::
   (Mode.T -> Bool) ->
   (Event.Data -> Bool)
checkMode p e =
   case e of
      Event.CtrlEv Event.Controller ctrlMode ->
         case ctrlMode ^. MALSA.ctrlControllerMode of
            MALSA.Mode mode -> p mode
            _ -> False
      _ -> False

checkProgram ::
   (Program -> Bool) ->
   (Event.Data -> Bool)
checkProgram p e =
   case e of
      Event.CtrlEv Event.PgmChange ctrl ->
         p (ctrl ^. MALSA.ctrlProgram)
      _ -> False


-- * event list support

mergeStable ::
   (NonNeg.C time) =>
   EventList.T time body ->
   EventList.T time body ->
   EventList.T time body
mergeStable =
   EventList.mergeBy (\_ _ -> True)

mergeEither ::
   (NonNeg.C time) =>
   EventList.T time a ->
   EventList.T time b ->
   EventList.T time (Either a b)
mergeEither xs ys =
   mergeStable (fmap Left xs) (fmap Right ys)