;;; Common definitions (define display (let ((orig-display display)) (lambda objs (for-each orig-display objs)))) (define (print . objs) (apply display objs) (newline)) (define (fmt . stuff) (apply format (current-output-port) stuff)) (define .. string-append) (define-syntax :optional (syntax-rules () ((_ val default-value) (if (null? val) default-value (car val))))) (define *base-directory* (file-name-directory *input-file-name*)) (define *root-directory* (regexp-substitute/global #f (rx (+ (~ #\/))) *base-directory* 'pre ".." 'post)) ;;; Basic style ; (define (prologue title) ; (fmt #< ; ; ; ~A ; ; ; ; EOF ; title ; (format-date "~Y-~m-~d ~H:~M:~S" (date)) ; scsh-version-string)) (define (prologue title) (fmt #< ~A EOF (format-date "~Y-~m-~d ~H:~M:~S" (date)) scsh-version-string title)) (define (epilogue) (print "") (print "")) (define (title text) (print "

" text "

")) (define (subtitle text) (fmt "

~A

" text)) (define (banner title_ . subtitle_) (print "
") (title title_) (if (not (null? subtitle_)) (subtitle (car subtitle_))) (print "
")) (define (section text) (print "

" text "

")) (define (subsection text) (print "

" text "

")) (define (anchor name) (print "")) (define (anchor-link name text) (print "" text "")) (define (begin-code-quote) (display "
"))

(define (end-code-quote)
  (display "
")) (define (go-back) (section "Go back") (print "

Back to Psyk Software homepage.

")) ;;; Images (define (image file . alt-text) (let-match (regexp-search (rx (submatch (+ digit)) "x" (submatch (+ digit))) (run/string (identify ,(.. *base-directory* file)))) (all width height) (fmt "" file width height (if (null? alt-text) "" (.. " alt='" (car alt-text) "'"))))) ;;; Internal linking (define (human-size size) (define (chop-precision original-number-string) (let* ((ns (.. original-number-string "000")) (pt (string-index ns #\.))) (if (not pt) original-number-string (substring ns 0 (+ pt 2))))) (let* ((K 1024) (M (* K K))) (cond ((< size K) (.. (chop-precision (number->string size)) " bytes")) ((< size M) (.. (chop-precision (number->string (exact->inexact (/ size K)))) "k")) (else (.. (chop-precision (number->string (exact->inexact (/ size M)))) "M"))))) (define (page-link file . text) (if (file-not-exists? (.. *base-directory* file)) (error "bad link to" file) (fmt "~A" file (:optional text file)))) (define (file-link file . text) ;show file size (if (file-not-exists? (.. *base-directory* file)) (error "bad link to" file) (fmt "~A (~A)" file (:optional text file) (human-size (file-size (.. *base-directory* file)))))) (define (cwsdpmi) (file-link (.. *root-directory* "cwsdpmi.zip") "CWSDPMI")) ;;; External links (define (external-http-link url . maybe-text) (let ((text (:optional maybe-text (string-append "http://" url)))) (display "" text ""))) (define (external-https-link url . maybe-text) (let ((text (:optional maybe-text (string-append "https://" url)))) (display "" text ""))) (define (external-ftp-link url text) (display "" text "")) (define (allegro-www . text) (external-http-link "alleg.sf.net/" (:optional text "Allegro"))) (define (allegro.cc-www . text) (external-http-link "www.allegro.cc/" (:optional text "Allegro.cc"))) (define (libnet-www) (external-http-link "libnet.sf.net" "Libnet")) (define (links-lua-www) (external-http-link "links.sourceforge.net/links-lua/" "Links-Lua")) (define (lua-www) (external-http-link "www.lua.org/" "Lua")) (define (jgmod-www) (external-http-link "surf.to/jgmod/" "JGMOD")) (define (djgpp-www) (external-http-link "www.delorie.com/djgpp/" "djgpp")) (define (scsh-www . text) (external-http-link "www.scsh.net/" (:optional text "Scsh (Scheme Shell)"))) (define (gtk+-www) (external-http-link "www.gtk.org/" "GTK+")) (define (png-www . text) (external-http-link "www.libpng.org/pub/png/" (:optional text "libpng"))) (define (zlib-www . text) (external-http-link "www.gzip.org/zlib/" (:optional text "zlib"))) (define (python-www) (external-http-link "www.python.org/" "Python")) (define (pygtk-www) (external-http-link "www.daa.com.au/~james/pygtk" "PyGTK")) (define (redpixel-www . text) (external-http-link "redpixel.sourceforge.net/" (:optional text "redpixel.sourceforge.net/"))) (define (redpixel2-www . text) (external-http-link "redpixel.sourceforge.net/redpixel2/" (:optional text "redpixel.sourceforge.net/redpixel2/"))) (define (sizehack2000-www) (external-http-link "www.cyberlink.bc.ca/~tmg/sizehack/" "Allegro SizeHack 2000")) (define (speedhack1999-www) (external-http-link "www.speedhack.allegro.cc" "Allegro Speed Hack 1999")) (define (speedhack2001-www) (external-http-link "www.speedhack.allegro.cc" "Allegro Speed Hack 2001")) (define (speedhack2002-www) (external-http-link "www.speedhack.allegro.cc" "Allegro Speed Hack 2002")) (define (speedhack2005-www) (external-http-link "www.speedhack.allegro.cc" "Allegro Speed Hack 2005")) (define (vladans-www) (external-http-link "www.geocities.com/SiliconValley/8682/" "Vladan's home page")) (define (anybrowser-www) (external-http-link "www.anybrowser.org/campaign/" "any browser")) (define (elinks-www) (external-http-link "elinks.or.cz" "ELinks")) (define (bigloo-www) (external-http-link "www-sop.inria.fr/mimosa/fp/Bigloo" "Bigloo")) (define (chicken-www) (external-http-link "www.call-with-current-continuation.org" "CHICKEN")) (define (ogg-vorbis-www) (external-http-link "www.xiph.org/ogg/vorbis/" "Ogg Vorbis")) ;; Mailto (define (mailto address) (fmt "~A" address address))