;;; ;;; $Orig-Id: niklas-web.scm,v 1.64 2005/01/05 16:22:55 niklas Exp niklas $ ;;; $Id: niklas-web.scm,v 1.8 2006/01/14 23:51:15 niklas Exp niklas $ ;;; ;;; (c) 1998-2006 Niklas Olmes ;;; http://faith.eu.org/ ;;; ;;; -------------------------------------------------------------------- ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;; -------------------------------------------------------------------- ;;; Speakhtml ;;; http://speakhtml.sourceforge.net ;;; (old: http://faith.eu.org/programs.html#Speakhtml) ;;; ;;; ;;; GNU General Public License ;;; http://www.gnu.org/copyleft/gpl.html ;;; (comment "$Orig-Id: niklas-web.scm,v 1.64 2005/01/05 16:22:55 niklas Exp niklas $") (comment "$Id: niklas-web.scm,v 1.8 2006/01/14 23:51:15 niklas Exp niklas $") (define mailaddress "niklas@noxa.de") (define mailto (string-append "mailto:" mailaddress)) (define email `(!a #(href ,mailto) "Niklas Olmes")) (define f-email `(!a #(href ,mailto) ,(string-append "Niklas Olmes <" mailaddress ">"))) (define r-email (string-append "Niklas Olmes <" mailaddress ">")) (define copyright `("Copyright © 1998-2006" ,email)) (define default-lisR `((,FILE ,FILE) ("niklas-web.scm" "niklas-web.scm"))) (define default-lisL '(("/" "Frontpage") ("http://faith.eu.org/programs.html" "Other programs"))) (define whitebg "#fafafa") (define whitebd "#aaaaaa") (define pastelbg "#eafaea") (define pastelbd "#aaaaaa") (define greybg "#dddddd") (define greybd "#aaaaaa") (define brownbg "#ffe6c2") (define brownbd "#aaaaaa") (define bluebg "#bbddff") (define bluebd "#aaaaaa") (define abluebg "#bbeedd") (define abluebd "#aaaaaa") (define bgwhite "#fdfdfd") (define lgreybg "#eeeeee") (define lgreybd "#aaaaaa") (define green "#99cc33") (define lgreen "#cde69b") (define (mybody left right bottom) (parse `(!body #((bgcolor ,lgreybg) (text black) (link "#3366cc") (vlink "#3366cc") (alink green)) (!table #((width "100%") (align center)) (!tr (!td #((width "20%") (valign top)) ,left) (!td #(width "80%") ,right))) (!table #((width "100%") (align center)) (!tr (!td ,bottom)))))) (define meta `((!meta #((http-equiv Content-Type) (content "text/html; charset=iso-8859-1"))) (!meta #((name author) (content ,r-email))) (!meta #((name publisher) (content ,r-email))) (!meta #((name copyright) (content ,r-email))) (!link #((rev made) (href ,mailto))) (!meta #((name robots) (content "all, index, follow"))) (!meta #((name revisit-after) (content "10 days"))) (!link #((rel stylesheet) (type text/css) (href "styles.css"))))) (define (address-nik) (greybox `((!b "E-Mail:") ,f-email (!br) (!b "PGP Key:") (!a #(href gpgkey) "1024D/C1AEAC54 2000-04-01 Niklas Olmes") (!br) (!b "Nickname:") "'(guru kaenguru nevermore)" (!br) (!b "RIPE handle:") (!a #(href "NEVM-RIPE") "NEVM-RIPE") (!br) (!b "Geekcode:") (!a #(href geekcode) "geekcode")))) (define valid-html '(!a #(href http://validator.w3.org/check/referer) (!img #((border 0) (align right) (src gfx/valid-html40.png) (alt "Valid HTML 4.0!") (height 31) (width 88))))) (define valid-css '(!a #(href "http://jigsaw.w3.org/css-validator/validator?uri=http://ffproxy.sourceforge.net") (!img #((border 0) (align right) (src gfx/vcss.gif) (alt "Valid CSS!") (height 31) (width 88))))) (define any-browser '(!a #((href http://www.anybrowser.org/campaign/) (target new)) (!img #((border 0) (align right) (src gfx/anybrowser.jpg) (alt "Viewable With Any Browser"))))) (define sourceforge '(!a #(href http://sourceforge.net) (!img #((src "http://sourceforge.net/sflogo.php?group_id=XXX&type=1") (width 88) (heigth 31) (border 0) (align right) (alt "SourceForge.net"))))) (define (footer change) (whitebox `(,valid-css ,valid-html ,sourceforge ("Last change:") (!code #(class quoted) ,change) (!br) ,copyright (!br) "Verbatim copying and distribution of this entire article is permitted in any medium, provided this notice is preserved."))) (define (fullbox border bg x . padding) (let ((t1 `#((width "100%") (bgcolor ,border) (border 0) (cellspacing 1) (cellpadding 0))) (t2 `#((width "100%") (bgcolor ,bg) (border 0) (cellspacing 1) (cellpadding ,(if (null? padding) 4 (car padding))))) (td `#((bgcolor ,bg) (width "100%") (valign top) (align left)))) (parse `(!p (!table ,t1 (!tr (!td (!table ,t2 (!tr (!td ,td ,x)))))))))) (define (brownbox x) (fullbox brownbd brownbg x)) (define (whitebox x) (fullbox whitebd whitebg x)) (define (greybox x) (fullbox greybd greybg x)) (define (lgreybox x) (fullbox lgreybd lgreybg x)) (define (bluebox x) (fullbox bluebd bluebg x)) (define (abluebox x) (fullbox abluebd abluebg x)) (define (pastelbox x) (fullbox pastelbd pastelbg x)) (define (nav-entry x) `((!br) (!a #((class navbar) (href ,(car x))) ,(string-append "::" (cadr x) "")))) (define (nav-leiste . args) (let ((lisL (if (or (null? args) (null? (cdr args))) default-lisL (cadr args))) (lisR (if (or (null? args) (null? (cdr args))) default-lisR (caddr args)))) (lgreybox `((!h1 "Navigation") (!b "Topics") ,(map (lambda (x) (nav-entry x)) lisL) (!p) (!b "Source of this page") ,(map (lambda (x) (nav-entry x)) lisR) (!p) (!b "Contact") ,(nav-entry `(,mailto "E-Mail")) ,(if (not (null? args)) `((!p)(!b "On this page")(!br),(car args)) ""))))) (define (pagelinks . lis) (let iter ((l lis)) (cond ((null? l) '()) (else (cons `((!a #(href ,(string-append "#" (car l))) ,(car l))(!br)) (iter (cdr l))))))) (define nietzsche-menu '((!br) (!a #(href pragmatismus.html) "(1) Pragmatismus") (!br) (!a #(href "pragmatismus.html#Pragmatik") "(2) Pragmatik") (!br) (!a #(href nietzsche.html) "(3) Nietzsche"))) (define gesellschaft-menu '((!br) (!a #(href "natur.html") "(1) Natur") (!br) (!a #(href "gruppen.html") "(2) Gruppenbildung"))) (define (pragmatismus-bib) (whitebox '((!p) (!b "Literatur") (!p) (!b "GJ") "Guenther Jacoby, Der Pragmatismus, Neue Bahnen in der Wissenschaftslehre des Auslands, Leipzig 1909" (!br) (!b "PD") "Schueler Duden Philosophie, Dudenverlag" (!br) (!b "GF") "Guenther Figal, Nietzsche, Eine philosophische Einfuehrung, Reclam" (!br) (!b "MB") "Martin Bauer, Der Philosoph als Arzt der Kultur, Artikel zum zum hundertsten Todestag Friedrich Nietzsches, veroeffentlicht bei BerlinOnline" (!br) (!b "MS") "Mike Sandbote, Pragmatische Medienphilosophie und das Internet, erschienen in Ueber Medien von Sybille Kraemer, Berlin 1998" (!br) (!b "FN") "Friedrich Nietzsche, Ueber Wahrheit und Luege im auszermoralischem Sinne, 1873"))) (define (psection title descr links . emb) (whitebox `((!p) (!a #(name ,title)) (!b ,title) (!p) (,descr) (!ul ,(map (lambda (x) (if (pair? x) `(!li (!a #(href ,(car x)) ,(cadr x)) ,(if (not (null? (cddr x))) (caddr x) '())) `(!li (!a #(href ,x) ,x)))) links)) ,(if (not (null? emb)) (car emb) '())))) (define (boxsection title x) (parse `(!p (!table #((width "100%") (bgcolor ,greybd) (border 0) (cellspacing 1) (cellpadding 0)) (!tr (!td (!table #((width "100%") (bgcolor ivory) (border 0) (cellspacing 1) (cellpadding 0)) (!tr (!td #(bgcolor ivory) (!a #(name ,title) (!b ,title)))) (!tr (!td (!table #((width "100%") (bgcolor ivory) (border 0) (cellspacing 0) (cellpadding 4)) (!tr (!td ,x))))))))))))