diff --git a/Cards.hs b/Cards.hs index 4296c38..f5e6d2c 100644 --- a/Cards.hs +++ b/Cards.hs @@ -1,23 +1,16 @@ module Cards - ( Element - , Card + ( module Cards.Card + , Element , Comment - , fromElement - , toElement - , isDue - , sides - , reset - , update - , showElement - , showElements - , parseElement - , parseElements + , toCard + , fromCard , 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 -isCard (ECard _) = True -isCard _ = False +toCard :: Element -> Maybe Card +toCard (ECard c) = Just c +toCard _ = Nothing -fromElement :: Element -> Maybe Card -fromElement (ECard c) = Just c -fromElement _ = Nothing +fromCard :: Card -> Element +fromCard = ECard -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 diff --git a/Cards/Card.hs b/Cards/Card.hs new file mode 100644 index 0000000..19f83d3 --- /dev/null +++ b/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 diff --git a/Main.hs b/Main.hs index 25e42f6..549b149 100644 --- a/Main.hs +++ b/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 -askElement time elem = - case fromElement elem of - Just card -> toElement <$> askCard time card - Nothing -> return elem +countDueCards :: UTCTime -> [Element] -> Int +countDueCards time elms = length $ filter isDueCard elms + where isDueCard e = fromMaybe False (isDue time <$> toCard e) + +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 - 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 do - return card + (_, unasked) <- spanM askSide $ sides card + mapM_ showSide $ drop 1 unasked + if null unasked + then lift $ lift $ update time card + else return $ reset time 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 time = mapWhileJustM (runMaybeT . askElement time) +learn :: [Element] -> InputT IO [Element] +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 time elem = do +run :: [Element] -> InputT IO [Element] +run elms = do cmd <- getInputLine "%> " case (map toLower) <$> cmd of - Nothing -> return elem - Just "quit" -> return elem - Just "q" -> return elem - Just "learn" -> learn time elem >>= run time - Just "l" -> learn time elem >>= run time - Just "show" -> stats elem >> run time elem - Just "s" -> stats elem >> run time elem + Nothing -> return elms + Just "quit" -> return elms + Just "q" -> return elms + Just "learn" -> learn elms >>= run + Just "l" -> learn elms >>= run + Just "show" -> stats elms >> run elms + 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 - elems <- runInputT inputSettings $ run time testElements - mapM_ (putStrLn . show) elems + elms <- runInputT inputSettings $ run testElements + mapM_ (putStrLn . show) elms