utils.rkt

#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)).})