Count down cards left while asking

Cards.hs

@@ -1,23 +1,16 @@
 module Cards
-  ( Element
+  ( module Cards.Card
-  , Card
+  , Element
   , Comment
-  , fromElement
+  , toCard
-  , toElement
+  , fromCard
-  , isDue
-  , sides
-  , reset
-  , update
-  , showElement
-  , showElements
-  , parseElement
-  , parseElements
   , testElements
   ) where
 
-import Data.List
+import Cards.Card
 import Data.Time
 
+testElements :: [Element]
 testElements =
   [ card ["first card", "really"]
   , card ["second card", "really"]
@@ -25,8 +18,9 @@ testElements =
   , card ["third card", "really"]
   , comment "second comment"
   ]
-  where card = ECard . Unrevised
+  where card = ECard . createCard someutctime
         comment = EComment . Comment
+        someutctime = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)
 
 data Element = ECard Card | EComment Comment
   deriving (Show)
@@ -34,83 +28,14 @@ data Element = ECard Card | EComment Comment
 data Comment = Comment String
   deriving (Show)
 
-data Card = Unrevised [String]
-          | Revised [String] Tier UTCTime NominalDiffTime
-  deriving (Show)
-
-data Tier = One | Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten
-  deriving (Show, Eq, Ord, Enum, Bounded)
-
 {-
  - Basic utility functions
  -}
 
-isCard :: Element -> Bool
+toCard :: Element -> Maybe Card
-isCard (ECard _) = True
+toCard (ECard c) = Just c
-isCard _         = False
+toCard  _        = Nothing
 
-fromElement :: Element -> Maybe Card
+fromCard :: Card -> Element
-fromElement (ECard c) = Just c
+fromCard = ECard
-fromElement  _        = Nothing
 
-toElement :: Card -> Element
-toElement = ECard
-
-tierDiff :: Tier -> NominalDiffTime
-tierDiff One   = 60 * 10
-tierDiff Two   = 60 * 20
-tierDiff Three = 60 * 40
-tierDiff Four  = 3600 * ( 1 * 24 - 8)
-tierDiff Five  = 3600 * ( 2 * 24 - 8)
-tierDiff Six   = 3600 * ( 4 * 24 - 8)
-tierDiff Seven = 3600 * ( 8 * 24 - 8)
-tierDiff Eight = 3600 * (16 * 24 - 8)
-tierDiff Nine  = 3600 * (32 * 24 - 8)
-tierDiff Ten   = 3600 * (64 * 24 - 8)
-
-tierName :: Tier -> String
-tierName One   = "10min"
-tierName Two   = "20min"
-tierName Three = "40min"
-tierName Four  =  "1d"
-tierName Five  =  "2d"
-tierName Six   =  "4d"
-tierName Seven =  "8d"
-tierName Eight = "16d"
-tierName Nine  = "32d"
-tierName Ten   = "64d"
-
-isDue :: UTCTime -> Card -> Bool
-isDue _ (Unrevised _) = True
-isDue time (Revised _ tier ctime cdiff) =
-  let tdiff = tierDiff tier
-  in  diffUTCTime time ctime >= cdiff + tdiff 
-
-sides :: Card -> [String]
-sides (Unrevised s)     = s
-sides (Revised s _ _ _) = s
-
-reset :: Card -> Card
-reset (Revised s _ _ _) = Unrevised s
-reset c@(Unrevised _)   = c
-
--- Uses the global RNG.
--- TODO: Add random offset based on tierDiff.
-update :: UTCTime -> Card -> IO Card
-update time (Unrevised s)     =
-  return $ Revised s minBound                             time (fromInteger 0)
-update time (Revised s t _ _) =
-  return $ Revised s (if t < maxBound then succ t else t) time (fromInteger 0)
-
-showElements :: [Element] -> String
-showElements = intercalate "\n\n" . map showElement
-
-showElement :: Element -> String
-showElement = undefined
-
-{-
- - Parsing
- -}
-
-parseElements = undefined
-parseElement = undefined

Cards/Card.hs

