tjhintz
/
schedule
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial.

Browse Source
master
Thomas Hintz 8 years ago
commit 1adff7d035
5 changed files with 720 additions and 0 deletions
Show Stats Download Patch File Download Diff File

198
app.scm
Unescape Escape View File

@ -0,0 +1,198 @@
(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)

1
res/css/app.css
Unescape Escape View File

@ -0,0 +1 @@
.schedule, li { white-space: pre }

1
res/css/foundation.min.css vendored
View File

File diff suppressed because one or more lines are too long

423
res/css/normalize.css vendored
Unescape Escape View File

@ -0,0 +1,423 @@
/*! normalize.css v3.0.0 | MIT License | git.io/normalize */
/**
* 1. Set default font family to sans-serif.
* 2. Prevent iOS text size adjust after orientation change, without disabling
* user zoom.
*/
html {
font-family: sans-serif; /* 1 */
-ms-text-size-adjust: 100%; /* 2 */
-webkit-text-size-adjust: 100%; /* 2 */
}
/**
* Remove default margin.
*/
body {
margin: 0;
}
/* HTML5 display definitions
========================================================================== */
/**
* Correct `block` display not defined in IE 8/9.
*/
article,
aside,
details,
figcaption,
figure,
footer,
header,
hgroup,
main,
nav,
section,
summary {
display: block;
}
/**
* 1. Correct `inline-block` display not defined in IE 8/9.
* 2. Normalize vertical alignment of `progress` in Chrome, Firefox, and Opera.
*/
audio,
canvas,
progress,
video {
display: inline-block; /* 1 */
vertical-align: baseline; /* 2 */
}
/**
* Prevent modern browsers from displaying `audio` without controls.
* Remove excess height in iOS 5 devices.
*/
audio:not([controls]) {
display: none;
height: 0;
}
/**
* Address `[hidden]` styling not present in IE 8/9.
* Hide the `template` element in IE, Safari, and Firefox < 22.
*/
[hidden],
template {
display: none;
}
/* Links
========================================================================== */
/**
* Remove the gray background color from active links in IE 10.
*/
a {
background: transparent;
}
/**
* Improve readability when focused and also mouse hovered in all browsers.
*/
a:active,
a:hover {
outline: 0;
}
/* Text-level semantics
========================================================================== */
/**
* Address styling not present in IE 8/9, Safari 5, and Chrome.
*/
abbr[title] {
border-bottom: 1px dotted;
}
/**
* Address style set to `bolder` in Firefox 4+, Safari 5, and Chrome.
*/
b,
strong {
font-weight: bold;
}
/**
* Address styling not present in Safari 5 and Chrome.
*/
dfn {
font-style: italic;
}
/**
* Address variable `h1` font-size and margin within `section` and `article`
* contexts in Firefox 4+, Safari 5, and Chrome.
*/
h1 {
font-size: 2em;
margin: 0.67em 0;
}
/**
* Address styling not present in IE 8/9.
*/
mark {
background: #ff0;
color: #000;
}
/**
* Address inconsistent and variable font size in all browsers.
*/
small {
font-size: 80%;
}
/**
* Prevent `sub` and `sup` affecting `line-height` in all browsers.
*/
sub,
sup {
font-size: 75%;
line-height: 0;
position: relative;
vertical-align: baseline;
}
sup {
top: -0.5em;
}
sub {
bottom: -0.25em;
}
/* Embedded content
========================================================================== */
/**
* Remove border when inside `a` element in IE 8/9.
*/
img {
border: 0;
}
/**
* Correct overflow displayed oddly in IE 9.
*/
svg:not(:root) {
overflow: hidden;
}
/* Grouping content
========================================================================== */
/**
* Address margin not present in IE 8/9 and Safari 5.
*/
figure {
margin: 1em 40px;
}
/**
* Address differences between Firefox and other browsers.
*/
hr {
-moz-box-sizing: content-box;
box-sizing: content-box;
height: 0;
}
/**
* Contain overflow in all browsers.
*/
pre {
overflow: auto;
}
/**
* Address odd `em`-unit font size rendering in all browsers.
*/
code,
kbd,
pre,
samp {
font-family: monospace, monospace;
font-size: 1em;
}
/* Forms
========================================================================== */
/**
* Known limitation: by default, Chrome and Safari on OS X allow very limited
* styling of `select`, unless a `border` property is set.
*/
/**
* 1. Correct color not being inherited.
* Known issue: affects color of disabled elements.
* 2. Correct font properties not being inherited.
* 3. Address margins set differently in Firefox 4+, Safari 5, and Chrome.
*/
button,
input,
optgroup,
select,
textarea {
color: inherit; /* 1 */
font: inherit; /* 2 */
margin: 0; /* 3 */
}
/**
* Address `overflow` set to `hidden` in IE 8/9/10.
*/
button {
overflow: visible;
}
/**
* Address inconsistent `text-transform` inheritance for `button` and `select`.
* All other form control elements do not inherit `text-transform` values.
* Correct `button` style inheritance in Firefox, IE 8+, and Opera
* Correct `select` style inheritance in Firefox.
*/
button,
select {
text-transform: none;
}
/**
* 1. Avoid the WebKit bug in Android 4.0.* where (2) destroys native `audio`
* and `video` controls.
* 2. Correct inability to style clickable `input` types in iOS.
* 3. Improve usability and consistency of cursor style between image-type
* `input` and others.
*/
button,
html input[type="button"], /* 1 */
input[type="reset"],
input[type="submit"] {
-webkit-appearance: button; /* 2 */
cursor: pointer; /* 3 */
}
/**
* Re-set default cursor for disabled elements.
*/
button[disabled],
html input[disabled] {
cursor: default;
}
/**
* Remove inner padding and border in Firefox 4+.
*/
button::-moz-focus-inner,
input::-moz-focus-inner {
border: 0;
padding: 0;
}
/**
* Address Firefox 4+ setting `line-height` on `input` using `!important` in
* the UA stylesheet.
*/
input {
line-height: normal;
}
/**
* It's recommended that you don't attempt to style these elements.
* Firefox's implementation doesn't respect box-sizing, padding, or width.
*
* 1. Address box sizing set to `content-box` in IE 8/9/10.
* 2. Remove excess padding in IE 8/9/10.
*/
input[type="checkbox"],
input[type="radio"] {
box-sizing: border-box; /* 1 */
padding: 0; /* 2 */
}
/**
* Fix the cursor style for Chrome's increment/decrement buttons. For certain
* `font-size` values of the `input`, it causes the cursor style of the
* decrement button to change from `default` to `text`.
*/
input[type="number"]::-webkit-inner-spin-button,
input[type="number"]::-webkit-outer-spin-button {
height: auto;
}
/**
* 1. Address `appearance` set to `searchfield` in Safari 5 and Chrome.
* 2. Address `box-sizing` set to `border-box` in Safari 5 and Chrome
* (include `-moz` to future-proof).
*/
input[type="search"] {
-webkit-appearance: textfield; /* 1 */
-moz-box-sizing: content-box;
-webkit-box-sizing: content-box; /* 2 */
box-sizing: content-box;
}
/**
* Remove inner padding and search cancel button in Safari and Chrome on OS X.
* Safari (but not Chrome) clips the cancel button when the search input has
* padding (and `textfield` appearance).
*/
input[type="search"]::-webkit-search-cancel-button,
input[type="search"]::-webkit-search-decoration {
-webkit-appearance: none;
}
/**
* Define consistent border, margin, and padding.
*/
fieldset {
border: 1px solid #c0c0c0;
margin: 0 2px;
padding: 0.35em 0.625em 0.75em;
}
/**
* 1. Correct `color` not being inherited in IE 8/9.
* 2. Remove padding so people aren't caught out if they zero out fieldsets.
*/
legend {
border: 0; /* 1 */
padding: 0; /* 2 */
}
/**
* Remove default vertical scrollbar in IE 8/9.
*/
textarea {
overflow: auto;
}
/**
* Don't inherit the `font-weight` (applied by a rule above).
* NOTE: the default cannot safely be changed in Chrome and Safari on OS X.
*/
optgroup {
font-weight: bold;
}
/* Tables
========================================================================== */
/**
* Remove most spacing between table cells.
*/
table {
border-collapse: collapse;
border-spacing: 0;
}
td,
th {
padding: 0;
}

97
widgets.scm
Unescape Escape View File

@ -0,0 +1,97 @@
(define *widgets* (widgets))
(define *widget-rules* (widget-rules))
(define-syntax with-widgets
(syntax-rules ()
((_ widgets* widget-rules* body ...)
(parameterize ((widgets widgets*) (widget-rules widget-rules*))
body ...))))
;; Make defining widgets less cumbersome and prevent conflicting
;; transform definitions that are hard to debug.
(define (widget name _markup _attributes)
(parameterize ((widgets *widgets*) (widget-rules *widget-rules*))
(add-widget name `((markup . `(*TOP* ,(begin (use uri-common) ,_markup)))
(attributes . ,_attributes))
(interaction-environment))
(set! *widgets* (widgets))
(set! *widget-rules* (widget-rules))))
(widget
'stylesheet
``(link (@ (href ,(string-append "/res/css/" path)) (type "text/css")
(rel "stylesheet")))
'((path "")))
(widget
'row
``(div (@ (class ,(conc "row" (if full-width " full-width " "")
(if padding "" " collapse ")))) ,@contents)
'((full-width #f) (padding #t)))
(widget
'col
``(div (@ (class ,(conc "column small-" width)) ,@attrs) ,@contents)
'((width 1) (attrs ())))
(widget
'cols
`(let ((class (++ "column small-" (number->string
(inexact->exact (round (/ 12 (length contents))))))))
`(div (@ (class ,(conc "row" (if full-width " full-width" ""))))
,@(map (lambda (col)
`(div (@ (class ,class)) ,col))
contents)
,(if fill-row `(div (@ (class "column end"))) "")))
'((fill-row #t) (full-width #f)))
(widget
'panel
``(div (@ (class "panel")) ,@contents)
'())
(widget
'panel-small
``(div (@ (class "panel panel-small") ,@attrs) ,@contents)
'((attrs '())))
(widget
'text-center
``(div (@ (class "text-center")) ,@contents)
'())
(widget
'group-box
``(div (@ (class "panel group-box"))
(h4 (@ (class "group-box-title")) ,title)
,@contents)
'((title "")))
(widget
'radio-button
``(label (input (@ (type "radio") (name ,name))) ,label)
'((name "radio1") (label "radio1")))
(widget
'spacer
``(div (@ (class "spacer")) ,@contents)
'())
(widget
'modal
``(div (@ (class "modal-overlay"))
(div (@ (class "modal-content"))
,@contents))
'())
(widget
'include-javascript
``(script (@ (language "javascript") (type "text/javascript")
(src ,(conc "/res/js/" (car contents)))))
'())
(widget
'spock-scripts
``(include-javascript "spock-runtime-debug.js")
'())
Write Preview
Loading…
Cancel
Save