;stylesheet.scm ;Sterling Stuart Stein ;Apply the template for LingCog webpage ;http://lingcog.iit.edu/ ;Module description (module stylesheet (main main) (library sxml) (include "stylesheet.sch") (from (stylesheet-bibtex "bibtex.scm") (stylesheet-const "const.scm") ) ) (define (display-header) (print " ") ) (define (navitem color name link myname) `("th" (("style". ,(string-append "background: #" color ";"))) ,(if (equal? name myname) name `("a" (("href". ,(string-append "/" link))) ,name ) ) ) ) (define (apply-page root branch templates param position) (let-attr branch (name color1 color2 fcolor1 fcolor2) `("html" (("xmlns"."http://www.w3.org/1999/xhtml")) ("head" () ("meta" ( ("http-equiv"."Content-Type") ("content"."application/xhtml+xml; charset=iso-8859-1") ) ) ("link" (("rel"."SHORTCUT ICON") ("href"."/favicon.ico") ("type"."image/png"))) ("title" () "Linguistic Cognition Laboratory -- " ,name) ("style" (("type"."text/css")) "\n" ".color1 {\n" ,(if (equal? color1 "") "" (string-append " background: " color1 ";\n") ) ,(if (equal? fcolor1 "") "" (string-append " color: " fcolor1 ";\n") ) "}\n\n" ".color2 {\n" ,(if (equal? color2 "") "" (string-append " background: " color2 ";\n") ) ,(if (equal? fcolor2 "") "" (string-append " color: " fcolor2 ";\n") ) "}\n\n" ".half {\nwidth: 50%;\n}\n\n" "img {\nborder: 0;\n}\n\n" ".toc li {\n" "float: left;\n" "margin: .2em;\n" "width: 18%;\n" "overflow: hidden;\n" "}\n\n" ) ) ("body" () ("table" (("width"."100%")) ;Name and logo ("tr" () ("td" () ("table" (("width"."100%")) ("tr" () ("td" (("valign"."middle")) ("a" (("href"."http://www.iit.edu/")) ("img" (("src"."/img/iitlogo.png") ("alt"."IIT logo"))) ) ) ("td" (("valign"."middle")) ("h1" (("style"."text-align: center;")) "IIT Linguistic Cognition Laboratory" ) ) ("td" (("valign"."middle")) ("a" (("href"."http://lingcog.iit.edu/")) ("img" (("src"."/img/llclogo.png") ("alt"."LCL logo"))) ) ) ) ) ) ) ;Navigation bar ("tr" () ("td" () ("table" (("width"."100%")) ("tr" () ,(navitem "FFC0C0" "Welcome" "" name) ,(navitem "FFE0C0" "News" "news.xml" name) ,(navitem "FFFFC0" "People" "people.xml" name) ,(navitem "C0FFC0" "Publications" "pub_year.xml" name) ,(navitem "C0FFFF" "Downloads" "download.xml" name) ,(navitem "FFC0FF" "Links" "links.xml" name) ) ) ) ) "\n" ;The main part of the body ;append-list because grouping in project returns ;multiple separate items, which get joined together. ;This is also why the other possible matches ;have to be an extra level deep. ,@(append-list (apply-templates-children root branch templates param)) ;The footer "\n" ("tr" () ("td" (("style"."text-align: center;")) "Laboratory of Linguistic Cognition webpage" ("br" ()) "maintained by " ("a" (("href"."http://www.iit.edu/~kbloom1/")) "Kenneth Bloom" ) "." ("br" ()) "If there are any problems or questions, please " ("a" (("href"."feedback.xml")) "contact me" ) "." ("br" ()) ("a" (("href"."http://www.anybrowser.org/campaign/")) ("img" ( ("src"."/img/anybrow.png") ("alt"."Works with any browser") ) ) ) ) ) ) ) ) ) ) (define (apply-item root branch templates param position) `( ("tr" ( ( "class" . ,(if (= 0 (modulo position 2)) "color1" "color2") ) ) "\n" ("td" () ,@(append-list (apply-templates-children root branch templates '())) ) ) ) ) (define (apply-label root branch templates param position) `( ("h2" () ("a" (("id" . ,(cleanlabel (value-of-text branch)))) "\n") ,@(get-children branch) ) ) ) (define (apply-text root branch templates param position) (let ((applied (apply-templates-children root branch templates param))) (if (pair? applied) applied (get-children branch) ) ) ) (define (apply-people root branch templates param position) (let* ( (value-of-role (make-value-of-select (equals-tag-name "role") value-of-text) ) (criteria (make-comparison-int (list (make-comparison-number-int (make-value-of-first value-of-role)) ) ) ) (grouping (group-by (get-children branch) value-of-role)) (grouped (map (lambda (x) `("item" () ("label" () ,(case (string->number (value-of-role (car x))) ;Mumble mumble C64 BASIC attack ((10) "Director") ((20) "Students") ((30) "Visiting Scholars") ((40) "Affiliated Faculty") ((50) "Affiliated Students") ((60) "Collaborators") ((70) "Alumni") (else "Other") ) ) ("text" () ("people1" () . ,x) ) ) ) (sort grouping criteria) ) ) ) (append-list (apply-templates-list root grouped templates param)) ) ) (define (apply-people1 root branch templates param position) (let* ( (vo-lastname (make-value-of-select (equals-tag-name "lastname") value-of-text) ) (vo-firstname (make-value-of-select (equals-tag-name "firstname") value-of-text) ) (criteria (make-comparison-int (list (make-comparison-string-int vo-lastname) (make-comparison-string-int vo-firstname) ) ) ) (sorted (connect-tag branch (sort (get-children branch) criteria))) ) `("table" (("width"."100%")) ,@(apply-templates-children root sorted templates param) ) ) ) (define (apply-person root branch templates param position) (let-child branch (firstname lastname comment webpage emailuser emailhost institution title) (let ( (personname (string-append title " " firstname " " lastname ) ) (personemail (string-append emailuser "@" emailhost ) ) ) `("tr" () ("td" (("class"."half")) ,(if (equal? webpage "") personname `("a" (("href". ,webpage)) ,personname) ) ,(if (equal? comment "") "" (string-append " " comment) ) ) ("td" (("class"."half")) ("a" (("href". ,(string-append "mailto:" firstname " " lastname " <" personemail ">"))) ,personemail ) ) ) ) ) ) (define (main argv) (let* ( (input (trim-all (call-with-input-file (if (> (length argv) 1) (cadr argv) "/dev/stdin" ) parse-xml ) ) ) (templates `( ;Register all of the templates to be executed (,(make-match-path '("page")) . ,apply-page) (,(make-match-path '("page" "item")) . ,apply-item) (,(make-match-path '(* "item" "label")) . ,apply-label) (,(make-match-path '(* "item" "text")) . ,apply-text) (,(make-match-path '(* "people")) . ,apply-people) (,(make-match-path '(* "people1")) . ,apply-people1) (,(make-match-path '(* "people1" "person")) . ,apply-person) (,(make-match-path '(* "bibauthor")) . ,apply-bibauthor) (,(make-match-path '(* "bib")) . ,apply-bib) (,(make-match-path '(* "papers1")) . ,apply-papers1) (,(make-match-path '(* "papers1" "paper")) . ,apply-paper1) (,(make-match-path '("bibtex")) . ,apply-bibtex) (,(make-match-path '(* "papers2" "paper")) . ,apply-paper2) ) ) (applied (apply-templates input templates '()) ) (output (if (pair? applied) (car applied) applied ) ) ) (display-header) (display-xml output (current-output-port)) (if (not (valid-tag output)) (display "Warning: Invalid XML output\n" (current-error-port)) ) ) )