@@ -0,0 +1,97 @@
+module Cards.Card
+  ( Tier -- Tier stuff
+  , tierDiff
+  , tierName
+  , Card -- Card stuff
+  , sides
+  , tier
+  , lastChecked
+  , offset
+  , isDue
+  , reset
+  , update
+  , createCard
+  ) where
+
+import Data.Time
+
+data Card = Card
+  { sides :: [String]
+  , tier :: Tier
+  , lastChecked :: UTCTime
+  , offset :: NominalDiffTime
+  } deriving (Show)
+
+data Tier = Unrevised
+          | TenMin | TwentyMin | FortyMin
+          | OneDay | TwoDays | FourDays | EightDays
+          | SixteenDays | ThirtyTwoDays | SixtyFourDays
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+{-
+ - Tier stuff
+ -}
+
+tierDiff :: Tier -> NominalDiffTime
+tierDiff Unrevised     = 0
+tierDiff TenMin        = 60 * 10
+tierDiff TwentyMin     = 60 * 20
+tierDiff FortyMin      = 60 * 40
+tierDiff OneDay        = 3600 * ( 1 * 24 - 8)
+tierDiff TwoDays       = 3600 * ( 2 * 24 - 8)
+tierDiff FourDays      = 3600 * ( 4 * 24 - 8)
+tierDiff EightDays     = 3600 * ( 8 * 24 - 8)
+tierDiff SixteenDays   = 3600 * (16 * 24 - 8)
+tierDiff ThirtyTwoDays = 3600 * (32 * 24 - 8)
+tierDiff SixtyFourDays = 3600 * (64 * 24 - 8)
+
+tierName :: Tier -> String
+tierName Unrevised     = "unrevised"
+tierName TenMin        = "10min"
+tierName TwentyMin     = "20min"
+tierName FortyMin      = "40min"
+tierName OneDay        =  "1d"
+tierName TwoDays       =  "2d"
+tierName FourDays      =  "4d"
+tierName EightDays     =  "8d"
+tierName SixteenDays   = "16d"
+tierName ThirtyTwoDays = "32d"
+tierName SixtyFourDays = "64d"
+
+{-
+ - Card stuff
+ -}
+
+isDue :: UTCTime -> Card -> Bool
+isDue time Card{tier=t, lastChecked=lc, offset=o} =
+  diffUTCTime time lc >= o + tierDiff t
+
+-- These functions use the IO monad for generating random offsets.
+-- TODO: actually implement random offset
+updateOffset :: Card -> IO Card
+updateOffset Card{sides=s, tier=t, lastChecked=lc} = do
+  return Card{sides=s, tier=t, lastChecked=lc, offset=0}
+
+reset :: UTCTime -> Card -> Card
+reset time Card{sides=s} =
+  Card{sides=s, tier=minBound, lastChecked=time, offset=0}
+
+update :: UTCTime -> Card -> IO Card
+update time Card{sides=s, tier=t} =
+  updateOffset $ Card {sides=s, tier=boundedSucc t, lastChecked=time, offset=0}
+
+-- helper function
+boundedSucc :: (Eq a, Bounded a, Enum a) => a -> a
+boundedSucc a
+  | a == maxBound = a
+  | otherwise     = succ a
+
+createCard :: UTCTime -> [String] -> Card
+createCard time s =
+  Card{sides=s, tier=minBound, lastChecked=time, offset=0}
+
+{-
+ - Parsing Cards
+ -}
+
+-- TODO

Main.hs

@@ -7,9 +7,11 @@ import Control.Monad
 import Control.Monad.Trans
 import Control.Monad.Trans.Maybe
 import Data.Char
+import Data.Maybe
 import Data.Time
 import System.Console.Haskeline
 
