1module UI.Cards (Card, State(..), drawUI, handleEvent, theMap) where 2 3import Brick 4import Control.Monad 5import Control.Monad.IO.Class 6import Lens.Micro.Platform 7import Types 8import States 9import StateManagement 10import Data.Char (isSpace) 11import Data.List.NonEmpty (NonEmpty) 12import Data.Map.Strict (Map) 13import Data.Maybe 14import Text.Wrap 15import Data.Text (pack) 16import UI.Attributes 17import UI.BrickHelpers 18import System.FilePath 19import qualified Data.List.NonEmpty as NE 20import qualified Data.Text as T 21import qualified Data.Map.Strict as M 22import qualified Brick.Widgets.Border as B 23import qualified Brick.Widgets.Border.Style as BS 24import qualified Brick.Widgets.Center as C 25import qualified Graphics.Vty as V 26 27--------------------------------------------------- 28--------------------- DRAWING --------------------- 29--------------------------------------------------- 30 31drawUI :: CS -> [Widget Name] 32drawUI s = [maybe emptyWidget (`drawPopup` s) (s^.popup), drawCardUI s <=> drawInfo s] 33 34drawInfo :: CS -> Widget Name 35drawInfo s = if not (s ^. showControls) then emptyWidget else 36 strWrap . ("ESC: quit" <>) $ case s ^. cardState of 37 DefinitionState {} -> ", ENTER: flip card / continue" 38 MultipleChoiceState {} -> ", ENTER: submit answer / continue" 39 MultipleAnswerState {} -> ", ENTER: select / continue, c: submit selection" 40 OpenQuestionState {} -> ", LEFT/RIGHT/TAB: navigate gaps, ENTER: submit answer / continue, F1: show answer" 41 ReorderState {} -> ", ENTER: grab, c: submit answer" 42 43drawCardBox :: Widget Name -> Widget Name 44drawCardBox w = C.center $ 45 withBorderStyle BS.unicodeRounded $ 46 B.border $ 47 withAttr textboxAttr $ 48 hLimitPercent 60 w 49 50drawFooter :: CS -> Widget Name 51drawFooter s = if s^.reviewMode 52 then padLeftRight 1 $ wrong <+> progress <+> correct 53 else progress 54 -- not guaranteed that progress is horizontally centered i think 55 where progress = C.hCenter $ str (show (s^.index + 1) ++ "/" ++ show (s^.nCards)) 56 wrong = withAttr wrongAttr (str ("✗ " <> show nWrong)) 57 correct = withAttr correctAttr (str ("✓ " <> show nCorrect)) 58 nCorrect = length (s^.correctCards) 59 nWrong = s^.index - nCorrect + (if endCard then 1 else 0) 60 endCard = maybe False (isFinalPopup . view popupState) (s^.popup) 61 62drawCardUI :: CS -> Widget Name 63drawCardUI s = let p = 1 in 64 joinBorders $ drawCardBox $ (<=> drawFooter s) $ 65 case (s ^. cards) !! (s ^. index) of 66 Definition title descr -> drawHeader title 67 <=> B.hBorder 68 <=> padLeftRight p (drawDef s descr <=> str " ") 69 70 MultipleChoice question correct others -> drawHeader question 71 <=> B.hBorder 72 <=> padLeftRight p (drawChoices s (listMultipleChoice correct others) <=> str " ") 73 74 OpenQuestion title perforated -> drawHeader title 75 <=> B.hBorder 76 <=> padLeftRight p (atLeastV 1 (drawPerforated s perforated) <=> str " ") 77 78 MultipleAnswer question options -> drawHeader question 79 <=> B.hBorder 80 <=> padRight (Pad p) (drawOptions s options <=> str " ") 81 82 Reorder question _ -> drawHeader question 83 <=> B.hBorder 84 <=> padLeftRight p (drawReorder s <=> str " ") 85 86drawHeader :: String -> Widget Name 87drawHeader title = withAttr titleAttr $ 88 padLeftRight 1 $ 89 hCenteredStrWrap title 90 91wrapSettings :: WrapSettings 92wrapSettings = WrapSettings {preserveIndentation=False, breakLongWords=True} 93 94drawDescr :: String -> Widget Name 95drawDescr = strWrapWith wrapSettings 96 97drawDef :: CS -> String -> Widget Name 98drawDef s def = if s ^. showHints then drawHintedDef s def else drawNormalDef s def 99 100drawHintedDef :: CS -> String -> Widget Name 101drawHintedDef s def = case s ^. cardState of 102 DefinitionState {_flipped=f} -> if f then drawDescr def else drawDescr [if isSpace' char then char else '_' | char <- def] 103 _ -> error "impossible: " 104 105isSpace' :: Char -> Bool 106isSpace' '\r' = True 107isSpace' a = isSpace a 108 109drawNormalDef:: CS -> String -> Widget Name 110drawNormalDef s def = case s ^. cardState of 111 DefinitionState {_flipped=f} -> if f 112 then drawDescr def 113 else Widget Greedy Fixed $ do 114 c <- getContext 115 let w = c^.availWidthL 116 render . vBox $ [str " " | _ <- wrapTextToLines wrapSettings w (pack def)] 117 _ -> error "impossible: " 118 119drawChoices :: CS -> [String] -> Widget Name 120drawChoices s options = case (s ^. cardState, s ^. currentCard) of 121 (MultipleChoiceState {_highlighted=i, _tried=kvs}, MultipleChoice _ (CorrectOption k _) _) -> vBox formattedOptions 122 123 where formattedOptions :: [Widget Name] 124 formattedOptions = [ prefix <+> coloring (drawDescr opt) | 125 (j, opt) <- zip [0..] options, 126 let prefix = if i == j then withAttr highlightedChoiceAttr (str "* ") else str " " 127 chosen = M.findWithDefault False j kvs 128 coloring = case (chosen, j==k) of 129 (False, _) -> id 130 (True, False) -> withAttr incorrectChoiceAttr 131 (True, True) -> withAttr correctChoiceAttr 132 ] 133 _ -> error "impossible" 134 135drawOptions :: CS -> NonEmpty Option -> Widget Name 136drawOptions s = case (s ^. cardState, s ^. currentCard) of 137 (MultipleAnswerState {_highlighted=j, _selected=kvs, _entered=submitted}, _) -> 138 vBox . NE.toList . NE.map drawOption . (`NE.zip` NE.fromList [0..]) 139 where drawOption (Option kind text, i) = coloring (str "[") <+> coloring (highlighting (str symbol)) <+> coloring (str "] ") <+> drawDescr text 140 where symbol = if (i == j && not submitted) || enabled then "*" else " " 141 enabled = M.findWithDefault False i kvs 142 highlighting = if i == j && not submitted then withAttr highlightedOptAttr else id 143 coloring = case (submitted, enabled, kind) of 144 (True, True, Correct) -> withAttr correctOptAttr 145 (True, False, Incorrect) -> withAttr correctOptAttr 146 (True, _, _) -> withAttr incorrectOptAttr 147 (False, True, _) -> withAttr selectedOptAttr 148 _ -> id 149 150 _ -> error "hopefully this is never shown" 151 152 153drawPerforated :: CS -> Perforated -> Widget Name 154drawPerforated s p = drawSentence s $ perforatedToSentence p 155 156drawSentence :: CS -> Sentence -> Widget Name 157drawSentence state sentence = Widget Greedy Fixed $ do 158 c <- getContext 159 let w = c^.availWidthL 160 render $ makeSentenceWidget w state sentence 161 162makeSentenceWidget :: Int -> CS -> Sentence -> Widget Name 163makeSentenceWidget w state = vBox . fst . makeSentenceWidget' 0 0 164 where 165 makeSentenceWidget' :: Int -> Int -> Sentence -> ([Widget Name], Bool) 166 makeSentenceWidget' padding _ (Normal s) = let (ws, _, fit) = wrapStringWithPadding padding w s in (ws, fit) 167 makeSentenceWidget' padding i (Perforated pre _ post) = case state ^. cardState of 168 OpenQuestionState {_gapInput = kvs, _highlighted=j, _entered=submitted, _correctGaps=cgs} -> 169 let (ws, n, fit') = wrapStringWithPadding padding w pre 170 gap = M.findWithDefault "" i kvs 171 n' = w - n - textWidth gap 172 173 cursor :: Widget Name -> Widget Name 174 -- i is the index of the gap that we are drawing; j is the gap that is currently selected 175 cursor = if i == j then showCursor Ordinary (Location (textWidth gap, 0)) else id 176 177 correct = M.findWithDefault False i cgs 178 coloring = case (submitted, correct) of 179 (False, _) -> withAttr gapAttr 180 (True, False) -> withAttr incorrectGapAttr 181 (True, True) -> withAttr correctGapAttr 182 183 gapWidget = cursor $ coloring (str gap) in 184 185 if n' >= 0 186 then let (ws1@(w':ws'), fit) = makeSentenceWidget' (w-n') (i+1) post in 187 if fit then ((ws & _last %~ (<+> (gapWidget <+> w'))) ++ ws', fit') 188 else ((ws & _last %~ (<+> gapWidget)) ++ ws1, fit') 189 else let (ws1@(w':ws'), fit) = makeSentenceWidget' (textWidth gap) (i+1) post in 190 if fit then (ws ++ [gapWidget <+> w'] ++ ws', fit') 191 else (ws ++ [gapWidget] ++ ws1, fit') 192 _ -> error "PANIC!" 193 194wrapStringWithPadding :: Int -> Int -> String -> ([Widget Name], Int, Bool) 195wrapStringWithPadding padding w s 196 | null (words s) = ([str ""], padding, True) 197 | otherwise = if textWidth (head (words s)) < w - padding then 198 let startsWithSpace = head s == ' ' 199 s' = if startsWithSpace then " " <> replicate padding 'X' <> tail s else replicate padding 'X' ++ s 200 lastLetter = last s 201 postfix = if lastLetter == ' ' then T.pack [lastLetter] else T.empty 202 ts = wrapTextToLines wrapSettings w (pack s') & ix 0 %~ (if startsWithSpace then (T.pack " " `T.append`) . T.drop (padding + 1) else T.drop padding) 203 ts' = ts & _last %~ (`T.append` postfix) 204 padding' = textWidth (last ts') + (if length ts' == 1 then 1 else 0) * padding in 205 (map txt (filter (/=T.empty) ts'), padding', True) 206 else 207 let lastLetter = last s 208 (x: xs) = s 209 s' = if x == ' ' then xs else s 210 postfix = if lastLetter == ' ' then T.pack [lastLetter] else T.empty 211 ts = wrapTextToLines wrapSettings w (pack s') 212 ts' = ts & _last %~ (`T.append` postfix) in 213 (map txt (filter (/=T.empty) ts'), textWidth (last ts'), False) 214 215drawReorder :: CS -> Widget Name 216drawReorder s = case (s ^. cardState, s ^. currentCard) of 217 (ReorderState {_highlighted=j, _grabbed=g, _order=kvs, _number=n, _entered=submitted}, Reorder _ _) -> 218 vBox . flip map (map (\i -> (i, kvs M.! i)) [0..n-1]) $ 219 \(i, (k, text)) -> 220 let color = case (i == j, g) of 221 (True, True ) -> withAttr grabbedElementAttr 222 (True, False) -> withAttr highlightedElementAttr 223 _ -> id 224 225 number = 226 case (submitted, i+1 == k) of 227 (False, _) -> str (show (i+1) <> ". ") 228 (True, False) -> withAttr incorrectElementAttr (str (show k <> ". ")) 229 (True, True ) -> withAttr correctElementAttr (str (show k <> ". ")) 230 in 231 number <+> color (drawDescr text) 232 233 _ -> error "cardstate mismatch" 234 235---------------------------------------------------- 236---------------------- Events ---------------------- 237---------------------------------------------------- 238halt' :: GlobalState -> EventM n (Next GlobalState) 239halt' = flip (moveToModeOrQuit' (\(CardSelectorState s) -> CardSelectorState <$> refreshRecents s)) CardSelector 240 241handleEvent :: GlobalState -> CS -> BrickEvent Name Event -> EventM Name (Next GlobalState) 242handleEvent gs s (VtyEvent e) = 243 let update = updateCS gs 244 continue' = continue . update in 245 case e of 246 V.EvKey V.KEsc [] -> halt' gs 247 V.EvKey V.KRight [V.MCtrl] -> if not (s^.reviewMode) then next gs s else continue gs 248 V.EvKey V.KLeft [V.MCtrl] -> if not (s^.reviewMode) then previous gs s else continue gs 249 250 ev -> 251 flip (`maybe` (\p -> handlePopupEvent p gs s ev)) (s ^. popup) $ 252 case (s ^. cardState, s ^. currentCard) of 253 (DefinitionState{_flipped = f}, _) -> 254 case ev of 255 V.EvKey V.KEnter [] -> 256 if f 257 then if not (s^.reviewMode) then next gs s 258 else continue' (s & popup ?~ correctPopup) 259 else continue' $ s & cardState.flipped %~ not 260 _ -> continue' s 261 262 (MultipleChoiceState {_highlighted = i, _number = n, _tried = kvs}, MultipleChoice _ (CorrectOption j _) _) -> 263 case ev of 264 V.EvKey V.KUp [] -> continue' up 265 V.EvKey (V.KChar 'k') [] -> continue' up 266 V.EvKey V.KDown [] -> continue' down 267 V.EvKey (V.KChar 'j') [] -> continue' down 268 269 V.EvKey V.KEnter [] -> 270 if frozen 271 then next gs $ s & if correctlyAnswered then correctCards %~ (s^.index:) else id 272 else continue' $ s & cardState.tried %~ M.insert i True 273 274 275 _ -> continue' s 276 277 where frozen = M.findWithDefault False j kvs 278 279 down = if i < n-1 && not frozen 280 then s & (cardState.highlighted) +~ 1 281 else s 282 283 up = if i > 0 && not frozen 284 then s & (cardState.highlighted) -~ 1 285 else s 286 287 correctlyAnswered = i == j && M.size (M.filter (==True) kvs) == 1 288 289 (MultipleAnswerState {_highlighted = i, _number = n, _entered = submitted, _selected = kvs}, MultipleAnswer _ opts) -> 290 case ev of 291 V.EvKey V.KUp [] -> continue' up 292 V.EvKey (V.KChar 'k') [] -> continue' up 293 V.EvKey V.KDown [] -> continue' down 294 V.EvKey (V.KChar 'j') [] -> continue' down 295 296 V.EvKey (V.KChar 'c') [] -> continue' $ s & (cardState.entered) .~ True 297 298 V.EvKey V.KEnter [] -> 299 if frozen 300 then next gs $ s & if correctlyAnswered then correctCards %~ (s^.index:) else id 301 else continue' $ s & cardState.selected %~ M.adjust not i 302 303 _ -> continue' s 304 305 306 where frozen = submitted 307 308 down = if i < n-1 && not frozen 309 then s & (cardState.highlighted) +~ 1 310 else s 311 312 up = if i > 0 && not frozen 313 then s & (cardState.highlighted) -~ 1 314 else s 315 316 correctlyAnswered = NE.toList (NE.map isOptionCorrect opts) == map snd (M.toAscList kvs) 317 318 (OpenQuestionState {_highlighted = i, _number = n, _gapInput = kvs, _correctGaps = cGaps, _failed=fail}, OpenQuestion _ perforated) -> 319 let frozen = M.foldr (&&) True cGaps in 320 case ev of 321 V.EvKey (V.KFun 1) [] -> continue' $ 322 s & cardState.gapInput .~ correctAnswers 323 & cardState.entered .~ True 324 & cardState.failed .~ True 325 & cardState.correctGaps .~ M.fromAscList [(i, True) | i <- [0..n-1]] 326 where correctAnswers = M.fromAscList $ zip [0..] $ map NE.head (sentenceToGaps (perforatedToSentence perforated)) 327 328 V.EvKey (V.KChar '\t') [] -> continue' $ 329 if i < n - 1 && not frozen 330 then s & (cardState.highlighted) +~ 1 331 else s & (cardState.highlighted) .~ 0 332 333 V.EvKey V.KRight [] -> continue' $ 334 if i < n - 1 && not frozen 335 then s & (cardState.highlighted) +~ 1 336 else s 337 338 V.EvKey V.KLeft [] -> continue' $ 339 if i > 0 && not frozen 340 then s & (cardState.highlighted) -~ 1 341 else s 342 343 V.EvKey (V.KChar c) [] -> continue' $ 344 if frozen then s else s & cardState.gapInput.at i.non "" %~ (++[c]) 345 346 V.EvKey V.KEnter [] -> if frozen 347 then if fail 348 then next gs s 349 else next gs (s & correctCards %~ (s^.index:)) 350 else continue' s' 351 where sentence = perforatedToSentence perforated 352 gaps = sentenceToGaps sentence 353 354 s' = s & (cardState.correctGaps) %~ M.mapWithKey (\j _ -> M.findWithDefault "" j kvs `elem` gaps !! j) 355 & (cardState.entered) .~ True 356 357 s'' = if M.foldr (&&) True (s' ^. cardState.correctGaps) 358 then s' 359 else s' & cardState.failed .~ True 360 361 V.EvKey V.KBS [] -> continue' $ 362 if frozen then s else s & cardState.gapInput.ix i %~ backspace 363 where backspace "" = "" 364 backspace xs = init xs 365 _ -> continue' s 366 367 (ReorderState {_highlighted = i, _entered = submitted, _grabbed=dragging, _number = n, _order = kvs }, Reorder _ elts) -> 368 case ev of 369 V.EvKey V.KUp [] -> continue' up 370 V.EvKey (V.KChar 'k') [] -> continue' up 371 V.EvKey V.KDown [] -> continue' down 372 V.EvKey (V.KChar 'j') [] -> continue' down 373 374 V.EvKey (V.KChar 'c') [] -> continue' $ s & (cardState.entered) .~ True 375 376 V.EvKey V.KEnter [] -> 377 if frozen 378 then next gs $ s & if correct then correctCards %~ (s^.index:) else id 379 else continue' $ s & cardState.grabbed %~ not 380 381 _ -> continue' s 382 383 384 where frozen = submitted 385 386 down = 387 case (frozen, i < n - 1, dragging) of 388 (True, _, _) -> s 389 (_, False, _) -> s 390 (_, _, False) -> s & (cardState.highlighted) +~ 1 391 (_, _, True) -> s & (cardState.highlighted) +~ 1 392 & (cardState.order) %~ interchange i (i+1) 393 394 up = 395 case (frozen, i > 0, dragging) of 396 (True, _, _) -> s 397 (_, False, _) -> s 398 (_, _, False) -> s & (cardState.highlighted) -~ 1 399 (_, _, True) -> s & (cardState.highlighted) -~ 1 400 & (cardState.order) %~ interchange i (i-1) 401 402 correct = all (uncurry (==) . (\i -> (i+1, fst (kvs M.! i)))) [0..n-1] 403 404 _ -> error "impossible" 405handleEvent gs _ _ = continue gs 406 407next :: GlobalState -> CS -> EventM Name (Next GlobalState) 408next gs s 409 | s ^. index + 1 < length (s ^. cards) = continue . updateCS gs . straightenState $ s & index +~ 1 410 | s ^. reviewMode = 411 let thePopup = 412 if null (s^.correctCards) || length (s^. correctCards) == length (s^.cards) 413 then finalPopup 414 else deckMakerPopup 415 in continue . updateCS gs $ s & popup ?~ thePopup 416 | otherwise = halt' gs 417 418previous :: GlobalState -> CS -> EventM Name (Next GlobalState) 419previous gs s | s ^. index > 0 = continue . updateCS gs . straightenState $ s & index -~ 1 420 | otherwise = continue gs 421 422straightenState :: CS -> CS 423straightenState s = 424 let card = (s ^. cards) !! (s ^. index) in s 425 & currentCard .~ card 426 & cardState .~ defaultCardState card 427 428interchange :: (Ord a) => a -> a -> Map a b -> Map a b 429interchange i j kvs = 430 let vali = kvs M.! i 431 valj = kvs M.! j in 432 M.insert j vali (M.insert i valj kvs) 433 434---------------------------------------------------- 435---------------------- Popups ---------------------- 436---------------------------------------------------- 437 438isFinalPopup :: PopupState -> Bool 439isFinalPopup FinalPopup = True 440isFinalPopup DeckMakerPopup{} = True 441isFinalPopup _ = False 442 443correctPopup :: Popup CS 444correctPopup = Popup drawer eventHandler initialState 445 where drawer s = 446 let selected = maybe 0 (^?! popupState.popupSelected) (s^.popup) 447 colorNo = if selected == 0 then selectedNoButtonAttr else noButtonAttr 448 colorYes = if selected == 1 then selectedYesButtonAttr else yesButtonAttr 449 no = withAttr colorNo $ str "No" 450 yes = withAttr colorYes $ str "Yes" in 451 centerPopup $ 452 B.borderWithLabel (str "Correct?") $ 453 hLimit 20 $ 454 str " " <=> 455 str " " <=> 456 (hFill ' ' <+> no <+> hFill ' ' <+> yes <+> hFill ' ') 457 458 initialState = CorrectPopup 0 459 460 eventHandler gs s ev = 461 let update = updateCS gs 462 continue' = continue . update 463 p = fromJust (s ^. popup) 464 in case ev of 465 V.EvKey V.KLeft [] -> continue' $ s & popup ?~ (p & popupState.popupSelected .~ 0) 466 V.EvKey V.KRight [] -> continue' $ s & popup ?~ (p & popupState.popupSelected .~ 1) 467 -- V.EvKey V.KRight [] -> s & popup .~ popupState.popupSelected .~ Just 1 468 V.EvKey V.KEnter [] -> next gs $ s & popup .~ Nothing 469 & if p ^?! popupState.popupSelected == 1 then correctCards %~ (s^.index:) else id 470 _ -> continue' s 471 472finalPopup :: Popup CS 473finalPopup = Popup drawer eventHandler initialState 474 where drawer s = 475 let wrong = withAttr wrongAttr (str (" Incorrect: " <> show nWrong) <+> hFill ' ') 476 correct = withAttr correctAttr (str (" Correct: " <> show nCorrect) <+> hFill ' ') 477 nCorrect = length (s^.correctCards) 478 nWrong = s^.index + 1 - nCorrect in 479 centerPopup $ 480 B.borderWithLabel (str "Finished") $ 481 hLimit 20 $ 482 str " " <=> 483 wrong <=> 484 correct 485 486 initialState = FinalPopup 487 488 eventHandler gs s (V.EvKey V.KEnter []) = halt' gs 489 eventHandler gs _ _ = continue gs 490 491deckMakerPopup :: Popup CS 492deckMakerPopup = Popup drawer eventHandler initialState 493 where drawer s = 494 let state = fromMaybe initialState $ view popupState <$> s^.popup 495 j = state ^?! popupSelected 496 497 makeSym lens i = case (state ^?! lens, i == j) of 498 (_, True) -> withAttr highlightedOptAttr $ str "*" 499 (True, _) -> withAttr selectedOptAttr $ str "*" 500 _ -> withAttr selectedOptAttr $ str " " 501 502 makeBox lens i = 503 (if state ^?! lens then withAttr selectedOptAttr else id) $ 504 str "[" <+> makeSym lens i <+> str "]" 505 506 wBox = makeBox makeDeckIncorrect 0 507 cBox = makeBox makeDeckCorrect 1 508 509 wrong = wBox <+> withAttr wrongAttr (str (" Incorrect: " <> show nWrong) <+> hFill ' ') 510 correct = cBox <+> withAttr correctAttr (str (" Correct: " <> show nCorrect) <+> hFill ' ') 511 nCorrect = length (s^.correctCards) 512 nWrong = s^.index + 1 - nCorrect in 513 centerPopup $ 514 B.borderWithLabel (str "Generate decks") $ 515 hLimit 20 $ 516 str " " <=> 517 wrong <=> 518 correct <=> 519 str " " <=> 520 C.hCenter ((if j == 2 then withAttr selectedAttr else id) (str "Ok")) 521 522 initialState = DeckMakerPopup 0 False False 523 524 eventHandler gs s ev = 525 let update = updateCS gs 526 continue' = continue . update 527 p = fromJust (s ^. popup) 528 state = p ^. popupState 529 in case state ^?! popupSelected of 530 0 -> case ev of 531 V.EvKey V.KEnter [] -> continue' $ s & popup ?~ (p & popupState.makeDeckIncorrect %~ not) 532 V.EvKey V.KDown [] -> continue' $ s & popup ?~ (p & popupState.popupSelected +~ 1) 533 V.EvKey (V.KChar 'j') [] -> continue' $ s & popup ?~ (p & popupState.popupSelected +~ 1) 534 _ -> continue' s 535 1 -> case ev of 536 V.EvKey V.KEnter [] -> continue' $ s & popup ?~ (p & popupState.makeDeckCorrect %~ not) 537 V.EvKey V.KDown [] -> continue' $ s & popup ?~ (p & popupState.popupSelected +~ 1) 538 V.EvKey (V.KChar 'j') [] -> continue' $ s & popup ?~ (p & popupState.popupSelected +~ 1) 539 V.EvKey V.KUp [] -> continue' $ s & popup ?~ (p & popupState.popupSelected -~ 1) 540 V.EvKey (V.KChar 'k') [] -> continue' $ s & popup ?~ (p & popupState.popupSelected -~ 1) 541 _ -> continue' s 542 2 -> case ev of 543 V.EvKey V.KEnter [] -> liftIO (generateDecks (s ^. pathToFile) (s ^. cards) (s ^. correctCards) (state ^?! makeDeckCorrect) (state ^?! makeDeckIncorrect)) 544 *> halt' gs 545 V.EvKey V.KUp [] -> continue' $ s & popup ?~ (p & popupState.popupSelected -~ 1) 546 V.EvKey (V.KChar 'k') [] -> continue' $ s & popup ?~ (p & popupState.popupSelected -~ 1) 547 _ -> continue' s 548 549generateDecks :: FilePath -> [Card] -> [Int] -> Bool -> Bool -> IO () 550generateDecks fp cards corrects makeCorrect makeIncorrect = 551 when (makeCorrect || makeIncorrect) $ 552 do let (correct, incorrect) = splitCorrectIncorrect cards corrects 553 when makeCorrect $ writeFile (replaceBaseName fp (takeBaseName fp <> "+")) (cardsToString correct) 554 when makeIncorrect $ writeFile (replaceBaseName fp (takeBaseName fp <> "-")) (cardsToString incorrect) 555 556-- gets list of cards, list of indices of correct cards; returns (correct, incorrect) 557splitCorrectIncorrect :: [Card] -> [Int] -> ([Card], [Card]) 558splitCorrectIncorrect cards indices = doSplit [] [] (zip [0..] cards) (reverse indices) 559 where doSplit cs ws [] _ = (reverse cs, reverse ws) 560 doSplit cs ws ((_, x):xs) [] = doSplit cs (x:ws) xs [] 561 doSplit cs ws ((j, x):xs) (i:is) = 562 if i == j 563 then doSplit (x:cs) ws xs is 564 else doSplit cs (x:ws) xs (i:is)