diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-10 17:23:34 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-10 17:23:34 +0200 |
commit | e028543baa552aa091fe3485b03da48d25ab8179 (patch) | |
tree | 89d481c7509d3634bce76e9319cb192c2b25a328 | |
parent | HTML work. (diff) | |
download | calp-e028543baa552aa091fe3485b03da48d25ab8179.tar.gz calp-e028543baa552aa091fe3485b03da48d25ab8179.tar.xz |
Really start breaking apart HTML.
Diffstat (limited to '')
-rw-r--r-- | module/html/config.scm | 18 | ||||
-rw-r--r-- | module/html/vcomponent.scm | 62 | ||||
-rw-r--r-- | module/html/view/calendar.scm | 335 | ||||
-rw-r--r-- | module/html/view/calendar/month.scm | 110 | ||||
-rw-r--r-- | module/html/view/calendar/shared.scm | 96 | ||||
-rw-r--r-- | module/html/view/calendar/week.scm | 114 | ||||
-rw-r--r-- | module/output/html.scm | 674 | ||||
-rw-r--r-- | module/srfi/srfi-41/util.scm | 12 |
8 files changed, 758 insertions, 663 deletions
diff --git a/module/html/config.scm b/module/html/config.scm new file mode 100644 index 00000000..3ae0e1da --- /dev/null +++ b/module/html/config.scm @@ -0,0 +1,18 @@ +(define-module (html config) + :use-module (util) + :use-module (util config) + ) + +(define-public debug (make-parameter #f)) +(define-config debug #f + "Places the generated thingy in debug mode" + post: debug) + + +;;; NOTE edit mode should preferably depend on login-status of the user +;;; but this works for the time being. +(define-public edit-mode (make-parameter #t)) +(define-config edit-mode #t + "Makes the document editable" + post: edit-mode) + diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm index 5e17932c..f9c24ecd 100644 --- a/module/html/vcomponent.scm +++ b/module/html/vcomponent.scm @@ -5,10 +5,12 @@ :use-module (srfi srfi-41) :use-module (datetime) :use-module (html util) + :use-module ((html components) :select (btn tabset)) :use-module ((output general) :select (calculate-fg-color)) :use-module ((vcomponent datetime output) :select (fmt-time-span format-description + format-summary format-recurrence-rule )) ) @@ -126,3 +128,63 @@ (list name (or bg-color 'white) (or fg-color 'black) name (or bg-color 'black)))) calendars)))) + +;; "Physical" block in calendar view +(define*-public (make-block ev optional: (extra-attributes '())) + + `((a (@ (href "#" ,(html-id ev)) + (class "hidelink")) + (div (@ ,@(assq-merge + extra-attributes + `((id ,(html-id ev)) + (class "event CAL_" ,(html-attr (or (prop (parent ev) 'NAME) + "unknown")) + ,(when (and (prop ev 'PARTSTAT) + (eq? 'TENTATIVE (prop ev 'PARTSTAT))) + " tentative")) + (onclick "toggle_popup('popup' + this.id)") + ))) + ;; Inner div to prevent overflow. Previously "overflow: none" + ;; was set on the surounding div, but the popup /needs/ to + ;; overflow (for the tabs?). + (div (@ (class "event-body")) + ,(when (prop ev 'RRULE) + `(span (@ (class "repeating")) "↺")) + (span (@ (class "summary")) + ,(format-summary ev (prop ev 'SUMMARY))) + ,(when (prop ev 'LOCATION) + `(span (@ (class "location")) + ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) + (prop ev 'LOCATION))))) + (div (@ (style "display:none !important;")) + ,((@ (output xcal) ns-wrap) + ((@ (output xcal) vcomponent->sxcal) + ev))))))) + + + +(define-public (popup ev id) + `(div (@ (class "popup-container") (id ,id) + (onclick "event.stopPropagation()")) + (div (@ (class "popup")) + (nav (@ (class "popup-control CAL_" + ,(html-attr (or (prop (parent ev) 'NAME) + "unknown")))) + ,(btn "×" + title: "Stäng" + onclick: "close_popup(document.getElementById(this.closest('.popup-container').id))" + class: '("close-tooltip")) + ,(btn "🗑" + title: "Ta bort" + onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))")) + + ,(tabset + `(("📅" title: "Översikt" + ,(fmt-single-event ev)) + ("⤓" title: "Nedladdning" + (div (@ (style "font-family:sans")) + (p "Ladda ner") + (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics")) + "som iCal")) + (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs")) + "som xCal")))))))))) diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm new file mode 100644 index 00000000..da1d6c9b --- /dev/null +++ b/module/html/view/calendar.scm @@ -0,0 +1,335 @@ +(define-module (html view calendar) + :use-module (util) + :use-module (vcomponent) + :use-module ((vcomponent datetime) + :select (events-between)) + :use-module ((vcomponent build) + :select (vcalendar vevent)) + :use-module (util config) + :use-module (datetime) + :use-module (html components) + :use-module ((html vcomponent) + :select (popup + calendar-styles + fmt-day + make-block + fmt-single-event + )) + :use-module (html config) + :use-module (html util) + :use-module (srfi srfi-1) + :use-module (srfi srfi-26) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module ((vcomponent group) + :select (group-stream get-groups-between)) + :use-module ((git) + :select (get-git-version)) + ) + +;; date should be start of month +;; @example +;; må ti on to fr lö sö +;; 1 2 3 4 5 6 7 +;; 8 9 10 11 12 13 14 +;; 15 16 17 18 19 20 21 +;; 22 23 24 25 26 27 28 +;; 29 30 +;; @end example +;; date - a date in the month to display +;; week-start - which day the week begins on, see (datetime util) +(define* (cal-table key: start-date end-date next-start prev-start + (week-start (get-config 'week-start))) + + (define (td date) + `(a (@ ,@(cond + ;; We are before our time interval + [(date< date start-date) + ;; TODO find a prettier way to generate links to previous and next time intervals + `((class "prev") + (href ,(date->string + (stream-find (lambda (d) (date<= d date (next-start d))) + (stream-iterate prev-start start-date)) + "~Y-~m-~d.html") + "#" ,(date-link date)))] + ;; We are after our time interval + [(date< end-date date) + `((class "next") + (href ,(date->string + (stream-find (lambda (d) (and (date<= d date) + (date< date (next-start d)))) + (stream-iterate next-start start-date)) + "~Y-~m-~d.html") + "#" ,(date-link date)))] + ;; We are in our time interval + [else `((href "#" ,(date-link date)))])) + ;; NOTE This time object is the correct place to show the existance + ;; of an event on a given day in this small calendar. For example + ;; making the text red for all holidays, or creating a yellow background + ;; for events from a specific source. + (time (@ (datetime ,(date->string date "~Y-~m-~d"))) ,(day date)))) + + (let* ((last-months current next + (month-days (start-of-month start-date) week-start)) + (events (append last-months current next))) + `(div (@ (class "small-calendar")) + (div (@ (class "column-head row-head")) "v.") + ,@(map (lambda (d) `(div (@ (class "column-head")) + ,(string-titlecase (week-day-name d 2)))) + (weekday-list week-start)) + ,@(let ((first (start-of-week (car events) week-start)) + (last (start-of-week (last events) week-start))) + (map (lambda (v) `(div (@ (class "row-head")) ,v)) + (map (lambda (d) (week-number d week-start)) + (stream->list + (stream-take-while (lambda (s) (date<= s last)) + (week-stream first)))))) + ,@(map td events + )))) + + + + +;;; Main-stuff + + +;;; NOTE +;;; The side bar filters all earlier events for each day to not create repeats, +;;; and the html-generate procedure also filters, but instead to find earlier eventns. +;;; All this filtering is probably slow, and should be looked into. + +(define repo-url (make-parameter "https://git.hornquist.se")) + +(define*-public (html-generate + key: + (intervaltype 'all) ; 'week | 'month | 'all + calendars events start-date end-date + render-calendar ; (bunch of kv args) → (list sxml) + next-start ; date → date + prev-start ; date → date + ;; The pre and post dates are if we want to show some dates just + ;; outside our actuall interval. Primarily for whole month views, + ;; which needs a bit on each side. + (pre-start start-date) + (post-end end-date)) + + ;; NOTE maybe don't do this again for every month + (define evs (get-groups-between (group-stream events) + start-date end-date)) + + (define (nav-link display date) + `(a (@ (href ,(date->string date "~Y-~m-~d") ".html") + (class "nav hidelink")) + (div (@ (class "nav")) + ,display))) + + (unless next-start + (error 'html-generate "Next-start needs to be a procedure")) + + (unless prev-start + (error 'html-generate "Prev-start needs to be a procedure")) + + ;; (display "<!doctype HTML>\n") + (;;(@ (ice-9 pretty-print) pretty-print) + (@ (sxml simple) sxml->xml) + (xhtml-doc + (@ (lang sv)) + (head + (title "Calendar") + (meta (@ (charset "utf-8"))) + ;; (meta (@ (http-equiv "Content-Type") (content "application/xhtml+xml"))) + (meta (@ (name viewport) + (content "width=device-width, initial-scale=0.5"))) + (meta (@ (name description) + (content "Calendar for the dates between " + ,(date->string start-date) " and " + ,(date->string end-date)))) + ;; NOTE this is only for the time actually part of this calendar. + ;; overflowing times from pre-start and post-end is currently ignored here. + (meta (@ (name start-time) + (content ,(date->string start-date "~s")))) + (meta (@ (name end-time) + (content ,(date->string (date+ end-date (date day: 1)) "~s")))) + + (script + "EDIT_MODE=true;") + + (style ,(format #f "html { + --editmode: 1.0; + --event-font-size: 8pt; + --gray: #757575; + --btn-height: 0.5ex; +}")) + + ,(include-css "/static/style.css") + ,(include-alt-css "/static/dark.css" '(title "Dark")) + ,(include-alt-css "/static/light.css" '(title "Light")) + + (script (@ (defer) (src "/static/script.js"))) + ,(calendar-styles calendars)) + + (body + (div (@ (class "root")) + (main + ;; Actuall calendar + (@ (style "grid-area: main")) + ,@(render-calendar calendars: calendars + events: events + start-date: start-date + end-date: end-date + pre-start: pre-start + post-end: post-end + next-start: next-start + prev-start: prev-start + ) + + ,@(for event in (stream->list + (events-between pre-start post-end events)) + (popup event (string-append "popup" (html-id event))))) + + ;; Page footer + (footer + (@ (style "grid-area: footer")) + (span "Page generated " ,(date->string (current-date))) + (span (a (@ (href ,(repo-url) "/calparse")) + "Source Code")) + ,(let* ((long-hash short-hash (get-git-version)) + (url (format #f "~a/calparse/commit/?id=~a" + (repo-url) long-hash))) + `(span "Version " (a (@ (href ,url)) ,short-hash)))) + + ;; Small calendar and navigation + (nav (@ (class "calnav") (style "grid-area: nav")) + (div (@ (class "change-view")) + ,(btn href: (date->string + (if (= 1 (day start-date)) + (start-of-week start-date (get-config 'week-start)) + start-date) + "/week/~1.html") + "veckovy") + + ,(btn href: (date->string (set (day start-date) 1) "/month/~1.html") + "månadsvy") + + ,(btn id: "today-button" + href: (string-append + "/today?" (case intervaltype + [(month) "view=month"] + [(week) "view=week"] + [else ""])) + "idag")) + + (div (@ (id "jump-to")) + ;; Firefox's accessability complain about each date + ;; component, meaning that it's broken. This label + ;; is for the whole input, which can be enabled + ;; if wanted. + ;; (label (@ (for "date")) "Hoppa till") + (form (@ (action "/today")) + (input (@ (type hidden) + (name "view") + (value ,(case intervaltype + [(month week) => symbol->string] + [else "month"])))) + (input (@ (type date) + (name "date") + (value ,(date->string start-date "~1")))) + ,(btn "➔")))) + + (details (@ (open) (style "grid-area: cal")) + (summary "Month overview") + (div (@ (class "smallcall-head")) + ,(string-titlecase (date->string start-date "~B ~Y"))) + ;; NOTE it might be a good idea to put the navigation buttons + ;; earlier in the DOM-tree/tag order. At least Vimium's + ;; @key{[[} keybind sometimes finds parts of events instead. + (div (@ (class "smallcal")) + ;; prev button + ,(nav-link "«" (prev-start start-date)) + + ;; calendar table + (div ,(cal-table start-date: start-date end-date: end-date + next-start: next-start + prev-start: prev-start + )) + + ;; next button + ,(nav-link "»" (next-start start-date)))) + + + (div (@ (style "grid-area: details")) + ,(when (or (debug) (edit-mode)) + `(details (@ (class "sliders")) + (summary "Option sliders") + + + ,@(when (edit-mode) + `((label "Event blankspace") + ,(slider-input + variable: "editmode" + min: 0 + max: 1 + step: 0.01 + value: 1))) + + ,@(when (debug) + `((label "Fontsize") + ,(slider-input + unit: "pt" + min: 1 + max: 20 + step: 1 + value: 8 + variable: "event-font-size"))))) + + ;; List of calendars + (details (@ (class "calendarlist")) + (summary "Calendar list") + (ul ,@(map + (lambda (calendar) + `(li (@ (class "CAL_bg_" + ,(html-attr (prop calendar 'NAME)))) + ,(prop calendar 'NAME))) + calendars)))) + + ;; List of events + (div (@ (class "eventlist") + (style "grid-area: events")) + ;; Events which started before our start point, + ;; but "spill" into our time span. + (section (@ (class "text-day")) + (header (h2 "Tidigare")) + ,@(stream->list + (stream-map + fmt-single-event + (stream-take-while + (compose (cut date/-time<? <> start-date) + (extract 'DTSTART)) + (cdr (stream-car evs)))))) + ,@(stream->list (stream-map fmt-day evs)))) + + ;; This would idealy be a <template> element, but there is some + ;; form of special case with those in xhtml, but I can't find + ;; the documentation for it. + ,@(let* ((cal (vcalendar + name: "Generated" + children: (list (vevent + ;; The event template SHOULD lack + ;; a UID, to stop potential problems + ;; with conflicts when multiple it's + ;; cloned mulitple times. + dtstart: (datetime) + dtend: (datetime) + summary: "New Event")))) + (event (car (children cal)))) + `((div (@ (class "template event-container") (id "event-template") + ;; Only needed to create a duration. So actual dates + ;; dosen't matter + (data-start "2020-01-01") + (data-end "2020-01-02")) + ,(caddar ; strip <a> tag + (make-block event `((class " generated "))))) + ;; TODO merge this into the event-set, add attribute + ;; for non-displaying elements. + (div (@ (class "template") (id "popup-template")) + ,(popup event (string-append "popup" (html-id event)))))))))) diff --git a/module/html/view/calendar/month.scm b/module/html/view/calendar/month.scm new file mode 100644 index 00000000..f02a10d6 --- /dev/null +++ b/module/html/view/calendar/month.scm @@ -0,0 +1,110 @@ +(define-module (html view calendar month) + :use-module (util) + :use-module (srfi srfi-1) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (datetime) + :use-module (html view calendar shared) + :use-module (html config) + :use-module (util config) + :use-module (vcomponent) + :use-module ((vcomponent datetime) + :select (really-long-event? + events-between)) + :use-module ((html vcomponent) + :select (make-block)) + :use-module ((vcomponent group) + :select (group-stream get-groups-between)) + ) + +;; (stream event-group) -> sxml +(define*-public (render-calendar-table key: events start-date end-date pre-start post-end #:allow-other-keys) + + (define-values (long-events short-events) + ;; TODO should be really-long-event? or event-spanning-midnight + (partition really-long-event? (stream->list (events-between pre-start post-end events)))) + + (define short-event-groups + (get-groups-between (group-stream (list->stream short-events)) + pre-start post-end)) + + (define long-event-groups + (map (lambda (s) + (define e (date+ s (date day: 6))) + (cons* s e + (stream->list + (events-between s e (list->stream long-events))))) + (date-range pre-start post-end (date day: 7)))) + + `((header (@ (class "table-head")) + ,(string-titlecase (date->string start-date "~B ~Y"))) + (div (@ (class "caltable") + (style "grid-template-rows: 2em" + ,(string-concatenate + (map (lambda (long-group) + (format #f " [time] 15pt [long] ~amm [short] 1fr" + (min 10 (* 4 (length (cddr long-group)))))) + long-event-groups)))) + ,@(map (lambda (d) `(div (@ (class "thead")) ,(string-titlecase (week-day-name d)))) + (weekday-list (get-config 'week-start))) + ,@(map (lambda (group i) + (let* (((s e . events) group)) + `(div (@ (class "cal-cell longevents event-container") + (style "grid-area: long " ,i ";" + "grid-column: 1 / span 7;") + (data-start ,(date->string s)) + (data-end ,(date->string (add-day e)))) + ,@(lay-out-long-events + s e events)))) + long-event-groups + (iota (length long-event-groups) 1)) + + ,@(caltable-time-cells start-date end-date + pre-start post-end) + + ,@(stream->list + (stream-map + (lambda (group i) + (define day-date (car group)) + (define events (cdr group)) + `(div (@ (style "grid-area:short " ,i) + (class "cal-cell cal-cell-short event-container") + (data-start ,(date->string day-date)) + (data-end ,(date->string (add-day day-date)))) + (div (@ (style "overflow-y:auto;")) + ,@(map make-small-block (stream->list events))))) + short-event-groups + (repeating-naturals 1 7) + ))))) + + + +;;; Table output + +(define (make-small-block event) + (make-block event)) + +(define (caltable-time-cells start-date end-date + pre-start post-end) + (map (lambda (day-date i) + `(div (@ (style "grid-area:time " ,i) + (class "cal-cell cal-cell-time")) + (a (@ (class "hidelink") + (href "/week/" ,(date->string day-date "~Y-~m-~d") + ".html#" ,(date->string day-date "~Y-~m-~d"))) + (time (@ (class "date-info " + ,(if (or (date< day-date start-date) + (date< end-date day-date)) + "non-current" + "current")) + (datetime ,(date->string day-date "~1"))) + (span (@ (class "day-number")) + ,(date->string day-date "~e")) + ,(when (= 1 (day day-date)) + `(span (@ (class "month-name")) + ,(date->string day-date "~b"))) + ,(when (= 1 (month day-date) (day day-date)) + `(span (@ (class "year-number")) + ", " ,(date->string day-date "~Y"))))))) + (date-range pre-start post-end) + (map floor (iota (length (date-range pre-start post-end)) 1 1/7)))) diff --git a/module/html/view/calendar/shared.scm b/module/html/view/calendar/shared.scm new file mode 100644 index 00000000..d1f58460 --- /dev/null +++ b/module/html/view/calendar/shared.scm @@ -0,0 +1,96 @@ +(define-module (html view calendar shared) + :use-module (util) + :use-module (srfi srfi-1) + :use-module (vcomponent) + :use-module ((vcomponent datetime) + :select (event-length + overlapping? + event-length/clamped)) + :use-module ((vcomponent datetime output) + :select (format-summary)) + :use-module (util tree) + :use-module (datetime) + :use-module (html config) + :use-module ((html components) + :select (btn tabset)) + :use-module ((html vcomponent) + :select (make-block) ) + ) + + + +(define-public x-pos (make-object-property)) +(define-public width (make-object-property)) + + +;; Takes a list of vcomponents, sets their widths and x-positions to optimally +;; fill out the space, without any overlaps. +(define*-public (fix-event-widths! lst key: event-length-key (event-length-comperator date/-time>?)) + ;; The tree construction is greedy. This means + ;; that if a smaller event preceeds a longer + ;; event it would capture the longer event to + ;; only find events which also overlaps the + ;; smaller event. + + ;; @var{x} is how for left in the container we are. + (let inner ((x 0) + (tree (make-tree overlapping? + (sort* lst event-length-comperator event-length-key + )))) + (unless (null? tree) + (let ((w (/ (- 1 x) + (+ 1 (length-of-longst-branch (left-subtree tree)))))) + (set! (width (car tree)) w + (x-pos (car tree)) x) + (inner (+ x w) (left-subtree tree)) + (inner x (right-subtree tree)))))) + + +(define-public (lay-out-long-events start end events) + (fix-event-widths! events event-length-key: event-length + event-length-comperator: date/-time>) + (map (lambda (e) (create-top-block start end e)) + events)) + +;; date{,time}-difference works in days, and days are simply multiplied by 24 to +;; get hours. This means that a day is always assumed to be 24h, even when that's +;; wrong. This might lead to some weirdness when the timezon switches (DST), but it +;; makes everything else behave MUCH better. +(define-public (create-top-block start-date end-date ev) + + (define total-length + (* 24 (days-in-interval start-date end-date))) + + (define top (* 100 (x-pos ev))) + (define height (* 100 (width ev))) + (define left ; start time + (* 100 + (let* ((dt (datetime date: start-date)) + (diff (datetime-difference + (datetime-max dt (as-datetime (prop ev 'DTSTART))) + dt))) + (/ (datetime->decimal-hour diff start-date) total-length)))) + + ;; Set length of event, which makes end time + (define width* + (* 100 + (/ (datetime->decimal-hour + (as-datetime (event-length/clamped start-date end-date ev)) + start-date) + total-length))) + + (define style + (if (edit-mode) + (format #f "top:calc(var(--editmode)*~,3f%);height:calc(var(--editmode)*~,3f%);left:~,3f%;width:~,3f%;" + top height left width*) + (format #f "top:~,3f%;height:~,3f%;left:~,3f%;width:~,3f%;" + top height left width*))) + + (make-block + ev `((class + ,(when (date/-time< (prop ev 'DTSTART) start-date) + " continued") + ,(when (and (prop ev 'DTEND) + (date/-time< (date+ end-date (date day: 1)) (prop ev 'DTEND))) + " continuing")) + (style ,style)))) diff --git a/module/html/view/calendar/week.scm b/module/html/view/calendar/week.scm new file mode 100644 index 00000000..7da186e1 --- /dev/null +++ b/module/html/view/calendar/week.scm @@ -0,0 +1,114 @@ +(define-module (html view calendar week) + :use-module (util) + :use-module (srfi srfi-1) + :use-module (srfi srfi-41) + :use-module (datetime) + :use-module (html view calendar shared) + :use-module (html config) + :use-module (html util) + :use-module (vcomponent) + :use-module ((vcomponent datetime) + :select (long-event? + event-length/day + event-zero-length? + events-between)) + :use-module ((html vcomponent) + :select (make-block) ) + :use-module ((vcomponent group) + :select (group-stream get-groups-between)) + ) + + +(define*-public (render-calendar key: events start-date end-date #:allow-other-keys) + (let* ((long-events short-events (partition long-event? (stream->list (events-between start-date end-date events)))) + (range (date-range start-date end-date))) + `((div (@ (class "calendar")) + (div (@ (class "days")) + ,@(time-marker-div) + (div (@ (class "longevents event-container") + (data-start ,(date->string start-date) ) + (data-end ,(date->string (add-day end-date)) ) + (style "grid-column-end: span " ,(days-in-interval start-date end-date))) + ,@(lay-out-long-events start-date end-date long-events)) + ,@(map (lambda (day-date) + `(div (@ (class "meta")) + (span (@ (class "daydate")) + ,(date->string day-date "~Y-~m-~d")) + (span (@ (class "dayname")) + ,(string-titlecase (date->string day-date "~a"))))) + range) + ,@(stream->list + (stream-map + lay-out-day + (get-groups-between (group-stream (list->stream short-events)) + start-date end-date)))))))) + + + +(define (time-marker-div) + ;; element to make rest of grid align correct. + ;; Could be extended to contain something fun. + `((div (@ (style "grid-row: 1 / span 2"))) + (div (@ (class "sideclock")) + ,@(map (lambda (time) + `(div (@ (class "clock clock-" ,time)) + (span (@ (class "clocktext")) + ,time ":00"))) + (iota 12 0 2))))) + +;; Lay out complete day (graphical) +;; (date . (events)) -> sxml +(define (lay-out-day day) + (let* (((day-date . events) day) + (time-obj (datetime date: day-date)) + (zero-length-events short-events + (partition event-zero-length? (stream->list events)))) + + (fix-event-widths! short-events event-length-key: + (lambda (e) (event-length/day day-date e))) + + `(div (@ (class "events event-container") (id ,(date-link day-date)) + (data-start ,(date->string day-date)) + (data-end ,(date->string (add-day day-date)) )) + ,@(map (lambda (time) + `(div (@ (class "clock clock-" ,time)))) + (iota 12 0 2)) + (div (@ (class "zero-width-events")) + ,(map make-block zero-length-events)) + ,@(map (lambda (e) (create-block day-date e)) short-events)))) + + + +;; Format single event for graphical display +;; This is extremely simmilar to create-top-block, which currently recides in ./shared +(define (create-block date ev) + ;; (define time (date->time-utc day)) + + (define left (* 100 (x-pos ev))) + (define width* (* 100 (width ev))) + (define top (if (date= date (as-date (prop ev 'DTSTART))) + (* 100/24 + (time->decimal-hour + (as-time (prop ev 'DTSTART)))) + 0)) + (define height (* 100/24 (time->decimal-hour (event-length/day date ev)))) + + + (define style + ;; The calc's here is to enable an "edit-mode". + ;; Setting --editmode ≈ 0.8 gives some whitespace to the right + ;; of the events, alowing draging there for creating new events. + (if (edit-mode) + (format #f "left:calc(var(--editmode)*~,3f%);width:calc(var(--editmode)*~,3f%);top:~,3f%;height:~,3f%;" + + left width* top height) + (format #f "left:~,3f%;width:~,3f%;top:~,3f%;height:~,3f%;" + left width* top height))) + + (make-block + ev `((class + ,(when (date<? (as-date (prop ev 'DTSTART)) date) + " continued") + ,(when (and (prop ev 'DTEND) (date<? date (as-date (prop ev 'DTEND)))) + " continuing")) + (style ,style)))) diff --git a/module/output/html.scm b/module/output/html.scm index 3125f38b..86b684bc 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -4,16 +4,15 @@ #:use-module (srfi srfi-41) #:use-module (srfi srfi-41 util) #:use-module (vcomponent) - #:use-module (vcomponent group) + ;; #:use-module (vcomponent group) #:use-module (vcomponent datetime) - #:use-module (vcomponent build) #:use-module (util) #:use-module (util exceptions) #:use-module (util config) - #:use-module (util tree) + ;; #:use-module (util tree) #:duplicates (last) #:use-module (datetime) - #:use-module (ice-9 curried-definitions) + ;; #:use-module (ice-9 curried-definitions) #:use-module (ice-9 match) #:use-module (text util) #:use-module (vcomponent datetime output) @@ -21,668 +20,17 @@ #:use-module (html components) #:use-module (html util) #:use-module (html vcomponent) + #:use-module ((html view calendar) + :select (html-generate)) - #:autoload (vcomponent instance) (global-event-object) - - #:use-module (git) - ;; #:use-module (module config all) - ) - -(define debug (make-parameter #f)) -(define-config debug #f - "Places the generated thingy in debug mode" - post: debug) - - -;;; NOTE edit mode should preferably depend on login-status of the user -;;; but this works for the time being. -(define edit-mode (make-parameter #t)) -(define-config edit-mode #t - "Makes the document editable" - post: edit-mode) - - - - -(define (popup ev id) - `(div (@ (class "popup-container") (id ,id) - (onclick "event.stopPropagation()")) - (div (@ (class "popup")) - (nav (@ (class "popup-control CAL_" - ,(html-attr (or (prop (parent ev) 'NAME) - "unknown")))) - ,(btn "×" - title: "Stäng" - onclick: "close_popup(document.getElementById(this.closest('.popup-container').id))" - class: '("close-tooltip")) - ,(btn "🗑" - title: "Ta bort" - onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))")) - - ,(tabset - `(("📅" title: "Översikt" - ,(fmt-single-event ev)) - ("⤓" title: "Nedladdning" - (div (@ (style "font-family:sans")) - (p "Ladda ner") - (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics")) - "som iCal")) - (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs")) - "som xCal")))))))))) - - - -;;; Procedures for wide output - - -(define x-pos (make-object-property)) -(define width (make-object-property)) - -;; Takes a list of vcomponents, sets their widths and x-positions to optimally -;; fill out the space, without any overlaps. -(define* (fix-event-widths! lst key: event-length-key (event-length-comperator date/-time>?)) - ;; The tree construction is greedy. This means - ;; that if a smaller event preceeds a longer - ;; event it would capture the longer event to - ;; only find events which also overlaps the - ;; smaller event. - - ;; @var{x} is how for left in the container we are. - (let inner ((x 0) - (tree (make-tree overlapping? - (sort* lst event-length-comperator event-length-key - )))) - (unless (null? tree) - (let ((w (/ (- 1 x) - (+ 1 (length-of-longst-branch (left-subtree tree)))))) - (set! (width (car tree)) w - (x-pos (car tree)) x) - (inner (+ x w) (left-subtree tree)) - (inner x (right-subtree tree)))))) - -(define* (make-block ev optional: (extra-attributes '())) - - `((a (@ (href "#" ,(html-id ev)) - (class "hidelink")) - (div (@ ,@(assq-merge - extra-attributes - `((id ,(html-id ev)) - (class "event CAL_" ,(html-attr (or (prop (parent ev) 'NAME) - "unknown")) - ,(when (and (prop ev 'PARTSTAT) - (eq? 'TENTATIVE (prop ev 'PARTSTAT))) - " tentative")) - (onclick "toggle_popup('popup' + this.id)") - ))) - ;; Inner div to prevent overflow. Previously "overflow: none" - ;; was set on the surounding div, but the popup /needs/ to - ;; overflow (for the tabs?). - (div (@ (class "event-body")) - ,(when (prop ev 'RRULE) - `(span (@ (class "repeating")) "↺")) - (span (@ (class "summary")) - ,(format-summary ev (prop ev 'SUMMARY))) - ,(when (prop ev 'LOCATION) - `(span (@ (class "location")) - ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) - (prop ev 'LOCATION))))) - (div (@ (style "display:none !important;")) - ,((@ (output xcal) ns-wrap) - ((@ (output xcal) vcomponent->sxcal) - ev))))))) - -;; Format single event for graphical display -(define (create-block date ev) - ;; (define time (date->time-utc day)) - - (define left (* 100 (x-pos ev))) - (define width* (* 100 (width ev))) - (define top (if (date= date (as-date (prop ev 'DTSTART))) - (* 100/24 - (time->decimal-hour - (as-time (prop ev 'DTSTART)))) - 0)) - (define height (* 100/24 (time->decimal-hour (event-length/day date ev)))) - - - (define style - ;; The calc's here is to enable an "edit-mode". - ;; Setting --editmode ≈ 0.8 gives some whitespace to the right - ;; of the events, alowing draging there for creating new events. - (if (edit-mode) - (format #f "left:calc(var(--editmode)*~,3f%);width:calc(var(--editmode)*~,3f%);top:~,3f%;height:~,3f%;" - - left width* top height) - (format #f "left:~,3f%;width:~,3f%;top:~,3f%;height:~,3f%;" - left width* top height))) - - (make-block - ev `((class - ,(when (date<? (as-date (prop ev 'DTSTART)) date) - " continued") - ,(when (and (prop ev 'DTEND) (date<? date (as-date (prop ev 'DTEND)))) - " continuing")) - (style ,style)))) - -;; date{,time}-difference works in days, and days are simply multiplied by 24 to -;; get hours. This means that a day is always assumed to be 24h, even when that's -;; wrong. This might lead to some weirdness when the timezon switches (DST), but it -;; makes everything else behave MUCH better. -(define (create-top-block start-date end-date ev) - - (define total-length - (* 24 (days-in-interval start-date end-date))) - - (define top (* 100 (x-pos ev))) - (define height (* 100 (width ev))) - (define left ; start time - (* 100 - (let* ((dt (datetime date: start-date)) - (diff (datetime-difference - (datetime-max dt (as-datetime (prop ev 'DTSTART))) - dt))) - (/ (datetime->decimal-hour diff start-date) total-length)))) - - ;; Set length of event, which makes end time - (define width* - (* 100 - (/ (datetime->decimal-hour - (as-datetime (event-length/clamped start-date end-date ev)) - start-date) - total-length))) - - (define style - (if (edit-mode) - (format #f "top:calc(var(--editmode)*~,3f%);height:calc(var(--editmode)*~,3f%);left:~,3f%;width:~,3f%;" - top height left width*) - (format #f "top:~,3f%;height:~,3f%;left:~,3f%;width:~,3f%;" - top height left width*))) - - (make-block - ev `((class - ,(when (date/-time< (prop ev 'DTSTART) start-date) - " continued") - ,(when (and (prop ev 'DTEND) - (date/-time< (date+ end-date (date day: 1)) (prop ev 'DTEND))) - " continuing")) - (style ,style)))) - - -;; Lay out complete day (graphical) -;; (date . (events)) -> sxml -(define (lay-out-day day) - (let* (((day-date . events) day) - (time-obj (datetime date: day-date)) - (zero-length-events short-events - (partition event-zero-length? (stream->list events)))) - - (fix-event-widths! short-events event-length-key: - (lambda (e) (event-length/day day-date e))) - - `(div (@ (class "events event-container") (id ,(date-link day-date)) - (data-start ,(date->string day-date)) - (data-end ,(date->string (add-day day-date)) )) - ,@(map (lambda (time) - `(div (@ (class "clock clock-" ,time)))) - (iota 12 0 2)) - (div (@ (class "zero-width-events")) - ,(map make-block zero-length-events)) - ,@(map (lambda (e) (create-block day-date e)) short-events)))) - - -(define (lay-out-long-events start end events) - (fix-event-widths! events event-length-key: event-length - event-length-comperator: date/-time>) - (map (lambda (e) (create-top-block start end e)) - events)) - - -(define (time-marker-div) - ;; element to make rest of grid align correct. - ;; Could be extended to contain something fun. - `((div (@ (style "grid-row: 1 / span 2"))) - (div (@ (class "sideclock")) - ,@(map (lambda (time) - `(div (@ (class "clock clock-" ,time)) - (span (@ (class "clocktext")) - ,time ":00"))) - (iota 12 0 2))))) - - -(define*-public (render-calendar key: events start-date end-date #:allow-other-keys) - (let* ((long-events short-events (partition long-event? (stream->list (events-between start-date end-date events)))) - (range (date-range start-date end-date))) - `((div (@ (class "calendar")) - (div (@ (class "days")) - ,@(time-marker-div) - (div (@ (class "longevents event-container") - (data-start ,(date->string start-date) ) - (data-end ,(date->string (add-day end-date)) ) - (style "grid-column-end: span " ,(days-in-interval start-date end-date))) - ,@(lay-out-long-events start-date end-date long-events)) - ,@(map (lambda (day-date) - `(div (@ (class "meta")) - (span (@ (class "daydate")) - ,(date->string day-date "~Y-~m-~d")) - (span (@ (class "dayname")) - ,(string-titlecase (date->string day-date "~a"))))) - range) - ,@(stream->list - (stream-map - lay-out-day - (get-groups-between (group-stream (list->stream short-events)) - start-date end-date)))))))) - - - -;;; Table output - -(define (make-small-block event) - (make-block event)) - -(define (caltable-time-cells start-date end-date - pre-start post-end) - (map (lambda (day-date i) - `(div (@ (style "grid-area:time " ,i) - (class "cal-cell cal-cell-time")) - (a (@ (class "hidelink") - (href "/week/" ,(date->string day-date "~Y-~m-~d") - ".html#" ,(date->string day-date "~Y-~m-~d"))) - (time (@ (class "date-info " - ,(if (or (date< day-date start-date) - (date< end-date day-date)) - "non-current" - "current")) - (datetime ,(date->string day-date "~1"))) - (span (@ (class "day-number")) - ,(date->string day-date "~e")) - ,(when (= 1 (day day-date)) - `(span (@ (class "month-name")) - ,(date->string day-date "~b"))) - ,(when (= 1 (month day-date) (day day-date)) - `(span (@ (class "year-number")) - ", " ,(date->string day-date "~Y"))))))) - (date-range pre-start post-end) - (map floor (iota (length (date-range pre-start post-end)) 1 1/7)))) - -;; Natural numbers from 1 and up, each number repeated 7 times. -(define (repeating-naturals from repeats) - (stream-unfold - cdr ; map - (const #t) ; continue? - (lambda (x) ; gen next - (if (= (1- repeats) (car x)) - (cons 0 (1+ (cdr x))) - (cons (1+ (car x)) (cdr x)))) - (cons 0 from))) + #:use-module ((html view calendar week) + :select (render-calendar)) -;; (stream event-group) -> sxml -(define*-public (render-calendar-table key: events start-date end-date pre-start post-end #:allow-other-keys) + #:use-module ((html view calendar month) + :select (render-calendar-table)) - (define-values (long-events short-events) - ;; TODO should be really-long-event? or event-spanning-midnight - (partition really-long-event? (stream->list (events-between pre-start post-end events)))) - - (define short-event-groups - (get-groups-between (group-stream (list->stream short-events)) - pre-start post-end)) - - (define long-event-groups - (map (lambda (s) - (define e (date+ s (date day: 6))) - (cons* s e - (stream->list - (events-between s e (list->stream long-events))))) - (date-range pre-start post-end (date day: 7)))) - - `((header (@ (class "table-head")) - ,(string-titlecase (date->string start-date "~B ~Y"))) - (div (@ (class "caltable") - (style "grid-template-rows: 2em" - ,(string-concatenate - (map (lambda (long-group) - (format #f " [time] 15pt [long] ~amm [short] 1fr" - (min 10 (* 4 (length (cddr long-group)))))) - long-event-groups)))) - ,@(map (lambda (d) `(div (@ (class "thead")) ,(string-titlecase (week-day-name d)))) - (weekday-list (get-config 'week-start))) - ,@(map (lambda (group i) - (let* (((s e . events) group)) - `(div (@ (class "cal-cell longevents event-container") - (style "grid-area: long " ,i ";" - "grid-column: 1 / span 7;") - (data-start ,(date->string s)) - (data-end ,(date->string (add-day e)))) - ,@(lay-out-long-events - s e events)))) - long-event-groups - (iota (length long-event-groups) 1)) - - ,@(caltable-time-cells start-date end-date - pre-start post-end) - - ,@(stream->list - (stream-map - (lambda (group i) - (define day-date (car group)) - (define events (cdr group)) - `(div (@ (style "grid-area:short " ,i) - (class "cal-cell cal-cell-short event-container") - (data-start ,(date->string day-date)) - (data-end ,(date->string (add-day day-date)))) - (div (@ (style "overflow-y:auto;")) - ,@(map make-small-block (stream->list events))))) - short-event-groups - (repeating-naturals 1 7) - ))))) - - - - - -;; date should be start of month -;; @example -;; må ti on to fr lö sö -;; 1 2 3 4 5 6 7 -;; 8 9 10 11 12 13 14 -;; 15 16 17 18 19 20 21 -;; 22 23 24 25 26 27 28 -;; 29 30 -;; @end example -;; date - a date in the month to display -;; week-start - which day the week begins on, see (datetime util) -(define* (cal-table key: start-date end-date next-start prev-start - (week-start (get-config 'week-start))) - - (define (td date) - `(a (@ ,@(cond - ;; We are before our time interval - [(date< date start-date) - ;; TODO find a prettier way to generate links to previous and next time intervals - `((class "prev") - (href ,(date->string - (stream-find (lambda (d) (date<= d date (next-start d))) - (stream-iterate prev-start start-date)) - "~Y-~m-~d.html") - "#" ,(date-link date)))] - ;; We are after our time interval - [(date< end-date date) - `((class "next") - (href ,(date->string - (stream-find (lambda (d) (and (date<= d date) - (date< date (next-start d)))) - (stream-iterate next-start start-date)) - "~Y-~m-~d.html") - "#" ,(date-link date)))] - ;; We are in our time interval - [else `((href "#" ,(date-link date)))])) - ;; NOTE This time object is the correct place to show the existance - ;; of an event on a given day in this small calendar. For example - ;; making the text red for all holidays, or creating a yellow background - ;; for events from a specific source. - (time (@ (datetime ,(date->string date "~Y-~m-~d"))) ,(day date)))) - - (let* ((last-months current next - (month-days (start-of-month start-date) week-start)) - (events (append last-months current next))) - `(div (@ (class "small-calendar")) - (div (@ (class "column-head row-head")) "v.") - ,@(map (lambda (d) `(div (@ (class "column-head")) - ,(string-titlecase (week-day-name d 2)))) - (weekday-list week-start)) - ,@(let ((first (start-of-week (car events) week-start)) - (last (start-of-week (last events) week-start))) - (map (lambda (v) `(div (@ (class "row-head")) ,v)) - (map (lambda (d) (week-number d week-start)) - (stream->list - (stream-take-while (lambda (s) (date<= s last)) - (week-stream first)))))) - ,@(map td events - )))) - - - -;;; Main-stuff - - -;;; NOTE -;;; The side bar filters all earlier events for each day to not create repeats, -;;; and the html-generate procedure also filters, but instead to find earlier eventns. -;;; All this filtering is probably slow, and should be looked into. - -(define repo-url (make-parameter "https://git.hornquist.se")) - -(define*-public (html-generate - key: - (intervaltype 'all) ; 'week | 'month | 'all - calendars events start-date end-date - render-calendar ; (bunch of kv args) → (list sxml) - next-start ; date → date - prev-start ; date → date - ;; The pre and post dates are if we want to show some dates just - ;; outside our actuall interval. Primarily for whole month views, - ;; which needs a bit on each side. - (pre-start start-date) - (post-end end-date)) - - ;; NOTE maybe don't do this again for every month - (define evs (get-groups-between (group-stream events) - start-date end-date)) - - (define (nav-link display date) - `(a (@ (href ,(date->string date "~Y-~m-~d") ".html") - (class "nav hidelink")) - (div (@ (class "nav")) - ,display))) - - (unless next-start - (error 'html-generate "Next-start needs to be a procedure")) - - (unless prev-start - (error 'html-generate "Prev-start needs to be a procedure")) - - ;; (display "<!doctype HTML>\n") - (;;(@ (ice-9 pretty-print) pretty-print) - (@ (sxml simple) sxml->xml) - (xhtml-doc - (@ (lang sv)) - (head - (title "Calendar") - (meta (@ (charset "utf-8"))) - ;; (meta (@ (http-equiv "Content-Type") (content "application/xhtml+xml"))) - (meta (@ (name viewport) - (content "width=device-width, initial-scale=0.5"))) - (meta (@ (name description) - (content "Calendar for the dates between " - ,(date->string start-date) " and " - ,(date->string end-date)))) - ;; NOTE this is only for the time actually part of this calendar. - ;; overflowing times from pre-start and post-end is currently ignored here. - (meta (@ (name start-time) - (content ,(date->string start-date "~s")))) - (meta (@ (name end-time) - (content ,(date->string (date+ end-date (date day: 1)) "~s")))) - - (script - "EDIT_MODE=true;") - - (style ,(format #f "html { - --editmode: 1.0; - --event-font-size: 8pt; - --gray: #757575; - --btn-height: 0.5ex; -}")) - - ,(include-css "/static/style.css") - ,(include-alt-css "/static/dark.css" '(title "Dark")) - ,(include-alt-css "/static/light.css" '(title "Light")) - - (script (@ (defer) (src "/static/script.js"))) - ,(calendar-styles calendars)) - - (body - (div (@ (class "root")) - (main - ;; Actuall calendar - (@ (style "grid-area: main")) - ,@(render-calendar calendars: calendars - events: events - start-date: start-date - end-date: end-date - pre-start: pre-start - post-end: post-end - next-start: next-start - prev-start: prev-start - ) - - ,@(for event in (stream->list - (events-between pre-start post-end events)) - (popup event (string-append "popup" (html-id event))))) - - ;; Page footer - (footer - (@ (style "grid-area: footer")) - (span "Page generated " ,(date->string (current-date))) - (span (a (@ (href ,(repo-url) "/calparse")) - "Source Code")) - ,(let* ((long-hash short-hash (get-git-version)) - (url (format #f "~a/calparse/commit/?id=~a" - (repo-url) long-hash))) - `(span "Version " (a (@ (href ,url)) ,short-hash)))) - - ;; Small calendar and navigation - (nav (@ (class "calnav") (style "grid-area: nav")) - (div (@ (class "change-view")) - ,(btn href: (date->string - (if (= 1 (day start-date)) - (start-of-week start-date (get-config 'week-start)) - start-date) - "/week/~1.html") - "veckovy") - - ,(btn href: (date->string (set (day start-date) 1) "/month/~1.html") - "månadsvy") - - ,(btn id: "today-button" - href: (string-append - "/today?" (case intervaltype - [(month) "view=month"] - [(week) "view=week"] - [else ""])) - "idag")) - - (div (@ (id "jump-to")) - ;; Firefox's accessability complain about each date - ;; component, meaning that it's broken. This label - ;; is for the whole input, which can be enabled - ;; if wanted. - ;; (label (@ (for "date")) "Hoppa till") - (form (@ (action "/today")) - (input (@ (type hidden) - (name "view") - (value ,(case intervaltype - [(month week) => symbol->string] - [else "month"])))) - (input (@ (type date) - (name "date") - (value ,(date->string start-date "~1")))) - ,(btn "➔")))) - - (details (@ (open) (style "grid-area: cal")) - (summary "Month overview") - (div (@ (class "smallcall-head")) - ,(string-titlecase (date->string start-date "~B ~Y"))) - ;; NOTE it might be a good idea to put the navigation buttons - ;; earlier in the DOM-tree/tag order. At least Vimium's - ;; @key{[[} keybind sometimes finds parts of events instead. - (div (@ (class "smallcal")) - ;; prev button - ,(nav-link "«" (prev-start start-date)) - - ;; calendar table - (div ,(cal-table start-date: start-date end-date: end-date - next-start: next-start - prev-start: prev-start - )) - - ;; next button - ,(nav-link "»" (next-start start-date)))) - - - (div (@ (style "grid-area: details")) - ,(when (or (debug) (edit-mode)) - `(details (@ (class "sliders")) - (summary "Option sliders") - - - ,@(when (edit-mode) - `((label "Event blankspace") - ,(slider-input - variable: "editmode" - min: 0 - max: 1 - step: 0.01 - value: 1))) - - ,@(when (debug) - `((label "Fontsize") - ,(slider-input - unit: "pt" - min: 1 - max: 20 - step: 1 - value: 8 - variable: "event-font-size"))))) - - ;; List of calendars - (details (@ (class "calendarlist")) - (summary "Calendar list") - (ul ,@(map - (lambda (calendar) - `(li (@ (class "CAL_bg_" - ,(html-attr (prop calendar 'NAME)))) - ,(prop calendar 'NAME))) - calendars)))) - - ;; List of events - (div (@ (class "eventlist") - (style "grid-area: events")) - ;; Events which started before our start point, - ;; but "spill" into our time span. - (section (@ (class "text-day")) - (header (h2 "Tidigare")) - ,@(stream->list - (stream-map - fmt-single-event - (stream-take-while - (compose (cut date/-time<? <> start-date) - (extract 'DTSTART)) - (cdr (stream-car evs)))))) - ,@(stream->list (stream-map fmt-day evs)))) - - ;; This would idealy be a <template> element, but there is some - ;; form of special case with those in xhtml, but I can't find - ;; the documentation for it. - ,@(let* ((cal (vcalendar - name: "Generated" - children: (list (vevent - ;; The event template SHOULD lack - ;; a UID, to stop potential problems - ;; with conflicts when multiple it's - ;; cloned mulitple times. - dtstart: (datetime) - dtend: (datetime) - summary: "New Event")))) - (event (car (children cal)))) - `((div (@ (class "template event-container") (id "event-template") - ;; Only needed to create a duration. So actual dates - ;; dosen't matter - (data-start "2020-01-01") - (data-end "2020-01-02")) - ,(caddar ; strip <a> tag - (make-block event `((class " generated "))))) - (div (@ (class "template") (id "popup-template")) - ,(popup event (string-append "popup" (html-id event)))))))))) + #:autoload (vcomponent instance) (global-event-object) + ) diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm index 51671985..eda379a7 100644 --- a/module/srfi/srfi-41/util.scm +++ b/module/srfi/srfi-41/util.scm @@ -77,6 +77,18 @@ (define-public (stream->values stream) (apply values (stream->list stream))) + +;; Natural numbers from 1 and up, each number repeated 7 times. +(define-public (repeating-naturals from repeats) + (stream-unfold + cdr ; map + (const #t) ; continue? + (lambda (x) ; gen next + (if (= (1- repeats) (car x)) + (cons 0 (1+ (cdr x))) + (cons (1+ (car x)) (cdr x)))) + (cons 0 from))) + ;; Returns two values. A stream of all the elements in stream ;; which satisfiy @var{pred}, and a stream of those elements ;; that don't. @var{pred} is called once per value in the |