Yvee1/hascard
1
1
Fork 0
mirror of https://github.com/Yvee1/hascard.git synced 2024-11-25 09:54:43 +03:00
Code Issues Projects Releases Wiki Activity

Add ordering type question, parsing and display

Browse Source
This commit is contained in:
Steven van den Broek 2020-07-25 13:16:20 +02:00
parent 7a23a760d3
commit a0887b039f
4 changed files with 218 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
cards/syntax.txt
View File

@ -23,3 +23,9 @@ Explanation or definition of this word, or the answer to the question.
The symbol € is for the currency named _Euro_, and is used in the _EU|European Union_.
---
# Order the letters in alphabetical order
4. u
1. l
2. p
3. s

27
src/Parser.hs
View File

@ -13,6 +13,7 @@ parseCards = parse pCards "failed when parsing cards"
pCards = pCard `sepEndBy1` seperator
pCard = uncurry3 MultipleChoice<$> try pMultChoice
<|> uncurry MultipleAnswer <$> try pMultAnswer
<|> uncurry Reorder <$> try pReorder
<|> uncurry OpenQuestion <$> try pOpen
<|> uncurry Definition <$> pDef
@ -32,7 +33,7 @@ pMultChoice = do
pChoice = do
kind <- oneOf "*-"
space
text <- manyTill anyChar $ lookAhead (try (try choicePrefix <|> seperator <|> (eof >> return [])))
text <- manyTill anyChar $ lookAhead (try (try choicePrefix <|> seperator <|> eof'))
return (kind, text)
choicePrefix = string "- "
@ -48,9 +49,25 @@ pOption = do
char '['
kind <- oneOf "*x "
string "] "
text <- manyTill anyChar $ lookAhead (try (seperator <|> string "[" <|> (eof >> return [])))
text <- manyTill anyChar $ lookAhead (try (seperator <|> string "[" <|> eof'))
return $ makeOption kind text
pReorder = do
header <- pHeader
many eol
elements <- pReorderElement `sepBy1` lookAhead (try pReorderPrefix)
return (header, NE.fromList elements)
pReorderElement = do
int <- pReorderPrefix
text <- manyTill anyChar $ lookAhead (try (try seperator <|> try pReorderPrefix <|> eof'))
return (read int, text)
pReorderPrefix = do
int <- many1 digit
string ". "
return int
pOpen = do
header <- pHeader
many eol
@ -81,13 +98,13 @@ gappedSpecialChars = seperator
<|> string "_"
pNormal = do
text <- manyTill (noneOf "_") $ lookAhead $ try $ gappedSpecialChars <|> (eof >> return [])
text <- manyTill (noneOf "_") $ lookAhead $ try $ gappedSpecialChars <|> eof'
return (Normal text)
pDef = do
header <- pHeader
many eol
descr <- manyTill chars $ lookAhead (try (seperator <|> (eof >> return [])))
descr <- manyTill chars $ lookAhead $ try $ seperator <|> eof'
return (header, descr)
eol = try (string "\n\r")
@ -96,6 +113,8 @@ eol = try (string "\n\r")
<|> string "\r"
<?> "end of line"
eof' = eof >> return [] <?> "end of file"
seperator = do
sep <- string "---"
many eol

15
src/Types.hs
View File

@ -15,13 +15,16 @@ makeLenses ''GlobalState
data Card = Definition String String
| OpenQuestion String Perforated
| MultipleChoice {
mcQuestion :: String,
mcCorrect :: CorrectOption,
mcIncorrects :: [IncorrectOption]}
-- | MultipleAnswer String (NE.NonEmpty Answer)
question :: String,
correct :: CorrectOption,
incorrects :: [IncorrectOption]}
| MultipleAnswer {
maQuestion :: String,
maOptions :: NonEmpty Option }
question :: String,
options :: NonEmpty Option }
| Reorder {
question :: String,
elements :: NonEmpty (Int, String)
}
deriving Show

253
src/UI/Cards.hs
View File

@ -28,22 +28,29 @@ data CardState =
{ _flipped :: Bool }
| MultipleChoiceState
{ _highlighted :: Int
, _nChoices :: Int
, _number :: Int
, _tried :: Map Int Bool -- indices of tried choices
}
| MultipleAnswerState
{ _highlighted :: Int
, _selected :: Map Int Bool
, _nChoices :: Int
, _number :: Int
, _entered :: Bool
}
| OpenQuestionState
{ _gapInput :: Map Int String
, _highlighted :: Int
, _nGaps :: Int
, _number :: Int
, _entered :: Bool
, _correctGaps :: Map Int Bool
}
| ReorderState
{ _highlighted :: Int
, _grabbed :: Bool
, _order :: Map Int (Int, String)
, _entered :: Bool
, _number :: Int
}
data State = State
{ _cards :: [Card] -- list of flashcards
@ -63,19 +70,25 @@ defaultCardState :: Card -> CardState
defaultCardState Definition{} = DefinitionState { _flipped = False }
defaultCardState (MultipleChoice _ _ ics) = MultipleChoiceState
{ _highlighted = 0
, _nChoices = length ics + 1
, _number = length ics + 1
, _tried = M.fromList [(i, False) | i <- [0..length ics]] }
defaultCardState (OpenQuestion _ perforated) = OpenQuestionState
{ _gapInput = M.empty
, _highlighted = 0
, _nGaps = nGapsInPerforated perforated
, _number = nGapsInPerforated perforated
, _entered = False
, _correctGaps = M.fromList [(i, False) | i <- [0..nGapsInPerforated perforated - 1]] }
defaultCardState (MultipleAnswer _ answers) = MultipleAnswerState
{ _highlighted = 0
, _selected = M.fromList [(i, False) | i <- [0..NE.length answers-1]]
, _entered = False
, _nChoices = NE.length answers }
, _number = NE.length answers }
defaultCardState (Reorder _ elements) = ReorderState
{ _highlighted = 0
, _grabbed = False
, _order = M.fromList (zip [0..] (NE.toList elements))
, _entered = False
, _number = NE.length elements }
app :: App State Event Name
app = App
@ -86,6 +99,24 @@ app = App
, appAttrMap = const theMap
}
runCardsUI :: GlobalState -> [Card] -> IO State
runCardsUI gs deck = do
hints <- getShowHints
controls <- getShowControls
let initialState = State { _cards = deck
, _index = 0
, _currentCard = head deck
, _cardState = defaultCardState (head deck)
, _nCards = length deck
, _showHints = hints
, _showControls = controls }
defaultMain app initialState
---------------------------------------------------
--------------------- DRAWING ---------------------
---------------------------------------------------
drawUI :: State -> [Widget Name]
drawUI s = [drawCardUI s <=> drawInfo s]
@ -93,13 +124,35 @@ drawInfo :: State -> Widget Name
drawInfo s = if not (s ^. showControls) then emptyWidget else
strWrap . ("ESC: quit" <>) $ case s ^. cardState of
DefinitionState {} -> ", ENTER: flip card / continue"
MultipleChoiceState {} -> ", ENTER: confirm answer / continue"
MultipleAnswerState {} -> ", ENTER: select / continue, c: confirm selection"
OpenQuestionState {} -> ", LEFT/RIGHT/TAB: navigate gaps, ENTER: confirm answer / continue"
MultipleChoiceState {} -> ", ENTER: submit answer / continue"
MultipleAnswerState {} -> ", ENTER: select / continue, c: submit selection"
OpenQuestionState {} -> ", LEFT/RIGHT/TAB: navigate gaps, ENTER: submit answer / continue"
ReorderState {} -> ", ENTER: grab, c: submit answer"
drawCardBox :: Widget Name -> Widget Name
drawCardBox w = C.center $
withBorderStyle BS.unicodeRounded $
B.border $
withAttr textboxAttr $
hLimitPercent 60 w
drawProgress :: State -> Widget Name
drawProgress s = C.hCenter $ str (show (s^.index + 1) ++ "/" ++ show (s^.nCards))
drawCardUI :: State -> Widget Name
drawCardUI s = let p = 1 in
joinBorders $ drawCardBox $ (<=> drawProgress s) $
case (s ^. cards) !! (s ^. index) of
Definition title descr -> drawHeader title <=> B.hBorder <=> padLeftRight p (drawDef s descr <=> str " ")
MultipleChoice question correct others -> drawHeader question <=> B.hBorder <=> padLeftRight p (drawChoices s (listMultipleChoice correct others) <=> str " ")
OpenQuestion title perforated -> drawHeader title <=> B.hBorder <=> padLeftRight p (drawPerforated s perforated <=> str " ")
MultipleAnswer question options -> drawHeader question <=> B.hBorder <=> padRight (Pad p) (drawOptions s options <=> str " ")
Reorder question elements -> drawHeader question <=> B.hBorder <=> padLeftRight p (drawReorder s elements <=> str " ")
drawHeader :: String -> Widget Name
drawHeader title = withAttr titleAttr $
padLeftRight 1 $
@ -118,29 +171,6 @@ drawDescr descr =
where
descr' = dropWhileEnd isSpace' descr
listMultipleChoice :: CorrectOption -> [IncorrectOption] -> [String]
listMultipleChoice c = reverse . listMultipleChoice' [] 0 c
where listMultipleChoice' opts i (CorrectOption j cStr) [] =
if i == j
then cStr : opts
else opts
listMultipleChoice' opts i c'@(CorrectOption j cStr) ics@(IncorrectOption icStr : ics') =
if i == j
then listMultipleChoice' (cStr : opts) (i+1) c' ics
else listMultipleChoice' (icStr : opts) (i+1) c' ics'
drawCardUI :: State -> Widget Name
drawCardUI s = let p = 1 in
joinBorders $ drawCardBox $ (<=> drawProgress s) $
case (s ^. cards) !! (s ^. index) of
Definition title descr -> drawHeader title <=> B.hBorder <=> padLeftRight p (drawDef s descr <=> str " ")
MultipleChoice question correct others -> drawHeader question <=> B.hBorder <=> padLeftRight p (drawChoices s (listMultipleChoice correct others) <=> str " ")
OpenQuestion title perforated -> drawHeader title <=> B.hBorder <=> padLeftRight p (drawPerforated s perforated <=> str " ")
MultipleAnswer question options -> drawHeader question <=> B.hBorder <=> padRight (Pad p) (drawOptions s options <=> str " ")
drawDef :: State -> String -> Widget Name
drawDef s def = if s ^. showHints then drawHintedDef s def else drawNormalDef s def
@ -160,6 +190,17 @@ drawNormalDef s def = case s ^. cardState of
render . vBox $ [str " " | _ <- wrapTextToLines wrapSettings w (pack def')]
_ -> error "impossible: "
listMultipleChoice :: CorrectOption -> [IncorrectOption] -> [String]
listMultipleChoice c = reverse . listMultipleChoice' [] 0 c
where listMultipleChoice' opts i (CorrectOption j cStr) [] =
if i == j
then cStr : opts
else opts
listMultipleChoice' opts i c'@(CorrectOption j cStr) ics@(IncorrectOption icStr : ics') =
if i == j
then listMultipleChoice' (cStr : opts) (i+1) c' ics
else listMultipleChoice' (icStr : opts) (i+1) c' ics'
drawChoices :: State -> [String] -> Widget Name
drawChoices s options = case (s ^. cardState, s ^. currentCard) of
(MultipleChoiceState {_highlighted=i, _tried=kvs}, MultipleChoice _ (CorrectOption k _) _) -> vBox formattedOptions
@ -256,12 +297,29 @@ wrapStringWithPadding padding w s
ts' = ts & _last %~ (`T.append` postfix) in
(map txt (filter (/=T.empty) ts'), T.length (last ts'), False)
drawCardBox :: Widget Name -> Widget Name
drawCardBox w = C.center $
withBorderStyle BS.unicodeRounded $
B.border $
withAttr textboxAttr $
hLimitPercent 60 w
drawReorder :: State -> NonEmpty (Int, String) -> Widget Name
drawReorder s elements = case (s ^. cardState, s ^. currentCard) of
(ReorderState {_highlighted=j, _grabbed=g, _order=kvs, _number=n, _entered=submitted}, Reorder _ _) ->
vBox . flip map (map (\i -> (i, kvs M.! i)) [0..n-1]) $
\(i, (k, text)) ->
let color = case (i == j, g) of
(True, True ) -> withAttr grabbedElementAttr
(True, False) -> withAttr highlightedElementAttr
_ -> id
number =
case (submitted, i+1 == k) of
(False, _) -> str (show (i+1) <> ". ")
(True, False) -> withAttr incorrectElementAttr (str (show k <> ". "))
(True, True ) -> withAttr correctElementAttr (str (show k <> ". "))
in
number <+> color (drawDescr text)
_ -> error "cardstate mismatch"
----------------------------------------------------
---------------------- Events ----------------------
----------------------------------------------------
handleEvent :: State -> BrickEvent Name Event -> EventM Name (Next State)
handleEvent s (VtyEvent e) = case e of
@ -279,7 +337,7 @@ handleEvent s (VtyEvent e) = case e of
else continue $ s & cardState.flipped %~ not
_ -> continue s
(MultipleChoiceState {_highlighted = i, _nChoices = n, _tried = kvs}, MultipleChoice _ (CorrectOption j _) _) ->
(MultipleChoiceState {_highlighted = i, _number = n, _tried = kvs}, MultipleChoice _ (CorrectOption j _) _) ->
case ev of
V.EvKey V.KUp [] -> continue up
V.EvKey (V.KChar 'k') [] -> continue up
@ -295,15 +353,15 @@ handleEvent s (VtyEvent e) = case e of
where frozen = M.findWithDefault False j kvs
down = if i < n - 1 && not frozen
down = if i < n && not frozen
then s & (cardState.highlighted) +~ 1
else s
up = if i > 0 && not frozen
up = if i > 1 && not frozen
then s & (cardState.highlighted) -~ 1
else s
(MultipleAnswerState {_highlighted = i, _nChoices = n, _entered = submitted}, MultipleAnswer {}) ->
(MultipleAnswerState {_highlighted = i, _number = n, _entered = submitted}, MultipleAnswer {}) ->
case ev of
V.EvKey V.KUp [] -> continue up
V.EvKey (V.KChar 'k') [] -> continue up
@ -330,7 +388,7 @@ handleEvent s (VtyEvent e) = case e of
then s & (cardState.highlighted) -~ 1
else s
(OpenQuestionState {_highlighted = i, _nGaps = n, _gapInput = kvs, _correctGaps = cGaps}, OpenQuestion _ perforated) ->
(OpenQuestionState {_highlighted = i, _number = n, _gapInput = kvs, _correctGaps = cGaps}, OpenQuestion _ perforated) ->
let correct = M.foldr (&&) True cGaps in
case ev of
V.EvKey (V.KChar '\t') [] -> continue $
@ -363,9 +421,69 @@ handleEvent s (VtyEvent e) = case e of
backspace xs = init xs
_ -> continue s
(ReorderState {_highlighted = i, _entered = submitted, _grabbed=dragging, _number = n }, Reorder _ _) ->
case ev of
V.EvKey V.KUp [] -> continue up
V.EvKey (V.KChar 'k') [] -> continue up
V.EvKey V.KDown [] -> continue down
V.EvKey (V.KChar 'j') [] -> continue down
V.EvKey (V.KChar 'c') [] -> continue $ s & (cardState.entered) .~ True
V.EvKey V.KEnter [] ->
if frozen
then next s
else continue $ s & cardState.grabbed %~ not
_ -> continue s
where frozen = submitted
down =
case (frozen, i < n - 1, dragging) of
(True, _, _) -> s
(_, False, _) -> s
(_, _, False) -> s & (cardState.highlighted) +~ 1
(_, _, True) -> s & (cardState.highlighted) +~ 1
& (cardState.order) %~ interchange i (i+1)
up =
case (frozen, i > 0, dragging) of
(True, _, _) -> s
(_, False, _) -> s
(_, _, False) -> s & (cardState.highlighted) -~ 1
(_, _, True) -> s & (cardState.highlighted) -~ 1
& (cardState.order) %~ interchange i (i-1)
_ -> error "impossible"
handleEvent s _ = continue s
next :: State -> EventM Name (Next State)
next s
| s ^. index + 1 < length (s ^. cards) = continue . updateState $ s & index +~ 1
| otherwise = halt s
previous :: State -> EventM Name (Next State)
previous s | s ^. index > 0 = continue . updateState $ s & index -~ 1
| otherwise = continue s
updateState :: State -> State
updateState s =
let card = (s ^. cards) !! (s ^. index) in s
& currentCard .~ card
& cardState .~ defaultCardState card
interchange :: (Ord a) => a -> a -> Map a b -> Map a b
interchange i j kvs =
let vali = kvs M.! i
valj = kvs M.! j in
M.insert j vali (M.insert i valj kvs)
----------------------------------------------------
-------------------- Attributes --------------------
----------------------------------------------------
titleAttr :: AttrName
titleAttr = attrName "title"
@ -393,9 +511,6 @@ correctOptAttr = attrName "correct option"
incorrectOptAttr :: AttrName
incorrectOptAttr = attrName "incorrect option"
hiddenAttr :: AttrName
hiddenAttr = attrName "hidden"
gapAttr :: AttrName
gapAttr = attrName "gap"
@ -405,6 +520,18 @@ incorrectGapAttr = attrName "incorrect gap"
correctGapAttr :: AttrName
correctGapAttr = attrName "correct gap"
highlightedElementAttr :: AttrName
highlightedElementAttr = attrName "highlighted element"
grabbedElementAttr :: AttrName
grabbedElementAttr = attrName "grabbed element"
correctElementAttr :: AttrName
correctElementAttr = attrName "correct element"
incorrectElementAttr :: AttrName
incorrectElementAttr = attrName "incorrect element"
theMap :: AttrMap
theMap = attrMap V.defAttr
[ (titleAttr, fg V.yellow)
@ -418,35 +545,9 @@ theMap = attrMap V.defAttr
, (selectedOptAttr, fg V.blue)
, (incorrectOptAttr, fg V.red)
, (correctOptAttr, fg V.green)
, (hiddenAttr, fg V.black)
, (highlightedElementAttr, fg V.yellow)
, (grabbedElementAttr, fg V.blue)
, (correctElementAttr, fg V.green)
, (incorrectElementAttr, fg V.red)
, (gapAttr, V.defAttr `V.withStyle` V.underline)
]
runCardsUI :: GlobalState -> [Card] -> IO State
runCardsUI gs deck = do
hints <- getShowHints
controls <- getShowControls
let initialState = State { _cards = deck
, _index = 0
, _currentCard = head deck
, _cardState = defaultCardState (head deck)
, _nCards = length deck
, _showHints = hints
, _showControls = controls }
defaultMain app initialState
next :: State -> EventM Name (Next State)
next s
| s ^. index + 1 < length (s ^. cards) = continue . updateState $ s & index +~ 1
| otherwise = halt s
previous :: State -> EventM Name (Next State)
previous s | s ^. index > 0 = continue . updateState $ s & index -~ 1
| otherwise = continue s
updateState :: State -> State
updateState s =
let card = (s ^. cards) !! (s ^. index) in s
& currentCard .~ card
& cardState .~ defaultCardState card