+inputSettings :: Settings IO
 inputSettings = Settings
   { complete       = noCompletion
   , historyFile    = Nothing
@@ -46,46 +48,47 @@ spanM f l@(x:xs) = do
     else do
       return ([], l)
 
--- A combination of span and map, but with monads.
--- Note the line-by-line similarity to spanM.
--- Basically like spanM, but instead of splitting the list by a Bool, splits it
--- by a Maybe.
-spanJustM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m ([b], [a])
-spanJustM _ [] = return ([], [])
-spanJustM f l@(x:xs) = do
-  result <- f x
-  case result of
-    Just r -> do
-      (just, nothing) <- spanJustM f xs
-      return (r:just, nothing)
-    Nothing -> do
-      return ([], l)
-
--- Basically spanJustM, but more similar to map.
-mapWhileJustM :: (Monad m) => (a -> m (Maybe a)) -> [a] -> m [a]
-mapWhileJustM f l = uncurry (++) <$> spanJustM f l
-
 {-
  - Dealing with Elements/Cards.
  -}
 
-askElement :: UTCTime -> Element -> MaybeT (InputT IO) Element
+countDueCards :: UTCTime -> [Element] -> Int
-askElement time elem =
+countDueCards time elms = length $ filter isDueCard elms
-  case fromElement elem of
+  where isDueCard e = fromMaybe False (isDue time <$> toCard e)
-    Just card -> toElement <$> askCard time card
+
-    Nothing   -> return elem
+askCountdown :: UTCTime -> Int -> [Element] -> InputT IO [Element]
+askCountdown _ _ [] = return []
+askCountdown time left elms@(e:es) = do
+  case toCard e of
+    Nothing   -> (e :) <$> askCountdown time left es
+    Just card -> defaultTo elms $
+      if isDue time card
+        then do
+          card' <- askNthCard time card (left - 1)
+          (fromCard card' :) <$> liftedAsk time (left - 1) es
+        else do
+          (e :) <$> liftedAsk time left es
+  where defaultTo what monad = fromMaybe what <$> runMaybeT monad
+        liftedAsk t l e' = lift $ askCountdown t l e'
+
+rjust :: Char -> Int -> String -> String
+rjust c l s = replicate (max 0 $ l - length s) c ++ s
+
+askNthCard :: UTCTime -> Card -> Int -> MaybeT (InputT IO) Card
+askNthCard time card left = do
+  let t = rjust ' ' 9 $ tierName $ tier card
+      l = rjust ' ' 3 $ show left
+  lift $ outputStrLn ""
+  lift $ outputStrLn $ "-----< tier: " ++ t ++ ", left: " ++ l ++ " >-----"
+  askCard time card
 
 askCard :: UTCTime -> Card -> MaybeT (InputT IO) Card
 askCard time card = do
-  if isDue time card
+  (_, unasked) <- spanM askSide $ sides card
-    then do
-      (asked, unasked) <- spanM askSide $ sides card
   mapM_ showSide $ drop 1 unasked
   if null unasked
     then lift $ lift $ update time card
-        else return $ reset card
+    else return $ reset time card
-    else do
-      return card
 
 askSide :: String -> MaybeT (InputT IO) Bool
 askSide side = do
@@ -104,30 +107,31 @@ displaySide side = lift (putStrLn side)
  - User prompt.
  -}
 
-learn :: UTCTime -> [Element] -> InputT IO [Element]
+learn :: [Element] -> InputT IO [Element]
-learn time = mapWhileJustM (runMaybeT . askElement time)
+learn elms = do
+  time <- lift $ getCurrentTime
+  askCountdown time (countDueCards time elms) elms
 
 stats :: [Element] -> InputT IO ()
 stats = undefined -- TODO: Use tierName
 
-run :: UTCTime -> [Element] -> InputT IO [Element]
+run :: [Element] -> InputT IO [Element]
-run time elem = do
+run elms = do
   cmd <- getInputLine "%> "
   case (map toLower) <$> cmd of
-    Nothing      -> return elem
+    Nothing      -> return elms
-    Just "quit"  -> return elem
+    Just "quit"  -> return elms
-    Just "q"     -> return elem
+    Just "q"     -> return elms
-    Just "learn" -> learn time elem >>= run time
+    Just "learn" -> learn elms >>= run
-    Just "l"     -> learn time elem >>= run time
+    Just "l"     -> learn elms >>= run
-    Just "show"  -> stats elem >> run time elem
+    Just "show"  -> stats elms >> run elms
-    Just "s"     -> stats elem >> run time elem
+    Just "s"     -> stats elms >> run elms
     Just x       -> do
       outputStrLn $ "Unknown command " ++ show x ++ "."
-      run time elem
+      run elms
     -- Maybe save cards?
 
 main :: IO ()
 main = do
-  time <- getCurrentTime
+  elms <- runInputT inputSettings $ run testElements
-  elems <- runInputT inputSettings $ run time testElements
+  mapM_ (putStrLn . show) elms
-  mapM_ (putStrLn . show) elems