You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

199 lines
6.3 KiB
Scheme

(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)))
;; 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)
(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)