-------------
-- Importe --
-------------

-- Verstecken bestimmter Funktionen aus dem Prelude,
-- um diese mit abstrakteren Versionen ersetzen zu koennen
import Prelude hiding (sum)

-- endliche Folgen (Sequenzen) mit besserer Performance gegenueber Listen
-- beim Herausgreifen und Aendern von Elementen
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq

-- herkoemmliche Baeume
import Data.Tree

-- Traversierung von Datenstrukturen, Operatoren fuer applikative Funktoren
-- sowie Faltungen von Datenstrukturen (wird benoetigt um Sequenzen in
-- Listen umzuwandeln, und zum Implementieren einer traversierbaren
-- Baum-Datenstruktur, bei der nur die Blaetter beschriftet sind)
import Data.Traversable
import Control.Applicative
import Data.Foldable

-- Monadenoperationen
import Control.Monad

-- Bruchzahlen
import Data.Ratio

-- formatierte Ausgabe
import Text.Printf

-- Zufallszahlerzeugung fuer Demonstrationsbeispiele
import System.Random


-----------------------------------
-- benoetigte Baum-Datenstruktur --
-----------------------------------

-- Datenstruktur eines Baumes bei dem nur die Blaetter beschriftet sind
data LeafLabeledTree a  =  Branches [LeafLabeledTree a] | Leaf a
  deriving (Eq, Ord, Show, Read)

-- strukturerhaltende Abbildungen, Faltungen und Traversierung
-- fuer oben definierte Baum-Datenstruktur
instance Functor  LeafLabeledTree    where  fmap    = fmapDefault
instance Foldable LeafLabeledTree    where  foldMap = foldMapDefault
instance Traversable LeafLabeledTree where
  traverse f (Leaf n)      =  Leaf <$> f n
  traverse f (Branches l)  =  Branches <$> (traverse (traverse f) l)


-------------------------
-- Rundungsalgorithmus --
-------------------------

-- kaufmaennische Rundung
financialRound :: (RealFrac r, Integral i) => r -> i
financialRound x  =  truncate (x + (signum x / 2))

-- Runden einer Sequenz von Summanden unter Angabe einer Ziel-Gesamtsumme
roundSummandSeqTo :: (RealFrac r, Integral i) => i -> Seq r -> Seq i
roundSummandSeqTo goal summands  =  adjustElements (fmap floor summands)
  where
    adjustElements s
      | current == goal  =  s
      | s == Seq.empty   =  error "Can not adjust an empty sequence."
      | current >  goal  =  adjustElements (fmap (\x -> x-1) s)
      | current <  goal  =  adjustElements (Seq.adjust (+1) idx s)
      where
        current  =  sum s
        idx      =  bestPosition s
    bestPosition s  =  fst (bestPositionFrom 0)
      where
        bestPositionFrom idx
          | match      =  (idx, diff)
          | otherwise  =  (idx', diff')
          where
            endReached     =  idx + 1 == Seq.length s
            a              =  Seq.index summands idx
            b              =  Seq.index summands idx'
            diff           =  a - (fromIntegral (Seq.index s idx))
            (idx', diff')  =  bestPositionFrom (idx + 1)
            match  =
              endReached || diff > diff' ||
              ( diff == diff' && ( a > b || (a == b && a >= 0) ) )

-- Runden einer Liste von Summanden unter der Angabe einer Ziel-Gesamtsumme
roundSumTo :: (RealFrac r, Integral i) => i -> [r] -> [i]
roundSumTo goal list  =
    toList ( roundSummandSeqTo goal (Seq.fromList list) )

-- Runden einer Liste von Summanden
roundSum :: (RealFrac r, Integral i) => [r] -> [i]
roundSum list  =  toList (
      roundSummandSeqTo (financialRound (sum list)) (Seq.fromList list)
    )

-- Runden von ineinander verschachtelten Summen
-- unter Angabe einer Ziel-Gesamtsumme
roundNestedSumsTo ::
    (RealFrac r, Integral i) => i -> LeafLabeledTree r -> LeafLabeledTree i
roundNestedSumsTo goal (Leaf _)         =  Leaf goal
roundNestedSumsTo goal (Branches list)  =  Branches list'
  where
    subtotals   =  map sum list
    subtotals'  =  roundSumTo goal subtotals
    list'       =  zipWith roundNestedSumsTo subtotals' list

-- Runden von ineinander verschachtelten Summen
roundNestedSums ::
    (RealFrac r, Integral i) => LeafLabeledTree r -> LeafLabeledTree i
roundNestedSums tree  =  roundNestedSumsTo (financialRound (sum tree)) tree


-----------------------------------------
-- Hilfs- und Demonstrationsfunktionen --
-----------------------------------------

-- Umwandeln eines Baumens bei dem die Blaetter mit Zahlen beschriftet sind
-- in einen mit den jeweiligen Summen komplett beschrifteten Baum
sumTree :: (Num n) => LeafLabeledTree n -> Tree n
sumTree (Leaf n)  =  Node { rootLabel = n, subForest = [] }
sumTree tree@(Branches children)  =  Node {
      rootLabel = sum tree,
      subForest = map sumTree children
    }

-- Zusammenfuehrung zweier Baeume zu einem
zipTreeWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c
zipTreeWith f a b  =  Node {
      rootLabel = f (rootLabel a) (rootLabel b),
      subForest = zipWith (zipTreeWith f) (subForest a) (subForest b)
    }

-- Visuelle Darstellung des Rundungsprozesses von verschachtelten Summen
showTreeRounding :: LeafLabeledTree Rational -> String
showTreeRounding tree  =  drawTree (
      zipTreeWith display (sumTree tree) (sumTree (roundNestedSums tree))
    )
  where
    display :: Rational -> Integer -> String
    display frac int
      | denominator frac == 1  =  printf "[%d -> %d]" (numerator frac) int
      | otherwise              =  printf "[%d/%d ~= %.2f -> %d]"
                                  (numerator frac)
                                  (denominator frac)
                                  (fromRational frac :: Double)
                                  int

-- Zufaelligen Bruch erzeugen
randomFraction :: IO Rational
randomFraction  =  do
    a <- randomIO :: IO Double; b <- randomIO :: IO Double
    let v = ceiling (-360 * log (1-a)) % ceiling (-12 * log (1-b))
    s <- randomIO
    if s then return (-v) else return v

-- Zufaelligen Baum erzeugen, bei dem die Blaetter mit zufaelligen
-- Bruechen beschriftet sind
randomFractionTree :: IO (LeafLabeledTree Rational)
randomFractionTree  =  randomFractionLeafsTree' 1
  where
    randomFractionLeafsTree' prob  =  do
        p <- randomIO :: IO Double
        if p < prob
          then do
            childCount <- randomRIO (2,4) :: IO Int
            children   <- replicateM childCount (
                randomFractionLeafsTree' (prob / 2)
              )
            return (Branches children)
          else do
            f <- randomFraction
            return (Leaf f)

-- besonders gut geeigneter Beispielbaum
exampleTree :: LeafLabeledTree Rational
exampleTree  =  Branches [
      Branches (replicate 4 leafA),
      Branches (replicate 4 leafB)
    ]
  where
    leafA  =  Leaf (333%10)
    leafB  =  Leaf (513%5)

-- Demonstrationsroutine
demo = do
    t <- randomFractionTree
    putStr (showTreeRounding t)
    putStrLn ""
    putStr (showTreeRounding exampleTree)