Skip to content

Instantly share code, notes, and snippets.

@samth

samth/utils.rkt

Created Jan 15, 2021
Embed
What would you like to do?
#lang at-exp racket
(provide indented
link-file
campuswire-url campuswire campuswire-invite ; piazza-url piazza
zoom canvas
youtube watch-youtube
textbook
the-design-recipe
bslblock
first-day-of-break-week week
assignment
print-handin-config
due-index-block
lecture-blurb lab-blurb problem-set-blurb office-hours-blurb
def-exercise
follow-the-dr
code-available)
(require scribble/manual
scribble/core
scribble/html-properties
scribble/decode
scribble/manual-struct
scribble/decode-struct
(only-in net/url-string string->url))
(define-syntax-rule (bslblock . body)
(codeblock #:keep-lang-line? #f "#lang htdp/bsl" "\n" . body))
#;(define piazza-url "http://piazza.com/iu/spring2020/c211")
(define campuswire-url "https://campuswire.com/c/GBCA390B2/feed")
#;(define piazza @link[piazza-url]{Piazza})
(define campuswire @link[campuswire-url]{CampusWire})
(define campuswire-invite-url "https://campuswire.com/p/GBCA390B2")
#;(define campuswire-invite @list{Sign up with this link: @link[campuswire-invite-url]{@campuswire-invite-url} and use the following code: 2233.})
(define campuswire-invite @list{You should have recieved an email invitation to CampusWire. Click on it to join. Check your spam folder if you can't find it.})
(define zoom @link["https://zoom.iu.edu"]{Zoom})
(define canvas @link["https://canvas.iu.edu"]{Canvas})
(define (youtube id . contents)
(apply link (string-append "https://www.youtube.com/watch?v=" id) contents))
(define (watch-youtube #:aspect-ratio [aspect-ratio 10/16] id)
(para #:style (style #f (list 'div))
(elem #:style (style #f (list (alt-tag "div")
(attributes `((style . ,(string-append "position:relative;padding-top:" (~r (* 100 aspect-ratio)) "%;"))))))
(elem #:style (style #f (list (alt-tag "iframe")
(attributes `((style . "position:absolute;top:0;left:0;width:100%;height:100%;")
(src . ,(string-append "https://www.youtube.com/embed/" id "?hl=en-us&modestbranding&rel=0"))
(frameborder . "0")
(allow . "fullscreen;picture-in-picture;"))))) ;accelerometer;gyroscope?
" "))))
(define (textbook [path ""] [content "the textbook"] . contents)
(apply link (string-append "http://www.htdp.org/2018-01-06/Book/" path) content contents))
(define the-design-recipe
(textbook "part_preface.html#%28part._sec~3asystematic-design%29" "the design recipe"))
(define (indented . args)
(apply nested #:style 'inset args))
(define (link-file path . content)
(apply elem #:style (style #f (list (link-resource path))) content))
; Dates in terms of the academic calendar
(require gregor gregor/time gregor/period (only-in rnrs/base-6 assert))
(define first-day-of-classes (date 2020 8 24))
(define first-day-of-break-week (date 2020 11 22))
(define course-timezone "America/New_York")
(assert (monday? first-day-of-classes))
(assert (sunday? first-day-of-break-week))
(define (week w [day-of-week 1] [hour #f] [minute 0] #:skip-break [skip-break #t])
; The week number w is 1-based: week 0 is the week before classes.
; The first day of classes is (week 1 1), a Monday.
; The day-of-week can be negative or greater than 6,
; which might result in a date within the break week.
; With skip-break default #t, week 16 is final exams.
(define first-day-of-week (+weeks first-day-of-classes (- w 1)))
(define actual-first-day-of-week
(if (and skip-break (date<? first-day-of-break-week first-day-of-week))
(+weeks first-day-of-classes w)
first-day-of-week))
(define the-date (+days actual-first-day-of-week (- day-of-week 1)))
(if hour
(with-timezone (-nanoseconds (+minutes (on-date (time hour minute) the-date) 1) 1)
course-timezone)
the-date))
(struct handin-info (name due-moment draft?) #:transparent)
(define handins (list (handin-info "test-handin" (week 17 0 0 0) #t)))
(define assignment-title-style
(let ([final-style (style #f '(unnumbered))]
[draft-style (style #f (list* (part-link-redirect (string->url ""))
(css-style-addition #"body{background-image:url(under-construction.png);background-color:#fffff5}")
'(unnumbered toc-hidden no-index)))])
(lambda (draft?) (if draft? draft-style final-style))))
(define (assignment due
#:grace [grace 60]
#:draft? [draft? #f]
#:tag [tag #f]
#:handin [handin #f]
#:not-due? [not-due? #f]
. title-content)
(define-values (due-moment due-string due-content due-on)
(cond [(date? due)
(values (with-timezone (-nanoseconds (on-date (time 0) (+days due 1)) 1)
course-timezone)
(date->iso8601 due)
(~t #:locale "en" due "EEEE, MMMM d")
(~t #:locale "en" due "'on' EEEE, MMMM d"))]
[(moment? due)
(values due
(moment->iso8601 due)
(~t #:locale "en" due "EEEE, MMMM d, h:mmaaaaa'm'")
(~t #:locale "en" due "'on' EEEE, MMMM d 'at' h:mmaaaaa'm'"))]))
(when handin
(set! handins (cons (handin-info handin
(+period due-moment (minutes grace))
draft?)
handins)))
(list (apply title #:style (assignment-title-style draft?)
#:tag tag
; #:tag-prefix (and draft? "DrAfT-")
title-content)
(if draft?
empty
(make-part-index-decl (list due-string (content->string title-content))
(list title-content (list " (" due-content ")"))))
(unless not-due? (list "This assignment is due " due-on "."))
(when handin (list " Submit it using Handin as assignment " (tt handin) "."))))
(define (print-handin-config path)
(define NOW (now/moment #:tz course-timezone))
(define-values (active inactive)
(partition (lambda (hi)
(and (not (handin-info-draft? hi))
(moment<? NOW (handin-info-due-moment hi))))
(sort handins moment<? #:key handin-info-due-moment)))
(define deadline
(map (lambda (hi)
`(,(handin-info-name hi)
(,(->year (handin-info-due-moment hi))
,(->month (handin-info-due-moment hi))
,(->day (handin-info-due-moment hi))
,(->hours (handin-info-due-moment hi))
,(->minutes (handin-info-due-moment hi))
,(->seconds (handin-info-due-moment hi)))
0))
(reverse handins)))
(call-with-output-file* path
#:mode 'text
#:exists 'truncate/replace
(lambda (port)
(parameterize ([pretty-print-columns 50])
(pretty-write `((active-dirs ,(map handin-info-name active))
(inactive-dirs ,(map handin-info-name inactive))
(deadline ,deadline))
port)))))
;; @due-index-block[] generates an index for all due dates in the current part.
;; @due-index-block[#:parent 1] generates an index for all due dates in the parent part.
;; The code below is modified from scribble/base:
; get-index-entries
; - uses the given section rather than its parent
; - only gets index entries whose first index term looks like a date or datetime
; index-block (renamed due-index-block)
; - generates no alphabet row at top
; - generates separate table rows for each index item always
; - takes optional keyword argument #:parent to say how many levels to go up
; the parts hierarchy to find the section whose index to compile
;; returns an ordered list of (list tag (text ...) (element ...) index-desc)
(define (get-index-entries sec ri)
(define (compare-lists xs ys <?)
(let loop ([xs xs] [ys ys])
(cond [(and (null? xs) (null? ys)) '=]
[(null? xs) '<]
[(null? ys) '>]
[(<? (car xs) (car ys)) '<]
[(<? (car ys) (car xs)) '>]
[else (loop (cdr ys) (cdr xs))])))
;; string-ci<? as a major key, and string<? next, so "Foo" precedes "foo"
;; (define (string*<? s1 s2)
;; (or (string-ci<? s1 s2)
;; (and (not (string-ci<? s2 s1)) (string<? s1 s2))))
(define (get-desc entry)
(let ([desc (cadddr entry)])
(cond [(exported-index-desc? desc)
(cons 'libs (map (lambda (l)
(format "~s" l))
(exported-index-desc-from-libs desc)))]
[(module-path-index-desc? desc) '(mod)]
[(part-index-desc? desc) '(part)]
[(delayed-index-desc? desc) '(delayed)]
[else '(#f)])))
;; parts first, then modules, then bindings, delayed means it's not
;; the last round, and #f means no desc
(define desc-order '(part mod libs delayed #f))
;; this defines an imposed ordering for module names
(define lib-order '(#rx"^racket(?:/|$)" #rx"^r.rs(?:/|$)" #rx"^lang(?:/|$)"))
(define (lib<? lib1 lib2)
(define (lib-level lib)
(let loop ([i 0] [rxs lib-order])
(if (or (null? rxs) (regexp-match? (car rxs) lib))
i (loop (add1 i) (cdr rxs)))))
(let ([l1 (lib-level lib1)] [l2 (lib-level lib2)])
(if (= l1 l2) (string<? lib1 lib2) (< l1 l2))))
(define (compare-desc e1 e2)
(let* ([d1 (get-desc e1)] [d2 (get-desc e2)]
[t1 (car d1)] [t2 (car d2)])
(cond [(memq t2 (cdr (memq t1 desc-order))) '<]
[(memq t1 (cdr (memq t2 desc-order))) '>]
[else (case t1 ; equal to t2
[(part) '=] ; will just compare tags
[(mod) '=] ; the text fields are the names of the modules
[(libs) (compare-lists (cdr d1) (cdr d2) lib<?)]
[(delayed) '>] ; dosn't matter, will run again
[(#f) '=])])))
(define (entry<? e1 e2)
(let ([text1 (cadr e1)] [text2 (cadr e2)])
(case (compare-lists text1 text2 string-ci<?)
[(<) #t] [(>) #f]
[else (case (compare-desc e1 e2)
[(<) #t] [(>) #f]
[else (case (compare-lists text1 text2 string<?)
[(<) #t] [(>) #f]
[else
;; (error 'get-index-entries
;; ;; when this happens, revise this code so
;; ;; ordering will always be deterministic
;; "internal error -- unordered entries: ~e ~e"
;; e1 e2)
;; Instead, just compare the tags
(string<? (format "~a" (car e1))
(format "~a" (car e2)))])])])))
(define l null)
(hash-for-each
(if sec
(collected-info-info (part-collected-info sec ri))
(let ([ci (resolve-info-ci ri)])
;; Force all xref info:
((collect-info-ext-demand ci) #f ci)
(collect-info-ext-ht ci)))
(lambda (k v)
(when (and (pair? k) (eq? 'index-entry (car k)))
(let ([v (if (known-doc? v) (known-doc-v v) v)])
(when (regexp-match? #px"^\\d{4}-\\d{2}-\\d{2}(?:T|$)" (caar v))
(set! l (cons (cons (cadr k) v) l)))))))
(sort l entry<?))
(define (parent n sec ri)
(if (and sec (positive? n))
(parent (- n 1) (collected-info-parent (part-collected-info sec ri)) ri)
sec))
(define (due-index-block #:parent [n 0])
(define (rows . rows)
(make-table (make-style 'index null)
(map (lambda (row)
(list (make-paragraph plain row)))
rows)))
(define contents
(lambda (renderer sec ri)
(define l (get-index-entries (parent n sec ri) ri))
(define body
(map (lambda (i)
(make-link-element
"indexlink"
(caddr i)
(car i)))
l))
(apply rows (map list body))))
(make-delayed-block contents))
(define lecture-blurb @list{
To help you with lectures and answer any questions, there will be
meetings on Mondays and Wednesdays at 9:25--10:40am and 3:15--4:30pm
(for C211) and on Tuesdays and Thursdays at 4:55pm--6:10pm
(for H211), all online using @|zoom|. A link to the lecture meeting will be
posted on @|campuswire| ahead of time and is also available on
@|canvas|.
The current policy is that you must attend two lecture meetings per week.})
(define lab-blurb @list{
To help you with labs and answer any questions, the instructors will
hold meetings on Thursdays and Fridays (see @secref["lab-schedule"])
online using @|zoom|. A link to the lab meeting will be posted on
@|campuswire| ahead of time and is also available on @|canvas|. You
are required to attend at least one lab meeting in each week. Plan to
attend the lab you are registered for, but if you need to attend a
different lab occasionally, that's ok.})
(define problem-set-blurb @list{
To help you with problem sets and answer any questions, the instructors will
hold office hours throughout the week (see @secref["office-hours"]) online
using @|zoom|. A link to the office hours will be posted on @|campuswire| ahead
of time and is also available on @|canvas|. Your attendance of office hours is
optional but highly recommended. You can come to office hours and hang out even
if you don't have a specific question but just want to study!})
(define office-hours-blurb @list{
Office hours begin on @~t[#:locale "en" (week 2) "EEEE, MMMM d"],
so there won't be office hours during the first week of classes.})
(define-syntax def-exercise
(syntax-rules ()
[(def-exercise e)
(def-exercise e n)]
[(def-exercise e n)
(begin
(define n 0)
(define (e . args)
(set! n (add1 n))
(define heading @bold{Exercise @number->string[n]. })
(if (empty? args)
heading
(nested heading (apply nested #:style 'inset args)))))]))
(define (code-available #:plural [plural #t] p) @list{
The code written in the video@(if plural "s" "") above is
@link-file[p]{available for your reference}.
To download it, don't use "Save Page As" or "Save As";
use "Save Link As" or "Download Linked File".})
(define (follow-the-dr
#:first [first @list{Remember to follow @|the-design-recipe|
whenever you design or write a function.}]
. dd) @list{
@|first|
In particular, every type mentioned in a signature must be introduced
by a data definition, except for these well-known types:
Number, Image, String@(if (null? dd) null (cons ", " dd)).})
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment