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

Work toward auto-grading of A1

parent 4223262e
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
......@@ -7,6 +8,8 @@
module App.Activity
( Activity (..),
Pointage (..),
genPointage,
makeActivity,
pointsBadge,
submittedPointsBadge,
......@@ -16,15 +19,25 @@ module App.Activity
formatDay,
maybeFormSuccess,
onFormSuccess,
pointageItem,
activityTests,
)
where
import App.Foundation
import App.Prelude
import App.TestUtils
import App.User
import Control.Lens (non)
import Data.Aeson as Js
import qualified Data.Aeson.Types as Js
import qualified Data.Text as Text
import Data.Time.Format
import Data.Time.LocalTime
import Hedgehog hiding (check)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Tasty
data Activity
= Activity
......@@ -57,6 +70,58 @@ pointsBadge Activity {..} = do
#{tshow pts}/#{tshow actMaxPoints} points
|]
data Pointage
= Pointage
{ pointsAdjust :: Int,
pointsRemark :: Text
}
deriving (Eq, Show)
instance Default Pointage where
def = Pointage def mempty
instance FromJSON Pointage where
parseJSON Js.Null = pure def
parseJSON (Js.String t) = pure def {pointsRemark = t}
parseJSON (Js.Number k) = parseJSON (Js.Number k) <&> \z -> def {pointsAdjust = z}
parseJSON (Js.Object o) =
Pointage
<$> o .:? "points" .!= def
<*> o .:? "remark" .!= mempty
parseJSON v = Js.typeMismatch "Pointage" v
instance ToJSON Pointage where
toJSON = \case
Pointage 0 "" -> Js.Null
Pointage 0 t -> Js.String t
Pointage k "" -> Js.Number (fromIntegral k)
Pointage k t -> Js.object ["points" .= k, "remark" .= t]
genPointage :: Gen Pointage
genPointage =
Pointage
<$> Gen.int (Range.linearFrom 0 (-10) 10)
<*> genRemark
genRemark :: Gen Text
genRemark =
Text.unwords
<$> Gen.list
(Range.linear 1 10)
(Gen.text (Range.linear 1 6) Gen.alphaNum)
pointageItem :: Pointage -> Widget
pointageItem Pointage {..} =
[whamlet|
$case compare pointsAdjust 0
$of EQ
$of GT
<span .badge .badge-success>+#{pointsAdjust}
$of LT
<span .badge .badge-danger>–#{abs pointsAdjust}
#{pointsRemark}
|]
submittedPointsBadge :: Activity -> (UserId -> WidgetFor App Bool) -> Widget
submittedPointsBadge Activity {..} checkSubmitted = do
(uid, user) <- requireAuth
......@@ -98,3 +163,12 @@ maybeFormSuccess _ = Nothing
onFormSuccess :: Monad m => FormResult a -> (a -> m ()) -> m ()
onFormSuccess r m = forM_ (maybeFormSuccess r) m
activityTests :: TestTree
activityTests =
testGroup
"App.Activity"
[ testGroup
"Pointage"
[jsonRoundTrip genPointage]
]
......@@ -7,6 +7,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
......@@ -19,6 +20,9 @@ module App.Assn1
assn1,
a1SubmittedBadge,
assn1Tests,
A1Answers (..),
A1AnswersKey (..),
A1GivenKey (..),
)
where
......@@ -32,9 +36,11 @@ import App.User
import App.YamlStore
import Conduit
import Data.Aeson as Js
import qualified Data.Aeson.Types as Js
import qualified Data.ByteString as BS
import Data.List (elem)
import qualified Data.Text as Text
import Data.Time.Calendar
import GHC.Generics
import Hedgehog hiding (check)
import qualified Hedgehog.Gen as Gen
......@@ -101,6 +107,34 @@ instance Key A1ImageKey where
guard (c == '-')
return $ A1ImageKey uid img
data A1Feedback
= A1Feedback
{ a1Submitted :: Maybe Day,
a1Human :: [Pointage],
a1Bot :: [Pointage]
}
deriving (Eq, Show, Generic)
instance FromJSON A1Feedback where
parseJSON = Js.withObject "A1Feedback" \o ->
A1Feedback
<$> o .:? "submitted" .!= def
<*> o .:? "human" .!= def
<*> o .:? "bot" .!= def
instance ToJSON A1Feedback where
toJSON = genericToJSON a1JsonOpts
instance Default A1Feedback where
def = A1Feedback def def def
genFeedback :: Gen A1Feedback
genFeedback =
A1Feedback
<$> Gen.maybe genDay
<*> Gen.list (Range.linear 0 5) genPointage
<*> Gen.list (Range.linear 0 5) genPointage
data A1Answers
= A1Answers
{ a1q1 :: Int,
......@@ -109,7 +143,8 @@ data A1Answers
a1q4 :: Int,
a1q5 :: Int,
a1q6 :: Int,
a1q7 :: Maybe Text
a1q7 :: Maybe Text,
a1feedback :: Maybe A1Feedback
}
deriving (Eq, Show, Generic)
......@@ -142,44 +177,53 @@ charField =
| Text.null txt = '?'
| otherwise = Text.head txt
answerForm :: AppHandler m => Maybe A1Answers -> AForm m A1Answers
answerForm :: forall m. AppHandler m => Maybe A1Answers -> AForm m A1Answers
answerForm prev =
A1Answers
<$> areq
intField
"How many distinct characters does your phrase contain? \
\(It should be the same as the number of leaves in your tree.)"
(a1q1 <$> prev)
<*> areq
intField
"If we were using a fixed-width encoding, how many bits per \
\character would you need to represent just those characters?"
(a1q2 <$> prev)
<*> areq
charField
"What is the most frequent character in your phrase? If there is \
\tie, then just choose one. If it's the space character, then enter \
\it as an underscore (shift-hyphen)."
(a1q3 <$> prev)
<*> areq
intField
"In your encoding tree, how many bits used for that most frequent \
\character (in the previous question)."
(a1q4 <$> prev)
<*> areq
intField
"What is the most number of bits used to encode any character in \
\your phrase?"
(a1q5 <$> prev)
<*> areq
intField
"How many bits does your encoding use to encode the entire phrase \
\you were given?"
(a1q6 <$> prev)
<*> aopt
(convertField unTextarea Textarea textareaField)
"You may use this space to include any comments about your solution."
(a1q7 <$> prev)
let disabled = isJust (a1feedback =<< prev)
setAttrs fs =
if disabled
then fs {fsAttrs = [("disabled", "disabled")]}
else fs
areq_ :: Field m a -> FieldSettings App -> Maybe a -> AForm m a
areq_ f s p = areq f (setAttrs s) p
aopt_ f s p = aopt f (setAttrs s) p
in A1Answers
<$> areq_
intField
"How many distinct characters does your phrase contain? \
\(It should be the same as the number of leaves in your tree.)"
(a1q1 <$> prev)
<*> areq_
intField
"If we were using a fixed-width encoding, how many bits per \
\character would you need to represent just those characters?"
(a1q2 <$> prev)
<*> areq_
charField
"What is the most frequent character in your phrase? If there is \
\tie, then just choose one. If it's the space character, then enter \
\it as an underscore (shift-hyphen)."
(a1q3 <$> prev)
<*> areq_
intField
"In your encoding tree, how many bits used for that most frequent \
\character (in the previous question)."
(a1q4 <$> prev)
<*> areq_
intField
"What is the most number of bits used to encode any character in \
\your phrase?"
(a1q5 <$> prev)
<*> areq_
intField
"How many bits does your encoding use to encode the entire phrase \
\you were given?"
(a1q6 <$> prev)
<*> aopt_
(convertField unTextarea Textarea textareaField)
"You may use this space to include any comments about your solution."
(a1q7 <$> prev)
<*> pure (a1feedback =<< prev)
a1SubmittedBadge :: Widget
a1SubmittedBadge =
......@@ -190,6 +234,8 @@ handleU1HuffAssnR :: Handler Html
handleU1HuffAssnR = do
uid <- requireAuthId
submitOpt <- runRo $ loadMaybeY $ A1AnswersKey uid
let feedback = a1feedback =<< submitOpt
disabled = isJust feedback
((result, widget), enctype) <- runFormPost $ renderTable $ answerForm submitOpt
onFormSuccess result \sub -> do
runRw $ do
......@@ -243,7 +289,17 @@ handleU1HuffAssnR = do
<form .mb-4 method=post enctype=#{enctype}>
<table .table>
^{widget}
<input .btn .btn-primary type=submit value="Save">
$maybe fb <- feedback
<h3>Assignment feedback
<ul>
$forall p <- a1Human fb
<li>
^{pointageItem p}
$forall p <- a1Bot fb
<li>
^{pointageItem p}
$nothing
<input .btn .btn-primary type=submit :disabled:disabled value="Save">
<h3>Upload images
......@@ -275,7 +331,10 @@ assn1Tests =
"App.Assn1"
[ testGroup
"A1ImageKey"
[storeKeyRoundTrip genA1ImageKey]
[storeKeyRoundTrip genA1ImageKey],
testGroup
"A1Feedback"
[jsonRoundTrip genFeedback]
]
getU1HuffDeleteR :: Text -> Handler ()
......
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module App.Assn1Grade
( main,
)
where
import App.Assn1
import App.ByteStoreWorkDir
import App.Prelude
import App.User
import App.YamlStore
import Control.Lens (non)
import Control.Monad.Trans.Resource
import Control.Monad.Writer
import Data.List (elem)
import Data.List (foldr)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import Text.Shakespeare.Text (stext)
type Count = Word
type Rank = Int
type Freqs = Map Char (Count, Rank)
mergeCR :: (Count, Rank) -> (Count, Rank) -> (Count, Rank)
mergeCR (j, r) (k, _) = (j + k, r)
addChar :: (Rank, Char) -> Freqs -> Freqs
addChar (r, ch) =
Map.insertWith mergeCR ch (1, r)
freqs :: Text -> Freqs
freqs =
foldr addChar mempty . zip [0 ..] . Text.unpack
data Huff
= Huff
{ huffCount :: Count,
huffRank :: Rank, -- Used to break ties in count
huffTree :: Tree
}
deriving (Show, Eq, Ord)
data Tree
= Leaf Char
| Branch Huff Huff
deriving (Show, Eq, Ord)
sexpr :: Huff -> String
sexpr h =
case huffTree h of
Leaf c -> [c]
Branch h1 h2 -> "(" <> sexpr h1 <> " " <> sexpr h2 <> ")"
type Queue = Set Huff
startQueue :: Freqs -> Queue
startQueue =
Set.fromList . map each . Map.toList
where
each (ch, (k, r)) = Huff k r (Leaf ch)
huffStep :: Queue -> Queue
huffStep q0 =
let (h1, q1) = Set.deleteFindMin q0
(h2, q2) = Set.deleteFindMin q1
in Set.insert
( Huff
(huffCount h1 + huffCount h2)
(min (huffRank h1) (huffRank h2))
(Branch h1 h2)
)
q2
huffIter :: Queue -> Huff
huffIter q =
if Set.size q == 1
then Set.findMin q
else huffIter (huffStep q)
type Bits = String
bitsForChar :: Huff -> Char -> Maybe Bits
bitsForChar h goal =
case huffTree h of
Leaf c
| c == goal -> Just []
| otherwise -> Nothing
Branch l r ->
('0' :) <$> bitsForChar l goal
<|> ('1' :) <$> bitsForChar r goal
q1DistinctChars :: Freqs -> Int
q1DistinctChars = Map.size
log2 :: Float -> Float
log2 x = log x / log 2
q2FixedBitsPerChar :: Freqs -> Int
q2FixedBitsPerChar =
ceiling . log2 . fromIntegral . q1DistinctChars
extremaChars :: (Queue -> Huff) -> Queue -> String
extremaChars extr q =
let hex = extr q
sameCount h = huffCount h == huffCount hex
getChar h =
case huffTree h of
Leaf c -> Just c
_ -> Nothing
in mapMaybe getChar $ filter sameCount $ Set.toList q
q3MostFreqChars :: Queue -> String
q3MostFreqChars = extremaChars Set.findMax
leastFreqChars :: Queue -> String
leastFreqChars = extremaChars Set.findMin
numBitsForChars :: Huff -> String -> Set Int
numBitsForChars h =
Set.fromList . map length . mapMaybe (bitsForChar h)
q4NumBitsForMostFreq :: Queue -> Huff -> Set Int
q4NumBitsForMostFreq q h =
numBitsForChars h (q3MostFreqChars q)
q5MostBits :: Queue -> Huff -> Int
q5MostBits q h =
maximum $ numBitsForChars h (leastFreqChars q)
q6BitsForPhrase :: Huff -> Text -> Int
q6BitsForPhrase h =
sum . map length . mapMaybe (bitsForChar h) . Text.unpack
(@?~=) :: (Ord a, Num a) => a -> a -> (Ordering, a)
actual @?~= expected =
case compare actual expected of
EQ -> (EQ, 0)
LT -> (LT, expected - actual)
GT -> (GT, actual - expected)
fixText :: ConvertibleStrings s Text => s -> Text
fixText =
Text.unwords . Text.lines . Text.strip . convertString
report :: (ConvertibleStrings s Text, MonadWriter [(Int, Text)] m) => Int -> s -> m ()
report points template =
tell [(points, fixText template)]
pow2 :: Int -> Integer
pow2 = (2 ^)
offByOne :: Int -> Int
offByOne 0 = 0
offByOne 1 = -2
offByOne _ = -3
autoCheck :: A1Answers -> Text -> [(Int, Text)]
autoCheck A1Answers {..} phrase = execWriter $ do
let fs = freqs phrase
q = startQueue fs
h = huffIter q
expect1 = q1DistinctChars fs
expect2 = q2FixedBitsPerChar fs
expect3 = q3MostFreqChars q
expect4 = q4NumBitsForMostFreq q h
expect5 = q5MostBits q h
expect6 = q6BitsForPhrase h phrase
---------------------------------------------
if a1q1 == expect1
then report 0 [stext|Q1: #{a1q1} distinct chars is correct|]
else
report
(-3)
[stext|
Q1: You said #{a1q1} distinct chars, but there are
actually #{expect1}: “#{Map.keys fs}”
|]
---------------------------------------------
case a1q2 @?~= expect2 of
(EQ, _) ->
report
0
[stext|
Q2: #{a1q2} bits per char is correct (it allows
2^#{a1q2} = #{tshow(pow2 a1q2)} chars)
|]
(LT, k) ->
report
(offByOne k)
[stext|
Q2: #{a1q2} bits per char is too small: it allows
only 2^#{a1q2} = #{tshow(pow2 a1q2)} chars but we
have #{expect1}. Correct answer is #{expect2} bits
per char.
|]
(GT, k) ->
report
(offByOne k)
[stext|
Q2: #{a1q2} bits per char is larger than needed:
it allows 2^#{a1q2} = #{tshow(pow2 a1q2)} chars
and we only need #{expect1}. Correct answer is
#{expect2} bits per char.
|]
---------------------------------------------
if a1q3 `elem` expect3
then
report
0
[stext|
Q3: Correct, ‘#{Text.singleton a1q3}’ is one of the most frequent characters.
|]
else
report
(-3)
[stext|
Q3: You said ‘#{Text.singleton a1q3}’ is a most frequent character,
but “#{expect3}” appears more frequently.
|]
---------------------------------------------
if not (Set.disjoint expect4 (Set.fromList [a1q4, a1q4 + 1, a1q4 -1]))
then
report
0
[stext|
Q4: Okay, ‘#{Text.singleton a1q3}’ can be encoded as #{a1q4} bits.
|]
else
report
(-3)
[stext|
Q4: You said ‘#{Text.singleton a1q3}’ can be encoded as #{a1q4} bits,
but I think it should be #{Text.intercalate " or " (map show (Set.toList expect4))}
|]
---------------------------------------------
case a1q5 @?~= expect5 of
(EQ, _) ->
report
0
[stext|
Q5: Correct, longest character is encoded as #{a1q5} bits
|]
(_, k) ->
report
(offByOne k)
[stext|
Q5: You said longest character uses #{a1q5} bits, but I
think it should be #{expect5}
|]
---------------------------------------------
case a1q6 @?~= expect6 of
(EQ, _) ->
report
0
[stext|
Q6: Spot on! We both encoded the phrase using exactly #{a1q6} bits
|]
(_, k) -> do
let delta = round (fromIntegral expect6 / 10 :: Float)
mesg = if k <= delta then "Pretty close!" else "" :: Text
report
(- (min 5 (k `div` delta)))
[stext|
Q6: You reported the entire phrase as using #{a1q6} bits, but my
tree does it with #{expect6} bits. #{mesg}
|]
---------------------------------------------
report
0
[stext|
For reference, the tree I produced is described by the
S-expression #{sexpr h}
|]
autoCheckStudent :: ByteStoreRO m => UserId -> m ()
autoCheckStudent uid = do
phrase <- (^. at uid . non "") <$> loadY A1GivenKey
putStrLn (userIdText uid)
loadMaybeY (A1AnswersKey uid) >>= \case
Nothing ->
putStrLn @Text " not submitted"
Just ans -> do
let msgs = autoCheck ans phrase
forM_ msgs \(pts, msg) ->
putStrLn (" " <> show pts <> ": " <> msg)
autoCheckAllStudents :: ByteStoreRO m => m ()
autoCheckAllStudents =
listKeys >>= mapM_ autoCheckStudent
main :: IO ()
main =
runResourceT $ runWorkDir "data" autoCheckAllStudents
......@@ -14,6 +14,7 @@ module App.Main
)
where
import App.Activity
import App.Asset
import App.Assn1
import App.Assn2
......@@ -171,5 +172,6 @@ test =
quiz1Tests,
assn1Tests,
quiz2Tests,
assn2Tests
assn2Tests,
activityTests
]
......@@ -12,6 +12,7 @@ module App.Prelude
Enum (..),
(||),