module Reactive.Banana.MIDI.Pattern where

import qualified Reactive.Banana.MIDI.Note as Note
import qualified Reactive.Banana.MIDI.KeySet as KeySet
import qualified Reactive.Banana.MIDI.DeBruijn as DeBruijn
import qualified Reactive.Banana.MIDI.Pitch as Pitch

import Reactive.Banana.MIDI.Common (splitFraction, )

import qualified Reactive.Banana.MIDI.Utility as RBU
import qualified Reactive.Banana.Bunch.Combinators as RB
import Reactive.Banana.Bunch.Combinators ((<@>), )

import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import Sound.MIDI.Message.Channel.Voice (Velocity, )

import qualified Data.EventList.Absolute.TimeBody as AbsEventList
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Relative.TimeMixed as EventListTM
import Data.EventList.Relative.MixedBody ((/.), (./), )
import qualified Numeric.NonNegative.Wrapper as NonNegW

import qualified Data.List.HT as ListHT
import qualified Data.List as List

import qualified System.Random as Rnd

import qualified Control.Monad.Trans.State as MS

import qualified Data.Traversable as Trav
import qualified Data.Foldable as Fold

import Control.Monad (guard, liftM, )
import Control.Applicative (pure, (<*>), )
import Data.Maybe (mapMaybe, maybeToList, )
import Data.Bool.HT (if', )
import Data.Ord.HT (comparing, )

import Prelude hiding (init, filter, reverse, )



-- * reactive patterns

type T m time set key value =
   RB.Behavior (set key value) ->
   RB.Event time ->
   m (RB.Event [Note.Boundary key value])

mono ::
   (RB.MonadMoment m) =>
   Selector set key Velocity i ->
   RB.Behavior (set key Velocity) ->
   RB.Event i ->
   m (RB.Event [Note.Boundary key Velocity])
mono select pressed pattern =
   liftM fst $ RBU.sequence [] $
   pure
      (\set i -> do
         off <- MS.get
         let mnote = select i set
             on =
                fmap
                   (\(key, vel) -> Note.Boundary key vel True)
                   mnote
         MS.put $ fmap
            (\(key, _vel) -> Note.Boundary key VoiceMsg.normalVelocity False)
            mnote
         return $ off ++ on)
      <*> pressed
      <@> pattern


poly ::
   (RB.MonadMoment m) =>
   Selector set key Velocity i ->
   RB.Behavior (set key Velocity) ->
   RB.Event [IndexNote i] ->
   m (RB.Event [Note.Boundary key Velocity])
poly select pressed pattern =
   liftM fst $ RBU.sequence EventList.empty $
   pure
      (\set is -> do
         off <- MS.get
         let (nowOff, laterOff) = EventListTM.splitAtTime 1 off
             sel = concatMap (Trav.traverse (flip select set)) is
             on =
                fmap
                   (\(IndexNote _ (key, vel)) ->
                      Note.Boundary key vel True)
                   sel
         MS.put $
            EventList.mergeBy (\ _ _ -> False) laterOff $
            EventList.fromAbsoluteEventList $
            AbsEventList.fromPairList $
            List.sortBy (comparing fst) $
            map
               (\(IndexNote dur (key, _vel)) ->
                  (dur, Note.Boundary key VoiceMsg.normalVelocity False))
            sel
         return $ Fold.toList nowOff ++ on)
      <*> pressed
      <@> pattern



-- * selectors

type Selector set key value i =
        i -> set key value -> [(key, value)]


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

instance Functor IndexNote where
   fmap f (IndexNote d i) = IndexNote d $ f i

instance Fold.Foldable IndexNote where
   foldMap = Trav.foldMapDefault

instance Trav.Traversable IndexNote where
   sequenceA (IndexNote d i) = fmap (IndexNote d) i


item :: i -> Int -> IndexNote i
item i n = IndexNote (NonNegW.fromNumberMsg "Pattern.item" n) i

data
   Poly set key value i =
      Poly (Selector set key value i) (EventList.T Int [IndexNote i])


{- |
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 ::
   (KeySet.C set, Ord pitch, Pitch.C pitch) =>
   Selector set pitch value Int
selectFromOctaveChord d chord =
   maybeToList $ do
      let size = KeySet.size chord
      guard (size>0)
      let (q,r) = divMod d size
      (pc, vel) <- KeySet.index r chord
      pcTrans <- Pitch.increase (12*q) pc
      return (pcTrans, vel)

selectFromChord ::
   (KeySet.C set, Ord key) =>
   Selector set key value Int
selectFromChord n chord =
   maybeToList $ KeySet.index n chord

selectFromChordRatio ::
   (KeySet.C set, Ord key) =>
   Selector set key value Double
selectFromChordRatio d chord =
   selectFromChord (floor $ d * fromIntegral (KeySet.size chord)) chord


selectInversion ::
   (KeySet.C set, Pitch.C pitch) =>
   Selector set pitch value Double
selectInversion d chord =
   let makeNote octave (pc, vel) =
          fmap
             (\pcTrans -> (pcTrans, vel))
             (Pitch.increase (octave*12) pc)
       (oct,p) = splitFraction d
       pivot = floor (p * fromIntegral (KeySet.size chord))
       (low,high) = splitAt pivot $ KeySet.toList chord
   in  mapMaybe (makeNote oct) high ++
       mapMaybe (makeNote (oct+1)) low



-- * 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]


cycleUpIndex, cycleDownIndex, pingPongIndex ::
   (RB.MonadMoment m) =>
   RB.Behavior Int ->
   RB.Event time ->
   m (RB.Event Int)
cycleUpIndex numbers times =
   liftM fst $ RB.mapAccum 0 $
   pure
      (\number _time i -> (i, mod (succ i) (max 1 number)))
      <*> numbers
      <@> times

cycleDownIndex numbers times =
   RB.accumE 0 $
   pure
      (\number _time i -> mod (pred i) (max 1 number))
      <*> numbers
      <@> times

pingPongIndex numbers times =
   liftM fst $ RB.mapAccum (0,1) $
   pure
      (\number _time (i,d0) ->
         (i, let j = i+d0
                 d1 =
                    if' (j>=number) (-1) $
                    if' (j<0) 1 d0
             in  (i+d1, d1)))
      <*> numbers
      <@> times

crossSumIndex ::
   (RB.MonadMoment m) =>
   RB.Behavior Int ->
   RB.Event time ->
   m (RB.Event Int)
crossSumIndex numbers times =
   flip liftM (fromList [0..] times) $ \ts ->
   pure
      (\number i ->
         let m = fromIntegral number
         in  if m <= 1
               then 0
               else fromInteger $ flip mod m $ sum $ decomposePositional m i)
      <*> numbers
      <@> ts


crossSumStaticIndex ::
   (RB.MonadMoment m) =>
   Int ->
   RB.Event time ->
   m (RB.Event Int)
crossSumStaticIndex number =
   fromList (flipSeq number)

fromList ::
   (RB.MonadMoment m) =>
   [a] -> RB.Event time -> m (RB.Event a)
fromList xs times =
   liftM (RB.filterJust . fst) $ RB.mapAccum xs $
   fmap
      (\_time xs0 ->
         case xs0 of
            [] -> (Nothing, [])
            x:xs1 -> (Just x, xs1))
      times


cycleUp, cycleDown, pingPong, crossSum ::
   (RB.MonadMoment m, KeySet.C set, Ord key) =>
   RB.Behavior Int -> T m time set key Velocity
cycleUp   numbers sets times =
   mono selectFromChord sets =<< cycleUpIndex numbers times
cycleDown numbers sets times =
   mono selectFromChord sets =<< cycleDownIndex numbers times
pingPong  numbers sets times =
   mono selectFromChord sets =<< pingPongIndex numbers times
crossSum  numbers sets times =
   mono selectFromChord sets =<< crossSumIndex numbers times

bruijn ::
   (RB.MonadMoment m, KeySet.C set, Ord key) =>
   Int -> Int -> T m time set key Velocity
bruijn n k sets times =
   mono selectFromChord sets =<<
   fromList (cycle $ DeBruijn.lexLeast n k) times


binaryStaccato, binaryLegato, binaryAccident ::
   (RB.MonadMoment m, KeySet.C set, Ord key) => T m time set key Velocity
{-
binary number Pattern.T:
   0
   1
   0 1
   2
   0 2
   1 2
   0 1 2
   3
-}
binaryStaccato sets times =
   poly selectFromChord sets =<<
      (flip fromList times $
       map
          (map (IndexNote 1 . fst) .
           List.filter ((/=0) . snd) .
           zip [0..] .
           decomposePositional 2)
          [0..])

binaryLegato sets times =
   poly selectFromChord sets =<<
      (flip fromList times $
       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 sets times =
   poly selectFromChord sets =<<
      (flip fromList times $
       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 ::
   (RB.MonadMoment m, KeySet.C set, Ord pitch, Pitch.C pitch) =>
   RB.Behavior Int -> T m time set pitch Velocity
cycleUpOctave numbers sets times =
   mono selectFromOctaveChord sets =<< cycleUpIndex numbers times


random ::
   (RB.MonadMoment m, KeySet.C set, Ord key) =>
   T m time set key Velocity
random sets times =
   (mono selectFromChordRatio sets =<<) $
   liftM fst $ RB.mapAccum (Rnd.mkStdGen 42) $
   fmap (const $ Rnd.randomR (0,1)) times

randomInversions ::
   (RB.MonadMoment m, KeySet.C set, Pitch.C pitch) =>
   T m time set pitch Velocity
randomInversions =
   inversions $
   map sum $
   ListHT.sliceVertical 3 $
   Rnd.randomRs (-1,1) $
   Rnd.mkStdGen 42

cycleUpInversions ::
   (RB.MonadMoment m, KeySet.C set, Pitch.C pitch) =>
   Int -> T m time set pitch Velocity
cycleUpInversions n =
   inversions $ cycle $ take n $
   map (\i -> fromInteger i / fromIntegral n) [0..]

inversions ::
   (RB.MonadMoment m, KeySet.C set, Pitch.C pitch) =>
   [Double] -> T m time set pitch Velocity
inversions rs sets times =
   mono selectInversion sets =<< fromList rs times



-- * tests

{-
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.
-}
examplePolyTempo0 ::
   EventList.T Int [IndexNote Int]
examplePolyTempo0 =
   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

examplePolyTempo1 ::
   EventList.T Int [IndexNote Int]
examplePolyTempo1 =
   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