From a0887b039f5111dc0738cf0424c86181b5f8694f Mon Sep 17 00:00:00 2001 From: Steven van den Broek Date: Sat, 25 Jul 2020 13:16:20 +0200 Subject: [PATCH] Add ordering type question, parsing and display --- cards/syntax.txt | 8 +- src/Parser.hs | 27 ++++- src/Types.hs | 15 +-- src/UI/Cards.hs | 257 +++++++++++++++++++++++++++++++++-------------- 4 files changed, 218 insertions(+), 89 deletions(-) diff --git a/cards/syntax.txt b/cards/syntax.txt index 6ba8cf9..697da77 100644 --- a/cards/syntax.txt +++ b/cards/syntax.txt @@ -22,4 +22,10 @@ Explanation or definition of this word, or the answer to the question. # Fill in the gaps The symbol € is for the currency named _Euro_, and is used in the _EU|European Union_. ---- \ No newline at end of file +--- + +# Order the letters in alphabetical order +4. u +1. l +2. p +3. s \ No newline at end of file diff --git a/src/Parser.hs b/src/Parser.hs index 3212f33..478e660 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs index 2b60884..9b47d0a 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/UI/Cards.hs b/src/UI/Cards.hs index db59cbd..9dd4c1a 100644 --- a/src/UI/Cards.hs +++ b/src/UI/Cards.hs @@ -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 + ] \ No newline at end of file