{-# LANGUAGE FlexibleInstances          #-}
{-# OPTIONS_GHC -fno-warn-orphans       #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HarmTrace.Base.Chord.Tests
-- Copyright   :  (c) 2012--2016, Chordify BV
-- License     :  LGPL-3
--
-- Maintainer  :  haskelldevelopers@chordify.net
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Summary: Defines some property tests for testing the HarmTrace.Base package
--------------------------------------------------------------------------------
module Main where

import HarmTrace.Base.Chord
import HarmTrace.Base.Parse   ( parseDataSafe, pChord )
import HarmTrace.Base.Time

import Test.QuickCheck
import Test.QuickCheck.Test   ( isSuccess )

import Data.List              ( sort, foldl' )

import System.Random          ( Random )
import System.Exit            ( exitFailure, exitSuccess )
import Control.Monad          ( when )

instance Arbitrary DiatonicNatural where
  arbitrary = elements . enumFrom $ C

instance Arbitrary IntNat where
  arbitrary = elements . enumFrom $ I1

instance Arbitrary Accidental where
  arbitrary = elements [Nat,Sh,Fl,SS,FF]


instance Arbitrary Root where
  arbitrary = elements . map pcToRoot $ [0..11]

instance Arbitrary Interval where
  arbitrary = choose (0,21) >>= return . icToInterval

-- instance Arbitrary a => Arbitrary (Note a) where
  -- arbitrary = do nat <- arbitrary
                 -- acc <- arbitrary
                 -- return (Note acc nat)


instance Arbitrary Shorthand where
  arbitrary = elements . enumFrom $ Maj

instance Arbitrary Addition where
  arbitrary = oneof [ arbitrary >>= return . Add
                    , arbitrary >>= return . NoAdd ]

instance Arbitrary a => Arbitrary (Chord a) where
  arbitrary = do r   <- arbitrary
                 sh  <- elements [Maj, Min, Aug, Dim, Maj7, Min7, Sev, Dim7, HDim7, MinMaj7]
                 -- sh  <- arbitrary
                 -- add <- arbitrary >>= listOf . return . Add

                 b   <- arbitrary
                 return (Chord r sh [] b ) -- (Note Nat I1))

instance Arbitrary a => Arbitrary (Timed a) where
  arbitrary = do x  <- arbitrary
                 s  <- elements [2 .. 5]
                 ts <- vector s -- guarantee that this list has a minimum of 2 items
                 return . Timed x . sort $ ts

data ChkTimed = ChkTimed MeterKind [Timed ChordLabel] deriving (Show, Eq)

instance Arbitrary ChkTimed where
  arbitrary = do let -- Step function for creating a Timed ChordLabel
                     f ::Fractional t => [Timed' t a] -> (a, [t]) -> [Timed' t a]
                     f _     (_,[]) = error "should not happen"
                     f [   ] (a, x) = [Timed a (map Time (0:x))]
                     f (h:t) (a, x) = let o   = offset h
                                          g y = Time (y + o)
                                      in Timed a (map g (0:x)) : h : t

                     -- creates additional duplicates at random places
                     -- dups ds ["a","b"] might return ["a", "a", "b"]
                     dups :: [Bool] -> [a] -> [a]
                     dups [ ]     l     = l
                     dups _      [ ]    = []
                     dups (b:bs) (e:es) | b         = e : dups bs (e : es)
                                        | otherwise = e : dups bs es

                 ds <- arbitrary  -- [Bool]
                 as <- arbitrary >>= return . dups ds -- chords including duplicates

                 -- e.g. Gen [[1.2,3.4], [2.2]] etc.
                 ns <- arbitrary >>= return . map (sort . map abs)
                                 >>= return . filter (\x -> let l = length x in l > 0 && l <= 4)

                 mk <- arbitrary -- MeterKind
                 bt <- elements [One, Two, Three, Four]

                 return . ChkTimed mk . updateBeats mk bt
                        . reverse . foldl' f [] $ zip as ns

instance (Random t, Fractional t) => Arbitrary (BeatTime t) where
  arbitrary = do choose (0.0, 100.0) >>= return . Time

instance Arbitrary MeterKind where
  arbitrary = elements [Duple, Triple]

instance Arbitrary Beat where
  arbitrary = elements [One, Two, Three, Four, NoBeat]

instance Arbitrary Mode where
  arbitrary = elements [MajMode, MinMode]

instance Arbitrary Key where
  arbitrary = Key <$> arbitrary <*> arbitrary  
  
pcProp :: Root -> Bool
pcProp r = (toPitchClass r) == toPitchClass (pcToRoot (toPitchClass r))

pcSetProp :: Chord Root -> Bool
pcSetProp c = c == toChord (chordRoot c) (toIntSet c) (chordBass c)

intervalProp :: Interval -> Bool
intervalProp i = i == icToInterval (toIntervalClss i)

-- intervalProp2 :: Int -> Bool
-- intervalProp2 i = i == toIntervalClss (icToInterval i)

enHarEqProp :: Root -> Bool
enHarEqProp a = a &== a

parseProp :: Chord Root -> Bool
parseProp c = parseDataSafe pChord (show c) == c

-- N.B. this test passes if you limit the inversions to intervals within one 
-- octave.
parseNoteInversionProp :: Chord Root -> Bool
parseNoteInversionProp c = parseDataSafe pChord (showChordWithNoteInversion c) == c

mergeTimedTest, mergeTimedTest2, mergeTimedTest3, mergeTimedTest4 :: ChkTimed -> Bool
mergeTimedTest (ChkTimed _ cs) = expandTimed (mergeTimed cs) == expandTimed cs
mergeTimedTest2 (ChkTimed _ cs) = expandTimed (expandTimed cs) == expandTimed cs
mergeTimedTest3 (ChkTimed _ cs) = mergeTimed (mergeTimed cs) == mergeTimed cs
mergeTimedTest4 (ChkTimed _ cs) = mergeTimed (expandTimed cs) == mergeTimed cs

meterKind1, meterKind2 :: ChkTimed -> Bool
meterKind1 (ChkTimed Duple  cs) = mergeTimed (setMeterKind Duple  cs) == mergeTimed cs
meterKind1 (ChkTimed Triple cs) = mergeTimed (setMeterKind Triple cs) == mergeTimed cs

meterKind2 (ChkTimed Duple  cs) = setMeterKind Duple  cs == expandTimed cs
meterKind2 (ChkTimed Triple cs) = setMeterKind Triple cs == expandTimed cs

-- meterKind1 (ChkTimed Duple  cs) = setMeterKind Duple  (setMeterKind Triple cs) == cs
-- meterKind1 (ChkTimed Triple cs) = setMeterKind Triple (setMeterKind Duple  cs) == cs

correctNextBeat :: ChkTimed -> Bool
correctNextBeat (ChkTimed mk cs) = and . map (correctBeatTimes mk . getTimeStamps) $ cs

correctBeatTimes :: Fractional t => MeterKind -> [BeatTime t] -> Bool
correctBeatTimes _  [ ] = True
correctBeatTimes _  [_] = True
correctBeatTimes mk (a:b:tl) = beat b == nextBeat mk (beat a) && correctBeatTimes mk tl

correctNextBeatMK :: (MeterKind, ChkTimed) -> Bool
correctNextBeatMK (mk, ChkTimed _ cs) = correctNextBeat
                                      . ChkTimed mk . mergeTimed . setMeterKind mk $ cs


keyShowRead :: Key -> Bool
keyShowRead k = (read $ show k) == k

--------------------------------------------------------------------------------
-- Execute the tests
--------------------------------------------------------------------------------

main :: IO ()
main = do let myTest :: Testable p => String -> [p] -> IO ()
              myTest s p = do putStrLn (" *** Testing HarmTrace-Base: "++ s ++": ... ")
                              rs <- mapM verboseCheckResult p
                              when (not . all isSuccess $ rs) exitFailure

          myTest "roots"        [ pcProp, enHarEqProp ]
          myTest "chords"       [ pcSetProp, parseProp ]
          myTest "intervals I"  [ intervalProp ]
          -- myTest "intervals II" [ intervalProp2 ]
          myTest "mergeTimed"   [ mergeTimedTest, mergeTimedTest2, mergeTimedTest3, mergeTimedTest4 ]
          myTest "nextBeat"     [ correctNextBeat ]
          myTest "meterKind"    [ meterKind1, meterKind2 ]
          myTest "meterKind II" [ correctNextBeatMK ]
          myTest "keyShowRead"  [ keyShowRead ]
          exitSuccess