Formula.hs

module Spreadsheet.Formula (
   Formula,
   CellId(CellId),
   Agg(..),
   constant,
   pi,
   fromInt,
   formatCSV,
   formatXML2003,
   aggregate,
   sum,

   Tracked(..),
   untracked,
   CellTracked,
   FormulaTracked,
   trackFraction,
   trackedVar,
   ) where

import qualified Data.Bifunctor as Bifunc
import Control.Applicative (liftA2)
import Data.Bitraversable (Bitraversable, bitraverse, bifoldMapDefault, )
import Data.Bifoldable (Bifoldable, bifoldMap, )
import Data.Biapplicative (Biapplicative, bipure, biliftA2, (<<*>>), )
import Data.Bifunctor (Bifunctor, bimap, )

import qualified Data.NonEmpty as NonEmpty
import qualified Data.List as List
import Data.Tuple.HT (swap)
import Data.Maybe.HT (toMaybe)
import Text.Printf (printf)
import Data.Char (ord, chr)
import Data.Ord.HT (comparing)
import Data.Eq.HT (equating)

import qualified Algebra.ToRational as ToRational
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 qualified Algebra.Additive as Additive
import Algebra.ToRational (realToField)
import NumericPrelude.Numeric hiding (sum, pi)
import NumericPrelude.Base
import Prelude ()


data Formula =
     Const Integer
   | Any String
   | Var CellId
   | Infix Infix Formula Formula
   | Agg Agg [Either Formula (CellId, CellId)]


data CellId = CellId Int Int
   deriving (Eq, Ord, Show)

data Infix = Times | Divide | Plus | Minus
   deriving (Show)

data Precedence = PrecSum | PrecProduct | PrecLiteral
   deriving (Eq, Ord, Enum)

data Agg = Sum | Minimum | Maximum | Median | Quartile Int
   deriving (Show)

format :: (CellId -> String) -> Formula -> String
format fmtCellId =
   let go paren form =
         case form of
            Const a -> show a
            Any str -> str
            Var cell -> fmtCellId cell
            Agg agg cells ->
               printf (formatAgg agg) $ List.intercalate ";" $
               map (either (go (PrecSum>)) (cellRange fmtCellId)) cells
            Infix Times x y ->
               parentheses (paren PrecProduct) $
               go (PrecProduct>) x ++ "*" ++ go (PrecProduct>) y
            Infix Divide x y ->
               parentheses (paren PrecProduct) $
               go (PrecProduct>) x ++ "/" ++ go (PrecProduct>=) y
            Infix Plus x y ->
               parentheses (paren PrecSum) $
               go (PrecSum>) x ++ "+" ++ go (PrecSum>) y
            Infix Minus x y ->
               parentheses (paren PrecSum) $
               go (PrecSum>) x ++ "-" ++ go (PrecSum>=) y
   in  go (const False)

formatCSV :: Formula -> String
formatCSV = format formatCellId

formatCellId :: CellId -> String
formatCellId (CellId row column) = formatColumnId column ++ show (row+1)

formatColumnId :: Int -> String
formatColumnId =
   let range = ord 'Z' - ord 'A' + 1
   in  map chr . map (ord 'A' +) . reverse .
       List.unfoldr (\k -> toMaybe (k>0) $ swap $ divMod (k-1) range) . (1+)

formatXML2003 :: Formula -> String
formatXML2003 = format formatCellIdXML2003

formatCellIdXML2003 :: CellId -> String
formatCellIdXML2003 (CellId row column) =
   printf "R%dC%d" (row+1) (column+1)

formatAgg :: Agg -> String
formatAgg agg =
   case agg of
      -- ToDo: SUMME in German locale
      Sum -> "SUM(%s)"
      Minimum -> "MIN(%s)"
      Maximum -> "MAX(%s)"
      Median -> "MEDIAN(%s)"
      Quartile n -> "QUARTILE(%s;" ++ show n ++ ")"

parentheses :: Bool -> String -> String
parentheses b xs =
   if b
     then '(' : xs ++ ")"
     else xs


constant :: Integer -> Formula
constant = Const


instance Additive.C Formula where
   zero = Const zero
   x + y  =  Infix Plus x y
   x - y  =  Infix Minus x y

instance Ring.C Formula where
   fromInteger = Const . Ring.fromInteger
   one = Const one
   x * y  =  Infix Times x y

instance Field.C Formula where
   x / y  =  Infix Divide x y


{- |
This type tracks the operations applied to the @a@-typed value.
Cf. EFA.Equation.Pair
-}
data Tracked formula a = Tracked {trackedFormula :: formula, trackedNumber :: a}
   deriving (Show)

instance Bifunctor Tracked where
   bimap f g (Tracked formula number) = Tracked (f formula) (g number)

instance Biapplicative Tracked where
   bipure = Tracked
   Tracked ff f <<*>> Tracked fx x  =  Tracked (ff fx) (f x)

instance Bifoldable Tracked where
   bifoldMap = bifoldMapDefault

instance Bitraversable Tracked where
   bitraverse f g (Tracked formula number) =
      liftA2 Tracked (f formula) (g number)

type FormulaTracked = Tracked Formula
type CellTracked = Tracked CellId

untracked :: String -> Tracked (Maybe Formula) String
untracked = Tracked Nothing


instance (Eq a) => Eq (Tracked formula a) where
   (==)  =  equating trackedNumber

instance (Ord a) => Ord (Tracked formula a) where
   compare  =  comparing trackedNumber


instance
   (Additive.C formula, Additive.C a) =>
      Additive.C (Tracked formula a) where
   zero = bipure zero zero
   (+) = biliftA2 (+) (+)
   (-) = biliftA2 (-) (-)

instance (Ring.C formula, Ring.C a) => Ring.C (Tracked formula a) where
   fromInteger n = bipure (Ring.fromInteger n) (Ring.fromInteger n)
   one = bipure one one
   (*) = biliftA2 (*) (*)

instance (Field.C formula, Field.C a) => Field.C (Tracked formula a) where
   (/) = biliftA2 (/) (/)


trackFraction :: (Real.C a, ToRational.C a) => a -> FormulaTracked a
trackFraction x =
   case splitFraction x of
      (i, frac) ->
         Tracked (if isZero frac then constant i else realToField x) x

trackedVar :: CellTracked a -> FormulaTracked a
trackedVar = Bifunc.first Var

fromInt :: (Ring.C a) => Tracked formula Int -> Tracked formula a
fromInt = Bifunc.second fromIntegral


pi :: (Trans.C a) => FormulaTracked a
pi = Tracked (Any "PI()") Trans.pi



{- |
Simplified implementation that works only for a rectangle of cells.
-}
cellRange :: (CellId -> String) -> (CellId, CellId) -> String
cellRange fmtCellId (from, to) =
   printf "%s:%s" (fmtCellId from) (fmtCellId to)

{- |
The set of cells must form a rectangle.
It is an unchecked error if that does not apply.
-}
aggregate ::
   Agg -> (NonEmpty.T [] a -> a) ->
   NonEmpty.T [] (CellTracked a) -> FormulaTracked a
aggregate op agg xs =
   Tracked
      (Agg op
         (let cells = fmap trackedFormula xs
          in  [Right (NonEmpty.minimum cells, NonEmpty.maximum cells)]))
      (agg $ fmap trackedNumber xs)

sum :: (Additive.C a) => [CellTracked a] -> FormulaTracked a
sum =
   maybe zero (aggregate Sum (Additive.sum . NonEmpty.flatten)) .
   NonEmpty.fetch