schedule/app.scm

(import chicken scheme srfi-1)
(use awful
     (only waffle waffle-sxml->html add-widget get-widget widgets widget-rules)
     numbers scss spiffy-request-vars format)

;; Widgets are like composable HTML templates but with SXML
(include "widgets") ; common web app widgets

;; Needed for interactive development because widgets are thread local
(define (waffle-sxml->html* sxml)
  (parameterize ((widgets *widgets*) (widget-rules *widget-rules*))
    (waffle-sxml->html sxml)))

;; Standardize all pages
(define (defpage path thunk)
  (define-page path (lambda ()
                      (with-output-to-string
                        (lambda ()
                          (waffle-sxml->html* (thunk)))))
    headers: (with-output-to-string
               (lambda ()
                 (waffle-sxml->html*
                  `((stylesheet (@ (path "normalize.css")))
                    (stylesheet (@ (path "foundation.min.css")))
                    (stylesheet (@ (path "app.css")))
                    ))))
    no-session: #t))

(widget
 'menu
 ``(group-box (@ (title ,title))
              ,@(map (lambda (n)
                       `((a (@ (href ,(conc "/?type=" type "&n=" n))) ,n)
                         (br) (br)))
                     (iota len)))
 '((title "") (type "none") (len 0)))

(widget
 'menu-bar
 ``(div
    (menu (@ (title "Investors") (type i) (len ,len-i)))
    (menu (@ (title "Companies") (type c) (len ,len-c))))
 '((len-i 0) (len-c 0)))

(widget
 'schedule-table
 ``(group-box
    (@ (title ,title))
    (cols (div
           (h5 "Schedule")
           (table (@ (class "schedule"))
                  (tr (th "Time") (th "Meeting with"))
                  ,@contents))))
 '((title "")))

(widget
 'shuffle-bar
 ``(cols (center
          (form (@ (action "/shuffle"))
                (button (@ (type "submit") (class "small")) "Shuffle"))))
 '())

;; add support for defaults to request variables
(define ((as-number/default default) var vars/vals)
  (or (as-number var vars/vals) default))
(define ((as-symbol/default default) var vars/vals)
  (or (as-symbol var vars/vals) default))

;;;;;; PAGES ;;;;;;

;; NOTE: company and investor relations are stored in a-lists where
;; the symbol 'i references an investor, 'c a company, and 's a score.
(defpage "/"
  (lambda ()
    (define (time t)
      (let* ((rem (remainder t 60))
             (hr (/ (- t rem) 60)))
        (format "~2D:~2,'0D" hr rem)))
    (define (schedule-for type n)
      (map (lambda (round) (find (lambda (x) (eq? (alist-ref type x) n)) round)) *schedule*))
    (define (slot type meeting t)
      `(tr (td ,(time t)) (td ,(if meeting (alist-ref type meeting) '-))))
    (define (type-title t) (if (eq? t 'c) "Company" "Investor"))

    (with-request-vars ((n (as-number/default 0)) (type (as-symbol/default 'c)))
      (let ((start-time (* 9 60)))
        `((row
           (col (@ (width 3))
                (menu-bar (@ (len-i ,(length *investors*))
                             (len-c ,(length *companies*))))
                (shuffle-bar))
           (col (@ (width 9))
                (schedule-table
                 (@ (title ,(conc (type-title type) " " n)))
                 ,@(let ((schedules (schedule-for type n)))
                     (map (lambda (schedule t)
                            (slot (if (eq? type 'c) 'i 'c) schedule t))
                          schedules
                          (iota (length schedules) start-time 20)))))))))))

(define-page "/shuffle"
  (lambda ()
    (regen-schedule)
    (redirect-to "/?type=c&n=0"))
  no-session: #t)

(define (run-awful) ; for emacs interactive development
  (thread-start!
   (lambda ()
     (awful-start (lambda () (void)) port: 8080))))

;;;;;; CSS ;;;;;;
(define (scss->file path scss)
  (with-output-to-file path
    (lambda () (write-css scss))))

(scss->file
 "res/css/app.css"
 '(css+
   ((.schedule li) (white-space pre))))


;;;;;; Scheduling ;;;;;;
(define (shuffle! v)
  (do ((n (vector-length v) (- n 1)))
      ((zero? n) v)
    (let* ((r (random n)) (t (vector-ref v r)))
      (vector-set! v r (vector-ref v (- n 1)))
      (vector-set! v (- n 1) t))))

(define (gen-ranks n)
  (vector->list (shuffle! (list->vector n))))

;; randomly generate lists of rankings
(define (gen-ranks-list n)
  (map (lambda (i) (gen-ranks (iota n))) (iota n)))

;; map ranking lists to companies and investors
;; score the combination by adding ranks together
;; higher is better.
;; As noted earlier: 'i == investor and 'c == company,
;; 's == score.
(define (score companies investors)
  (map (lambda (c i)
         (map (lambda (j)
                `((c . ,i)
                  (i . ,j)
                  (s .
                     ,(+ (list-ref (list-ref investors j) i)
                         (list-ref c j)))))
              (iota (length companies))))
       companies (iota (length investors))))

(define (sort-scores companies investors)
  (map
   (lambda (company)
     (sort
      company
      (lambda (x1 x2)
        (> (alist-ref 's x1) (alist-ref 's x2)))))
   (score companies investors)))

;; greedily find best match and return unmatched combinations
(define (match/remainder taken ranks)
  (let ((mtch (find (lambda (x) (not (memq (alist-ref 'i x) taken))) ranks)))
    (receive (head tail) (span (lambda (x) (not (eq? x mtch))) ranks)
      (if (null? tail)
          (values #f head) ; no match found
          (values (car tail) (append head (cdr tail)))))))

(define (allocate-round ranks)
 (let loop ((taken '()) (matches '()) (ranks ranks) (left '()))
   (if (null? ranks)
       (values (reverse matches) (reverse left))
       (receive (mtch rem) (match/remainder taken (car ranks))
         (if mtch
             (loop (cons (alist-ref 'i mtch) taken)
                   (cons mtch matches) (cdr ranks) (cons rem left))
             (loop taken matches (cdr ranks) (cons rem left)))))))

(define (make-schedule ranks)
  (let loop ((ranks ranks) (matches '()))
    (if (null? ranks)
        (reverse matches)
        (receive (mtchs new-ranks) (allocate-round ranks)
          (if (null? mtchs)
              (reverse matches)
              (loop new-ranks (cons mtchs matches)))))))

(define *schedule* '())
(define *companies* '())
(define *investors* '())

(define (regen-schedule)
  (set! *companies* (gen-ranks-list 10))
  (set! *investors* (gen-ranks-list 10))
  (set! *schedule* (make-schedule (sort-scores *companies* *investors*))))
(regen-schedule)