; 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  USA
;;;; 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.<p>
;;;;
;;;; <b> This library is now obsolete</b>. Use <a href = "../html4.01-transitional-validating/man/convenience.html"> the convenience library </a>
;;;; together with the <a href="../html4.01-transitional-validating/man/basis.html">basis mirror</a> and <a href="../html4.01-transitional-validating/man/surface.html">surface mirror</a> of HTML4.01 transitional.
;;; Document type definition. 
;;; This section contains <kbd>document-type-declaration</kbd>, that returns the appropriate
;;; document type declaration of this mirror.
;; Return a document type declaration of this mirror.
In html: Link from document-type-declaration to it's cross reference table entry 
(define (document-type-declaration) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">") ;;; 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. In html: 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>"))) In html: 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 In html: Link from table-1 to it's cross reference table entry 8.3. The program file menu and coloring schemes
(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 In html: 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. In html: 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>"))) ;; A variant of table-1 with a row color list instead of a column color list. ;; The length of row-color-list must be the same as the length of each row list in list-of-list. In html: Link from table-4 to it's cross reference table entry 8.3. The program file menu and coloring schemes
(define (table-4 border cell-width-list row-color-list list-of-list . valign) (let ((va (if (null? valign) "top" (as-string (car valign))))) (html:table (apply string-append (map (lambda (row row-color) (html:tr (apply string-append (map (lambda (cell width) (html:td (as-string cell) 'width (as-string width) 'valign va 'bgcolor (rgb-string-list row-color) ) ) row cell-width-list)) )) list-of-list row-color-list ) ) 'border (as-string border)))) ; 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 cgi-url upon form completion. In html: 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>")) ;; Embed x into a multipart form. Activate cgi-url when the form is submitted. ;; A multipart form is used for file uploading. Files are written into ;; target-directory when uploaded. ;; The parameter target-directory-url gives the URL of the directory, in which the file is uploaded. ;; This is used for subsequent WWW retrival of the file. In html: Link from multipart-form to it's cross reference table entry 
(define (multipart-form cgi-url target-directory target-directory-url x) (string-append "<form method = " (string-it "post") " " "enctype=" (string-it "multipart/form-data") " " "action = " (string-it cgi-url) ">" (string-append (hidden-line "target-directory!!!" target-directory) (hidden-line "target-directory-url!!!" target-directory-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. In html: 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). In html: 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. In html: 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 In html: 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 file. ;; Such an input tag is used for file uploading. ;; The name of the uploading is name. In html: Link from file-upload to it's cross reference table entry 
(define (file-upload name . optional-parameters) (let ((value (optional-parameter 1 optional-parameters #f))) (if value (string-append "<input type = " (string-it "file") " " "name = " (string-it (as-string name)) " " "value = " (string-it (as-string value)) ">") (string-append "<input type = " (string-it "file") " " "name = " (string-it (as-string name)) " " ">")))) ;; 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...). In html: 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. If the optional parameter name ;; is given it identifies a particular submit button with a name, value pair in the submitted data. ;; .form (submit value [name]) In html: Link from submit to it's cross reference table entry 
(define (submit value . optional-parameters) (let ((name (optional-parameter 1 optional-parameters #f))) (if name (string-append "<input type = " (string-it "submit") " " "name = " (string-it (as-string name)) " " "value = " (string-it (as-string 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. In html: 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 a 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. In html: 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. In html: 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>")) In html: 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. In html: 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. In html: 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. In html: 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. In html: Link from tracing-comment to it's cross reference table entry 
(define (tracing-comment) "") ; meant to be redefined in another place In html: 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. In html: 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. In html: 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>")) In html: 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 In html: 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 In html: 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 In html: 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 In html: 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. In html: 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). In html: 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 In html: 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. In html: 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. In html: 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 In html: 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. In html: 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 In html: 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 In html: Link from brl to it's cross reference table entry 
(define brl br-list) ;; A convenient alias for unordered-list In html: Link from ul to it's cross reference table entry 
(define ul unordered-list) In html: 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 In html: Link from dl to it's cross reference table entry 
(define dl definition-list) ; ----------------------------------------------------------------------------- ; Bullet list In html: 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))) In html: Link from bl to it's cross reference table entry 
(define (bl lst) ;; a large, red bulleted list (bullet-list lst 'large 'red)) In html: 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)))) In html: 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. In html: 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 In html: 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. In html: 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. In html: 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 In html: 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. In html: 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 In html: 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 In html: 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 In html: 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 In html: Link from center to it's cross reference table entry 
(define (center x) (string-append "<center>" (as-string x) "</center>")) In html: 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))) In html: 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>"))) In html: 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>"))) In html: 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) In html: 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) In html: 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) In html: 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 In html: 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 In html: 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. In html: 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) In html: Link from br to it's cross reference table entry 
(define (br) "<br>") ;; Return n space special characters (horizontal space) In html: 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 In html: Link from horizontal-space to it's cross reference table entry 
(define horizontal-space space) ;; Return n vertical spaces, i.e., n p tags In html: 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 In html: Link from html-comment to it's cross reference table entry 
(define (html-comment comment) (string-append "<!-- " comment "-->")) ;; Return an HTML a tag (anchor) which links to the LAML software home page via an small gif icon. ;; If possible, a relative URL is used as the href attribute. ;; The parameter extra-level is an extra level to add. Normally, extra-level is 0 (zero). ;; As an example, extra-level should be 1 in case HTML files are organized ;; in a sub-directory relative to the laml source file. ;; Text-or-image is either the symbol 'text or 'image, or a string. If 'text, a textual anchor is used. ;; if 'image, a small 'laml house' is used as image. If text-or-image is a string it is a name of an image file ;; in the laml image directory (including file name extension, excluding any file path). ;; The optional start-dir gives the directory, in which the home button is to be placed; It defaults to (startup-directory). In html: Link from laml-home-button to it's cross reference table entry 
(define (laml-home-button extra-level text-or-image . start-dir) (let* ((start-dir-1 (if (null? start-dir) (startup-directory) (car start-dir))) (url-of-laml (laml-home-url-prefix extra-level start-dir-1)) (help-text (if (equal? url-of-laml laml-absolute-url-prefix) "The LAML software home page at Aalborg University" "The local LAML software home page")) (image-file (cond ((eq? text-or-image 'text) "") ; not defined ((eq? text-or-image 'image) "images/blue-house.gif") ((string? text-or-image) (string-append "images/" text-or-image)) (else "???"))) ) (html:a (cond ((eq? text-or-image 'text) "LAML home") ((or (eq? text-or-image 'image) (string? text-or-image)) (html:img 'src (string-append url-of-laml image-file) 'alt help-text 'border 0)) (else "LAML home")) 'href (string-append url-of-laml "index.html") 'title help-text 'target "_top"))) ;; Return a banner with left, middle, and right justified contributions. In html: Link from left-middle-right-banner to it's cross reference table entry 
(define (left-middle-right-banner left middle right) (html:table (html:tr (con (html:td (font-size 2 left) 'width "33%" 'align "left" 'valign "top") (html:td (font-size 2 middle) 'width "34%" 'align "center" 'valign "top") (html:td (font-size 2 right) 'width "33%" 'align "right" 'valign "top") ) ) 'border "0" 'cellpadding "0" 'cellspacing "0" 'width "100%") ) ;; Return a banner with left and right justified contributions. In html: Link from left-right-banner to it's cross reference table entry 
(define (left-right-banner left right) (html:table (html:tr (con (html:td (font-size 2 left) 'width "50%" 'align "left" 'valign "top") (html:td (font-size 2 right) 'width "50%" 'align "right" 'valign "top") ) ) 'border "0" 'cellpadding "0" 'cellspacing "0" 'width "100%") ) ;; Return the standard LAML top banner with time of generation, copyright, and home icon In html: Link from laml-top-banner to it's cross reference table entry 
(define (laml-top-banner) (left-middle-right-banner (when-generated) (string-append "Copyright " copyright " 2000, Kurt Nørmark") (laml-home-button 0 "laml-home.gif"))) ; _____________________________________________________________________________ ;;; Indenting and framing. ;;; Here is a number of functions of indentation and framing ;; Indent text with p pixels In html: 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 In html: 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 In html: 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 In html: 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. In html: 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. In html: 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. In html: 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. In html: 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 In html: Link from center-frame to it's cross reference table entry 
(define (center-frame indentation text) (center (narrow-with-pixels indentation (frame text)))) ; _____________________________________________________________________________ In html: 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 In html: 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")) ) ) In html: 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")) ) ) In html: 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))))) In html: 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 In html: 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)) In html: 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))))) ; --------------------------------------------------------------------------------------------------------------- In html: 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))) ; ----------------------------------------------------------------------------- ;; Concatenete a number of strings. Con is an alias of string-append. ;; It is the intension to use it when concatenating HTML constituents. ;; .form (con . string-list) ;; .reference "similar function" "concatenate" "../html4.0-loose/man/surface.html#concatenate" In html: Link from con to it's cross reference table entry 
(define con string-append) ;; Like con, but ensure that there are white space in between the concatenated strings. In html: Link from con-space to it's cross reference table entry 
(define (con-space . string-list) (let ((space-list (make-list (- (length string-list) 1) " "))) (string-merge string-list space-list))) ;; Like con, but ensure that there are paragraphs marks in between the concatenated strings. In html: 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))) ; Definition of underscore as space suppresssion. In this mirror the value is the empty string. ; This is used as a convenient notation for white space suppression in many documents. ; Serves the purpose of forward compatibility with newer mirrors. In html: Link from _ to it's cross reference table entry 
(define _ "") ; ----------------------------------------------------------------------------- ; Character entities In html: 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")))) In html: 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")))) In html: Link from copyright to it's cross reference table entry 
(define copyright (character-entity "copy")) ;; Embed x into a copyright indication In html: 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. In html: 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-version ". " "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. In html: 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" "æ" "ø" "å")))) In html: 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)))) ; ----------------------------------------------------------------------------- In html: 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))) In html: 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). In html: 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). In html: 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) )) In html: 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)) In html: 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. In html: 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 In html: 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 In html: 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"))) ;; Makes a horizontal menu menu in terms of a table with links. ;; The table is made on the basis of parameter mini-menu-list, which is a list of ;; menu entries. A menu entry is a list of anchor-text and URL pairs (lists of ;; two strings). Dark-color must be some dark color. In html: Link from mini-menu to it's cross reference table entry 
(define (mini-menu mini-menu-list dark-color) (letrec ((mini-menu-entry (lambda (e) (let ((text (car e)) (url (cadr e))) (con (html:a (font 2 white text) 'href url 'css:text-decoration "none") (horizontal-space 5))))) (lgt (length mini-menu-list))) (table-1 1 (make-list lgt 160) (make-list lgt dark-color) (list (map mini-menu-entry mini-menu-list)))))