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

auto-grading and reporting for A1

parent 48bd0a89
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module App.Activity
( Activity (..),
Pointage (..),
( Activity,
actId,
actMaxPoints,
actDeadline,
Pointage,
pointsAdjust,
pointsRemark,
pointageSum,
clampPoints,
genPointage,
makeActivity,
pointsBadge,
submittedPointsBadge,
isPast,
isLate,
howLate,
lateFactor,
userPointsFor,
dueBadge,
formatDay,
......@@ -24,14 +35,16 @@ module App.Activity
)
where
import App.DefaultInstances ()
import App.Foundation
import App.Prelude
import App.TestUtils
import App.User
import Control.Lens (non)
import Control.Lens (makeLenses, non)
import Data.Aeson as Js
import qualified Data.Aeson.Types as Js
import qualified Data.Text as Text
import Data.Time.Clock (NominalDiffTime, diffUTCTime)
import Data.Time.Format
import Data.Time.LocalTime
import Hedgehog hiding (check)
......@@ -41,49 +54,75 @@ import Test.Tasty
data Activity
= Activity
{ actId :: ActivityId,
actDeadline :: ZonedTime,
actMaxPoints :: Points
{ _actId :: ActivityId,
_actDeadline :: ZonedTime,
_actMaxPoints :: Points
}
deriving (Show)
makeLenses ''Activity
instance Default Activity where
def = Activity mempty def def
makeActivity :: ActivityId -> Points -> String -> Activity
makeActivity actId actMaxPoints timeStr =
Activity {..}
makeActivity aid pts timeStr =
def
& actId .~ aid
& actMaxPoints .~ pts
& actDeadline .~ parseZTime timeStr
parseZTime :: ParseTime t => String -> t
parseZTime =
parseTimeOrError
False -- Allow leading spaces
defaultTimeLocale
"%F %H:%M %Z"
userPointsFor :: Activity -> UserEntity -> Points
userPointsFor act =
view $ _2 . userScores . at (act ^. actId) . non 0
clampPoints :: Activity -> Int -> Points
clampPoints a i =
if i > fromIntegral p
then p
else
if i < 0
then 0
else fromIntegral i
where
actDeadline =
parseTimeOrError
False -- Allow leading spaces
defaultTimeLocale
"%F %H:%M %Z"
timeStr
userPointsFor :: ActivityId -> UserEntity -> Points
userPointsFor aid =
view $ _2 . userScores . at aid . non 0
p = a ^. actMaxPoints
pointsBadge :: Activity -> Widget
pointsBadge Activity {..} = do
pts <- userPointsFor actId <$> requireAuth
let cls = if pts == actMaxPoints then "success" else "primary" :: Text
pointsBadge act = do
pts <- userPointsFor act <$> requireAuth
let maxp = act ^. actMaxPoints
cls :: Text
cls = if pts == maxp then "success" else "primary"
[whamlet|
<span class="badge badge-#{cls}">
#{tshow pts}/#{tshow actMaxPoints} points
#{tshow pts}/#{tshow maxp} points
|]
data Pointage
= Pointage
{ pointsAdjust :: Int,
pointsRemark :: Text
{ _pointsAdjust :: Int,
_pointsRemark :: Text
}
deriving (Eq, Show)
makeLenses ''Pointage
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.String t) =
pure $ def & pointsRemark .~ t
parseJSON v@(Js.Number _) =
flip (pointsAdjust .~) def <$> parseJSON v
parseJSON (Js.Object o) =
Pointage
<$> o .:? "points" .!= def
......@@ -110,26 +149,30 @@ genRemark =
(Range.linear 1 10)
(Gen.text (Range.linear 1 6) Gen.alphaNum)
pointageSum :: [Pointage] -> Int
pointageSum = sum . map (view pointsAdjust)
pointageItem :: Pointage -> Widget
pointageItem Pointage {..} =
pointageItem p = do
let adj = p ^. pointsAdjust
[whamlet|
$case compare pointsAdjust 0
$case compare adj 0
$of EQ
$of GT
<span .badge .badge-success>+#{pointsAdjust}
<span .badge .badge-success>+#{adj}
$of LT
<span .badge .badge-danger>–#{abs pointsAdjust}
#{pointsRemark}
<span .badge .badge-danger>–#{abs adj}
#{p ^. pointsRemark}
|]
submittedPointsBadge :: Activity -> (UserId -> WidgetFor App Bool) -> Widget
submittedPointsBadge Activity {..} checkSubmitted = do
submittedPointsBadge act checkSubmitted = do
(uid, user) <- requireAuth
submitted <- checkSubmitted uid
let outOf = tshow actMaxPoints
let outOf = tshow (act ^. actMaxPoints)
[whamlet|
$if submitted
$maybe pts <- user ^. (userScores . at actId)
$maybe pts <- user ^. (userScores . at (act ^. actId))
<span class="badge badge-success">
#{tshow pts}/#{outOf} points
$nothing
......@@ -140,21 +183,39 @@ $else
0/#{outOf} points
|]
isPast :: MonadIO m => ZonedTime -> m Bool
isPast zt =
(> zonedTimeToUTC zt) <$> getCurrentTime
isLate :: MonadIO m => Activity -> m Bool
isLate act =
(> zonedTimeToUTC (act ^. actDeadline)) <$> getCurrentTime
howLate :: Activity -> Maybe LocalTime -> NominalDiffTime
howLate _ Nothing = 0
howLate act (Just t) =
max 0 $
zonedTimeToUTC (ZonedTime t (zonedTimeZone (act ^. actDeadline)))
`diffUTCTime` zonedTimeToUTC (act ^. actDeadline)
lateFactor :: NominalDiffTime -> Float
lateFactor sec =
min 1 ((18 - log2 (realToFrac sec / 86400)) / 20)
formatDay :: FormatTime t => t -> String
formatDay =
formatTime defaultTimeLocale "%a %e %b"
dueBadge :: ZonedTime -> Widget
dueBadge deadline = do
isLate <- isPast deadline
let cls = if isLate then "danger" else "info" :: Text
formatDeadline :: Activity -> String
formatDeadline =
formatDay . view actDeadline
dueBadge :: Activity -> Widget
dueBadge act = do
late <- isLate act
[whamlet|
<span class="badge badge-#{cls}">
due #{formatDay deadline}
$if late
<span class="badge badge-danger">
due #{formatDeadline act}
$else
<span class="badge badge-info">
due #{formatDeadline act}
|]
maybeFormSuccess :: FormResult a -> Maybe a
......
......@@ -8,6 +8,7 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
......@@ -23,6 +24,10 @@ module App.Assn1
A1Answers (..),
A1AnswersKey (..),
A1GivenKey (..),
a1human,
a1bot,
a1submitted,
feedbackPoints,
)
where
......@@ -35,12 +40,12 @@ import App.TestUtils
import App.User
import App.YamlStore
import Conduit
import Control.Lens (makeLenses)
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 Data.Time.LocalTime
import GHC.Generics
import Hedgehog hiding (check)
import qualified Hedgehog.Gen as Gen
......@@ -68,10 +73,7 @@ instance Key A1GivenKey where
instance YamlEntity A1GivenKey (Map UserId Text)
data A1AnswersKey
= A1AnswersKey
{ a1User :: UserId
}
data A1AnswersKey = A1AnswersKey UserId
deriving (Eq, Ord, Show)
instance Key A1AnswersKey where
......@@ -109,11 +111,13 @@ instance Key A1ImageKey where
data A1Feedback
= A1Feedback
{ a1Submitted :: Maybe Day,
a1Human :: [Pointage],
a1Bot :: [Pointage]
{ _a1submitted :: Maybe LocalTime,
_a1human :: [Pointage],
_a1bot :: [Pointage]
}
deriving (Eq, Show, Generic)
deriving (Eq, Show)
makeLenses ''A1Feedback
instance FromJSON A1Feedback where
parseJSON = Js.withObject "A1Feedback" \o ->
......@@ -123,7 +127,12 @@ instance FromJSON A1Feedback where
<*> o .:? "bot" .!= def
instance ToJSON A1Feedback where
toJSON = genericToJSON a1JsonOpts
toJSON a =
Js.object
[ "submitted" .= (a ^. a1submitted),
"human" .= (a ^. a1human),
"bot" .= (a ^. a1bot)
]
instance Default A1Feedback where
def = A1Feedback def def def
......@@ -131,10 +140,17 @@ instance Default A1Feedback where
genFeedback :: Gen A1Feedback
genFeedback =
A1Feedback
<$> Gen.maybe genDay
<$> Gen.maybe genLocalTime
<*> Gen.list (Range.linear 0 5) genPointage
<*> Gen.list (Range.linear 0 5) genPointage
feedbackPoints :: A1Feedback -> Points
feedbackPoints fb =
clampPoints assn1 $
fromIntegral (assn1 ^. actMaxPoints)
+ pointageSum (fb ^. a1human)
+ pointageSum (fb ^. a1bot)
data A1Answers
= A1Answers
{ a1q1 :: Int,
......@@ -266,7 +282,7 @@ handleU1HuffAssnR = do
<div .col-12>
<p>
^{a1SubmittedBadge}
^{dueBadge (actDeadline assn1)}
^{dueBadge assn1}
#{preEscapedToMarkup body}
......@@ -292,25 +308,26 @@ handleU1HuffAssnR = do
$maybe fb <- feedback
<h3>Assignment feedback
<ul>
$forall p <- a1Human fb
$forall p <- fb ^. a1bot
<li>
^{pointageItem p}
$forall p <- a1Bot fb
$forall p <- fb ^. a1human
<li>
^{pointageItem p}
$nothing
<input .btn .btn-primary type=submit :disabled:disabled value="Save">
<h3>Upload images
$if not disabled
<h3>Upload images
<p>
In this section, you can upload photos of your tree and any other work,
such as your encoding as bits and frequency analysis. Showing your work
can improve your score!
<p>
In this section, you can upload photos of your tree and any other work,
such as your encoding as bits and frequency analysis. Showing your work
can improve your score!
<form .mb-4 method=post action=@{U1HuffUploadR} enctype=#{encfile}>
^{upfile}
<input .btn .btn-primary .mt-2 type=submit value="Upload">
<form .mb-4 method=post action=@{U1HuffUploadR} enctype=#{encfile}>
^{upfile}
<input .btn .btn-primary .mt-2 type=submit value="Upload">
<p>#{plural (length images) "file"} submitted
......@@ -321,7 +338,8 @@ $forall A1ImageKey _ image <- images
$else
<a href=@{U1HuffViewR image}>📁
<br>
<a .btn .btn-danger .mt-1 href=@{U1HuffDeleteR image}>Delete
$if not disabled
<a .btn .btn-danger .mt-1 href=@{U1HuffDeleteR image}>Delete
#{image}
|]
......
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module App.Assn1Grade
( main,
)
where
import App.Activity
import App.Assn1
import App.ByteStoreWorkDir
import App.Prelude
......@@ -104,9 +105,6 @@ bitsForChar h goal =
q1DistinctChars :: Freqs -> Int
q1DistinctChars = Map.size
log2 :: Float -> Float
log2 x = log x / log 2
q2FixedBitsPerChar :: Freqs -> Int
q2FixedBitsPerChar =
ceiling . log2 . fromIntegral . q1DistinctChars
......@@ -154,19 +152,21 @@ 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 :: (ConvertibleStrings s Text, MonadWriter [Pointage] m) => Int -> s -> m ()
report points template =
tell [(points, fixText template)]
tell [def & pointsAdjust .~ points & pointsRemark .~ fixText template]
pow2 :: Int -> Integer
pow2 = (2 ^)
offByOne :: Int -> Int
offByOne 0 = 0
offByOne 1 = -2
offByOne _ = -3
offBy :: Int -> Int -> Int
offBy limit delta =
case compare delta limit of
LT -> 0
EQ -> -2
GT -> -3
autoCheck :: A1Answers -> Text -> [(Int, Text)]
autoCheck :: A1Answers -> Text -> [Pointage]
autoCheck A1Answers {..} phrase = execWriter $ do
let fs = freqs phrase
q = startQueue fs
......@@ -198,7 +198,7 @@ Q2: #{a1q2} bits per char is correct (it allows
|]
(LT, k) ->
report
(offByOne k)
(offBy 1 k)
[stext|
Q2: #{a1q2} bits per char is too small: it allows
only 2^#{a1q2} = #{tshow(pow2 a1q2)} chars but we
......@@ -207,7 +207,7 @@ per char.
|]
(GT, k) ->
report
(offByOne k)
(offBy 1 k)
[stext|
Q2: #{a1q2} bits per char is larger than needed:
it allows 2^#{a1q2} = #{tshow(pow2 a1q2)} chars
......@@ -252,12 +252,14 @@ but I think it should be #{Text.intercalate " or " (map show (Set.toList expect4
[stext|
Q5: Correct, longest character is encoded as #{a1q5} bits
|]
(_, k) ->
(_, k) -> do
let deduct = offBy 2 k
mesg = if deduct == 0 then "Close enough!" else "" :: Text
report
(offByOne k)
deduct
[stext|
Q5: You said longest character uses #{a1q5} bits, but I
think it should be #{expect5}
Q5: You said longest character uses #{a1q5} bits, but it’s
#{expect5} bits in my tree. #{mesg}
|]
---------------------------------------------
case a1q6 @?~= expect6 of
......@@ -284,19 +286,39 @@ For reference, the tree I produced is described by the
S-expression #{sexpr h}
|]
autoCheckStudent :: ByteStoreRO m => UserId -> m ()
autoCheckStudent :: ByteStoreRW m => UserId -> m ()
autoCheckStudent uid = do
phrase <- (^. at uid . non "") <$> loadY A1GivenKey
let k = A1AnswersKey uid
putStrLn (userIdText uid)
loadMaybeY (A1AnswersKey uid) >>= \case
loadMaybeY k >>= \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 ()
let fb0 = a1feedback ans ^. non def
lateSec = howLate assn1 (fb0 ^. a1submitted)
lateF = lateFactor lateSec
lateMsgs =
if lateF > 0.99
then []
else
[ def & pointsRemark
.~ "Submitted " <> tshowDP @Float 1 (realToFrac lateSec / 86400)
<> " days late, so late factor is "
<> tshowDP 2 lateF
]
msgs = autoCheck ans phrase <> lateMsgs
fb = fb0 & a1bot .~ msgs
rawScore = feedbackPoints fb
score = ceiling (lateF * fromIntegral rawScore)
forM_ msgs \pt ->
putStrLn $ " " <> show (pt ^. pointsAdjust) <> ": " <> pt ^. pointsRemark
putStrLn $ " " <> tshow score <> "/" <> show (assn1 ^. actMaxPoints)
putStrLn $ " LATENESS " <> tshow lateSec <> " " <> tshow lateF
saveY k ans {a1feedback = Just fb}
updatePureY_ uid (userScores . at (assn1 ^. actId) ?~ score)
autoCheckAllStudents :: ByteStoreRW m => m ()
autoCheckAllStudents =
listKeys >>= mapM_ autoCheckStudent
......
......@@ -261,7 +261,7 @@ textarea {
<form .col-12 method=post enctype=application/x-www-form-urlencoded>
<p>
^{a2SubmittedBadge}
^{dueBadge (actDeadline assn2)}
^{dueBadge assn2}
<p>
For this assignment, you will construct digital images by composing
hexadecimal numbers to control separate red, green, and blue images
......
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module App.DefaultInstances
(
)
where
import App.Prelude
import Data.Time.Calendar (Day (..))
import Data.Time.Clock (UTCTime (..))
import Data.Time.LocalTime
instance Default Day where
def = ModifiedJulianDay def
instance Default TimeOfDay where
def = midday
instance Default LocalTime where
def = LocalTime def def
instance Default TimeZone where
def = utc
instance Default ZonedTime where
def = ZonedTime def def
instance Default UTCTime where
def = zonedTimeToUTC def
......@@ -132,7 +132,7 @@ unit1 = do
<a href=@{U1ToBaseR}>
Convert to base
^{pointsBadge u1ToBase}
^{dueBadge (actDeadline u1ToBase)}
^{dueBadge u1ToBase}
<li .list-group-item>
Notes:
<a href=@{PageDocR "notes120-binary.org"}>
......@@ -150,13 +150,13 @@ unit1 = do
<a href=@{U1HuffAssnR}>
Text compression
^{a1SubmittedBadge}
^{dueBadge (actDeadline assn1)}
^{dueBadge assn1}
<li .list-group-item>
Check-in:
<a href=@{U1DecodeTreeR}>
Decode text bits
^{pointsBadge u1DecodeTree}
^{dueBadge (actDeadline u1DecodeTree)}
^{dueBadge u1DecodeTree}
<li .list-group-item>
Notes:
<a href=@{PageDocR "notes140-images.org"}>
......@@ -166,7 +166,7 @@ unit1 = do
<a href=@{U1HexAssnR}>
Hexadecimal images
^{a2SubmittedBadge}
^{dueBadge (actDeadline assn2)}
^{dueBadge assn2}
|]
getHomeR :: Handler Html
......
......@@ -25,11 +25,13 @@ module App.Prelude
Integral (..),
Float,
(^),
realToFrac,
fromIntegral,
log,
ceiling,
round,
sum,
log2,
(/),
-- Maybe, Either
Maybe (..),
......@@ -71,6 +73,7 @@ module App.Prelude
showsPrec,
show,
tshow,
tshowDP,
Read (readPrec),
readMaybe,
lowerFirst,
......@@ -174,6 +177,7 @@ import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Data.Time.Clock as Clock
import Data.Word (Word, Word16)
import qualified Numeric.Extra as Nex
import System.FilePath
import System.IO.Error (IOError, doesNotExistErrorType, isDoesNotExistError, mkIOError)
import qualified Text.Read as Read
......@@ -269,3 +273,10 @@ plural k noun = tshow k <> " " <> noun <> "s"
identity :: a -> a
identity x = x
log2 :: Float -> Float
log2 x = log x / log 2
tshowDP :: RealFloat a => Int -> a -> T.Text
tshowDP n x =
convertString (Nex.showDP n x)