Commit f5ae0502 authored by Christopher League's avatar Christopher League
Browse files

Check-in 2, decode words

parent 86173abf
......@@ -101,6 +101,7 @@ mkYesodData
/unit/1/from-base U1FromBaseR
/unit/1/to-base U1ToBaseR
/unit/1/hex-spell U1HexSpellR GET POST
/unit/1/tree-dec U1DecodeTreeR
/assn/1/huffman U1HuffAssnR
/assn/1/huffman/upload U1HuffUploadR POST
......@@ -116,8 +117,6 @@ mkYesodData
|]
-- /submit/#Text SubmitR GET POST
type AppHandler m = (MonadHandler m, HandlerSite m ~ App)
runRo :: AppHandler m => (forall s. ByteStoreRO s => s a) -> m a
......
......@@ -27,14 +27,13 @@ import App.Post
import App.Prelude
import App.Profile
import App.Quiz1
import App.Quiz2
import App.Schedule
import App.User
import App.YamlStore
import Conduit
import Control.Monad.Catch (MonadMask)
import qualified Data.Map as Map
import qualified Data.Yaml as Yaml
import Network.Mime
import System.Environment
import System.Exit
import Test.Tasty
......@@ -58,52 +57,6 @@ deleteMetaCacheR = do
writeIORef cacheRef mempty
return $ "meta cache: dropped " <> show num <> " entries.\n"
-- getSubmitR :: Text -> Handler Html
-- getSubmitR sid = undefined
-- (widget, enctype) <- generateFormPost $ renderDivs $ fileAFormReq "your-file"
-- defaultLayout
-- [whamlet|
-- <p>Submitting #{sid}
-- <form method=post enctype=#{enctype}>
-- ^{widget}
-- <button .btn .btn-primary>Upload
-- | ]
-- data SubmitFile
-- = SubmitFile
-- { submitId :: Text,
-- submitUser :: UserId,
-- submitFileName :: Text
-- }
-- deriving (Eq, Ord, Show)
-- -- won't be able to list these keys because separate subdirs?
-- instance Key SubmitFile where
-- keyDir = "submit"
-- keyToFileName SubmitFile {..} =
-- convertString submitId
-- </> convertString (userIdText submitUser)
-- </> convertString submitFileName
-- postSubmitR :: Text -> Handler Html
-- postSubmitR sid = do
-- uid <- requireAuthId
-- ((res, _), _) <- runFormPost $ renderDivs $ fileAFormReq "your-file"
-- case res of
-- FormSuccess FileInfo {..} -> do
-- let sf = SubmitFile sid uid fileName
-- st = keyToFilePath @_ @Text sf
-- runRw $ do
-- logMessage st
-- runConduit $
-- transPipe liftResourceT fileSourceRaw .| writeObj sf
-- defaultLayout
-- [whamlet|
-- <p>Got #{fileName} (#{fileContentType})
-- <p>Will upload to #{st}
-- | ]
getPostR :: PostId -> Handler Html
getPostR pid = do
uid <- requireAuthId
......@@ -215,5 +168,6 @@ test =
pageTests,
postTests,
quiz1Tests,
assn1Tests
assn1Tests,
quiz2Tests
]
......@@ -22,6 +22,7 @@ import App.Page
import App.Post
import App.Prelude
import App.Quiz1
import App.Quiz2
import App.User
import qualified Data.Set as Set
import Data.Tuple.Extra
......@@ -136,6 +137,12 @@ unit1 = do
Text compression
^{a1SubmittedBadge}
^{dueBadge (actDeadline assn1)}
<li .list-group-item>
Check-in:
<a href=@{U1DecodeTreeR}>
Decode text bits
^{pointsBadge u1DecodeTree}
^{dueBadge (actDeadline u1DecodeTree)}
<li .list-group-item>
Notes:
<a href=@{PageDocR "notes140-images.org"}>
......
......@@ -27,6 +27,7 @@ module App.Prelude
Maybe (..),
Either (..),
fromMaybe,
fromMaybeM,
maybe,
maybeReturn,
maybeToMonadPlus,
......
......@@ -383,7 +383,6 @@ handleU1ToBaseR = do
addMessage
"success"
[shamlet|
<b>
$if isLate && (newPts < actMaxPoints)
You got it! However, the deadline has passed, so no further points
can be awarded.
......@@ -440,9 +439,9 @@ $else
hexableWords :: [Text]
hexableWords =
Text.split (== ' ') $
"ace aced add added babe bad bead bed bee beef cab cafe dab dad "
<> "dead decaf deed fab face faced fad fade faded faff fed fee feed"
Text.words
"ace aced add added babe bad bead bed bee beef cab cafe dab dad \
\dead decaf deed fab face faced fad fade faded faff fed fee feed"
genHexSpell :: Gen Text
genHexSpell = do
......
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module App.Quiz2
( handleU1DecodeTreeR,
u1DecodeTree,
quiz2Tests,
)
where
import App.Activity
import App.Foundation
import App.Page (AssetId (..))
import App.Prelude
import App.User
import Control.Lens (at)
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import qualified Data.Map as Map
import qualified Data.Text as Text
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.Hedgehog
import Text.Blaze.Html (ToMarkup (..))
type Bits = Text -- Just 0/1
newtype TreeWord
= TreeWord {unTreeWord :: CI Text}
deriving (Show, Eq)
mkTreeWord :: Text -> TreeWord
mkTreeWord =
TreeWord . CI.mk . Text.strip
instance PathPiece TreeWord where
toPathPiece =
CI.original . unTreeWord
fromPathPiece =
Just . mkTreeWord
instance ConvertibleStrings TreeWord [Char] where
convertString = Text.unpack . toPathPiece
instance ConvertibleStrings TreeWord [CI Char] where
convertString = map CI.mk . convertString
instance ToMarkup TreeWord where
toMarkup = toMarkup . toPathPiece
treeWords :: [TreeWord]
treeWords =
map mkTreeWord $
Text.words
"EEL EERIE EGG EGRET EIGHT ELF ELITE ETHER FEE FEEL FEET FELL FELT FIFE\
\ FIFTH FIG FIGHT FILE FILET FILL FILTH FIR FIRE FIT FLEE FLEET FLIER\
\ FLIRT FLIT FREE FRET FRILL GIFT GIG GILL GILT GIRL GLEE GRIEF GRILL\
\ GRIT HEEL HEFT HEIR HER HERE HIGH HILL HILT HIRE HIT ILL IRE LEER LEFT\
\ LEG LET LIE LIEGE LIFE LIFT LIGHT LIRE LIT LITHE REEF REEL REFER REFIT\
\ RIFE RIFF RIFT RIG RIGHT RILE RITE TEE TEETH TELL THE THEE THEFT\
\ THEIR THERE THIEF THIGH THREE TIE TIER TIFF TIGER TIGHT TILE TILER\
\ TILL TILT TIRE TITLE TREE TRILL TRITE"
charEnc :: Map (CI Char) Bits
charEnc =
Map.fromList
[ (CI.mk 'E', "000"),
(CI.mk 'F', "001"),
(CI.mk 'G', "01"),
(CI.mk 'H', "1000"),
(CI.mk 'I', "1001"),
(CI.mk 'L', "101"),
(CI.mk 'R', "110"),
(CI.mk 'T', "111")
]
charToBits :: CI Char -> Maybe Bits
charToBits =
flip Map.lookup charEnc
wordToBits :: TreeWord -> Maybe Bits
wordToBits =
map Text.concat . mapM charToBits . convertString
reqWordToBits :: TreeWord -> Bits
reqWordToBits =
Text.concat . mapMaybe charToBits . convertString
u1DecodeTree :: Activity
u1DecodeTree =
makeActivity "u1dtree" 10 "2020-02-19 23:59 EST"
newTreeSession :: Handler TreeWord
newTreeSession = do
w <- Gen.sample $ Gen.element treeWords
let txt = toPathPiece w
setSession (actId u1DecodeTree) txt
putStrLn $ "newTreeSession: " <> txt
return w
getTreeSession :: Handler TreeWord
getTreeSession =
fromMaybeM newTreeSession $
map mkTreeWord <$> lookupSession (actId u1DecodeTree)
wordField :: Field Handler TreeWord
wordField =
convertField mkTreeWord toPathPiece textField
wordForm :: AForm Handler TreeWord
wordForm =
areq
wordField
""
{ fsAttrs =
[ ("placeholder", "Decoded word"),
("autocomplete", "off")
]
}
Nothing
handleU1DecodeTreeR :: Handler Html
handleU1DecodeTreeR = do
w <- getTreeSession
((result, widget), enctype) <- runFormPost $ renderDivsNoLabels wordForm
let bits = reqWordToBits w
correct = maybe False (== w) $ maybeFormSuccess result
Activity {..} = u1DecodeTree
onFormSuccess result \_ -> do
when correct $ do
origPts <- userPointsFor actId <$> requireAuth
isLate <- isPast actDeadline
let award = if isLate then 0 else 4
newPts = min actMaxPoints (origPts + award)
deltaPts = newPts - origPts
when (deltaPts > 0) $
updateAuth_
("u1DecodeTree points := " <> show newPts)
(userScores . at actId ?~ newPts)
deleteSession actId
addMessage
"success"
[shamlet|
$if isLate && (newPts < actMaxPoints)
You got it! However, the deadline has passed, so no further points
can be awarded.
$elseif deltaPts == 0
Nice! You already have the maximum points for this activity,
but feel free to continue practicing.
$else
Great — you earned #{plural deltaPts "point"}!
|]
when (not correct) $ do
addMessage
"danger"
[shamlet|
Sorry, that's not correct. Please try again!
|]
defaultLayout $ do
setTitle "Decode bits representing text"
[whamlet|
<div .col-12>
^{pointsBadge u1DecodeTree}
<p>
These bits represent a single English word, encoded using the tree
below. What is the word?
<p .col-md-6 .text-monospace style="font-size:140%">
#{bits}
$if correct
<div .col-md-12>
<p .text-monospace style="font-size:140%">
#{w}
<a .mb-2 .btn .btn-secondary href=@{U1DecodeTreeR}>
Try another problem
$else
<form .col-md-6 method=post enctype=#{enctype}>
^{widget}
<input .mt-2 .btn .btn-primary type=submit value="Submit">
<div .col-12>
<img src=@{PageAssetR (AssetId "quiztree.svg")}>
|]
wordIsEncodable :: TestTree
wordIsEncodable =
testCase "All words can be encoded by tree" $
forM_ treeWords \w ->
assertBool (convertString w) (isJust (wordToBits w))
sameEncoding :: TestTree
sameEncoding =
testProperty "wordToBits / reqWordToBits correspond"
$ property
$ do
w <-
forAll $
mkTreeWord
<$> Gen.text
(Range.linear 0 10)
(Gen.element ('!' : map CI.original (Map.keys charEnc)))
maybe discard (=== reqWordToBits w) (wordToBits w)
codesUnambiguous :: TestTree
codesUnambiguous =
testCase "Codes are unambiguous"
$ forM_ pairs
$ \(b1, b2) ->
assertBool
("Ambiguity between " <> show (b1, b2))
(b1 == b2 || not (Text.isPrefixOf b1 b2))
where
codes = Map.elems charEnc
pairs = [(b1, b2) | b1 <- codes, b2 <- codes]
quiz2Tests :: TestTree
quiz2Tests =
testGroup
"App.Quiz2"
[wordIsEncodable, codesUnambiguous, sameEncoding]
......@@ -39,6 +39,7 @@ executable:
- tagged
- tasty
- tasty-hedgehog
- tasty-hunit
- text
- time
- transformers
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment