Initial version0.1.0

2 files changed, 136 insertions, 0 deletions

diff --git a/src/Lib.hs b/src/Lib.hs
new file mode 100644
index 0000000..a7c64c6
--- /dev/null
+++ b/src/Lib.hs
@@ -0,0 +1,71 @@
+module Lib
+  ( partition
+  , partitionDays
+  ) where
+
+import Data.List (group, sortOn, span)
+import Data.Ord (Down(Down))
+
+import Data.Time.Calendar (Day, addDays, diffDays)
+
+{- | Split a strictly increasing list of integer numbers into intervals
+such that the width of each interval is defined by a positive, weakly increasing
+function of the interval's serial number (1, 2, 3, ...).
+Some of the intervals may be empty.
+
+>>> partition (const 1) [1,2,3,4,5,6,7,8,9]
+[[1],[2],[3],[4],[5],[6],[7],[8],[9]]
+
+>>> partition (const 1) [1,3,5,7,9,11,13,15,17,19]
+[[1],[],[3],[],[5],[],[7],[],[9],[],[11],[],[13],[],[15],[],[17],[],[19]]
+
+>>> partition (const 2) $ take 10 [1,3 ..]
+[[1],[3],[5],[7],[9],[11],[13],[15],[17],[19]]
+
+>>> partition (\n -> floor (2^n)) $ take 20 [1, 2 ..]
+[[1,2],[3,4,5,6],[7,8,9,10,11,12,13,14],[15,16,17,18,19,20]]
+
+>>> partition (\n -> floor (2^n)) [2,5,14,20]
+[[2],[5],[14],[20]]
+
+>>> partition (\n -> floor (2^n)) $ take 20 [10,20 ..]
+[[10],[],[20],[30],[40,50,60,70],[80,90,100,110,120,130],[140,150,160,170,180,190,200]]
+
+-}
+partition ::
+     (Ord t, Num t)
+  => (Int -> t) -- ^ positive, weakly increasing function of a natural number
+  -> [t] -- ^ strictly increasing, non-empty list
+  -> [[t]]
+partition f l = go 1 (head l) l
+  where
+    go _ _ [] = []
+    go n a aa =
+      let a' = a + f n
+          n' = n + 1
+          (slot, rest) = span (< a') aa
+       in slot : go n' a' rest
+
+{- | Split days into intervals, backwards from the most recent day.
+This function uses the 'partition' function after calculating differences
+between the days.
+
+>>> let days = map read ["2019-08-30", "2019-08-31", "2019-09-02"]
+>>> partitionDays (const 1) days
+[[2019-09-02],[],[2019-08-31],[2019-08-30]]
+
+>>> let days = map read ["2019-08-30", "2019-08-31", "2019-09-01", "2019-09-02", "2019-09-03", "2019-09-04"]
+>>> partitionDays (\n -> floor (2^(n-1))) days
+[[2019-09-04],[2019-09-03,2019-09-02],[2019-09-01,2019-08-31,2019-08-30]]
+
+-}
+partitionDays ::
+     (Int -> Integer) -- ^ positive, weakly increasing function of a natural number
+  -> [Day] -- ^ non-empty list of days, with no other restrictions
+  -> [[Day]]
+partitionDays f days = map (map int2day) (partition f ints)
+  where
+    sorted = map head . group . sortOn Down $ days
+    day1 = head sorted
+    ints = map (diffDays day1) sorted
+    int2day i = addDays (-i) day1
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..0ab3259
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,65 @@
+module Main
+  ( main
+  ) where
+
+import System.IO (hPutStrLn, stderr)
+
+import Data.Time.Calendar (Day)
+import Options.Applicative
+  ( Parser
+  , (<**>)
+  , (<|>)
+  , argument
+  , auto
+  , execParser
+  , flag'
+  , fullDesc
+  , help
+  , helper
+  , info
+  , long
+  , metavar
+  , option
+  , optional
+  , short
+  , showDefault
+  , some
+  , value
+  )
+
+import Lib (partitionDays)
+
+data Mode
+  = Keep
+  | Delete
+
+data Options = Options
+  { mode :: Maybe Mode
+  , base :: Double
+  , days :: [Day]
+  }
+
+parseMode :: Parser Mode
+parseMode = keep <|> delete
+  where
+    keep = flag' Keep (long "keep" <> short 'k' <> help "Print days to keep")
+    delete =
+      flag' Delete (long "delete" <> short 'd' <> help "Print days to delete")
+
+parseOptions :: Parser Options
+parseOptions =
+  Options <$> optional parseMode <*>
+  option
+    auto
+    (long "base" <> short 'b' <> metavar "BASE" <> showDefault <> value 1.1 <>
+     help "Base of the exponent") <*>
+  some (argument auto (metavar "DAY..."))
+
+main :: IO ()
+main = do
+  opts <- execParser $ info (parseOptions <**> helper) fullDesc
+  let groups = partitionDays (\n -> floor (base opts ^ (n - 1))) (days opts)
+  case mode opts of
+    Just Keep -> putStrLn $ unwords . map show . concatMap (take 1) $ groups
+    Just Delete -> putStrLn $ unwords . map show . concatMap (drop 1) $ groups
+    Nothing -> mapM_ (hPutStrLn stderr . unwords . map show) groups