{- |
Module      :  $Header$
Description :  Module that contains basic music definitions
Copyright   :  (c) David Janin, 2017
License     :  see the LICENSE file in the distribution

Maintainer  :  janin@labri.fr
Stability   :  experimental

This module extends midi data types with adhoc parameters.
-}

{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}

{-# LANGUAGE FlexibleInstances,
             MultiParamTypeClasses,
             ScopedTypeVariables #-}

module TScore.MidiPlus where

import TScore.Midi
import Data.Word.Odd
import GHC.Float
import Tile.Tile

import System.IO.Unsafe
import System.Random
import Data.List
import Debug.Trace


-- | Pattern of bounded integers with explicit (dynamic) bounds
data Pattern = Pattern {
      lval:: [Int],
      minV:: Int,
      maxV :: Int
              } deriving (Show,Eq,Read)
             
-- | Rescales the value of a given pattern
rescale :: Pattern -> Int -> Int -> Pattern
rescale (Pattern lv min max) nmin nmax
    = if (nmin >= nmax) then (Pattern (fmap (const nmin) lv) nmin nmin) else
          let nrange = int2Float (nmax - nmin)
              rescaleV v = let ratio = int2Float (v - min) / int2Float (max - min)
                           in nmin + round (ratio*nrange)                     
          in (Pattern (fmap rescaleV lv) nmin nmax)

-- | Linear interpolation of pattern to change its length
density :: Integer -> Pattern -> Pattern
density n' (Pattern lv min max)
    = let n = maximum[ 1,n']-- be sure n greater than 0
      in (Pattern (fmap (interpolate n lv) [0..(n-1)])  min max)

-- | Linear interpolation of integers in list
interpolate :: Integer -> [Int] -> Integer -> Int
interpolate 1 l x = l!!0
interpolate n l x'
    = let x = max 0 (min x' (n-1))
          -- x should ranges from 0 to n-1
          sp = toRational ((length l) -1) / fromInteger (n- 1)
          h = toRational x * sp -- h ranges from 0 to |l|-1
          h1 = floor h 
          h2 =ceiling h 
          delta = fromRational$ h - toRational h1
      in round $ (1 -delta)*(toRational $ l!!h1) + delta*(toRational $ l!!(h2))
                    
makeRythmPattern :: Fractional d => Pattern -> d -> [d]
makeRythmPattern p length
    = let p1 = lval (rescale p 1 4) :: [Int]
          p2 = map (\x -> 1/x) $ fmap (fromIntegral) p1
          d = 10 -- foldl (+) 0 p2
          p3 = map (\x -> (length)*x/d) p2
      in p3


{-# NOINLINE randomPermute #-}
randomPermute :: [t] -> [t]
randomPermute [] = []
randomPermute l = let n = unsafePerformIO (randomRIO (1,length l))
                  in l!!(n-1): randomPermute (take (n-1) l ++ drop n l)

dodecaphonicMode :: Num t => () -> [t]
dodecaphonicMode () = randomPermute [0,1,2,3,4,5,6,7,8,9,10,11]


-- * Some basic functions handling lastest appeareance record (LAR) and key detection from augmented fifth detection
                      
-- | Update the LAR by the arrival of a new element

larUpdate :: Eq a => [a] -> a -> [a]
larUpdate l p =  
    let (l1,l2) = span ( /= p) l
    in case l2 of
         (p:l2') -> (p:l1)++ l2' -- cutLast l2'
         _ -> p:l

-- | Cuts the last element of a list
cutLast [] = []
cutLast [x] = []
cutLast (x:l) = x:(cutLast l)

-- | update the LAR by the arrival of a list of new element

-- lar ::(Eq a) => [a] -> [a] -> [a]
-- lar l0 l = foldl larUpdate l0 l

-- | update the LAR by the arrival of a list of pitches, read as pitch classes (modulo 12)

larPc :: (Integral a, Num a, Eq a) => [a] -> [a] -> [a]
larPc l0 l = foldl larUpdate l0 (fmap (\x -> mod x 12) l)

            
-- | Scales generators
              
data ScaleS a = ScaleS [a] (a,ScaleType) deriving (Show,Eq)

instance Functor  ScaleS where
    fmap f (ScaleS l (a,st)) = ScaleS (fmap f l) (f a,st)

                               
instance Ord a => Ord (ScaleS a) where
    compare (ScaleS l1 (a1,st1)) (ScaleS l2 (a2,st2))
        = case compare st1 st2 of
            LT -> LT
            GT -> GT
            EQ -> compare (a1,l1) (a2,l2)
                                     
majorC = ScaleS [0, 2, 4, 5, 7, 9, 11] (0,Major)
pentatonicC = ScaleS [0, 2, 4, 7, 9] (0,Pentatonic)
minorC = ScaleS [0, 2, 3, 5, 7, 8, 11] (0,Minor)
indianC = ScaleS [0, 1, 4, 5, 7, 8, 11] (0,Altered)
toneC = ScaleS [0,2,4,6,8,10] (0,Tone)
betweenC = ScaleS [0,2,4,7,9] (0,Between)
diminished1C  = ScaleS [0,1,3,4,6,7,9,10] (0,Diminished)
diminished2C  = ScaleS [0,2,3,5,6,8,9,11] (1,Diminished)
chromaticC = ScaleS [0,1,2,3,4,5,6,7,8,9,10,11] (0,Chromatic)

             
scaleS :: (Integral a, Num a) => a -> ScaleS a -> ScaleS a           
scaleS p s = let (ScaleS l (a,st)) = fmap (\x -> mod (x + p) 12) s
             in ScaleS (sort l) (a,st)

-- | Generates a sorted lists of all pitches in a every given keys
generateAllKeys k = fmap (\s -> (fmap (\p -> scaleS p s) [0..11])) k

-- | All keys and scales among which the computer may choose when analyzing the input
allKeys = []
          -- ++ (sort $ concat $ generateAllKeys [pentatonicC]) ++ [toneC]
          -- ++ (sort $ concat $ generateAllKeys [betweenC])
          ++ (sort $ concat $ generateAllKeys [majorC])
          -- ++ (sort $ concat $ generateAllKeys [minorC]) 
          -- ++(sort $ concat $ generateAllKeys [indianC])
          -- ++ [diminished1C,diminished2C,chromaticC]

-- | Gets keys that are compatible with an LAR sorted list of last pitches
getCompatibleKeys l =
    let filter (ScaleS l0 (a,st)) l =
            isSubsequenceOf (sort l) l0
    in fmap (\(ScaleS _ (a,s)) -> (a, s)) $ sort  [m | m <- allKeys, filter m l]

-- | Changes key according to previous key and  an LAR sorted list of last pitches
changeKey (pc,st, []) = (pc,st)
changeKey (pc,st, l)
    = let filter (ScaleS l0 (a,st)) l =
            isSubsequenceOf l l0
          sp = [m | m <- allKeys, filter m (sort l)]
               
          leastWeight w lo l [] = (w,lo)
          leastWeight w lo l (s@(ScaleS sl _):sp) =
              let nw = scaleDist l sl
              in case (compare nw w) of
                   LT -> leastWeight nw [s] l sp
                   EQ -> leastWeight w (s:lo) l sp
                   GT -> leastWeight w lo l sp
          (w,lo) = -- traceShowId $
                   leastWeight 15 [] (sort l) allKeys
          (w1,lo1) = -- traceShowId $
                     leastWeight 15 [] (take 3 $ sort l) lo
      in case (w <= 6) of
           False -> (pc,st)
           True -> case lo1 of
                     [] -> error "change Key: this should not happen"
                     (ScaleS _ (a,st):_) -> (pitchToPitchClass a, st)
               
{-    = let sp = getCompatibleKeys l
      in  case sp of
            [] -> changeKey (pc,st,cutLast l)
            _ -> {- case isSubsequenceOf [(pitchClassToPitch pc,st)] sp of
                   True -> (pc,st)
                   False -> -} let sp' = fmap (\(a,st) -> (pitchToPitchClass a, st)) sp
                            in  (sortBy (pcstOrd (pc,st)) sp') !! 0  -- choosing the smalest change
  -}

-- | Distance between scale seen as ordered pitch classes (from 0 to 11)
scaleDist :: [MidiPitch] -> [MidiPitch] -> Int 
scaleDist [] l = length l 
scaleDist l [] = length l
scaleDist (x:xs) (y:ys) =
    case (compare x y) of
      LT -> 1 + scaleDist xs (y:ys)
      EQ -> scaleDist xs ys
      GT -> 1 + scaleDist (x:xs) ys
            
-- | Distance between pitchclesses seen as keys
pcDist :: PitchClass -> PitchClass -> Int
pcDist pc1 pc2 =
    let p1 = fromEnum . pitchToPitchClass . pitchClassToPitch $ pc1
        p2 = fromEnum . pitchToPitchClass . pitchClassToPitch $ pc2
    in min (mod (p2 -p1) 12) (12 - (mod (p2 -p1) 12))

-- | Distance between scales
pcstDist :: (PitchClass, ScaleType)
                  -> (PitchClass, ScaleType) -> Int
pcstDist (pc1,st1) (pc2,st2) =
    case (st1 == st2) of
      True -> 2*(pcDist pc1 pc2)
      False -> case st1 of
                 Major -> 1+2*(pcDist (toEnum(3+fromEnum pc1)) pc2)
                 _ -> 1+2*(pcDist (toEnum(3+fromEnum pc2)) pc1)
--                 _ -> 14 -- greater than 2*6+1

-- | Partial ordering of scales with respect to a given scale
pcstOrd (pc,st) (pc1,st1) (pc2,st2) 
    = let d1 = pcstDist (pc,st) (pc1,st1)
          d2 = pcstDist (pc,st) (pc2,st2)
      in case (compare st1 st2) of
           LT -> LT
           GT -> GT
           _ -> compare d1 d2