Commit 4f822b7f authored by Christopher League's avatar Christopher League
Browse files

Hex workshop!

parent f5ae0502
......@@ -9,6 +9,7 @@ module App.Activity
( Activity (..),
makeActivity,
pointsBadge,
submittedPointsBadge,
isPast,
userPointsFor,
dueBadge,
......@@ -21,7 +22,7 @@ where
import App.Foundation
import App.Prelude
import App.User
import Control.Lens (at, non)
import Control.Lens (non)
import Data.Time.Format
import Data.Time.LocalTime
......@@ -56,6 +57,24 @@ pointsBadge Activity {..} = do
#{tshow pts}/#{tshow actMaxPoints} points
|]
submittedPointsBadge :: Activity -> (UserId -> WidgetFor App Bool) -> Widget
submittedPointsBadge Activity {..} checkSubmitted = do
(uid, user) <- requireAuth
submitted <- checkSubmitted uid
let outOf = tshow actMaxPoints
[whamlet|
$if submitted
$maybe pts <- user ^. (userScores . at actId)
<span class="badge badge-success">
#{tshow pts}/#{outOf} points
$nothing
<span class="badge badge-secondary">
submitted: TBD/#{outOf} points
$else
<span class="badge badge-primary">
0/#{outOf} points
|]
isPast :: MonadIO m => ZonedTime -> m Bool
isPast zt =
(> zonedTimeToUTC zt) <$> getCurrentTime
......
......@@ -31,7 +31,6 @@ import App.TestUtils
import App.User
import App.YamlStore
import Conduit
import Control.Lens (at)
import Data.Aeson as Js
import qualified Data.ByteString as BS
import Data.List (elem)
......@@ -183,22 +182,9 @@ answerForm prev =
(a1q7 <$> prev)
a1SubmittedBadge :: Widget
a1SubmittedBadge = do
(uid, user) <- requireAuth
submitted <- runRo $ existsObj $ A1AnswersKey uid
let outOf = tshow (actMaxPoints assn1)
[whamlet|
$if submitted
$maybe pts <- user ^. (userScores . at (actId assn1))
<span class="badge badge-success">
#{tshow pts}/#{outOf} points
$nothing
<span class="badge badge-secondary">
submitted: TBD/#{outOf} points
$else
<span class="badge badge-primary">
0/#{outOf} points
|]
a1SubmittedBadge =
submittedPointsBadge assn1 $ \uid ->
runRo $ existsObj $ A1AnswersKey uid
handleU1HuffAssnR :: Handler Html
handleU1HuffAssnR = do
......
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}
module App.Assn2
( getU1HexAssnR,
postU1HexAssnR,
getU1HexDeleteR,
a2SubmittedBadge,
assn2Tests,
assn2,
)
where
import App.Activity
import App.Foundation
import App.Prelude
import App.TestUtils
import App.User
import App.YamlStore
import Data.Aeson as Js
import qualified Data.Aeson.Types as Js
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Char (isHexDigit)
import Data.List.Extra (enumerate)
import qualified Data.Map as Map
import Data.String (IsString (..))
import qualified Data.Text as Text
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Tasty
import Text.Blaze.Html
import Text.Julius (juliusFile)
assn2 :: Activity
assn2 =
makeActivity "a2" 60 "2020-02-21 23:59 EST"
a2SubmittedBadge :: Widget
a2SubmittedBadge =
submittedPointsBadge assn2 $ \uid ->
runRo $ existsObj $ A2ImagesKey uid
data A2ImagesKey
= A2ImagesKey
{ a2User :: UserId
}
deriving (Eq, Ord, Show)
genA2ImagesKey :: Gen A2ImagesKey
genA2ImagesKey =
A2ImagesKey <$> genUserId
instance Key A2ImagesKey where
keyDir = "submit/a2"
keyToFileName (A2ImagesKey uid) = keyToFileName uid
keyFromFileName fn = A2ImagesKey <$> keyFromFileName fn
newtype HexPixels
= HexPixels {hexText :: CI Text}
deriving (Eq, Show)
mkHexPixels :: Text -> HexPixels
mkHexPixels =
HexPixels . CI.mk . Text.filter isHexDigit
instance PathPiece HexPixels where
toPathPiece = CI.original . hexText
fromPathPiece = Just . mkHexPixels
instance IsString HexPixels where
fromString = mkHexPixels . fromString
instance ToMarkup HexPixels where
toMarkup = toMarkup . toPathPiece
instance FromJSON HexPixels where
parseJSON = Js.withText "HexPixels" $ pure . mkHexPixels
instance Default HexPixels where
def = ""
genHexPixels :: Gen HexPixels
genHexPixels =
mkHexPixels
<$> Gen.text (Range.linear 0 64) (Gen.element "0123456789abcdefABCDEFx ,z")
data Channel = Red | Green | Blue
deriving (Eq, Ord, Show, Bounded, Enum)
instance ToMarkup Channel where
toMarkup = toMarkup . tshow
data HexImage
= HexImage
{ hexImageId :: Maybe Text,
hexWidthQuads :: Word,
hexHeightQuads :: Word,
hexPixels :: Map Channel HexPixels
}
deriving (Show, Eq)
channels :: [Channel]
channels = enumerate
rgbPixels :: HexPixels -> HexPixels -> HexPixels -> Map Channel HexPixels
rgbPixels r g b =
Map.fromList $ zip channels [r, g, b]
chunkedPixels :: HexImage -> Channel -> Text
chunkedPixels HexImage {..} chan =
Text.intercalate " "
$ Text.chunksOf (fromIntegral hexWidthQuads)
$ maybe mempty toPathPiece
$ Map.lookup chan hexPixels
genPixels :: Gen (Map Channel HexPixels)
genPixels =
rgbPixels
<$> genHexPixels
<*> genHexPixels
<*> genHexPixels
genImageId :: Gen Text
genImageId =
Gen.text (Range.singleton 24) Gen.digit
genHexImage :: Gen HexImage
genHexImage =
HexImage
<$> Gen.maybe genImageId
<*> Gen.word (Range.linear 1 5)
<*> Gen.word (Range.linear 1 5)
<*> genPixels
instance ToJSON HexImage where
toJSON x@HexImage {..} =
object
[ "w" .= hexWidthQuads,
"h" .= hexHeightQuads,
"r" .= chunkedPixels x Red,
"g" .= chunkedPixels x Green,
"b" .= chunkedPixels x Blue,
"id" .= hexImageId
]
instance FromJSON HexImage where
parseJSON = Js.withObject "HexImage" \o ->
HexImage
<$> o .:? "id"
<*> o .: "w"
<*> o .: "h"
<*> ( rgbPixels
<$> o .: "r"
<*> o .: "g"
<*> o .: "b"
)
data A2Images
= A2Images
{ a2part1 :: Maybe HexImage,
a2part2 :: Maybe HexImage,
a2others :: [HexImage]
}
deriving (Eq, Show)
instance Default A2Images where
def = A2Images def def def
genA2Images :: Gen A2Images
genA2Images =
A2Images
<$> Gen.maybe genHexImage
<*> Gen.maybe genHexImage
<*> Gen.list (Range.linear 0 5) genHexImage
instance ToJSON A2Images where
toJSON A2Images {..} =
Js.object
[ "part1" .= a2part1,
"part2" .= a2part2,
"others" .= a2others
]
instance FromJSON A2Images where
parseJSON Js.Null = pure def
parseJSON (Js.Object o) =
A2Images
<$> o .:? "part1"
<*> o .:? "part2"
<*> o .:? "others" .!= mempty
parseJSON v = Js.typeMismatch "A2Images" v
instance YamlEntity A2ImagesKey A2Images
option :: Word -> Word -> Widget
option selected value =
[whamlet|
$if selected == value
<option selected>#{value}
$else
<option>#{value}
|]
gridSizeOptions :: Word -> Widget
gridSizeOptions selected =
mapM_ (option selected) [4 * q | q <- [1 .. 16]]
pixelSizeOptions :: Word -> Widget
pixelSizeOptions selected =
mapM_ (option selected) [4 * q | q <- [1 .. 6]]
savedPic :: HexImage -> Widget
savedPic img =
[whamlet|
<canvas .savedPic .ml-2
title=#{fromMaybe "" (hexImageId img)}
data-w=#{4 * hexWidthQuads img}
data-h=#{4 * hexHeightQuads img}
data-r=#{chunkedPixels img Red}
data-g=#{chunkedPixels img Green}
data-b=#{chunkedPixels img Blue}>
|]
getU1HexAssnR :: Handler Html
getU1HexAssnR = do
let indices = [1 ..] :: [Int]
uid <- requireAuthId
submission <- runRo $ fromMaybe def <$> loadMaybeY (A2ImagesKey uid)
defaultLayout $ do
setTitle "Hexadecimal image workshop"
toWidget $(juliusFile "heximage.js")
toWidget
[lucius|
textarea {
font-family: monospace;
}
.savedPic {
border: 1px solid #666;
background-color: black;
cursor: pointer;
}
.deletePic {
}
.channelPic {
border: 3px solid #666;
background-color: black;
margin: 2ex 2ex 0 2ex;
}
|]
[whamlet|
<form .col-12 method=post enctype=application/x-www-form-urlencoded>
<p>
^{a2SubmittedBadge}
^{dueBadge (actDeadline assn2)}
<p>
For this assignment, you will construct digital images by composing
hexadecimal numbers to control separate red, green, and blue images
that are then merged together to form a final 8-color image. You can
also adjust the size of the canvas using the drop-downs below. You
must create <b>two images:</b>
<ol>
<li>
Write <i>your two initials</i> into a 16×8 grid using the
letter-forms from the 8×8 pixel font in the notes. Each initial
should be in a <b>different secondary</b> color (cyan, magenta,
or yellow).
<li>
Be creative and design any icon, logo, or character you wish.
<p>
See the bottom of the page for some examples. You can click any image
down there to load its codes into the input boxes.
<p>
Grid size
<select #gridWidth name=gridWidth .sizeSelector>
^{gridSizeOptions 16}
×
<select #gridHeight name=gridHeight .sizeSelector>
^{gridSizeOptions 8}
Pixel size
<select #pixelSize .sizeSelector>
^{pixelSizeOptions 8}
<input .ml-4 .mt-1 .btn .btn-primary type=submit name="saveAs" value="Save as image 1">
<input .ml-1 .mt-1 .btn .btn-primary type=submit name="saveAs" value="Save as image 2">
<span #clearButton .ml-4 .mt-1 .btn .btn-danger>Clear
$forall (i, chan) <- zip indices channels
<div style="float:left">
<textarea #hex#{i} name=hex#{i} .hex rows=4 spellcheck=false placeholder="#{chan}">
<canvas #pic#{i} .channelPic>
<canvas #pic4 .channelPic style="clear:left; float:left">
<div .col-md-12 .clearfix>
<h2 .h4 .mt-4>Submissions
<ol>
<li .float-left .mr-4 .mb-4>
$maybe p1 <- a2part1 submission
^{savedPic p1}
$nothing
Not submitted yet
<li .float-left .mr-4 .mb-4>
$maybe p2 <- a2part2 submission
^{savedPic p2}
$nothing
Not submitted yet
$if not (null (a2others submission))
<h2 .h4 .mt-4 style="clear:left">Save history
$forall img <- a2others submission
<span .text-nowrap>
^{savedPic img}
$maybe imgId <- hexImageId img
<a .deletePic .btn .btn-sm .btn-danger href=@{U1HexDeleteR imgId} title="Delete">×
<h2 .h4 .mt-4 style="clear:left">Examples
$forall img <- examples
^{savedPic img}
|]
hexPixField :: Field Handler HexPixels
hexPixField =
convertField mkHexPixels toPathPiece textField
pixInput :: FormInput Handler (Map Channel HexPixels)
pixInput =
rgbPixels
<$> (fromMaybe def <$> iopt hexPixField "hex1")
<*> (fromMaybe def <$> iopt hexPixField "hex2")
<*> (fromMaybe def <$> iopt hexPixField "hex3")
imgInput :: FormInput Handler HexImage
imgInput =
HexImage
<$> pure def
<*> (flip div 4 <$> ireq intField "gridWidth")
<*> (flip div 4 <$> ireq intField "gridHeight")
<*> pixInput
data WhichImage = Image1 | Image2
deriving (Eq, Show)
whichImage :: Text -> WhichImage
whichImage t =
if "1" `Text.isSuffixOf` t then Image1 else Image2
whichImageField :: Field Handler WhichImage
whichImageField =
convertField whichImage tshow textField
saveAsInput :: FormInput Handler (HexImage, WhichImage)
saveAsInput =
(,)
<$> imgInput
<*> ireq whichImageField "saveAs"
postU1HexAssnR :: Handler ()
postU1HexAssnR = do
uid <- requireAuthId
(img, which) <- runInputPost saveAsInput
imgId <- Gen.sample genImageId
runRw $ do
logMessage $ userIdText uid <> " A2 save"
upsertPureY_ (A2ImagesKey uid) \ao ->
let a@A2Images {..} = fromMaybe def ao
save p =
maybe identity (\old -> (old {hexImageId = Just imgId} :)) p a2others
in case which of
Image1 ->
a {a2part1 = Just img, a2others = save a2part1}
Image2 ->
a {a2part2 = Just img, a2others = save a2part2}
addMessage "success" "Image has been saved — see below to load or delete."
redirect U1HexAssnR
getU1HexDeleteR :: Text -> Handler ()
getU1HexDeleteR imgId = do
uid <- requireAuthId
runRw $ do
logMessage $ userIdText uid <> " A2 delete"
updatePureY_ (A2ImagesKey uid) \a ->
a {a2others = filter (\HexImage {..} -> hexImageId /= Just imgId) (a2others a)}
addMessage "success" "Deleted selected image."
redirect U1HexAssnR
assn2Tests :: TestTree
assn2Tests =
testGroup
"App.Assn2"
[ testGroup
"A2ImagesKey"
[storeKeyRoundTrip genA2ImagesKey],
testGroup
"HexImage"
[jsonRoundTrip genHexImage],
testGroup
"A2Images"
[jsonRoundTrip genA2Images]
]
examples :: [HexImage]
examples =
[ HexImage (Just "My initials") 4 2 $
rgbPixels
"1e60306060606060606030601e7e"
"006000600060006000600060007e"
"1e00300060006000600030001e00",
HexImage (Just "slash asterisk") 4 2 $
rgbPixels
"030006000c00180030006000c00000"
"030006660c3c18ff303c6066c00000"
"00000066003c00ff003c0066000000",
HexImage (Just "French flag") 3 2 $
rgbPixels
"0ff0ff0ff0ff0ff0ff0ff0ff"
"0f00f00f00f00f00f00f00f0"
"ff0ff0ff0ff0ff0ff0ff0ff0",
HexImage (Just "Mario") 3 4 $
rgbPixels
"ffffffc6faefa779e1ffff7ff6ff0fe07e07c03c638f10f0"
"e0fc01c6faefa779e1fffc0f801000c93e07c03c638f10f0"
"e0fc01c07801800801e03c8f8910f01f81f83fcfff8f10f0",
HexImage (Just "Race car") 7 4 $
rgbPixels
"ffffffffffffbffff939ffff939ffffffffffffffffffffffffffc7ff7fcc39f7fd990fbe33d2fc073d6bfff3d29ffe190c0ff039e1ff87f"
"fff003fffe0f03ffd9301ffb9301f800004e05a01ec0f003cb1a0c683000c0007fc18003e0240800025480002508000190c0ff039e1ff87f"
"fff003fffe0f43ffddb61ffbdb61f800000e00000cc0000008000000000000007fc18003e0240800025480002508000190c0ff039e1ff87f"
]
......@@ -109,6 +109,9 @@ mkYesodData
/assn/1/huffman/delete/#Text U1HuffDeleteR GET
!/assn/1/#AssetId U1HuffAssetR GET
/assn/2/heximage U1HexAssnR GET POST
/assn/2/heximage/delete/#Text U1HexDeleteR GET
/page/#PageId PageDocR GET
!/page/#AssetId PageAssetR GET
/post/#PostId PostR GET
......@@ -211,6 +214,7 @@ instance Yesod App where
Nothing -> return False
Just MetaCacheR -> return False
Just U1HexSpellR -> return False
Just U1HexAssnR -> return False
Just r -> isWriteRequest r
authRoute _ = Just (AuthR LoginR)
......
......@@ -16,6 +16,7 @@ where
import App.Asset
import App.Assn1
import App.Assn2
import App.ByteStoreDynamic
import App.ByteStoreGitDir (bareRepo)
import App.ByteStoreWorkDir
......@@ -169,5 +170,6 @@ test =
postTests,
quiz1Tests,
assn1Tests,
quiz2Tests
quiz2Tests,
assn2Tests
]
......@@ -16,6 +16,7 @@ where
import App.Activity
import App.Assn1
import App.Assn2
import App.ByteStoreWorkDir
import App.Foundation
import App.Page
......@@ -147,6 +148,12 @@ unit1 = do
Notes:
<a href=@{PageDocR "notes140-images.org"}>
Image encoding
<li .list-group-item>
Assignment:
<a href=@{U1HexAssnR}>
Hexadecimal images
^{a2SubmittedBadge}
^{dueBadge (actDeadline assn2)}
|]
getHomeR :: Handler Html
......
......@@ -8,6 +8,8 @@ module App.Prelude
Eq (..),
Ord (..),
Ordering (..),
Bounded (..),
Enum (..),
(||),
(&&),
-- Numbers
......@@ -22,7 +24,6 @@ module App.Prelude
Integral (..),
(^),
fromIntegral,
succ,
-- Maybe, Either
Maybe (..),
Either (..),
......@@ -71,6 +72,7 @@ module App.Prelude
flip,
const,
uncurry,
identity,
(.),
(>>>),
(&),
......@@ -116,6 +118,7 @@ module App.Prelude
-- Lens
Default (def),
view,
at,
_1,
_2,
(.~),
......@@ -256,3 +259,6 @@ drop = Pre.drop . fromIntegral
plural :: (Integral i, Show i) => i -> T.Text -> T.Text
plural 1 noun = "1 " <> noun
plural k noun = tshow k <> " " <> noun <> "s"
identity :: a -> a
identity x = x
......@@ -30,7 +30,7 @@ import App.Foundation
import App.Prelude
import App.TestUtils
import App.User
import Control.Lens (at, makeLenses)
import Control.Lens (makeLenses)
import qualified Data.Binary as Bin
import Data.List ((!!), elem, elemIndex, reverse)
import qualified Data.Text as Text
......
......@@ -21,7 +21,6 @@ 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
......
......@@ -17,6 +17,9 @@ module App.YamlStore
updateY,
updatePureY,
updatePureY_,
upsertY,
upsertPureY,
upsertPureY_,
sourceObjectsY,
module App.ByteStore,
)
......@@ -88,6 +91,21 @@ updatePureY_ :: (YamlEntity k v, ByteStoreRW m) => k -> (v -> v) -> m ()
updatePureY_ key change =
updatePureY key change $> ()
upsertY :: (YamlEntity k v, ByteStoreRW m) => k -> (Maybe v -> m v) -> m v
upsertY key change = do
old <- loadMaybeY key
new <- change old
saveY key new