{-# LANGUAGE RebindableSyntax #-}
module Spreadsheet.Format (
   Results,
   Measurements,
   AllPaths,
   TableFormats(..),

   Flags(..), defaultFlags,
   RecordingFlags(..),

   writeOverviewHead,
   writeOverviewFoot,
   appendOverview,
   appendTreatmentOverview,
   formatTables,

   -- * utility
   (<->),
   ) where

import qualified LabelTrack
import qualified LabelChain
import qualified Durations as Durs
import qualified ClassRecord
import qualified Class
import qualified Time
import qualified SpectralDistribution as SD
import qualified Signal
import qualified Rate
import Measurement
         (SpectralParameters(SpectralParameters, spectralFlatness),
          ClassFeatures, )

import qualified Spreadsheet.Formula as CalcForm
import qualified Spreadsheet.Palisade as Palisade
import qualified Spreadsheet.Row as CalcRow
import qualified Text.CSV.Lazy.String as CSV
import Spreadsheet.Row (FieldTracked, Precision(Prec0, Prec3, Prec6))

import qualified Data.Text as Text
import Data.Text (Text, )

import qualified Control.Monad.Trans.Writer as MW
import Control.DeepSeq (NFData, rnf, force, )
import Control.Monad (void, liftM2, liftM3, when, )
import Control.Applicative (Applicative, liftA2, liftA3, pure, (<*>), )
import Data.Biapplicative (bipure, (<<*>>), )

import qualified Data.Traversable as Trav
import qualified Data.Foldable as Fold
import qualified Data.NonEmpty as NonEmpty
import qualified Data.List.Match as Match
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Monoid.HT as Mn
import qualified Data.Semigroup as Sg
import qualified Data.Char as Char
import Data.IORef (IORef, newIORef, readIORef, modifyIORef, )
import Data.Foldable (foldMap, fold, )
import Data.Monoid (Monoid, mempty, mappend, (<>), )
import Data.Tuple.HT (mapPair, mapSnd, fst3, snd3, thd3, )
import Data.Maybe.HT (toMaybe, )
import Data.Maybe (mapMaybe, )
import Data.Map (Map, )

import qualified System.FilePath.Find as Find
import qualified System.Path.PartClass as PathClass
import qualified System.Path.Directory as Dir
import qualified System.Path.IO as PathIO
import qualified System.Path as Path
import System.FilePath.Find ((~~?), (==?), (&&?), (||?), )
import System.Path ((</>), (<.>), )
import Text.Printf (printf, )

import qualified Algebra.RealRing as Real
import qualified Algebra.Transcendental as Trans
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import Algebra.ToRational (realToField)
import NumericPrelude.Numeric
import NumericPrelude.Base
import Prelude (Num)


spectralParametersReal ::
   (Trans.C a) =>
   Formula a -> SpectralParameters Float ->
   SpectralParameters (Formula a)
spectralParametersReal
      rate (SpectralParameters flatness maxFreq (centroid,deviation) distr) =
   SpectralParameters
      (realToField flatness) (rate * realToField maxFreq)
      (realToField centroid, realToField deviation)
      (spectralDistributionReal rate distr)

spectralDistributionReal ::
   (Trans.C a) =>
   Formula a -> SD.T Float -> SD.T (Formula a)
spectralDistributionReal rate (SD.Cons centroid spread) =
   let angularRate = rate / (Ring.fromInteger 2 * CalcForm.pi)
   in  SD.Cons
          (realToField centroid * angularRate)
          (realToField (SD.signedSqrt spread) * angularRate)


type Cell = CalcForm.CellTracked
type Formula = CalcForm.FormulaTracked


palBounds ::
   (CalcRow.Fraction a, Real.C a) =>
   Palisade.T (Cell a) a
palBounds =
   Palisade.colNoSum "Start/s"
   `Palisade.right`
   Palisade.colNoSum "Stop/s"
   `Palisade.right`
   Palisade.colSum Prec6 "Duration/s"

rowBounds ::
   (CalcRow.Fraction a) =>
   Formula a -> (Int,Int) -> CalcRow.M (Cell a)
rowBounds rate bounds = do
   start <- CalcRow.putFractionFormula Prec6 $ fromIntegral (fst bounds) / rate
   stop  <- CalcRow.putFractionFormula Prec6 $ fromIntegral (snd bounds) / rate
   CalcRow.putFraction Prec6 $ stop - start


precSpectral :: SpectralParameters Precision
precSpectral = (pure Prec0) {spectralFlatness = Prec3}

palSpectral ::
   (CalcRow.Fraction a, Real.C a) =>
   Palisade.T (SpectralParameters (Cell a)) (SpectralParameters a)
palSpectral =
   Palisade.Cons
      (map (flip (,) True) $ Fold.toList $
       SpectralParameters
          "WienerEntropy" "MaxFreq/Hz"
          ("BandCentroid/Hz", "BandDeviation/Hz")
          (SD.Cons "SpecCentroid/Hz" "SpecSpread/Hz"))
      (fold . liftA2 Palisade.summarySum5 precSpectral . Trav.sequenceA)
      (fmap CalcForm.trackedNumber)
      (fold . liftA2 Palisade.summary5String precSpectral . Trav.sequenceA)

rowSpectral ::
   (CalcRow.Fraction a) =>
   SpectralParameters (Formula a) ->
   CalcRow.M (SpectralParameters (Cell a))
rowSpectral =
   Trav.sequence . liftA2 CalcRow.putFraction precSpectral


_palClickDur :: (CalcRow.Fraction a, Real.C a) => Palisade.T (Cell a) a
_palClickDur = Palisade.colSum5 Prec6 "ClickDur/s"

_rowClickDur ::
   (CalcRow.Fraction a) =>
   Formula a -> [LabelChain.ClickAbs Int] -> CalcRow.M (Cell a)
_rowClickDur rate clicks =
   CalcRow.putFraction Prec6 $
      fromIntegral (sum (map (\(LabelChain.ClickAbs t0 t1 _) -> t1-t0) clicks))
      /
      (rate * fromIntegral (length clicks))


type Advertisement a = (BoundRasping a, Maybe (BoundChirping a))

type BoundAdvertisement a = (a, Advertisement a)

palBoundAdvertisement ::
   (CalcRow.Fraction a, Real.C a) =>
   Palisade.T (BoundAdvertisement (Cell a)) (BoundAdvertisement a)
palBoundAdvertisement =
   Palisade.pair palBounds $
   Palisade.pair
      (Palisade.mapHeaders ("Slow " ++) $
       Palisade.pair (Palisade.colSum5 Prec6 "Dur/s") palRasping)
      (Palisade.maybe $
       Palisade.mapHeaders ("Fast " ++) $
       Palisade.pair (Palisade.colSum5 Prec6 "Dur/s") palChirping)

type Rasping a = ((a, a), (a, a, a), SpectralParameters a)

palRasping ::
   (CalcRow.Fraction a, Real.C a) =>
   Palisade.T (Rasping (Cell a)) (Rasping a)
palRasping =
   Palisade.triple
      (Palisade.pair
         (Palisade.colSum Prec3 "NumClicks")
         (Palisade.colSum Prec3 "NumEmphasized"))
      (Palisade.triple
         (Palisade.colSum5 Prec3 "ClickRate/Hz")
         (Palisade.colSum5 Prec6 "ClickHalfLife/s")
         (Palisade.colSum5 Prec6 "ClickPause/s"))
      palSpectral

rowRasping ::
   (CalcRow.Fraction a) =>
   Formula a -> Formula a ->
   ((Int, Int, Int), SpectralParameters (Formula a)) ->
   CalcRow.M (Rasping (Cell a))
rowRasping rate dur
      ((numClicksInt, sumHalfLifes, numEmphasizedInt), spectralDistr) = do
   numClicksCell <- CalcRow.putInt numClicksInt
   let numClicks = CalcForm.trackedVar numClicksCell
   numEmphasized <- CalcRow.putInt numEmphasizedInt
   clickRate <- CalcRow.putFraction Prec3 $ numClicks / dur
   hlife <-
      CalcRow.putFraction Prec6 $
      fromIntegral sumHalfLifes / (numClicks * rate)
   clickPause <-
      CalcRow.putFraction Prec6 $ dur / numClicks - CalcForm.trackedVar hlife
   spectral <- rowSpectral spectralDistr
   return
      ((numClicksCell, numEmphasized),
       (clickRate, hlife, clickPause),
       spectral)

type BoundRasping a = (a, Rasping a)

palBoundRasping ::
   (CalcRow.Fraction a, Real.C a) =>
   Palisade.T (BoundRasping (Cell a)) (BoundRasping a)
palBoundRasping = Palisade.pair palBounds palRasping


type Chirping a = (a, SpectralParameters a)

palChirping ::
   (CalcRow.Fraction a, Real.C a) =>
   Palisade.T (Chirping (Cell a)) (Chirping a)
palChirping =
   Palisade.pair (Palisade.colSum5 Prec6 "MainDur/s") palSpectral

rowChirping ::
   (CalcRow.Fraction a) =>
   Formula a ->
   (Int, SpectralParameters (Formula a)) ->
   CalcRow.M (Chirping (Cell a))
rowChirping rate (brk, spectralDistr) = do
   mainDur <- CalcRow.putFraction Prec6 $ fromIntegral brk / rate
   spectral <- rowSpectral spectralDistr
   return (mainDur, spectral)

rowNoChirping :: CalcRow.M ()
rowNoChirping =
   case palChirping ::
         Palisade.T (Chirping (Cell Double)) (Chirping Double) of
      Palisade.Cons tabHeadChirping _ _ _ ->
         sequence_ $ Match.replicate tabHeadChirping CalcRow.putEmpty

type BoundChirping a = (a, Chirping a)

palBoundChirping ::
   (CalcRow.Fraction a, Real.C a) =>
   Palisade.T (BoundChirping (Cell a)) (BoundChirping a)
palBoundChirping = Palisade.pair palBounds palChirping


type Ticking a = (a, a, SpectralParameters a)

palTicking ::
   (CalcRow.Fraction a, Real.C a) =>
   Palisade.T (Ticking (Cell a)) (Ticking a)
palTicking =
   Palisade.triple
      (Palisade.colSum5 Prec3 "NumClicks")
      (Palisade.colSum Prec3 "ClickRate/Hz")
      palSpectral

rowTicking ::
   (CalcRow.Fraction a) =>
   Formula a ->
   (Int, SpectralParameters (Formula a)) ->
   CalcRow.M (Ticking (Cell a))
rowTicking dur (numClicksInt, spectralDistr) = do
   numClicks <- CalcRow.putInt numClicksInt
   clickRate <- CalcRow.putFraction Prec3 $ CalcForm.trackedVar numClicks / dur
   spectral <- rowSpectral spectralDistr
   return (numClicks, clickRate, spectral)

type BoundTicking a = (a, Ticking a)

palBoundTicking ::
   (CalcRow.Fraction a, Real.C a) =>
   Palisade.T (BoundTicking (Cell a)) (BoundTicking a)
palBoundTicking = Palisade.pair palBounds palTicking


type Growling a = Rasping a

palGrowling ::
   (CalcRow.Fraction a, Real.C a) =>
   Palisade.T (Growling (Cell a)) (Growling a)
palGrowling = palRasping

rowGrowling ::
   (CalcRow.Fraction a) =>
   Formula a -> Formula a ->
   ((Int, Int, Int), SpectralParameters (Formula a)) ->
   CalcRow.M (Growling (Cell a))
rowGrowling = rowRasping

type BoundGrowling a = (a, Growling a)

palBoundGrowling ::
   (CalcRow.Fraction a, Real.C a) =>
   Palisade.T (BoundGrowling (Cell a)) (BoundGrowling a)
palBoundGrowling = Palisade.pair palBounds palGrowling


data EvalType = Number | Formula
   deriving (Eq, Ord, Show, Enum)

typeName :: EvalType -> String
typeName typ =
   case typ of
      Formula -> "formula"
      Number -> "number"

typeSelect :: EvalType -> CalcForm.Tracked a a -> a
typeSelect typ =
   case typ of
      Formula -> CalcForm.trackedFormula
      Number -> CalcForm.trackedNumber


infixl 7 <->

(<->) :: Path.File ar -> String -> Path.File ar
path <-> var = Path.mapFileName (++ "-" ++ var) path

formatTable ::
   (PathClass.AbsRel ar) =>
   Path.File ar -> EvalType -> String -> [[FieldTracked]] ->
   TableFormats (Path.File ar, Text)
formatTable outputStem typ cls content =
   liftA2 (,)
      (fmap
         (\ext -> outputStem <-> map Char.toLower cls <-> typeName typ <.> ext)
         formatExtensions)
      (fmap
         (\fmt ->
            Text.pack $
            formatOpen fmt cls ++ formatRows fmt typ content ++ formatClose fmt) $
       formats)


formatMultiTable ::
   (PathClass.AbsRel ar) =>
   Path.File ar -> EvalType ->
   ClassRecord.T (String, [[FieldTracked]]) ->
   TableFormats (Path.File ar, Text)
formatMultiTable outputStem typ tables =
   liftA2 (,)
      (fmap (\ext -> outputStem <-> typeName typ <.> ext) formatExtensions)
      (fmap
         (\fmt ->
            Text.pack $
               formatFileOpen fmt ++
               foldMap (uncurry (formatSheet fmt typ)) tables ++
               formatFileClose fmt)
       formats)

renderTable2 ::
   Palisade.T a b -> [CalcRow.M a] -> ([[FieldTracked]], [b])
renderTable2 (Palisade.Cons tabHead aggregate select _) table =
   let (meass, content) = unzip $ zipWith CalcRow.run [1..] table
   in  ((map tableHead $ "Source" : map fst tabHead) :
        content ++
        [] :
        List.transpose
          (map tableHead (Fold.toList Palisade.summary5Names ++ ["Sum"]) :
           flip map (aggregate meass)
             (\(sum5, sumRes) -> Fold.toList sum5 ++ [sumRes]))
        ,
        map select meass)


data TableFormats a = TableFormats {tableCSV, tableHTML, tableXML2003 :: a}
type TablePaths ar = TableFormats (Maybe (Path.File ar))
data Resolutions a = Resolutions {resTreatment, resAnimal, resRecording :: a}
type ResPaths ar = Resolutions (TablePaths ar)
type ClassPaths ar = ClassRecord.T (ResPaths ar)
type DurPaths ar = ((TablePaths ar, TablePaths ar), IORef Int)
type AllPaths ar = (DurPaths ar, ClassPaths ar, (Path.Dir ar, String, String))


instance Functor TableFormats where
   fmap = Trav.fmapDefault

instance Fold.Foldable TableFormats where
   foldMap = Trav.foldMapDefault

instance Trav.Traversable TableFormats where
   traverse f (TableFormats csv html xml2003) =
      liftA3 TableFormats (f csv) (f html) (f xml2003)

instance Applicative TableFormats where
   pure a = TableFormats a a a
   TableFormats fCSV fHTML fXML2003 <*> TableFormats xCSV xHTML xXML2003 =
      TableFormats (fCSV xCSV) (fHTML xHTML) (fXML2003 xXML2003)

formatExtensions :: TableFormats String
formatExtensions = TableFormats "csv" "html" "xml"


instance Fold.Foldable Resolutions where
   foldMap f (Resolutions treatment animal recording) =
      f treatment <> f animal <> f recording


tableHead :: String -> FieldTracked
tableHead content =
   (tableField content) {
      CalcRow.fieldHead = True
   }

tableSpanHead :: Int -> String -> FieldTracked
tableSpanHead colSpan content =
   (tableHead content) {
      CalcRow.fieldSpan = colSpan
   }

tableField :: String -> FieldTracked
tableField content =
   CalcRow.TableField {
      CalcRow.fieldType = CalcRow.TypeString,
      CalcRow.fieldQuoted = False,
      CalcRow.fieldAnchor = "",
      CalcRow.fieldHead = False,
      CalcRow.fieldSpan = 1,
      CalcRow.fieldPrecision = Nothing,
      CalcRow.fieldContent = CalcForm.untracked content
   }

tableFieldInt :: Int -> FieldTracked
tableFieldInt number =
   (tableField $ show number) {
      CalcRow.fieldType = CalcRow.TypeNumber
   }

tableFieldAnchor ::
   (PathClass.FileDir fd) =>
   Path.AbsDir -> Path.Rel fd -> FieldTracked
tableFieldAnchor path file =
   (tableField $ Path.toString file) {
      CalcRow.fieldAnchor = Path.toString $ path </> file
   }


initFile ::
   (PathClass.AbsRel ar) =>
   Path.File ar -> String -> IO (Path.File ar)
initFile path str = do
   PathIO.writeFile path str
   return path



data
   Format =
      Format {
         formatOpen :: String -> String,
         formatClose :: String,
         formatRows :: EvalType -> [[FieldTracked]] -> String,
         formatFileOpen :: String,
         formatFileClose :: String,
         formatSheet :: EvalType -> String -> [[FieldTracked]] -> String
      }

formats :: TableFormats Format
formats =
   TableFormats {
      tableCSV = formatCSV,
      tableHTML = formatHTML,
      tableXML2003 = formatXML2003
   }

formatCSV, formatHTML, formatXML2003 :: Format
formatCSV =
   Format {
      formatOpen = const "",
      formatClose = "",
      formatRows = formatCSVRows,
      formatFileOpen = "",
      formatFileClose = "",
      formatSheet = \typ name content ->
         (prettyCSVTable [[name]])
         ++
         formatCSVRows typ content
         ++
         (prettyCSVTable [[]])
   }

formatHTML =
   let fileOpenNamed name =
         "<html lang=en>" :
         printf "<head><title>%s</title></head>" name :
         "<body>" :
         []

       fileOpen =
         "<html lang=en>" :
         "<body>" :
         []

       tableOpen =
         "<table>" :
         []

       tableClose =
         "</table>" :
         []

       fileClose =
         "</body>" :
         "</html>" :
         []

   in  Format {
          formatOpen = \name -> unlines $ fileOpenNamed name ++ tableOpen,
          formatClose = unlines $ tableClose ++ fileClose,
          formatRows = (unlines .) . formatHTMLRows,
          formatFileOpen = unlines fileOpen,
          formatFileClose = unlines fileClose,
          formatSheet = \typ name content -> unlines $
             printf "<h1>%s</h1>" name
             :
             tableOpen
             ++
             formatHTMLRows typ content
             ++
             tableClose
       }

formatXML2003 =
   let fileOpen =
         "<?xml version='1.0' encoding='UTF-8'?>" :
         "<?mso-application progid='Excel.Sheet'?>" :
         "<Workbook" :
         "  xmlns='urn:schemas-microsoft-com:office:spreadsheet'" :
         "  xmlns:c='urn:schemas-microsoft-com:office:component:spreadsheet'" :
         "  xmlns:o='urn:schemas-microsoft-com:office:office'" :
         "  xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet'" :
         "  xmlns:x2='http://schemas.microsoft.com/office/excel/2003/xml'" :
         "  xmlns:x='urn:schemas-microsoft-com:office:excel'>" :
         "<Styles>" :
         "<Style ss:ID='head'>" :
         "  <Alignment ss:Horizontal='Center'/>" :
         "  <Font ss:Bold='1'/>" :
         "</Style>" :
         "<Style ss:ID='frac0'>" :
         "  <NumberFormat ss:Format='0'/>" :
         "</Style>" :
         "<Style ss:ID='frac3'>" :
         "  <NumberFormat ss:Format='0.000'/>" :
         "</Style>" :
         "<Style ss:ID='frac6'>" :
         "  <NumberFormat ss:Format='0.000000'/>" :
         "</Style>" :
         "</Styles>" :
         []

       tableOpen name =
         printf "<ss:Worksheet ss:Name='%s'>" name :
         "<Table>" :
         []

       tableClose =
         "</Table>" :
         "</ss:Worksheet>" :
         []

       fileClose =
         "</Workbook>" :
         []

   in  Format {
          formatOpen = \name -> unlines $ fileOpen ++ tableOpen name,
          formatClose = unlines $ tableClose ++ fileClose,
          formatRows = (unlines .) . formatXML2003Rows,
          formatFileOpen = unlines fileOpen,
          formatFileClose = unlines fileClose,
          formatSheet = \typ name content -> unlines $
             tableOpen name
             ++
             formatXML2003Rows typ content
             ++
             tableClose
       }



writeTableInit ::
   (PathClass.AbsRel ar) =>
   TableFormats Bool -> Path.File ar ->
   [[FieldTracked]] -> IO (TablePaths ar)
writeTableInit mask path content = do
   let name = Path.toString $ Path.takeFileName path
   Trav.sequence $
      liftA3
         (\enable ext fmt ->
            Trav.sequence $ toMaybe enable $
            initFile (path <.> ext)
               (formatOpen fmt name ++ formatRows fmt Number content))
         mask formatExtensions formats


expandTableHead1 :: [(String, [String])] -> [[FieldTracked]]
expandTableHead1 =
   (:[]) .
   concatMap (\(top,below) -> map (tableHead . ((top++"\n") ++)) below)

expandTableHead2 :: [(String, [String])] -> [[FieldTracked]]
expandTableHead2 =
   (\(top,below) -> [top, concat below]) . unzip .
   map (\(top,below) -> (tableSpanHead (length below) top, map tableHead below))

{-
ToDo:
We could try to write the median for every recording
immediately after the processing of the recording is finished.
However this would require more effort to bring the rows in order,
since the recordings are processed in parallel.
-}
writeMedianHead ::
   (PathClass.AbsRel ar) =>
   TableFormats Bool -> Bool -> Path.Dir ar ->
   Palisade.T (Cell Double, a) (Double, b) ->
   String -> IO (ResPaths ar)
writeMedianHead mask divTH output pal cls = do
   let headers = map fst $ filter snd $ Palisade.header pal
   let summ5Names = Fold.toList Palisade.summary5Names
   let writeHead resolution leading = do
         writeTableInit mask
               (output </> Path.path (map Char.toLower cls) <-> resolution) $
            (if divTH then expandTableHead2 else expandTableHead1) $
            map (flip (,) [""]) leading ++ map (flip (,) summ5Names) headers
   liftM3 Resolutions
      (writeHead "treatment" $ "Night" : "Treatment" : "Number" : [])
      (writeHead "animal" $ "Night" : "Animal" : "Trial" : "Number" : [])
      (writeHead "recording" $
         "Night" : "Animal" : "Trial" : "Recording" : "Number" : [])

findAdvertisementData ::
   (PathClass.AbsRel ar) => String -> Path.Dir ar -> IO [Path.File ar]
findAdvertisementData fmt =
   let isAdv =
         Find.fileName ~~? printf fmt "*" &&?
         (Find.fileType ==? Find.RegularFile ||?
          Find.fileType ==? Find.SymbolicLink)
   in  fmap (map Path.path) . Find.find (Find.depth ==? 0) isAdv . Path.toString

writeOverviewHead ::
   (PathClass.AbsRel ar) => Flags -> Path.Dir ar -> IO (AllPaths ar)
writeOverviewHead flags output = do
   let backup pathFmt =
         findAdvertisementData pathFmt output >>=
            mapM_ (\path -> Dir.renameFile path (path <.> "bak"))
   let advertisementHourlyFmt = "advertisement-hourly-%s.ssv"
   let advertisementFmt = "advertisement-%s.ssv"
   backup advertisementHourlyFmt
   backup advertisementFmt
   let durHead =
         map tableHead $
         ["Night", "Animal", "Trial"] ++
         Fold.toList (fmap (++"/s") Durs.names) ++
         "Sum/s" : Fold.toList (fmap (++" rel") ClassRecord.names)
   let (CalcForm.Tracked emitForm emitNumber) = emitFormula flags
   let writeDurationHead enable typ =
         writeTableInit (fmap (enable&&) $ emitFormats flags)
            (output </> Path.path "duration" <-> typeName typ) [durHead]
   durationTable <-
      liftM2 (,)
         (writeDurationHead emitForm Formula)
         (writeDurationHead emitNumber Number)
   rowRef <- newIORef 0
   let writeMedHead =
         writeMedianHead (emitFormats flags) (dividedTableHead flags) output
   medianTables <-
      Trav.sequence $
         ClassRecord.Cons
            (writeMedHead palBoundAdvertisement)
            (writeMedHead palBoundRasping)
            (writeMedHead palBoundChirping)
            (writeMedHead palBoundTicking)
            (writeMedHead palBoundGrowling)
         <*>
         ClassRecord.names
   return ((durationTable, rowRef), medianTables,
           (output, advertisementFmt, advertisementHourlyFmt))

for2_ ::
   (Applicative t, Applicative f, Fold.Foldable t) =>
   t a -> t b -> (a -> b -> f ()) -> f ()
for2_ xs ys act =
   Fold.sequenceA_ $ liftA2 act xs ys

writeOverviewFoot ::
   (PathClass.AbsRel ar) => AllPaths ar -> IO ()
writeOverviewFoot
      (((durationFormulaTable, durationNumberTable), _rowRef),
       classTables, _advertisementPath) = do
   let closeTable paths =
         for2_ paths formats $ \mpath format ->
            Fold.for_ mpath $ \path ->
               PathIO.appendFile path $ formatClose format
   closeTable durationFormulaTable
   closeTable durationNumberTable
   Fold.mapM_ (Fold.mapM_ closeTable) classTables


formatField :: EvalType -> FieldTracked -> String
formatField typ x =
   case CalcRow.fieldContent x of
      CalcForm.Tracked formula str ->
         case typ of
            Number -> str
            Formula -> maybe str (('=':) . CalcForm.formatCSV) formula

prettyCSVTable :: [[String]] -> String
prettyCSVTable = CSV.ppCSVTable . snd . CSV.toCSVTable

formatCSVRows :: EvalType -> [[FieldTracked]] -> String
formatCSVRows typ =
   prettyCSVTable .
   map
      (concatMap
         (\x -> take (CalcRow.fieldSpan x) $ formatField typ x : repeat ""))

formatHTMLRows :: EvalType -> [[FieldTracked]] -> [String]
formatHTMLRows typ =
   map (\row -> "<tr>"++row++"</tr>") .
   map (concatMap
      (\x ->
         let tag = if CalcRow.fieldHead x then "th" else "td"
             colSpan, anchorOpen, anchorClose :: String
             colSpan =
               Mn.when (CalcRow.fieldSpan x > 1) $
                  printf " colspan=%d" (CalcRow.fieldSpan x)
             (anchorOpen, anchorClose) =
               Mn.when (not $ null $ CalcRow.fieldAnchor x)
                  (printf "<a href='%s'>" $ CalcRow.fieldAnchor x, "</a>")
             escape = concatMap (\c -> if c=='\n' then "<br>" else [c])
         in  printf "<%s%s>%s%s%s</%s>"
               tag colSpan anchorOpen
               (escape $ formatField typ x) anchorClose tag))

formatXML2003Rows :: EvalType -> [[FieldTracked]] -> [String]
formatXML2003Rows ftyp =
   concatMap (\row -> "<Row>" : row ++ "</Row>" : []) .
   map (map
      (\x ->
         let style, colSpan, anchor :: String
             style =
               if CalcRow.fieldHead x
                 then " ss:StyleID='head'"
                 else foldMap
                        (printf " ss:StyleID='%s'" . precision)
                        (CalcRow.fieldPrecision x)
             precision prec =
               case prec of
                  Prec0 -> "frac0"
                  Prec3 -> "frac3"
                  Prec6 -> "frac6"
             colSpan =
               Mn.when (CalcRow.fieldSpan x > 1) $
                  printf " ss:MergeAcross='%d'" $ CalcRow.fieldSpan x - 1
             anchor =
               Mn.when (not $ null $ CalcRow.fieldAnchor x) $
                  printf " ss:HRef='%s'" $ CalcRow.fieldAnchor x
             CalcForm.Tracked mformula display = CalcRow.fieldContent x
             escape = concatMap (\c -> if c=='\n' then "&#10;" else [c])
             formula =
               case ftyp of
                  Number -> ""
                  Formula ->
                     foldMap
                        (printf " ss:Formula='=%s'" . CalcForm.formatXML2003)
                        mformula
             typ =
               case CalcRow.fieldType x of
                  CalcRow.TypeString -> "String"
                  CalcRow.TypeNumber -> "Number"
         in  printf "<Cell%s%s%s%s><Data ss:Type='%s'>%s</Data></Cell>"
               style colSpan anchor formula typ (escape display)))

appendTable ::
   (PathClass.AbsRel ar) =>
   EvalType -> TablePaths ar -> [[FieldTracked]] -> IO ()
appendTable typ paths content =
   for2_ paths formats $ \mpath format ->
      Fold.for_ mpath $ \path ->
         PathIO.appendFile path $ formatRows format typ content

appendMedian ::
   (PathClass.AbsRel ar) =>
   [FieldTracked] -> [meas] ->
   Palisade.T a b -> (meas -> [b]) -> TablePaths ar ->
   IO ()
appendMedian source totalDursMeass pal selectMeas tablePath =
   appendTable Number tablePath $
      let meass = concatMap selectMeas totalDursMeass
      in  [source ++
           tableFieldInt (length meass) :
           concatMap Fold.toList (Palisade.selectedSummary5 pal meass)]

appendMedian2 ::
   (PathClass.AbsRel ar) =>
   [FieldTracked] -> Path.AbsDir -> [(Path.RelFile, meas)] ->
   Palisade.T a b -> (meas -> [b]) -> ResPaths ar ->
   IO ()
appendMedian2 source fullDir1 totalDursMeass pal selectMeas
      (Resolutions {resAnimal = animalPath, resRecording = recordingPath}) = do
   appendMedian source (map snd totalDursMeass) pal selectMeas animalPath
   appendTable Number recordingPath $
      flip map (map (mapSnd selectMeas) totalDursMeass) $
         \(name,meass) ->
            source ++ tableFieldAnchor fullDir1 name :
            tableFieldInt (length meass) :
            concatMap Fold.toList (Palisade.selectedSummary5 pal meass)


calcFormPutAnchor ::
   (PathClass.FileDir fd, PathClass.AbsRel ar) =>
   Path.Path ar fd -> Path.Rel fd -> CalcRow.M ()
calcFormPutAnchor url disp =
   CalcRow.putAnchor (Path.toString url) (Path.toString disp)


type
   Results =
      (Durs.T Double, Map Time.Hour (Durs.T Double), Measurements Double)

appendOverview ::
   (PathClass.AbsRel ar) =>
   AllPaths ar ->
   Path.AbsDir -> Path.RelDir -> Path.RelDir -> Int ->
   [(Path.RelFile, Results)] -> IO ()
appendOverview
      (((durationFormulaTable, durationNumberTable), rowRef),
       classTables, _advertisementPath)
      input dir0 dir1 animal totalDursMeass = do

   modifyIORef rowRef succ
   rowPos <- readIORef rowRef
   let fullDir0 = input </> dir0
   let fullDir1 = fullDir0 </> dir1
   let row =
         CalcRow.exec rowPos $ do
            calcFormPutAnchor fullDir0 dir0
            void $ CalcRow.putNumber animal
            calcFormPutAnchor fullDir1 dir1
            durClasses <-
               fmap (fmap CalcForm.trackedVar . Durs.classes) $
               Trav.traverse (CalcRow.putPlainFraction Prec3) $
               List.foldl' (\x y -> force $ liftA2 (+) x y) (pure 0) $
               map (fst3 . snd) totalDursMeass
            durSum <-
               CalcRow.putFractionFormula Prec3 $ Fold.foldl1 (+) durClasses
            Fold.mapM_ (CalcRow.putFraction Prec3 . (/durSum)) durClasses
   appendTable Formula durationFormulaTable [row]
   appendTable Number  durationNumberTable  [row]

   let source =
         tableFieldAnchor input dir0 :
         tableFieldInt animal :
         tableFieldAnchor fullDir0 dir1 :
         []
   let appendMed =
         appendMedian2 source fullDir1 $ map (mapSnd thd3) totalDursMeass

   Fold.sequence_ $
      ClassRecord.Cons
         (appendMed palBoundAdvertisement measAdvertisement)
         (appendMed palBoundRasping measRasping)
         (appendMed palBoundChirping measChirping)
         (appendMed palBoundTicking measTicking)
         (appendMed palBoundGrowling measGrowling)
      <*>
      classTables


summary5 ::
   (Field.C a, Real.C a, Num a) =>
   [[ClassRecord.T a]] -> Maybe (Palisade.FiveNumberSummary a)
summary5 =
   fmap Palisade.summary5Number .
   NonEmpty.fetch . map (uncurry (/)) . filter ((/=0) . snd) .
   map
      (\durs ->
         (sum (map ClassRecord.advertisement durs),
          sum (map Fold.sum durs)))

transposeMapList :: (Ord k) => [Map k a] -> Map k [a]
transposeMapList = Map.unionsWith (++) . map (fmap (:[]))

appendTreatmentOverview ::
   (PathClass.AbsRel ar) =>
   AllPaths ar -> Path.AbsDir -> Path.RelDir -> String ->
   [[(Path.RelFile, Results)]] -> IO ()
appendTreatmentOverview
      (_durationTable, classTables,
       (output, advertisementFmt, advertisementHourlyFmt))
      input dir0 treatment fileTotalDursMeass = do

   let totalDursMeass = map (map snd) fileTotalDursMeass
   let appendMed =
         appendMedian
            [tableFieldAnchor input dir0, tableField treatment]
            (map thd3 $ concat totalDursMeass)

   Fold.sequence_ $
      ClassRecord.Cons
         (appendMed palBoundAdvertisement measAdvertisement)
         (appendMed palBoundRasping measRasping)
         (appendMed palBoundChirping measChirping)
         (appendMed palBoundTicking measTicking)
         (appendMed palBoundGrowling measGrowling)
      <*>
      fmap resTreatment classTables

   let hourSumms =
         map (mapPair
            (Time.formatHour "%Y-%m-%d %H",
             Fold.toList . fmap (printf "%.3f"))) $
         Map.toAscList $
         Map.mapMaybe summary5 $
         transposeMapList $
         map
            (transposeMapList . map (fmap Durs.classes . snd3))
            totalDursMeass

   PathIO.writeFile
         (output </> dir0 </>
          Path.relFile (printf advertisementHourlyFmt treatment)) $
      unlines $
      map (\(hour,summ) -> unwords $ hour : summ) $
      hourSumms

   PathIO.appendFile
         (output </>
          Path.relFile (printf advertisementHourlyFmt treatment)) $
      unlines $
      map (\(hour,summ) -> unwords $ hour : summ) $
      ListHT.switchR []
         (\_xs (hour,summ) ->
            hourSumms ++ [(hour, Match.replicate summ "NaN")]) $
         hourSumms

   PathIO.appendFile
         (output </> Path.path (printf advertisementFmt treatment)) $
      printf "\"%s\" %s\n" (Path.toString dir0) $
      List.intercalate " " $ Fold.toList $
      maybe (pure "NaN") (fmap (printf "%.3f")) $ summary5 $
      map (map (Durs.classes . fst3))
      totalDursMeass


data
   Measurements a =
      Measurements {
         measAdvertisement :: [BoundAdvertisement a],
         measRasping :: [BoundRasping a],
         measChirping :: [BoundChirping a],
         measTicking :: [BoundTicking a],
         measGrowling :: [BoundGrowling a]
      }

instance Sg.Semigroup (Measurements a) where
   Measurements a0 r0 c0 t0 g0 <> Measurements a1 r1 c1 t1 g1 =
      Measurements (a0++a1) (r0++r1) (c0++c1) (t0++t1) (g0++g1)

instance Monoid (Measurements a) where
   mempty = Measurements [] [] [] [] []
   mappend = (<>)

instance (NFData a) => NFData (Measurements a) where
   rnf (Measurements a r c t g) = rnf (a,r,c,t,g)


data
   Flags =
      Flags {
         emitFormula :: CalcForm.Tracked Bool Bool,
         emitFormats :: TableFormats Bool,
         emitRecording :: RecordingFlags Bool,
         dividedTableHead :: Bool
      }

data RecordingFlags a = RecordingFlags {emitSingle, emitMulti :: a}

instance Functor RecordingFlags where
   fmap = Trav.fmapDefault

instance Fold.Foldable RecordingFlags where
   foldMap = Trav.foldMapDefault

instance Trav.Traversable RecordingFlags where
   traverse f (RecordingFlags single multi) =
      liftA2 RecordingFlags (f single) (f multi)

instance Applicative RecordingFlags where
   pure a = RecordingFlags a a
   RecordingFlags fSingle fMulti <*> RecordingFlags single multi =
      RecordingFlags (fSingle single) (fMulti multi)

defaultFlags :: Flags
defaultFlags =
   Flags {
      emitFormula = CalcForm.Tracked True True,
      emitFormats =
         TableFormats {tableCSV = False, tableHTML = True, tableXML2003 = True},
      emitRecording = RecordingFlags {emitSingle = False, emitMulti = True},
      dividedTableHead = False
   }


formatTables ::
   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
   Flags ->
   Rate.Sample -> Path.File ar0 -> Path.File ar1 ->
   Signal.LabelChain Rate.Measure (SpectralParameters Float, ClassFeatures) ->
   MW.Writer [(Path.File ar1, Text)] (Measurements Double)
formatTables
      (Flags formFlags fmtFlags recFlags _divTH)
      highRateReal input outputStem
      (Signal.Cons lowRateReal measures) = do
   let putInput = calcFormPutAnchor input $ Path.takeBaseName input
       lowRate = CalcForm.trackFraction $ Rate.unpack lowRateReal
       highRate = CalcForm.trackFraction $ Rate.unpack highRateReal
       classMeasures =
         LabelTrack.decons $ LabelTrack.fromLabelChain $
         LabelChain.abstractFromSoundClassIntervals $
         fmap
            (\(spec, cls) ->
               let spectralDistr = spectralParametersReal highRate spec
               in  case cls of
                      Class.Rasping clickMeasure ->
                         Class.Rasping (clickMeasure, spectralDistr)
                      Class.Chirping chirpMain ->
                         Class.Chirping (chirpMain, spectralDistr)
                      Class.Ticking numClicks ->
                         Class.Ticking (numClicks, spectralDistr)
                      Class.Growling clickMeasure ->
                         Class.Growling (clickMeasure, spectralDistr)
                      Class.Other str -> Class.Other str) $
         measures

       renderTable pal renderRow =
          renderTable2 pal $ mapMaybe renderRow classMeasures

       (tables, meass) =
         bipure ClassRecord.Cons Measurements
         <<*>>
         (renderTable palBoundAdvertisement $ \(bnd,cls) ->
            case cls of
               Class.Advertisement brk raspingMeas mchirpingMeas ->
                  Just $ do
                     putInput
                     durCell <- rowBounds lowRate bnd
                     durRaspingCell <-
                        CalcRow.putFraction Prec6 $
                           (fromIntegral brk - fromIntegral (fst bnd)) / lowRate
                     let dur = CalcForm.trackedVar durCell
                     let durRasping = CalcForm.trackedVar durRaspingCell
                     rasping <- rowRasping lowRate durRasping raspingMeas
                     chirping <-
                        case mchirpingMeas of
                           Nothing -> do
                              CalcRow.putEmpty
                              rowNoChirping
                              return Nothing
                           Just chirping ->
                              fmap Just $
                              liftM2 (,)
                                 (CalcRow.putFraction Prec6 $ dur - durRasping)
                                 (rowChirping lowRate chirping)
                     return (durCell, ((durRaspingCell, rasping), chirping))
               _ -> Nothing)
         <<*>>
         (renderTable palBoundRasping $ \(bnd,cls) ->
            case cls of
               Class.NoAdvertisement (Class.Rasping measured) ->
                  Just $ do
                     putInput
                     dur <- rowBounds lowRate bnd
                     rasping <-
                        rowRasping lowRate (CalcForm.trackedVar dur) measured
                     return (dur, rasping)
               _ -> Nothing)
         <<*>>
         (renderTable palBoundChirping $ \(bnd,cls) ->
            case cls of
               Class.NoAdvertisement (Class.Chirping measured) ->
                  Just $ do
                     putInput
                     dur <- rowBounds lowRate bnd
                     chirping <- rowChirping lowRate measured
                     return (dur, chirping)
               _ -> Nothing)
         <<*>>
         (renderTable palBoundTicking $ \(bnd,cls) ->
            case cls of
               Class.NoAdvertisement (Class.Ticking measured) ->
                  Just $ do
                     putInput
                     dur <- rowBounds lowRate bnd
                     ticking <- rowTicking (CalcForm.trackedVar dur) measured
                     return (dur, ticking)
               _ -> Nothing)
         <<*>>
         (renderTable palBoundGrowling $ \(bnd,cls) ->
            case cls of
               Class.NoAdvertisement (Class.Growling measured) ->
                  Just $ do
                     putInput
                     dur <- rowBounds lowRate bnd
                     rasping <-
                        rowGrowling lowRate (CalcForm.trackedVar dur) measured
                     return (dur, rasping)
               _ -> Nothing)

   let tellSelected mask tbls =
         for2_ mask tbls $ \enable table -> when enable $ MW.tell [table]
   let formatSelected typ mask makeTables =
         when (typeSelect typ formFlags) $
            tellSelected mask $ makeTables typ
   let whenFormula formulaFormats numberFormats makeTables = do
         formatSelected Formula formulaFormats makeTables
         formatSelected Number  numberFormats  makeTables

   when (emitSingle recFlags) $
      for2_ ClassRecord.names tables $ \cls table ->
         whenFormula fmtFlags fmtFlags $ \typ ->
            formatTable outputStem typ cls table

   {-
   In CSV and HTML files the cell references in formulas
   become invalid by concatenating tables.
   Thus we allow to skip CSV and HTML creation for formula tables.
   -}
   let fmtFormFlags = fmtFlags {tableCSV = False, tableHTML = False}
   when (emitMulti recFlags) $
      whenFormula fmtFormFlags fmtFlags $ \typ ->
         formatMultiTable outputStem typ $
         liftA2 (,) ClassRecord.names tables

   return meass