Count down cards left while asking
This commit is contained in:
Joscha
parent
7afb8d3b60
commit
373a245591
3 changed files with 162 additions and 136 deletions
101
Cards.hs
101
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
|
||||
|
|
|
|||
97
Cards/Card.hs
Normal file
97
Cards/Card.hs
Normal file
|
|
@ -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
|
||||
100
Main.hs
100
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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue