add plt-bacon easter egg

pasterack.rkt

@@ -43,7 +43,7 @@
 ;irc bot
 (define-values (irc-connection ready)
 ;  (irc-connect "card.freenode.net" 6667 "pasterackm" "pasterackm" "pasterack.org mirror"))
-  (irc-connect "card.freenode.net" 6667 "pasterack" "pasterack" "pasterack.org"))
+  (irc-connect "chat.freenode.net" 6667 "pasterack" "pasterack" "pasterack.org"))
 (sync ready)
 ;(define irc-channels '("#racktest"))
 (define irc-channels '("#racket"))
@@ -699,11 +699,13 @@
                  (table ((style "margin-top:-15px;font-size:95%"))
                         ,@test-cases-htmls))))))
 
+(require "plt-bacon.rkt")
 (define-values (do-dispatch mk-url)
   (dispatch-rules
    [("") serve-home]
    [("pastes" (string-arg)) serve-paste]
    [("tests") serve-tests]
+   [("bacon") serve-bacon]
    #;[else serve-home]))
 
 

plt-bacon.rkt

@@ -0,0 +1,196 @@
+#lang racket
+(require 
+  web-server/servlet web-server/servlet-env
+  web-server/formlets web-server/formlets/servlet
+  net/url
+  graph)
+
+;; scrape data ----------------------------------------------------------------
+(define PLT-PUBS-URL (string->url "http://www.ccs.neu.edu/racket/pubs/"))
+(define neu-pubs-port (get-pure-port PLT-PUBS-URL))
+;(define neu-pubs-port (open-input-file "plt-pubs.html"))
+
+(define name-pat "([A-Z][a-z\\-]+\\s?)+")
+(define word-pat "([A-Za-z\\-]+\\s?)+")
+(define names-pat (string-append "(" name-pat ",\\s)+" name-pat))
+(define title-pat (string-append "(?<=<cite>)\\s+(" word-pat ")+"))
+(define authors-px 
+  (pregexp 
+   (string-append "(?<=:|<div>)\\s*" names-pat ".+?" title-pat)))
+
+(define matches (regexp-match* authors-px neu-pubs-port))
+
+;; authors+title : [Listof author-string ... title-string]
+(define authors+title
+  (for/list ([authors matches])
+    (define as+title 
+      (string-split (string-trim (bytes->string/utf-8 authors)) #px",\\s+"))
+    (define last-auth+title 
+      (car (reverse as+title)))
+    (define first-authors 
+      (reverse (cdr (reverse as+title))))
+    (define last-auth+title-match 
+      (regexp-split #px"\\s+<br />|\\s+<cite>" last-auth+title))
+    (define as+t
+      (append first-authors 
+              (list (first last-auth+title-match)
+                    (string-trim (car (reverse last-auth+title-match))))))
+    as+t))
+
+;; populate graph -------------------------------------------------------------
+(define PLT-GRAPH (unweighted-graph/undirected null))
+(define-edge-property PLT-GRAPH papers)
+
+(for ([as+t authors+title])
+  (define authors (cdr (reverse as+t)))
+  (define title (car (reverse as+t)))
+  (for* ([auth1 authors]
+         [auth2 authors]
+         #:unless (string=? auth1 auth2))
+    (define papers-curr (papers auth1 auth2 #:default null))
+    (add-edge! PLT-GRAPH auth1 auth2)
+    (papers-set! auth1 auth2 (cons title papers-curr))))
+
+;; print to stdout ------------------------------------------------------------
+#;(define (plt-bacon auth erdos bacon)
+  (define erdos-path (fewest-vertices-path PLT-GRAPH auth erdos))
+  (define bacon-path (fewest-vertices-path PLT-GRAPH auth bacon))
+  ;; print erdos path
+  (for ([a1 erdos-path]
+        [a2 (cdr erdos-path)])
+    (printf "~a co-authored with ~a:\n" a1 a2)
+    (for ([p (papers a1 a2)])
+      (printf "  ~a\n" p)))
+  (define erdos-num (sub1 (length erdos-path)))
+  (printf "\n** ~a's ~a-number is: ~a\n\n" auth erdos erdos-num)
+  ;; print bacon path
+  (for ([a1 bacon-path]
+        [a2 (cdr bacon-path)])
+    (printf "~a co-authored with ~a:\n" a1 a2)
+    (for ([p (papers a1 a2)])
+      (printf "  ~a\n" p)))
+  (define bacon-num (sub1 (length bacon-path)))
+  (printf "\n** ~a's ~a-number is: ~a\n\n" auth bacon bacon-num)
+  (printf "## ~a's ~a-~a-number is: ~a\n"
+          auth erdos bacon
+          (+ erdos-num bacon-num)))
+  
+;; html output ----------------------------------------------------------------
+(define (plt-bacon-html auth erdos bacon)
+  (define erdos-path (fewest-vertices-path PLT-GRAPH auth erdos))
+  (define bacon-path (fewest-vertices-path PLT-GRAPH auth bacon))
+  (define erdos-num (sub1 (length erdos-path)))
+  (define bacon-num (sub1 (length bacon-path)))
+  `(table
+    (tr "Computed "
+        (i ,auth)
+        "'s "
+        (b ,erdos) "-" (b ,bacon) " number:")
+    (tr (br) (hr))
+    (tr
+     ;; print erdos path
+     ,@(for/list ([a1 erdos-path]
+                  [a2 (cdr erdos-path)])
+         `(table (tr (i ,(format "~a" a1))
+                     " co-authored with "
+                     (i ,(format "~a" a2))
+                     ":")
+                 (tr (ul
+                 ,@(for/list ([p (papers a1 a2)])
+                     `(li ,(format "~a" p))))))))
+    (tr "** "
+        (i ,(format "~a" auth))
+        "'s "
+        (b ,(format "~a" erdos))
+        "-number is: "
+        (b ,(format "~a" erdos-num)))
+    (tr (br) (hr))
+    (tr (br))
+    (tr
+    ;  ;; print bacon path
+    ,@(for/list ([a1 bacon-path]
+                 [a2 (cdr bacon-path)])
+         `(table (tr (i ,(format "~a" a1))
+                     " co-authored with "
+                     (i ,(format "~a" a2))
+                     ":")
+                (tr (ul
+                     ,@(for/list ([p (papers a1 a2)])
+                         `(li ,(format "~a" p))))))))
+    (tr "** "
+        (i ,(format "~a" auth))
+        "'s "
+        (b ,(format "~a" bacon))
+        "-number is: "
+        (b ,(format "~a" bacon-num)))
+    (tr (br) (hr))
+    (tr (br))
+    (tr
+        "## "
+        (i ,(format "~a" auth))
+        "'s "
+        (b ,(format "~a-~a" erdos bacon))
+        "-number is: "
+        (b ,(format "~a" (+ erdos-num bacon-num))))
+    (tr (br) (hr))))
+
+;;-----------------------------------------------------------------------------
+;; web server front end
+
+(define author-choices 
+  (sort
+   (filter-not 
+    (λ (v) (regexp-match #px"and\\s|b>|Felleisen\\." v))
+    (get-vertices PLT-GRAPH))
+   string<?))
+(define author-formlet
+  (formlet*
+   `(div
+     (div "Author Name: "
+          ,{(select-input
+             author-choices
+             #:selected? (lambda (x) (string=? x "Chang")))
+            . =>* . author})
+     (div "\"Bacon\": "
+          ,{(select-input
+             author-choices
+             #:selected? (lambda (x) (string=? x "Felleisen")))
+            . =>* . bacon})
+     (div "\"Erdos\": "
+          ,{(select-input
+             author-choices
+             #:selected? (lambda (x) (string=? x "Flatt")))
+            . =>* . erdos})
+     (div ,{(submit "Compute!") . =>* . res}))
+   ;(list author erdos bacon)))
+   ;; Q: Why is author etc a list?
+   (let ([response-gen
+          (λ (embed/url)
+            (response/xexpr
+             `(html
+               (title "Results")
+               (body (h1 "Results")
+                     (div ,(plt-bacon-html (car author) (car bacon) (car erdos)))
+                     (br) (br)
+                     (a ([href ,(embed/url serve-bacon)]) "Start Again")))))])
+     (send/suspend/dispatch response-gen))))
+   
+;(define (start request) (serve-bacon request))
+
+(provide serve-bacon)
+(define (serve-bacon request)
+  (define (response-generator embed/url)
+    (response/xexpr
+     `(html
+       (head (title "PLT Bacon"))
+       (body (h1 "PLT Bacon")
+             (img ([src "plt-bacon.png"]))
+             ,(embed-formlet embed/url author-formlet)))))
+  (send/suspend/dispatch response-generator))
+
+
+#;(serve/servlet start
+               #:launch-browser? #t
+               #:quit? #f
+               #:listen-ip #f
+               #:port 8000)