module Sound.MIDI.ALSA.CausalExample where

import qualified Sound.MIDI.ALSA.Causal as Causal
import qualified Sound.MIDI.ALSA.Common as Common
import qualified Sound.MIDI.ALSA.Training as Training

import Sound.MIDI.ALSA.Causal
          (process, map, lift, guide, guideWithMode,
           patternTempo, transpose, )
import Sound.MIDI.ALSA.Common
          (channel, pitch, program, controller, velocity, )

import qualified Sound.MIDI.Controller as Ctrl
import qualified Sound.MIDI.Message.Channel.Mode as ModeMsg

import qualified System.Random as Random

import Data.Ord.HT (limit, )
import Data.Maybe (fromMaybe, )
import qualified Data.List as List

import Control.Category ((.), )
import Control.Monad.Trans.Reader (ReaderT, )

import Prelude hiding (init, map, filter, (.), id, reverse, )


defaultTempo :: Causal.TempoControl
defaultTempo =
   (Common.defaultTempoCtrl, (0.25, 0.12, 0.05))


run :: ReaderT Common.Handle IO a -> IO a
run x = Common.with $ Common.connectLLVM >> x


pass,
   reverse,
   delay,
   cycleUp,
   cycleUpTempo,
   cycleUpPoly,
   sweep,
   split,
   splitPattern,
   serialPattern,
   serialLatch,
   cyclePrograms,
   cycleProgramsDefer,
   binary,
   crossSum,
   bruijn,
   latch,
   groupLatch,
   groupCycleUp,
   groupBinary,
   groupCrossSum,
   groupBruijn,
   groupRandom,
   groupRandomInversions,
   filterKey,
   guitar,
   sendProgram,
   sendMode,
   releaseAllKeys :: ReaderT Common.Handle IO ()

pass =
   process (map (maybe [] Common.singletonBundle) . transpose 12)

reverse =
   process (map (maybe [] Common.singletonBundle) . Causal.reverse)

delay =
   process (Causal.delayAdd 50 1)

cycleUp =
   process (Causal.patternMono (Common.cycleUp 4) 0.12)

cycleUpTempo =
   process (patternTempo (Common.cycleUp 4) defaultTempo)

cycleUpPoly =
   process (patternTempo
      (Common.PatternPoly
          Common.selectFromLimittedChord
          Common.examplePatternPolyTempo1)
      defaultTempo)

sweep =
   process
      (map Common.immediateBundle
       .
       Causal.sweep (channel 1)
         0.01 (controller 16, (0.1, 1))
         (controller 17) (controller 94)
         (sin . (2*pi*)))

split =
   process
      (guideWithMode
         (\e ->
            (Common.checkChannel (channel 0 ==) e &&
             Common.checkPitch   (pitch 60 >) e) ||
            Common.checkController (controller 94 ==) e ||
            Common.checkController (controller 95 ==) e)
         (map (maybe [] Common.singletonBundle)
          .
          transpose 12
          .
          map (Common.setChannel (channel 1)))
         (map (maybe [] Common.singletonBundle)
          .
          transpose 0))

splitPattern =
   process
      (guideWithMode
         (\e ->
             Common.checkPitch (pitch 60 >) e ||
             Common.checkController (snd Common.defaultTempoCtrl ==) e)
         (map concat
          .
          lift (patternTempo (Common.cycleUp 4) defaultTempo)
          .
          map (fromMaybe [])
          .
          lift Causal.groupLatch
          .
          transpose 12)
         (map Common.singletonBundle))

serialPattern =
   process (Causal.patternSerialTempo 4 (Common.cycleUp 4) defaultTempo)

serialLatch =
   process (map Common.immediateBundle . Causal.serialLatch 4)

cyclePrograms =
   process
      (map Common.immediateBundle .
       Causal.cyclePrograms (List.map program [16..20]))

cycleProgramsDefer =
   process
      (map Common.immediateBundle .
       Causal.cycleProgramsDefer 0.1
          (List.map program [16..20]))

binary =
   process (patternTempo Common.binaryLegato defaultTempo)

crossSum =
   process (patternTempo (Common.crossSum 4) defaultTempo)

bruijn =
   process (patternTempo (Common.bruijnPat 4 2) defaultTempo)

latch =
   process (map (maybe [] Common.singletonBundle) . Causal.latch)

groupLatch =
   process (map Common.immediateBundle . Causal.groupLatch)


withGroup ::
   (Causal.Pattern pat) =>
   pat -> ReaderT Common.Handle IO ()
withGroup f =
   process
      (map concat
       .
       lift (patternTempo f defaultTempo)
       .
       Causal.groupLatch)

groupBinary =
   withGroup Common.binaryLegato

groupCrossSum =
   withGroup (Common.crossSum 4)

groupBruijn =
   withGroup (Common.bruijnPat 4 2)

groupCycleUp =
   withGroup (Common.cycleUp 4)

groupRandom =
   withGroup Common.random

groupRandomInversions =
   withGroup Common.randomInversions

filterKey =
   process
      (map (maybe [] Common.singletonBundle)
       .
       guide
         (Common.checkPitch (pitch 60 >))
         (transpose 12)
         (map (Common.controllerFromNote
                 (\p ->
                    {-
                    A880 shall be mapped to the center of the controller,
                    and the note intervals shall be mapped to according frequency ratios.
                    It is adapted to the current configuration of LLVM synthesizer.
                    -}
                    limit (0,127) $ 2*(p-69)+64)
--                 (controller 91))))
                 (Ctrl.effect4Depth))))

guitar =
   process (Causal.guitar 0.05 0.03)


trainer ::
   (Random.RandomGen g) =>
   g -> ReaderT Common.Handle IO ()
trainer g =
   process (Causal.trainer (channel 0) 0.5 0.3 (Training.all g))

sendProgram =
   Common.sendProgram (channel 0) (program 0) >>
   process (map Common.singletonBundle)

sendMode =
   Common.sendMode (channel 0) ModeMsg.AllNotesOff

releaseAllKeys =
   mapM_
      (Common.sendKey (channel 0) False (velocity 0))
      [minBound..maxBound]