;s3.scm ;Sterling Stuart Stein ;Apply the template for my webpage ;Module description (module s3 (main main) (library sxml) ) (define (display-header) (print " ") ) (define (cleanlabel str) (let* ( (len (string-length str)) (outstr (if (and (> len 0) (char>=? (string-ref str 0) #\0) (char<=? (string-ref str 0) #\9)) (string-append "s_" str) (string-copy str) ) ) ) (letrec ( (cl-loop (lambda (i) (if (>= i len) outstr (let ((c (string-ref outstr i))) (if (and (or (char? c #\z)) (or (char? c #\Z)) (or (char? c #\9)) ) (string-set! outstr i #\_) ) (cl-loop (+ i 1)) ) ) ) ) ) (cl-loop 0) ) ) ) (define (navitem name link myname) (let* ( (current (equal? name myname)) (dispname (if current (string-append "» " name) name ) ) (attr `( ("href". ,(string-append link ".xml")) . ,(if current '(("class"."current")) '() ) ) ) ) `("a" ,attr ,dispname ("br" ()) ) ) ) (define (apply-page root branch templates param position) (let ((name (get-attr branch "name"))) `("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/x-icon"))) ("link" (("rel"."stylesheet") ("type"."text/css") ("media"."screen") ("href"."s3.css"))) ("link" (("rel"."stylesheet") ("type"."text/css") ("media"."print") ("href"."print.css"))) ("title" () "S³'s " ,name) ) ("body" () ("div" (("class"."spaceholder")) " " ("div" (("id"."nav")) ,(navitem "Home" "home" name) ,(navitem "Resumé" "resume" name) ,(navitem "Projects" "projects" name) ,(navitem "Portfolio" "port" name) ,(navitem "Guides" "guide" name) ,(navitem "Personal" "personal" name) ) ) "\n" ("table" (("id"."main")) ("tr" () ("td" () ;append-list because grouping in project returns ;multiple separate items, which become divs. ;This is also why the other possible matches ;have to be an extra level deep. ,@(append-list (apply-templates-children root branch templates param)) "\n" ("div" (("class"."footer")) ("a" (("href"."http://validator.w3.org/check?uri=referer")) ("img" (("src"."/img/xhtml11.png") ("alt"."Valid XHTML 1.1"))) ) " " ("a" (("href"."http://www.anybrowser.org/campaign/")) ("img" (("src"."/img/anybrow.png") ("alt"."Use any browser"))) ) " " ("a" (("href"."http://www.mozilla.com/")) ("img" (("src"."firefox.png") ("alt"."Get FireFox"))) ) " " ("a" (("href"."http://jigsaw.w3.org/css-validator/check/referer")) ("img" (("src"."/img/css.png") ("alt"."Valid CSS"))) ) ) ) ) ) ) ) ) ) (define (apply-item root branch templates param position) `( ("div" ( ("class" . ,(if (= 0 (modulo position 2)) "color1" "color2") ) ) . ,(append-list (apply-templates-children root branch templates param)) ) ) ) ;Nested an extra level deep (define (apply-label root branch templates param position) `( ("h2" () ("a" (("id" . ,(cleanlabel (value-of-text branch)))) "\n") . ,(get-children branch) ) ) ) ;Nested an extra level deep (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-projgroup root branch templates param position) (let* ( (value-of-year (make-value-of-select (equals-tag-name "year") value-of-text) ) (value-of-season (make-value-of-select (equals-tag-name "season") value-of-text) ) (value-of-both (lambda (x) (string-append (value-of-year x) "-" (value-of-season x)) ) ) (criteria (make-comparison-int-desc (list (make-comparison-number-int (make-value-of-first value-of-year)) (make-comparison-number-int (make-value-of-first value-of-season)) ) ) ) (grouping (group-by (get-children branch) value-of-both)) (grouped (map (lambda (x) `("item" () ("label" () ,(value-of-year (car x)) " " ,(case (string->number (value-of-season (car x))) ((1) "Spring") ((2) "Summer") ((3) "Fall") ((4) "Winter") (else "Other") ) ) ("text" () ("projgroup1" () . ,x)) ) ) (sort grouping criteria) ) ) ) (append-list (apply-templates-list root grouped templates param)) ) ) (define (apply-projgroup1 root branch templates param position) `("ul" (("class"."spaced")) . ,(apply-templates-children root branch templates param) ) ) (define (apply-project1 root branch templates param position) `("li" () ("i" () ,(just-text branch "name") ". " ,@(just-children branch "class") "." ) ("br" ()) ,@(just-children branch "desc") ("br" ()) . ,(just-children branch "links") ) ) (define (apply-projgroup2 root branch templates param position) `("table" (("class"."bordered")) ("tr" () ("th" () "Name") ("th" () "Description") ("th" () "Download") ("th" () "Picture") ) . ,(apply-templates-children root branch templates param) ) ) (define (apply-project2 root branch templates param position) `("tr" () ("td" () ,(just-text branch "name") ) ("td" () . ,(just-children branch "desc") ) ("td" () . ,(just-children branch "links") ) ("td" () . ,(just-children branch "pic") ) ) ) (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 '(* "projgroup")) . ,apply-projgroup) (,(make-match-path '(* "projgroup1")) . ,apply-projgroup1) (,(make-match-path '(* "projgroup1" "project")) . ,apply-project1) (,(make-match-path '(* "projgroup2")) . ,apply-projgroup2) (,(make-match-path '(* "projgroup2" "project")) . ,apply-project2) ) ) (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)) ) ) )