; The LAML library and programs written by Kurt Normark, Aalborg University, Denmark.
; Copyright (C) 1999  Kurt Normark.
;
; 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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  US
;;;; This is the library of Scheme functions which mirrors HTML. The set of 
;;;; functions in this library is a rather unsystematic, ad hoc collection. Nevertheless,
;;;; it has proven quite useful. Much of our current software uses this library heavily. <p>
;;;;
;;;; We have made 'a new and more systematic beginning' with a set of basic HTML mirror functions
;;;; in the library html-v1. In the future we intend to built op top of this basis
;;; Table functions.
;;; A set of functions which generate HTML tables from Scheme list-of-list structures.
;; Return a table with elements from list-of-list. 
;; The sublists of list represent the rows in the table. The border is an optional parameter.
Show source file in small font Link from table to it's cross reference table entry 
(define (table list-of-list . border) (let ((bdr (string-append "border = " (if (null? border) "1" (as-string (car border)))))) (string-append "<table " bdr ">" (apply string-append (map table-row list-of-list)) "</table>"))) Show source file in small font Link from table-row to it's cross reference table entry 
(define (table-row lst) (string-append "<tr>" (apply string-append (map (lambda (cell) (string-append "<td>" (as-string cell) "</td>")) lst)) "</tr>")) ; more advance version of table, called table-1 ;; A more versatile variant of table. ;; A variant of table which requires border (an integer, 0 if no border), ;; a list of cell widths, a list of column colors, the table contens (list-of-list), and an optional valign parameter Show source file in small font Link from table-1 to it's cross reference table entry 
(define (table-1 border cell-width-list cell-color-list-1 list-of-list . valign) (let ((bdr (string-append "border = " (as-string border))) (va (if (null? valign) "top" (as-string (car valign))))) (string-append "<table " bdr ">" (apply string-append (map (lambda (row) (string-append "<tr>" (apply string-append (map (lambda (cell width color-1) (string-append "<td width = " (as-string width) " " "valign = " va " " "bgcolor = " (string-it (rgb-string-list color-1)) ">" (as-string cell) "</td>")) row cell-width-list cell-color-list-1)) "</tr>")) list-of-list)) "</table>"))) ;; A variant of table and table-1 which supports a header row Show source file in small font Link from table-2 to it's cross reference table entry 
(define (table-2 border cell-width-list cell-color-list-1 header-list list-of-list ) (let ((bdr (string-append "border = " (as-string border)))) (string-append "<table " bdr ">" "<tr>" (apply string-append (map (lambda (h) (string-append "<th>" h "</th>")) header-list)) "</tr>" (apply string-append (map (lambda (row) (string-append "<tr>" (apply string-append (map (lambda (cell width color-1) (string-append "<td width = " (as-string width) " " "valign = top " "bgcolor = " (string-it (rgb-string-list color-1)) ">" (as-string cell) "</td>")) row cell-width-list cell-color-list-1)) "</tr>")) list-of-list)) "</table>"))) ;; A variant of table-1, but without a column color list. ;; The cell color becomes identical with the background. Show source file in small font Link from table-3 to it's cross reference table entry 
(define (table-3 border cell-width-list list-of-list . valign) (let ((bdr (string-append "border = " (as-string border))) (va (if (null? valign) "top" (as-string (car valign))))) (string-append "<table " bdr ">" (apply string-append (map (lambda (row) (string-append "<tr>" (apply string-append (map (lambda (cell width) (string-append "<td width = " (as-string width) " " "valign = " va " " ">" (as-string cell) "</td>")) row cell-width-list)) "</tr>")) list-of-list)) "</table>"))) ; end more advanced table ; ; --------------------------------------------------------------------------------------------------- ;;; Form stuff. ;;; A number of functions which supports the work with (input) forms in Scheme. ;; Embed x in to form, which activates url upon form completion Show source file in small font Link from form to it's cross reference table entry 
(define (form cgi-url x) (string-append "<form method = " (string-it "post") " " "action = " (string-it cgi-url) ">" x "</form>")) ; OLD. New version defined 2.2.99 ; (define (checkbox name) ; (string-append ; "<input type = " (string-it "checkbox") " " ; "name = " (string-it (as-string name)) ">")) ;; Return an input tag of type checkbox. The name is a string or symbol which identifies the checkbox. ;; Checked is an optional boolean parameter. If checked is #t, the checkbox will be checked initially. ;; Returns the string true to the form processing application if checked. Show source file in small font Link from checkbox to it's cross reference table entry 
(define (checkbox name . checked) (let ((checked1 (if (null? checked) #f (car checked)))) (string-append "<input type = " (string-it "checkbox") " " (if checked1 "checked " "") " " "value = " (string-it "true") " " "name = " (string-it (as-string name)) ">"))) ;; Return an input tag of type radio. ;; checked is a boolean parameter, i.e. true or false (in Scheme sense). Show source file in small font Link from radio-button to it's cross reference table entry 
(define (radio-button value group-name . checked) (let ((is-checked (and (not (null? checked)) (boolean? (car checked)) (car checked)))) (string-append "<input type = " (string-it "radio") " " (if is-checked "checked " "") " " "name = " (string-it (as-string group-name)) " " "value = " (string-it (as-string value)) ">"))) ;; Return an input tag of type text. ;; The name is a string of symbol which identifies the text line. ;; Size is the the text line width in character positions. ;; Value is the initial value on the text line. Show source file in small font Link from text-line to it's cross reference table entry 
(define (text-line name size value) (string-append "<input type = " (string-it "text") " " "name = " (string-it (as-string name)) " " "size = " (string-it (as-string size)) " " "value = " (string-it (as-string value)) ">")) ;; Return an input tag of type hidden. ;; The name is a string of symbol which identifies the hidden line. ;; Value is the string contents of the hidden line Show source file in small font Link from hidden-line to it's cross reference table entry 
(define (hidden-line name value) (string-append "<input type = " (string-it "hidden") " " "name = " (string-it (as-string name)) " " "value = " (string-it (as-string value)) ">")) ;; Return an input tag of type password. ;; The name is a string of symbol which identifies the password. ;; Size is the the line width in character positions. ;; Value is the initial contents of the password field (not very useful...). Show source file in small font Link from password-line to it's cross reference table entry 
(define (password-line name size value) (string-append "<input type = " (string-it "password") " " "name = " (string-it (as-string name)) " " "size = " (string-it (as-string size)) " " "value = " (string-it (as-string value)) ">")) ;; Return an input tag of type submit. Renders a button. ;; Value is the string label of the button. Show source file in small font Link from submit to it's cross reference table entry 
(define (submit value) (string-append "<input type = " (string-it "submit") " " "value = " (string-it (as-string value)) ">")) ;; Return an input tag of type reset. ;; Value is the string label of the button. Show source file in small font Link from reset to it's cross reference table entry 
(define (reset value) (string-append "<input type = " (string-it "reset") " " "value = " (string-it (as-string value)) ">")) ; Return a select tag. ; (define (select name value-list contents-list) ; (string-append "<select name = " (string-it (as-string name)) "> " ; (apply string-append ; (map (lambda (value contents) ; (string-append "<option value = " (string-it (as-string value)) ">" ; (as-string contents) "</option>")) ; value-list contents-list)) ; "</select>") ;; Return a select tag, defining multiple choice menu. Name is a string or symbol which identifies the selection. ;; Value-list is a list of the values to be returned upon selection. ;; Contents-list is the list of contents to be shown in the menu. ;; Selected-value is an optional value, which is to be selected initially. This value should be a member of value-list. Show source file in small font Link from select to it's cross reference table entry 
(define (select name value-list contents-list . selected-value) (let ((selected (if (null? selected-value) "" (car selected-value)))) (string-append "<select name = " (string-it (as-string name)) "> " (apply string-append (map (lambda (value contents) (string-append "<option value = " (string-it (as-string value)) (if (equal? selected value) " selected " "") ">" (as-string contents) "</option>")) value-list contents-list)) "</select>"))) ;; Return a textarea form. ;; Rows is the number of rows of the text area. ;; Cols is the number of columns measured in characters. ;; Contents is the initial contents of the text area. Show source file in small font Link from textarea to it's cross reference table entry 
(define (textarea name rows cols contents) (string-append "<textarea " "name = " (string-it (as-string name)) " " "rows = " (string-it (as-string rows)) " " "cols = " (string-it (as-string cols)) ">" (as-string contents) "</textarea>")) Show source file in small font Link from formtest to it's cross reference table entry 
(define (formtest) (page "t" (form "URL" (con (checkbox "n") (p) (radio-button "v" "g") (p) (text-line 'n 50 'v) (p) (submit 'send-det) (p) (reset 'nulstil) (p) (select 'n '(a b c d e) '(1 2 3 4 5))(p) (textarea 'n 30 40 "noget indhold") (p))))) ; end form stuff ; ; ; ; -------------------------------------------------------------------------------------------------- ;;; Multi column lists. ;;; The functions in this section return multi-column lists. Given a list of elements the functions ;;; return a table in which the elements have been arranged in a number of columns. The first function, ;;; multi-column-list, arranges the elements in row major order. The two last functions arrange the ;;; the elements in column major order. These are the most advanced functions due to the way tables ;;; are organized in HTML ;; Return a multi-column list, row major, with columns columns. ;; Columns (the first parameter) must be at least 2. ;; The total width (sum of column widths) is given as the last parameter. ;; Internally, a HTML table with zero border is formed and returned. Show source file in small font Link from multi-column-list to it's cross reference table entry 
(define (multi-column-list columns elements total-width) (let* ((lgt (length elements)) (rem (remainder lgt columns)) (elements-2 (cond ((= lgt 0) (make-list columns " ")) ; ensure that list length is a multiplum of column, and at least column ((= 0 rem) elements) (else (append elements (make-list (- columns rem) " "))))) (rows (sublist-by-rows columns elements-2)) (column-width (quotient total-width columns)) (column-widths (make-list columns column-width))) (table-3 0 column-widths rows))) ;; Return a two column list, column major. ;; total-width (sum of column widths) is the width you want the resulting table to have. ;; Internally, a HTML table with zero border is formed and returned. Show source file in small font Link from two-column-list to it's cross reference table entry 7.5. Making the table of contents
(define (two-column-list elements total-width) (let* ((lgt (length elements)) (rem (remainder lgt 2)) ; not used any more ; ensure that list length is a multiplum of column, and at least column (elements-2 (cond ((= lgt 0) (make-list 2 " ")) ((= 0 rem) elements) (else (append elements (make-list (- 2 rem) " "))))) (rows (sublist-by-2columns elements " ")) (column-width (quotient total-width 2)) (column-widths (make-list 2 column-width))) (table-3 0 column-widths rows))) ;; Return an n column list, column-major, of the element list (second parameter). ;; This is a generalized version of two-column-list. ;; total-width (sum of column widths) is the width you want the resulting table to have. ;; n is the number of columens ;; Internally, a HTML table with zero border is formed and returned. Show source file in small font Link from n-column-list to it's cross reference table entry 
(define (n-column-list n elements total-width) (let* ((lgt (length elements)) (rows (sublist-by-columns n elements " ")) (column-width (quotient total-width n)) (column-widths (make-list n column-width))) (table-3 0 column-widths rows))) ; --------------------------------------------------------------------------------------------------- ;;; Uncategorized functions. ;;; The rest of the functions are not yet categorized ;; The result of this function is inserted as an HTML comment on each html page generated. ;; Redefine this function for your own tracing. ;; As of here, it returns the empty string. Show source file in small font Link from tracing-comment to it's cross reference table entry 
(define (tracing-comment) "") ; meant to be redefined in another place Show source file in small font Link from page to it's cross reference table entry 8.1. Some HTML details.
(define (page title body . color-list) ;; Return a simple HTML page with html, head and title tags. ;; Also include the value of the parameter-less function (laml-standard-comment) as an initial html-comment. ;; The optional color-list must consist of a background color, text color, link color and visited link color. (let ((bd (if (null? color-list) "<body>" (apply body-tag color-list)))) (string-append (copyright-clause) (newline-string) "<html><head><title> " title "</title></head>" bd body "</body> </html>" (newline-string) (laml-standard-comment) (newline-string) (tracing-comment) (newline-string) ))) ;; the part of a HTML page before the body. A html-v1 version of this function should be provided for. Show source file in small font Link from pre-page to it's cross reference table entry 2.1. Getting started: the top level functions
(define (pre-page title . color-list) (let ((bd (if (null? color-list) "<body>" (apply body-tag color-list)))) (string-append (laml-standard-comment) (newline-string) (tracing-comment) (newline-string) "<html><head><title>" title "</title></head>" bd ))) ;; the part of a HTML page after the body. A html-v1 version of this function should be provided for. Show source file in small font Link from post-page to it's cross reference table entry 2.1. Getting started: the top level functions
(define (post-page) (string-append "</body></html>")) Show source file in small font Link from body-tag to it's cross reference table entry 
(define (body-tag bg-color text-color link-color vlink-color) (string-append "<body " "bgcolor = " quote-string (apply rgb-string bg-color) quote-string " " "text = " quote-string (apply rgb-string text-color) quote-string " " "link = " quote-string (apply rgb-string link-color) quote-string " " "vlink = " quote-string (apply rgb-string vlink-color) quote-string " " ">")) ; obsolete Show source file in small font Link from report-as-list to it's cross reference table entry 
(define (report-as-list alist-input) (string-append "<ul>" (list-report alist-input) "</ul>")) ; obsolete Show source file in small font Link from list-report to it's cross reference table entry 
(define (list-report alist) (if (null? alist) "" (let ((key (car (car alist))) (value (cdr (car alist)))) (string-append "<li>" "<b>" key "</b>" "<br>" value (list-report (cdr alist)))))) ; obsolete Show source file in small font Link from report-as-table to it's cross reference table entry 
(define (report-as-table alist-input) (string-append "<table border = 1>" (table-report alist-input) "</table>")) ; obsolete Show source file in small font Link from table-report to it's cross reference table entry 
(define (table-report alist) (if (null? alist) "" (let ((key (car (car alist))) (value (cdr (car alist)))) (string-append "<tr>" "<td>" key "</td>" "<td>" value "</td>" "</tr>" (table-report (cdr alist)))))) ;; Return an a tag constructructed from the URL and the anchor. ;; If no anchor is provided uses the url as anchor text. Show source file in small font Link from a-tag to it's cross reference table entry 
(define (a-tag url . anchor) (string-append "<a href = " quote-string (as-string url) quote-string ">" (if (null? anchor) url (as-string (car anchor))) "</a>")) ;; A variant of a tag which supports a target attribute of the a-tag (where in browser to show the result). Show source file in small font Link from a-tag-target to it's cross reference table entry 
(define (a-tag-target url anchor target) (string-append "<a href = " quote-string (as-string url) quote-string " target = " target ">" (as-string anchor) "</a>")) ;; Name the current place by means of an a tag with name attribute Show source file in small font Link from a-name to it's cross reference table entry 
(define (a-name name) (string-append "<a name=" (string-it (as-string name)) ">")) ;; Return a mail link by means of the mailto facility in an a tag. Show source file in small font Link from mail-link to it's cross reference table entry 
(define (mail-link email-adr . anchor-name) (if (null? anchor-name) (a-tag (string-append "mailto:" email-adr) email-adr) (a-tag (string-append "mailto:" email-adr) (as-string (car anchor-name))))) ;; Return an ol (ordered list) tag. The elements in list becomes the elements. Li tags are inserted automatically by this function. Show source file in small font Link from ordered-list to it's cross reference table entry 
(define (ordered-list lst) (string-append "<ol>" (apply string-append (map (lambda(el) (string-append "<li>" (as-string el))) lst)) "</ol>")) ;; A convenient alias for ordered-list Show source file in small font Link from ol to it's cross reference table entry 
(define ol ordered-list) ;; Return an ul (uordered list) tag. The elements in list becomes the elements. Li tags are inserted automatically by this function. Show source file in small font Link from unordered-list to it's cross reference table entry 
(define (unordered-list lst) (string-append "<ul>" (apply string-append (map (lambda(el) (string-append "<li type = disc>" (as-string el) "</li>")) lst)) "</ul>")) ;; Return a flat list, separate by breaks Show source file in small font Link from br-list to it's cross reference table entry 
(define (br-list lst) (apply string-append (map (lambda(el) (string-append (as-string el) (br))) lst))) ;; A convenient alias for br-list Show source file in small font Link from brl to it's cross reference table entry 
(define brl br-list) ;; A convenient alias for unordered-list Show source file in small font Link from ul to it's cross reference table entry 
(define ul unordered-list) Show source file in small font Link from definition-list to it's cross reference table entry 
(define (definition-list lst) ;; Make a definition list. ;; lst is a list of lists. Each inner list must be of length two, ;; dt and dd respectively. I.e. definition terms and the defintion proper, resp. ;; As a special case supported, the inner list can be of lenght one, in which case ;; the dd is considered empty (string-append "<dl>" (apply string-append (map (lambda(el) (let ((dt (car el)) (dd (if (= 1 (length el)) "" (cadr el)))) (string-append "<dt>" (as-string dt) " </dt>" (if (equal? dd "") "" (string-append "<dd>" (as-string dd) " </dd>"))))) lst)) "</dl>")) ;; A convenient alias for definition-list Show source file in small font Link from dl to it's cross reference table entry 
(define dl definition-list) ; ----------------------------------------------------------------------------- ; Bullet list Show source file in small font Link from bullet-list to it's cross reference table entry 
(define (bullet-list lst bullet-size bullet-color) ;; Render lst as a bulleted list. Both parameters must be symbols. ;; Bullet-size is either 'small or 'large. ;; Bullet-color is either 'red, 'green, 'yellow, 'blue, or 'cyan. ;; Depends on the presence of appropriate gif files in images directory. (apply string-append (map (lambda(el) (table-3 0 '(18 "*") (list (list (bullet-image bullet-size bullet-color) (con (as-string el) (p)))) "baseline")) lst))) Show source file in small font Link from bl to it's cross reference table entry 
(define (bl lst) ;; a large, red bulleted list (bullet-list lst 'large 'red)) Show source file in small font Link from bullet-image to it's cross reference table entry 
(define (bullet-image size color) (let ((path (image-file-path)) (filename (bullet-filename size color))) (img (string-append path filename)))) Show source file in small font Link from bullet-filename to it's cross reference table entry 
(define (bullet-filename size color) ; size and color are symbols, small or large, and red, green or yellow, respectivel (string-append (as-string color) "-" "ball" "-" (as-string size) "." "gif")) ; ----------------------------------------------------------------------------- ;; Show tree as an indented, bulleted list. ;; A tree is a list. ;; The first element of the list is the root. ;; The tail of the list is the list of subtrees. ;; A subtree, which is a leaf, can be given as a symbol, string or number <br> Show source file in small font Link from ul-tree to it's cross reference table entry 
(define (ul-tree tree) ; Example (a (b c d) (e (f g) h)) ; ; a ; / ; b e ; / / ; c d f h ; | ; g (cond ((or (symbol? tree) (string? tree) (number? tree)) (ul (list (as-string tree)))) ((pair? tree) (string-append "<ul>" "<li type = disc>" (as-string (car tree)) (apply string-append (map ul-tree (cdr tree))) "</ul>")))) ;; Present x in a kbd tag Show source file in small font Link from kbd to it's cross reference table entry 
(define (kbd x) (string-append "<kbd>" (as-string x) "</kbd>")) ;; Return a horizontal rule, a hr tag. Show source file in small font Link from hr to it's cross reference table entry 
(define (hr . size) (if (null? size) "<hr>" (string-append "<hr size = " (as-string (car size)) ">"))) ;; Return an img tag, in which a file on file-name is presented. An optional width parameter is supported. Show source file in small font Link from img to it's cross reference table entry 
(define (img file-name . width) (if (not (null? width)) (string-append "<img src = " quote-string (as-string file-name) quote-string " width = " (as-string (car width)) " " " border = 0 " ">") (string-append "<img src = " quote-string (as-string file-name) quote-string " border = 0 " ">"))) ;; A variant of img which presents an image with a border Show source file in small font Link from img-with-border to it's cross reference table entry 
(define (img-with-border file-name . width) (if (not (null? width)) (string-append "<img src = " quote-string (as-string file-name) quote-string " width = " (as-string (car width)) " " ">") (string-append "<img src = " quote-string (as-string file-name) quote-string ">"))) ;; Returns h tags, h1 if i=1, h2 if i=2, etc. Show source file in small font Link from h to it's cross reference table entry 
(define (h i x) (let* ((start-tag (string-append "<h" (as-string i) ">")) (end-tag (string-append "</h" (as-string i) ">"))) (string-append start-tag (as-string x) end-tag))) ;; Present x in a i tag Show source file in small font Link from i to it's cross reference table entry 
(define (i x) (string-append "<i>" (as-string x) "</i>")) ;; Present x in a strong tag Show source file in small font Link from strong to it's cross reference table entry 
(define (strong x) (string-append "<strong>" (as-string x) "</strong>")) ;; Present x in a pre tag Show source file in small font Link from pre to it's cross reference table entry 
(define (pre x) (string-append "<pre>" (as-string x) "</pre>")) ;; Present x in a center tag Show source file in small font Link from center to it's cross reference table entry 
(define (center x) (string-append "<center>" (as-string x) "</center>")) Show source file in small font Link from convert-size to it's cross reference table entry 
(define (convert-size size) (if (and (symbol? size) (eq? size 'normal)) "3" (as-string size))) Show source file in small font Link from font to it's cross reference table entry 
(define (font size color x) ;; Returns a font tag. ;; size is a number and color is a rgb list of three, decimal integers or ;; a color symbol. (let ((ss (string-append "size = " (convert-size size))) (cs (string-append "color = " quote-string (apply rgb-string color) quote-string))) (string-append "<font " ss " " cs ">" (as-string x) "</font>"))) Show source file in small font Link from font-size to it's cross reference table entry 
(define (font-size size x) ;; Like font, but only supports size. ;; size is a number and color is a rgb list of three, decimal integers or ;; a color symbol. (let ((ss (string-append "size = " (convert-size size)))) (string-append "<font " ss ">" (as-string x) "</font>"))) Show source file in small font Link from font-color to it's cross reference table entry 
(define (font-color color x) ;; Like font, but only supports color. ;; color is a rgb list of three, decimal integers (let ((cs (string-append "color = " quote-string (apply rgb-string color) quote-string ""))) (string-append "<font " cs ">" (as-string x) "</font>"))) ;; Present x in a b tag (bold) Show source file in small font Link from b to it's cross reference table entry 
(define (b x) (string-append "<b>" (as-string x) "</b>")) ;; Present x in a u tag (underline) Show source file in small font Link from u to it's cross reference table entry 
(define (u x) (string-append "<u>" (as-string x) "</u>")) ;; Present x in a em tag (emphasize) Show source file in small font Link from em to it's cross reference table entry 
(define (em x) (string-append "<em>" (as-string x) "</em>")) ;; Present x in a blockquote tag Show source file in small font Link from cite to it's cross reference table entry 
(define (cite x) (string-append "<blockquote>" (as-string x) "</blockquote>")) ;; Present x in a blockquote tag Show source file in small font Link from blockquote to it's cross reference table entry 
(define blockquote cite) ;; Present a p tag (paragraph). If no parameter is given, just return a p tag without contens. ;; If a parameter is given, return x embedded in a p tag. Show source file in small font Link from p to it's cross reference table entry 
(define (p . x) (if (null? x) "<p>" (string-append "<p>" (as-string (car x)) "</p>"))) ;; Return a br tag (break) Show source file in small font Link from br to it's cross reference table entry 
(define (br) "<br>") ;; Return n space special characters (horizontal space) Show source file in small font Link from space to it's cross reference table entry 
(define (space n) (apply string-append (make-list n "&nbsp;"))) ;; Return n space special characters Show source file in small font Link from horizontal-space to it's cross reference table entry 
(define horizontal-space space) ;; Return n vertical spaces, i.e., n p tags Show source file in small font Link from vertical-space to it's cross reference table entry 
(define (vertical-space n) (if (= n 0) "" (con (space 1) (p) (vertical-space (- n 1))))) ;; Return an HTML comment form. I.e, embed comment into the HTML comment characters Show source file in small font Link from html-comment to it's cross reference table entry 
(define (html-comment comment) (string-append "<!-- " comment "-->")) ; _____________________________________________________________________________ ;;; Indenting and framing. ;;; Here is a number of functions of indentation and framing ;; Indent text with p pixels Show source file in small font Link from indent-pixels to it's cross reference table entry 
(define (indent-pixels p text) (table-3 0 (list p "*") ; (make-list 2 slide-background-color) (list (list "" text)))) ;; Show text in a column, narrowed from both left and right with p pixels Show source file in small font Link from narrow-with-pixels to it's cross reference table entry 
(define (narrow-with-pixels p text) (table-3 0 (list p "*" p) ; (make-list 3 slide-background-color) (list (list "" text "")))) ;; Shown text in a simple frame Show source file in small font Link from frame to it's cross reference table entry 
(define (frame text) (table-3 1 (list "*") ; (make-list 1 slide-background-color) (list (list text)))) ;; Embed text in an invisible table with one cell Show source file in small font Link from box to it's cross reference table entry 
(define (box text) (table-3 0 (list "*") (list (list text)))) ;; Present the contents-list, which is a list of elements, in a narrow ;; column of width, separated with activations of separator-fn. Show source file in small font Link from narrow to it's cross reference table entry 
(define (narrow separator-fn width . contents-list) (let ((separator-list (make-list (- (length contents-list) 1) (separator-fn)))) (table-3 0 (list width) (list (list (string-merge contents-list separator-list)))))) ;; Embed text into a color frame. It is the background which is colored. Show source file in small font Link from color-frame to it's cross reference table entry 
(define (color-frame text color) (table-1 0 (list "*") (make-list 1 color) (list (list text)) "bottom")) ;; As color-frame, but this function supports and extra widht parameter. This is an integer: the with of the frame in pixels. Show source file in small font Link from color-frame-width to it's cross reference table entry 
(define (color-frame-width text color width) (table-1 0 (list width) (make-list 1 color) (list (list text)) "bottom")) ;; Like frame, but with an extra width parameter. This is an integer: the with of the frame in pixels. Show source file in small font Link from frame-width to it's cross reference table entry 
(define (frame-width text width) (table-3 1 (list width) ; (make-list 1 slide-background-color) (list (list text)))) ;; Embed text into a centered frame Show source file in small font Link from center-frame to it's cross reference table entry 
(define (center-frame indentation text) (center (narrow-with-pixels indentation (frame text)))) ; _____________________________________________________________________________ Show source file in small font Link from html-protect to it's cross reference table entry 
(define (html-protect str) ;; Transliterate angle brackets in str to the particular html character entities. ;; With this useful function it is possible to show the html tags in a browser (transliterate (transliterate (transliterate str #\& "&amp;" ) #\> "&gt;") #\< "&lt;")) ; ----------------------------------------------------------------------------- ; Colorizing substrings: ; ; About faces: ; We support the following face symbols: italic, bold, typewriter, underlined, plain Show source file in small font Link from face-start-tag to it's cross reference table entry 
(define (face-start-tag face-symbol) (cond ((eq? face-symbol 'italic) "<i>") ((eq? face-symbol 'bold) "<b>") ((eq? face-symbol 'typerwriter) "<kbd>") ((eq? face-symbol 'underlined) "<u>") ((eq? face-symbol 'plain) "") (else (error "face start tag: Unknown face symbol")) ) ) Show source file in small font Link from face-end-tag to it's cross reference table entry 
(define (face-end-tag face-symbol) (cond ((eq? face-symbol 'italic) "</i>") ((eq? face-symbol 'bold) "</b>") ((eq? face-symbol 'typerwriter) "</kbd>") ((eq? face-symbol 'underlined) "</u>") ((eq? face-symbol 'plain) "") (else (error "face end tag: Unknown face symbol")) ) ) Show source file in small font Link from colorize-substrings to it's cross reference table entry 
(define (colorize-substrings str region-color-list) ;; This is a more advanced function which make font changes to substrings of str. ;; Surround substrings of str, as specified by the third parameter, in font tags. ;; Region-color-list is a list of coloring descriptors. <p> ;; Each color descriptor is of the form: ;; (from-string to-string color face multiplicity). <p> ;; Face and multiplicity are optional. ;; From-string and to-strings delimits and identifies a substring of str to colorize etc. ;; color is a list of three integers: a rgb list. ;; We support the following face symbols: italic, bold, typewriter, underlined, plain (default bold). ;; Multiplicity is an integer telling how many times to to attempt the colorization on str (default 1). <p> ;; NB: In strange situations, the fontification of an early region-color-element may ;; affect the searching for latter region-color-elements. This is not an error, but a consequence of ;; the way font tags are puted into str. (set! last-coloring-length 0) (if (null? region-color-list) str (let* ((region-color (car region-color-list)) (from-str (car region-color)) (to-str (cadr region-color)) (color (caddr region-color)) (face (if (= 4 (length region-color)) (cadddr region-color) 'bold)) (multiplicity (if (= 5 (length region-color)) (fifth region-color) 1)) ) (colorize-substrings (font-substring str 0 from-str to-str color face multiplicity) (cdr region-color-list))))) Show source file in small font Link from last-coloring-length to it's cross reference table entry 
(define last-coloring-length 0) ; holds the length of font text from last substitution ; set by font-substring-by-index ; ; (define (font-substring str start-index from-delimiting-string to-delimiting-string color face multiplicity) ; ; surround a substring, delimited by from-delimiting-string and to-delimiting-string, by a html font tag ; ; with a color attribute. ; ; starting looking for delimiting strings at from-index ; (let* ((from-index (substring-index str start-index from-delimiting-string)) ; (to-index (substring-index str ; (+ from-index (string-length from-delimiting-string)) ; addition 10.9.98 ; to-delimiting-string))) ; (if (and from-index to-index) ; (font-substring-by-index str from-index (+ to-index (string-length to-delimiting-string)) color face) ; (error (string-append "Substring fonting/colorizing: Cannot find delimiting strings: " from-delimiting-string ", " to-delimiting-string))))) ; ; --------------------------------------------------------------------------------------------------------------- ; new Show source file in small font Link from repeat-colorizing to it's cross reference table entry 
(define (repeat-colorizing str start-index from-str to-str color face n) (if (> n 0) (font-substring str start-index from-str to-str color face n) str)) Show source file in small font Link from font-substring to it's cross reference table entry 
(define (font-substring str start-index from-delimiting-string to-delimiting-string color face multiplicity) ; surround a substring, delimited by from-delimiting-string and to-delimiting-string, by a html font tag ; with a color attribute. ; starting looking for delimiting strings at from-index (let ((from-index (substring-index str start-index from-delimiting-string))) (if from-index (let ((to-index (substring-index str (+ from-index (string-length from-delimiting-string)) ; addition 10.9.98 to-delimiting-string))) (if to-index (repeat-colorizing (font-substring-by-index str from-index (+ to-index (string-length to-delimiting-string)) color face) (+ to-index last-coloring-length) from-delimiting-string to-delimiting-string color face (- multiplicity 1)) (error (string-append "Substring fonting/colorizing: Cannot find the to delimiting strings: " to-delimiting-string)))) (error (string-append "Substring fonting/colorizing: Cannot find the from delimiting strings: " from-delimiting-string))))) ; --------------------------------------------------------------------------------------------------------------- Show source file in small font Link from font-substring-by-index to it's cross reference table entry 
(define (font-substring-by-index str from-index to-index color face) ; to-index is larger than from-index. ; insert a font tag around index range (let* ((cs (string-append "color = " quote-string (apply rgb-string color) quote-string)) (pre (string-append (face-start-tag face) "<font " cs ">")) (post (string-append "</font>" (face-end-tag face))) ) (set! last-coloring-length (+ (string-length pre) (string-length post))) (put-around-substring str from-index pre to-index post))) ; ----------------------------------------------------------------------------- Show source file in small font Link from con-par to it's cross reference table entry 
(define (con-par . string-list) ;; like con, but insert a p tag between all strings in string-list (let ((par-list (make-list (- (length string-list) 1) (p)))) (string-merge string-list par-list))) ; ----------------------------------------------------------------------------- ; Character entities Show source file in small font Link from character-entity to it's cross reference table entry 
(define (character-entity x) ;; if x is a number return a numbered character entity. ;; if x is a symbol og string, return a named character entity. (cond ((number? x) (string-append "&#" (three-digit-string x) ";")) ; remember to ensure leading zeros ((or (string? x) (symbol? x)) (string-append "&" (as-string x) ";")) (else (error "character-entity: the parameter must be numeric, a symbol, or a string")))) Show source file in small font Link from three-digit-string to it's cross reference table entry 
(define (three-digit-string n) ; Return a number string of exactly length three ; n is a number between 0 and 999 (cond ((and (>= n 0) (< n 10)) (string-append "00" (as-string n))) ((and (>= n 10) (< n 100)) (string-append "0" (as-string n))) ((< n 1000) (as-string n)) (else (error "three-digit-string: parameter must be between 0 and 999")))) Show source file in small font Link from copyright to it's cross reference table entry 
(define copyright (character-entity "copy")) ;; Embed x into a copyright indication Show source file in small font Link from copyright-owner to it's cross reference table entry 
(define (copyright-owner x) (string-append x " " copyright)) ; ----------------------------------------------------------------------------- ;; Return the standard LAML comment, to be inserted at the top of every LAML generated page. Show source file in small font Link from laml-standard-comment to it's cross reference table entry 
(define (laml-standard-comment) (let ((dt (date-time (current-time)))) (html-comment (string-append "Generated from an LAML (Lisp Abstracted Markup Language) source file. LAML is designed and implemented by Kurt Nørmark, normark@cs.auc.dk. " "Time of generation: " (car dt) " " (cadr dt) )))) ; ----------------------------------------------------------------------------- ; ; alphabetical index index (links from letter array...) ;; Support of generation of alphabetic indexes. Show source file in small font Link from alphabetic-link-array to it's cross reference table entry 7.2. Alphabetically organized cross reference indexes
(define (alphabetic-link-array) ;; Return an 'array' of letter links to #letter (apply string-append (map (lambda (letter) (string-append (a-tag (string-append "#" letter) (capitalize-string letter)) (horizontal-space 1))) (list "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "æ" "ø" "å")))) Show source file in small font Link from alphabetic-link-array-1 to it's cross reference table entry 7.2. Alphabetically organized cross reference indexes
(define (alphabetic-link-array-1 target-file-prefix alphabet . emphasis-letter) ;; Return an 'array' of letter links to (string-append target-file-prefix "-" letter ".html") for all letters in alphabet. ;; This is a generalized version of alphabetic-link-array. ;; target-file-prefix is a prefix of the file names, in which the index files are located. ;; alphabet is a list of letters, for which to generate index links from the alphabet arrays. Some letters ;; may be missing from the alphabet compared with a complete alphabet. ;; emphasis-letter is an optional letter which we emphasize in the link array (let* ((em-let (if (not (null? emphasis-letter)) (as-string (car emphasis-letter)) #f)) (alphabet-1 (map as-string alphabet))) (apply string-append (map (lambda (letter) (string-append (a-tag (string-append target-file-prefix "-" letter ".html") (if (and em-let (equal? em-let letter)) (font 4 red (b (capitalize-string-nd letter))) (capitalize-string-nd letter)) (horizontal-space 1)) " " )) alphabet-1)))) ; ----------------------------------------------------------------------------- Show source file in small font Link from html-appender to it's cross reference table entry 
(define (html-appender element) ;; generate a function which appends element (lambda (existing-stuff) (string-append existing-stuff " " element))) Show source file in small font Link from font-rise to it's cross reference table entry 
(define (font-rise str base-size) ;; Return a html fonted version of str. Initial letter is sized base-size+1. ;; The rest is size base-size (string-append (font-size (+ base-size 1) (substring str 0 1)) (font-size base-size (substring str 1 (string-length str))))) ; ----------------------------------------------------------------------------- ; IMAGE FILE ACCESS ; ; A variable which tells how to access images (icons) via the function image-file. ; (define image-file-access 'local) ;; The URL where the author of this library keeps a number of images (icons). Show source file in small font Link from kn-internet-image-path to it's cross reference table entry 
(define kn-internet-image-path "http://www.cs.auc.dk/~normark/images/") ;; Determination of the actual file path to images in html files. ;; This function depends on the variable image-file-access, which MUST defined external to this library. ;; The value of image-file-access can be changed via procedure set-image-file-access! ;; One of the following symbols: local, parent, net, sub-directory, or fixed. Default is local. ;; local means that images are taken from the current directory. ;; parent means that images are tagen from ../images. ;; sub-directory means that images are taken from ./images. ;; fixed means that images are taken from fixed-image-directory (a variable which must be defined ;; external to this library). ;; Finally, net means that images are taken from kn-internet-image-path (a variable). Show source file in small font Link from image-file-path to it's cross reference table entry 
(define (image-file-path) (cond ((eq? image-file-access 'local) "") ((eq? image-file-access 'parent) "../images/") ((eq? image-file-access 'sub-directory) "./images/") ((eq? image-file-access 'net) kn-internet-image-path) ((eq? image-file-access 'fixed) fixed-image-directory) )) Show source file in small font Link from set-image-file-path! to it's cross reference table entry 
(define (set-image-file-path! mode) ;; Set the image-file-access variable. ;; mode is symbol, either local, parent, sub-directory, net, or fixed. ;; Relative to the hmtl directory, where the target files are written. (set! image-file-access mode)) Show source file in small font Link from image-file to it's cross reference table entry 
(define (image-file file-name) ;; Return the full path/address f image file named file-name. ;; Relies of the setting of the variable image-file-access via the procedure set-image-file-path! ;; File name must include file extension (string-append (image-file-path) file-name )) ;; Return a Javascript calling form, given function function-name and parameters. ;; Returns a string of the form: function-name(parameters). ;; This functions adds commas between the actual Javascript parameters. Show source file in small font Link from js-call to it's cross reference table entry 
(define (js-call function-name parameters) (string-append function-name "(" (string-merge (map as-string parameters) (make-list (- (length parameters) 1) ", ")) ")")) ;; Return a manifest javascript array given its elements Show source file in small font Link from js-string-array to it's cross reference table entry 
(define (js-string-array elements) (string-append "[" (string-merge (map string-it-single (map as-string elements)) (make-list (- (length elements) 1) ",")) "]")) ;; Write a HTML page consisting of header and body to file. ;; File is without extension. This function adds the html extension Show source file in small font Link from write-html-page to it's cross reference table entry 
(define (write-html-page file header body) (write-text-file (page header body) (string-append file ".html")))