module Reactive.Banana.ALSA.Pattern where

import qualified Reactive.Banana.ALSA.KeySet as KeySet
import qualified Reactive.Banana.ALSA.DeBruijn as DeBruijn

import Reactive.Banana.ALSA.Common
          (NoteBoundary(NoteBoundary), splitFraction, increasePitch, )

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

import qualified Sound.MIDI.Message.Channel as ChannelMsg
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg

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, )
import Control.Applicative (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 t time set =
   RB.Behavior t set ->
   RB.Event t time ->
   RB.Event t [NoteBoundary]

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


poly ::
   (KeySet.C set) =>
   Selector set i ->
   RB.Behavior t set ->
   RB.Event t [IndexNote i] ->
   RB.Event t [NoteBoundary]
poly select pressed pattern =
   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)) ->
                      NoteBoundary key vel True)
                   sel
         MS.put $
            EventList.mergeBy (\ _ _ -> False) laterOff $
            EventList.fromAbsoluteEventList $
            AbsEventList.fromPairList $
            List.sortBy (comparing fst) $
            map
               (\(IndexNote dur (key, _vel)) ->
                  (dur, NoteBoundary key VoiceMsg.normalVelocity False))
            sel
         return $ Fold.toList nowOff ++ on)
      <*> pressed
      <@> pattern



-- * selectors

type Selector set i =
        i -> set -> [((VoiceMsg.Pitch, ChannelMsg.Channel), VoiceMsg.Velocity)]


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 i = Poly (Selector set 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 =>
   Selector set Int
selectFromOctaveChord d chord =
   maybeToList $ do
      let size = KeySet.size chord
      guard (size>0)
      let (q,r) = divMod d size
      ((pit,chan), vel) <- KeySet.index r chord
      transPitch <- increasePitch (12*q) pit
      return ((transPitch,chan), vel)

selectFromChord ::
   KeySet.C set =>
   Selector set Int
selectFromChord n chord =
   maybeToList $ KeySet.index n chord

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


selectInversion ::
   KeySet.C set =>
   Selector set Double
selectInversion d chord =
   let makeNote octave ((pit,chan), vel) =
          fmap
             (\pitchTrans -> ((pitchTrans,chan), vel))
             (increasePitch (octave*12) pit)
       (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.Behavior t Int ->
   RB.Event t time ->
   RB.Event t Int
cycleUpIndex numbers times =
   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 =
   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.Behavior t Int ->
   RB.Event t time ->
   RB.Event t Int
crossSumIndex numbers times =
   pure
      (\number i ->
         let m = fromIntegral number
         in  if m <= 1
               then 0
               else fromInteger $ flip mod m $ sum $ decomposePositional m i)
      <*> numbers
      <@> fromList [0..] times


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

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


cycleUp, cycleDown, pingPong, crossSum ::
   KeySet.C set =>
   RB.Behavior t Int -> T t time set
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 ::
   KeySet.C set =>
   Int -> Int -> T t time set
bruijn n k sets times =
   mono selectFromChord sets $
   fromList (cycle $ DeBruijn.lexLeast n k) times


binaryStaccato, binaryLegato, binaryAccident ::
   KeySet.C set => T t time set
{-
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 ::
   KeySet.C set =>
   RB.Behavior t Int -> T t time set
cycleUpOctave numbers sets times =
   mono selectFromOctaveChord sets (cycleUpIndex numbers times)


random, randomInversions ::
   KeySet.C set => T t time set
random sets times =
   mono selectFromChordRatio sets $
   fst $ RB.mapAccum (Rnd.mkStdGen 42) $
   fmap (const $ Rnd.randomR (0,1)) times

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

cycleUpInversions :: KeySet.C set => Int -> T t time set
cycleUpInversions n =
   inversions $ cycle $ take n $
   map (\i -> fromInteger i / fromIntegral n) [0..]

inversions :: KeySet.C set => [Double] -> T t time set
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