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

Practice widget for converting from base

parent f7ad3769
......@@ -87,18 +87,19 @@ mkYesodData
"App"
[parseRoutes|
/ HomeR GET
/pandoc.css PandocStyleR GET
/favicon.ico FaviconR GET
/cs101.ics Schedule101R GET
/ics/#Text ScheduleR GET
/me ProfileR GET POST
/page/#PageId PageDocR GET
!/page/#AssetId PageAssetR GET
/post/#PostId PostR GET
/submit/#Text SubmitR GET POST
/cache/meta MetaCacheR GET DELETE
/auth AuthR Auth getAuth
/ HomeR GET
/pandoc.css PandocStyleR GET
/favicon.ico FaviconR GET
/cs101.ics Schedule101R GET
/ics/#Text ScheduleR GET
/me ProfileR GET POST
/unit/1/from-base U1FromBaseR GET POST
/page/#PageId PageDocR GET
!/page/#AssetId PageAssetR GET
/post/#PostId PostR GET
/submit/#Text SubmitR GET POST
/cache/meta MetaCacheR GET DELETE
/auth AuthR Auth getAuth
|]
......
......@@ -23,6 +23,7 @@ import App.Page
import App.Post
import App.Prelude
import App.Profile
import App.Quiz1
import App.Schedule
import App.User
import App.YamlStore
......
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
......@@ -28,31 +29,39 @@ formatDay :: Day -> String
formatDay =
formatTime defaultTimeLocale "%a %e %b"
essentialLinks :: Widget
essentialLinks = do
let syllabusId = AssetId "cs101s20.pdf"
syllabusOk <- runRo $ existsObj syllabusId
cardList :: (ToWidget App h, ToWidget App b) => h -> b -> Widget
cardList header body =
[whamlet|
<div .col-lg-6>
<div .card .mb-4>
<div .card-header>
Essential information #
^{header}
<ul .list-group .list-group-flush>
$if syllabusOk
<li .list-group-item>
<a href=@{PageAssetR syllabusId}>Syllabus (pdf)
<li .list-group-item>
<b>Meets:
MW 9–10:50 AM in Pratt 610
<li .list-group-item>
<b>Instructor:
Christopher League
<a href=mailto:christopher.league@liu.edu>email
<li .list-group-item>
<b>Office hours:
MW 4–4:50 PM and
<a href=//bookme.liucs.net/>and by appointment
in Sloane 101
^{body}
|]
essentialLinks :: Widget
essentialLinks = do
let syllabusId = AssetId "cs101s20.pdf"
syllabusOk <- runRo $ existsObj syllabusId
cardList @Text
"Essential information"
[whamlet|
$if syllabusOk
<li .list-group-item>
<a href=@{PageAssetR syllabusId}>Syllabus (pdf)
<li .list-group-item>
<b>Meets:
MW 9–10:50 AM in Pratt 610
<li .list-group-item>
<b>Instructor:
Christopher League
<a href=mailto:christopher.league@liu.edu>email
<li .list-group-item>
<b>Office hours:
MW 4–4:50 PM and
<a href=//bookme.liucs.net/>and by appointment
in Sloane 101
|]
recentPosts :: Widget
......@@ -64,40 +73,48 @@ recentPosts =
title <- getPageMeta pid >>= formatTitle
return (pid, title, not (Set.member pid (user ^. userReadPosts)))
let newCount = length $ filter thd3 posts
[whamlet|
<div .col-lg-6>
<div .card .mb-4>
<div .card-header>
Announcements #
$if newCount > 0
<span .badge .badge-primary>
#{newCount}
<ul .list-group .list-group-flush>
$forall (post, title, newp) <- posts
<li .list-group-item>
<a href=@{PostR post}>
$if newp
<span .font-weight-bold .text-muted>
⇒ #{formatDay (postDay post)}
$else
<span .text-muted>
#{formatDay (postDay post)}
#{preEscapedToMarkup title}
header =
[whamlet|
Announcements #
$if newCount > 0
<span .badge .badge-primary>
#{newCount}
|]
cardList
header
[whamlet|
$forall (post, title, newp) <- posts
<li .list-group-item>
<a href=@{PostR post}>
$if newp
<span .font-weight-bold .text-muted>
⇒ #{formatDay (postDay post)}
$else
<span .text-muted>
#{formatDay (postDay post)}
#{preEscapedToMarkup title}
|]
unitTitle :: Int -> Text -> Widget
unitTitle num title =
[whamlet|
<span .text-muted>
Unit #{num}
#{title}
|]
unit1 :: Widget
unit1 =
[whamlet|
<div .col-lg-6>
<div .card .mb-4>
<div .card-header>
<span .text-muted>
Unit 1:
Digital representations
<ul .list-group .list-group-flush>
<li .list-group-item>
<a href=@{PageDocR "notes110-numbers.org"}>
Notes: Positional numbering
cardList (unitTitle 1 "Digital representations") $
[whamlet|
<li .list-group-item>
Notes:
<a href=@{PageDocR "notes110-numbers.org"}>
Positional numbering
<li .list-group-item>
Practice:
<a href=@{U1FromBaseR}>
Convert from base
|]
getHomeR :: Handler Html
......
......@@ -17,16 +17,16 @@ module App.Page
where
import App.ByteStore
import Prelude (error)
import App.Prelude
import Data.Aeson as Js
import Data.Aeson.Types as Js
import Data.String
import Data.Maybe (maybe)
import Data.String
import qualified Data.Text as Text
import Text.Blaze.Html
import Text.Pandoc
import Web.PathPieces
import Prelude (error)
data PageFormat
= OrgPage
......@@ -59,8 +59,8 @@ instance PathPiece PageFile where
instance IsString PageFile where
fromString =
fromMaybe (error "Invalid PageFile literal")
. fromPathPiece
. convertString
. fromPathPiece
. convertString
instance ToJSON PageFile where
toJSON = toPathPiece >>> toJSON
......
......@@ -15,6 +15,8 @@ module App.Prelude
not,
Int,
Num (..),
Integral (..),
(^),
fromIntegral,
-- Maybe, Either
Maybe (..),
......@@ -30,9 +32,11 @@ module App.Prelude
eitherReturn,
eitherThrow,
isJust,
isNothing,
-- Lists
find,
drop,
take,
zip,
length,
filter,
......@@ -64,6 +68,7 @@ module App.Prelude
-- Functor, Applicative, Monad
Functor,
Applicative (..),
Alternative (..),
Monad (..),
void,
join,
......@@ -82,7 +87,6 @@ module App.Prelude
(=<<),
(>=>),
(<=<),
(<|>),
-- Exceptions
Exception,
MonadThrow (..),
......@@ -115,6 +119,9 @@ module App.Prelude
undefined,
getCurrentTime,
Clock.UTCTime,
-- Random
randomIO,
randomRIO,
-- File paths
FilePath,
(</>),
......@@ -142,7 +149,7 @@ import Data.Default (Default (def))
import Data.Functor
import Data.List (find)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)
import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
import qualified Data.Set as Set
import Data.String.Conversions
import qualified Data.Text as T
......@@ -150,6 +157,7 @@ import qualified Data.Text.IO as TIO
import qualified Data.Time.Clock as Clock
import System.FilePath
import System.IO.Error (IOError, doesNotExistErrorType, isDoesNotExistError, mkIOError)
import qualified System.Random as Rand
import qualified Text.Read as Read
import UnliftIO.Exception (throwString)
import Util (makeRelativeTo)
......@@ -227,3 +235,9 @@ onNotExist a =
notFoundExn :: String -> FilePath -> IOError
notFoundExn loc =
mkIOError doesNotExistErrorType loc Nothing . Just
randomIO :: (Rand.Random a, MonadIO m) => m a
randomIO = liftIO Rand.randomIO
randomRIO :: (Rand.Random a, MonadIO m) => (a, a) -> m a
randomRIO = liftIO . Rand.randomRIO
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module App.Quiz1
( getU1FromBaseR,
postU1FromBaseR,
)
where
import App.Foundation
import App.Prelude
import Control.Monad.Random hiding (randomIO, randomRIO)
import qualified Data.Binary as Bin
import Data.Ix (inRange)
import Data.List ((!!))
import Data.String (IsString)
import qualified Data.Text as Text
import Data.Word (Word)
import GHC.Generics
import Numeric (showIntAtBase)
data BaseConvert
= BaseConvert
{ bcBase :: Word,
bcValue :: Word
}
deriving (Show, Generic)
baseRange :: (Word, Word)
baseRange = (3, 9)
valueRange :: (Word, Word)
valueRange = (100, 1000)
makeBaseConvert :: Alternative f => Word -> Word -> f BaseConvert
makeBaseConvert b v =
guard (inRange baseRange b)
*> guard (inRange valueRange v)
$> BaseConvert b v
instance Bin.Binary BaseConvert where
put BaseConvert {..} =
Bin.put bcBase
*> Bin.put bcValue
get = do
b <- Bin.get
v <- Bin.get
makeBaseConvert b v
instance Random BaseConvert where
random =
runRand $ BaseConvert <$> getRandomR baseRange <*> getRandomR valueRange
randomR _ =
random
newBaseConvertSession :: Text -> Handler BaseConvert
newBaseConvertSession key = do
bc <- randomIO
setSessionBS key $ convertString $ Bin.encode bc
return bc
getBaseConvertSession :: Text -> Handler BaseConvert
getBaseConvertSession key =
lookupSessionBS key >>= \case
Nothing -> newBaseConvertSession key
Just buf ->
case Bin.decodeOrFail (convertString buf) of
Right (_, _, bc) -> return bc
Left _ -> newBaseConvertSession key
digitChars :: String
digitChars = ['0' .. '9'] <> ['A' .. 'Z']
toBase :: BaseConvert -> String
toBase BaseConvert {..} =
showIntAtBase bcBase (digitChars !!) bcValue ""
englishBase :: IsString s => BaseConvert -> s
englishBase bc =
case bcBase bc of
2 -> "two"
3 -> "three"
4 -> "four"
5 -> "five"
6 -> "six"
7 -> "seven"
8 -> "eight"
9 -> "nine"
10 -> "ten"
_ -> "UNHANDLED"
correctBaseTen :: BaseConvert -> Word -> Either Text Word
correctBaseTen bc w
| w == bcValue bc =
Right w
| otherwise =
Left $ "Sorry, " <> show w <> " is not the correct value in base ten."
fromBaseForm :: BaseConvert -> Html -> MForm Handler (FormResult Word, Widget)
fromBaseForm bc extra = do
(wordResult, wordView) <-
mreq (check (correctBaseTen bc) intField) "" Nothing
let digits = toBase bc
ndigits = length digits
columns = map (bcBase bc ^) [ndigits -1, ndigits -2 .. 0]
widget = do
toWidget
[lucius|
sub {
font-size: 70%;
position: relative;
top: 1.4ex
}
.base-ten > input {
width: 5em;
}
|]
[whamlet|
#{extra}
$maybe err <- fvErrors wordView
<div .alert .alert-danger>
#{err}
<b>Hint:
The column values for base #{bcBase bc} are
#{Text.intercalate ", " (map show columns)}.
$case wordResult
$of FormSuccess _
<div .alert .alert-success>
<b>Great job!
$of _
<div .text-monospace style="font-size:150%">
<p>
$forall digit <- digits
<span .px-2 .my-3 style="border-bottom: 2px solid #007bff">
#{digit}
<sub>#{bcBase bc}
=
<span .base-ten>
^{fvInput wordView}
<sub>10
$case wordResult
$of FormSuccess _
<a href=@{U1FromBaseR} .btn .btn-primary>Try a new problem
$of _
<input .btn .btn-primary type=submit value="Submit">
|]
return (wordResult, widget)
u1FromKey :: Text
u1FromKey = "u1from"
getU1FromBaseR :: Handler Html
getU1FromBaseR = do
bc <- getBaseConvertSession u1FromKey
(widget, enctype) <- generateFormPost $ fromBaseForm bc
defaultLayout $ do
setTitle $ "Convert from base " <> englishBase bc
[whamlet|
<div .col-12>
<form method=post enctype=#{enctype}>
^{widget}
|]
isFormSuccess :: FormResult a -> Bool
isFormSuccess (FormSuccess _) = True
isFormSuccess _ = False
postU1FromBaseR :: Handler Html
postU1FromBaseR = do
bc <- getBaseConvertSession u1FromKey
((result, widget), enctype) <- runFormPost $ fromBaseForm bc
when (isFormSuccess result) $ deleteSession u1FromKey
defaultLayout $ do
setTitle $ "Convert from base " <> englishBase bc
[whamlet|
<div .col-12>
<form method=post enctype=#{enctype}>
^{widget}
|]
......@@ -21,11 +21,11 @@ import App.ByteStoreWorkDir
import App.Foundation
import App.Prelude
import App.YamlStore
import Control.Monad (mzero)
import Control.Monad.Trans.Resource
import Data.Aeson as Js
import Data.Function (on)
import Data.List (elem, any, zipWith)
import Control.Monad (mzero)
import Data.List (any, elem, zipWith)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
......@@ -172,11 +172,12 @@ meetingTex :: Bool -> TextFmt -> Meeting -> LazyText
meetingTex blend fmt m@Meeting {..} =
LT.intercalate ". " $
catMaybes
[ case (blend, meetFormatDef m) of
(True, Meet_f2f) -> Just "Face-to-face meeting"
(False, Meet_f2f) -> Nothing
(_, Meet_online) -> Just "Online meeting"
(_, Meet_async) -> Just "No meeting",
[ textit fmt
<$> case (blend, meetFormatDef m) of
(True, Meet_f2f) -> Just "Face-to-face meeting"
(False, Meet_f2f) -> Nothing
(_, Meet_online) -> Just "Online meeting"
(_, Meet_async) -> Just "No meeting",
textit fmt <$> meetUnit,
textbf fmt <$> meetExam,
meetTopic,
......@@ -243,32 +244,29 @@ instance Default VEvent where
}
durationFromTime :: TimeOfDay -> DurationProp
durationFromTime TimeOfDay{..} =
durationFromTime TimeOfDay {..} =
DurationProp (DurationTime def todHour todMin 0) def
classTZ :: IsString s => s
classTZ = "America/New_York"
mkClassMeeting :: UTCTime -> Schedule -> DateTime -> Meeting -> VEvent
mkClassMeeting now sch start m@Meeting{..} =
mkClassMeeting now sch start m@Meeting {..} =
def
{ veDTStamp = DTStamp now def,
veUID = UID (schCourse sch <> "-mtg-" <> show day) def,
veLocation =
case meetFormatDef m of
Meet_f2f -> Just (Location (schLocation sch) def def def)
Meet_online -> Just (Location "Online" def def def)
Meet_async -> Nothing,
veDTStart =
case meetFormatDef m of
Meet_async -> Just (DTStartDate (Date day) def)
_ -> Just (DTStartDateTime start def),
veLocation = case meetFormatDef m of
Meet_f2f -> Just (Location (schLocation sch) def def def)
Meet_online -> Just (Location "Online" def def def)
Meet_async -> Nothing,
veDTStart = case meetFormatDef m of
Meet_async -> Just (DTStartDate (Date day) def)
_ -> Just (DTStartDateTime start def),
veSummary = Just (Summary title def def def),
veDescription = Just (Description descr def def def),
veDTEndDuration =
case meetFormatDef m of
Meet_async -> Nothing
_ -> Just (Right (durationFromTime (schDuration sch)))
veDTEndDuration = case meetFormatDef m of
Meet_async -> Nothing
_ -> Just (Right (durationFromTime (schDuration sch)))
}
where
day = localDay (dateTimeFloating start)
......
{ mkDerivation, aeson, base, blaze-html, bytestring
{ mkDerivation, aeson, base, binary, blaze-html, bytestring
, case-insensitive, conduit, containers, cryptohash, data-default
, directory, exceptions, extra, filelock, filepath, ghc-lib-parser
, gitlib, gitlib-libgit2, hashable, hpack, iCalendar, lens
, mime-mail, mime-types, mtl, pandoc, path-pieces, resourcet
, shakespeare, smtp-mail, stdenv, string-conversions, tagged, text
, time, transformers, unix, unliftio, unordered-containers, yaml
, yesod, yesod-auth, yesod-core, yesod-form
, mime-mail, mime-types, MonadRandom, mtl, pandoc, path-pieces
, random, resourcet, shakespeare, smtp-mail, stdenv
, string-conversions, tagged, text, time, transformers, unix
, unliftio, unordered-containers, yaml, yesod, yesod-auth
, yesod-core, yesod-form
}:
mkDerivation {
pname = "cms101";
......@@ -15,13 +16,13 @@ mkDerivation {
isExecutable = true;
libraryToolDepends = [ hpack ];
executableHaskellDepends = [
aeson base blaze-html bytestring case-insensitive conduit
aeson base binary blaze-html bytestring case-insensitive conduit
containers cryptohash data-default directory exceptions extra
filelock filepath ghc-lib-parser gitlib gitlib-libgit2 hashable
iCalendar lens mime-mail mime-types mtl pandoc path-pieces
resourcet shakespeare smtp-mail string-conversions tagged text time
transformers unix unliftio unordered-containers yaml yesod
yesod-auth yesod-core yesod-form
iCalendar lens mime-mail mime-types MonadRandom mtl pandoc
path-pieces random resourcet shakespeare smtp-mail
string-conversions tagged text time transformers unix unliftio
unordered-containers yaml yesod yesod-auth yesod-core yesod-form
];
prePatch = "hpack";
license = "unknown";
......
......@@ -6,7 +6,9 @@ executable:
source-dirs: .
dependencies:
- base >= 4.12
- MonadRandom
- aeson
- binary
- blaze-html
- bytestring
- case-insensitive
......@@ -30,6 +32,7 @@ executable:
- mtl
- pandoc
- path-pieces
- random
- resourcet
- shakespeare
- smtp-mail
......
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