; This file is made during the LAML configuration process - DO NOT EDIT!

;;;; .title Reference Manual of the LAML library
;;;; The file <kbd>laml.scm</kbd> is the very first laml file to load.
;;;; It contains a number of variable and functions which must be defined whenever LAML is used.
;;;; Some of the variables - the configuration variables - are defined via the LAML configuration process.
;;;; It also contains some very fundamental LAML stuff, including a number of top level commands that activate LAML tools.
;;;; Physically, laml.scm is composed of a tiny, configuration dependent file followed by the file laml-fundamental.scm.
;;;; These two files are documented together.<p>
;;;;
;;;;
;;;; <kbd>laml.scm</kbd> loads 
;;;; the scheme/OS/platform specific compatibility file
;;;; and the <a href="../lib/man/general.html">general library</a> from the <kbd>lib</kbd> directory.
;;;;
;;;;
;;;; It is assumed that the value of the variable <kbd>laml-dir</kbd> is the full path of the LAML directory;
;;;; <kbd>laml-dir</kbd> must be defined when <kbd>laml.scm</kbd> is loaded, and the path must end in a "/".
;;;; The laml command prompt command and the LAML Emacs activation commands will take care of the definition of <kbd>laml-dir</kbd> for you.

; Physically, this file constitute the configuration dependent part.
; The configuration independent part are located in laml-fundamental.scm

; The LAML library and programs are written by Kurt Normark, Aalborg University, Denmark.
; Copyright (C) 1999-2006  Kurt Normark, normark@s.aau.dk.
;
; 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


;;; The configuration section.
;;; The configuration section is meant to be addapted in each new LAML installation.
;;; This section contains a few fundamental variables. The variables are defined via
;;; the configuration file in the laml-config directory. 
;;; .section-id config-section
; ---------------------------------------------------------------------------------------------------
; CONFIGURATION SECTION

 
(define scheme-system 'mzscheme-200)

 
(define laml-platform 'unix)

 
(define operating-system 'linux)

 
(define laml-library "lib")

 
(define laml-version "Version 38.0 (November 14, 2011, full)")


; Determines how the laml processing is initiated. A symbol.
; rich: Information is transferred from the context such that the Scheme system knows the 
; file name and the start-up directory.
; poor: No information is transferred from the context.
; We now always use the value rich - in reality this variable does not play a role any longer.
(define laml-activation 'rich)


; The default name of an LAML output file.
; In case laml-activation is 'rich we use the name of the laml file to determine the name of the html output file.
; In poor laml activation situations we use the value of the variable laml-default-output-file.
; A file name without initial path and without extension.
; This variable does not play a role any longer.
(define laml-default-output-file "default")

; The default directory of LAML output.
; In case laml-activation is 'rich we use the name of the startup directory 
; (as returned by (startup-directory scheme-system) to determine this directory.
; The variable laml-default-output-directory is only used in case of poor laml-activation.
; This variable does not play a role any longer.
(define laml-default-output-directory "")

; The machine on which I use LAML-based software.
; This variable is not used any place in the LAML software, so *you* can forget about.
; I use it in the setup files of the LENO and course-plan systems. The variable allows
; me to find out on which machine I am running. Files, on which I rely, may be placed different
; places on different machines.
; Possible values: cs-unix, home-pc, thinkpad
(define computer-system 'cs-unix)

 
(define (begin-laml)
  ; Load the user's laml init file, if specified in the configuration file, and if the file exists.
  (if (and (not (equal? "/user/normark/.laml" "false")) (file-exists? "/user/normark/.laml"))
    (load "/user/normark/.laml")))

 
(define end-laml-loading begin-laml)

 
(define laml-execution-mode 'fast)

; END CONFIGURATIONS.

; ---------------------------------------------------------------------------------------------------------------------------------------------------------

; ADDITIONAL LOADING

; Load the relevant LAML compatibility file.
(let ((laml-lib-comp-file (lambda (nm) (string-append laml-dir "lib/compatibility/" nm)))
      (comp-file (lambda (nm) (string-append laml-dir "lib/compatibility/" nm)))
      (schemesys-platform-os (string-append (symbol->string laml-platform) "_" (symbol->string operating-system) "_" (symbol->string scheme-system) ".scm"))
      (schemesys-platform-star (string-append (symbol->string laml-platform) "_" "star" "_" (symbol->string scheme-system) ".scm"))
      (schemesys-star-star (string-append "star" "_" "star" "_" (symbol->string scheme-system) ".scm"))
     )
  (cond ((file-exists? (laml-lib-comp-file schemesys-platform-os))
             (load (comp-file schemesys-platform-os)))
        ((file-exists? (laml-lib-comp-file schemesys-platform-star))
             (load (comp-file schemesys-platform-star)))
        ((file-exists? (laml-lib-comp-file schemesys-star-star))
             (load (comp-file schemesys-star-star)))
        (else (error (string-append "Compatibility loading: Cannot find compatibility file in lib/compatibility.")))))

; Load the general LAML library
(load (string-append laml-dir "lib/general.scm"))

; Load the configuration independent part of the fundamental LAML library. 
(load (string-append laml-dir "laml-fundamental.scm"))

(if (and (not (equal? "/user/normark/.laml" "false")) (file-exists? "/user/normark/.laml"))
    (load "/user/normark/.laml")); =>man/laml.sdoc

; The configuration independent part of the laml.scm.
; Loaded by laml.scm, and assumed to form the rear part of laml.scm.


; Yet another configuration feature

 
(define (laml-temp-file-path)
  (string-append laml-dir "temp/"))





; TIMING.
; In MzScheme we meassure the time used by LAML to process a document.
; The end-laml procedure reports on the elapsed time.
; We Start the timing here. 

; start-laml-time is curretly only valid in mzscheme and guile. Units: System dependent.
(define start-laml-time 
   (cond ((or (eq? scheme-system 'mzscheme) (eq? scheme-system 'mzscheme-200))
             (current-process-milliseconds))
         ((eq? scheme-system 'guile) (get-internal-run-time)) 
         (else 0)))

; ---------------------------------------------------------------------------------------------------


; Other variables.
; This part of the laml.scm file contains some other variables. Most LAML users can ignore these.
; Taken out of the manual interface May 14, 2003.


; An alias of laml-dir.
; For backward compatibility.
; Some LAML applications change this variable to a more local directory.
(define software-directory laml-dir)

; An alias of laml-library. 
; For backward compatibility
(define scheme-library laml-library)

; Full path to the scheme library.
; Normally the value of this variable is derived from laml-dir and laml-library. 
; Ends in a slash.
(define the-library (string-append laml-dir laml-library "/"))

; A global variable which signals some kind of variations in the loading of a LAML style or library.
; If no load variation is present, the value of the variable will be #f. The interpretation of a non-false value
; is entirely up to a style or a library.
; The value of this variable is assigned by the style and laml-style form based on the last optional parameter of style or laml-style
(define laml-load-variation #f)


; An association list of languages and language maps.
; The variable is related to the xml-in-laml library.
(define xml-in-laml-languages-in-use '())

; An association list of languages and XML navigator structures.
; Used for fast navigation in ASTs, guided by static information from the
; underlying DTD.
(define xml-in-laml-navigator-structures '())

; An association list of languages and XML validation structures.
; Used for access to XML validation procedures given an element name.
(define xml-in-laml-validator-structures '())

; An association list of languages and XML content model structures.
; Used for access to the XML content models at document generation or transformation time.
(define xml-in-laml-content-model-structures '())

; As association list of languages and action procedure structures.
; A single action procedure structure of an XML language maps XML elements to action procedures of the language. 
(define xml-in-laml-action-procedure-structures '())

; ---------------------------------------------------------------------------------------------------
; Variables related to link checking.
; Belongs naturally in lib/xml-in-laml/xml-in-laml.scm, but located here
; in case xml-in-laml.scm becomes reloaded before end-laml is called.

; A list of relative url entries for later checing. Each entry is of the form (rel-url surrounding-absolute-file).
(define relative-url-list-for-later-checking '())

; A list of absolute url entries for later checing. Each entry is a string (the absolute url).
(define absolute-url-list-for-later-checking '())

; Internal global variable used for counting relative url linking problems
(define relative-url-problem-count 0)

; Internal global variable used for counting absolute url linking problems
(define absolute-url-problem-count 0)

; ---------------------------------------------------------------------------------------------------


;;; LAML version information.
;;; The functions in this section return information about the version of LAML that you have installed.
;;; The functions basically return the same information as the string laml-version.
;;; We provide these function to make the LAML version information available on a more convenient form than in
;;; in the string laml-version. The version information is taken from the file distribution-version.lsp in the 
;;; root of the LAML distribution. Always use the functions in this section to access the version information.
;;; (Do not read and interpret the information in distribution-version.lsp directly).
;;; .section-id laml-version-functions
 
(define (laml-version-numbers)
 (let ((laml-version-info (file-read (string-append laml-dir "distribution-version.lsp"))))
   (list (car laml-version-info) (cadr laml-version-info))))

 
(define (laml-version-time)
 (let ((laml-version-info (file-read (string-append laml-dir "distribution-version.lsp"))))
   (car (cddr laml-version-info))))

 
(define (laml-version-kind)
 (let ((laml-version-info (file-read (string-append laml-dir "distribution-version.lsp"))))
   (as-string (car (cdr (cdr (cdr laml-version-info)))))))




; ---------------------------------------------------------------------------------------------------

;;; Library, style, tool, and local dir loading.
;;; The functions in this section loads LAML libraries and LAML styles.
;;; .section-id loading-section
 
(define (lib-load suffix-path)
  (load (string-append the-library suffix-path)))

 
(define (laml-tool-load suffix-path)
  (load (string-append laml-dir "tools/" suffix-path)))

 
(define (local-load suffix-path)
  (load (string-append (startup-directory) suffix-path)))

; Load a LAML style.
; .form (style style-spec [style-base load-variation])
; .parameter style-spec The name of the style to load. A style-spec is without extension. However, the style file must have the scm extension.
; .parameter style-base: The directory which contains the style. If style-base is given it must be a directory (a slash terminated string) from which to load your style. If style-base is omitted, the style is loaded from styles subdirectory of the LAML directory.
; .parameter load-variation: A load-variation assigned to the global LAML variable laml-load-variation.
; .example  (style "simple" #f 'xyz-variation)
; .example  (style "manual" "manual/")
; .internal-references "also relevant" "laml-style"
(define (style style-spec . optional-parameters)
 (let ((original-load-variation laml-load-variation))
  (let ((style-base (optional-parameter 1 optional-parameters))
        (load-variation (optional-parameter 2 optional-parameters))
       )
   (set! laml-load-variation load-variation)
   (if style-base
       (load (string-append style-base style-spec ".scm"))
       (load (string-append software-directory "styles/" style-spec ".scm")))
   (set! laml-load-variation original-load-variation))))

 
(define laml-style style)

; ---------------------------------------------------------------------------------------------------

;;; LAML contextual information.
;;; The functions in this section deal with the necessary context information,
;;; which must be passed to Scheme when we use LAML.
;;; .section-id context-section
 
(define (source-filename-without-extension . unused-parameter)
  (let ((cmd-line (laml-canonical-command-line)))
    (if cmd-line (cadr cmd-line) #f)))

 
(define (startup-directory . unused-parameter)
  (let ((cmd-line (laml-canonical-command-line)))
    (if cmd-line (caddr cmd-line) #f)))

 
(define (laml-program-parameters)
  (let ((cmd-line (laml-canonical-command-line)))
    (if (and cmd-line (>= (length cmd-line) 3))
        (cadddr cmd-line)
        '())))
  

 
(define (laml-canonical-command-line)
  (error "laml-canonical-command-line is not defined in scheme-system dependent compatibility file"))

 
(define (fake-startup-parameters source-file startup-dir . program-parameters)
  (error "fake-startup-parameters is not defined in scheme-system dependent compatibility file"))

 
(define (fake-startup-parameters-prog-par-list source-file startup-dir program-parameter-list)
  (apply fake-startup-parameters (append (list source-file startup-dir) program-parameter-list)))


 
(define (set-laml-startup-directory dir)
 (let ((start-dir (startup-directory)))
  (let ((abs-dir
          (cond ((and (equal? ".." dir) start-dir (parent-directory start-dir)) (parent-directory start-dir))
                ((and (not (absolute-file-path? dir)) start-dir) (string-append start-dir (ensure-final-character dir #\/)))
                ((absolute-file-path? dir) (ensure-final-character dir #\/))
                (else (display-error (string-append "Use an absolute file path!!!"))))))
    (if (directory-exists? abs-dir)
        (begin 
          (fake-startup-parameters-prog-par-list
             (source-filename-without-extension) abs-dir (laml-program-parameters))
          (display-message (string-append "Using LAML in directory: " abs-dir)))
        (laml-error "Non-existing directory: " abs-dir)))))

 
(define (in-startup-directory . suffixes)
 (let ((suffix (accumulate-right string-append "" suffixes)))
  (string-append (startup-directory) suffix)))

 
(define (laml-source-file-path . optional-parameter-list)
  (let ((ext (optional-parameter 1 optional-parameter-list #f)))
    (in-startup-directory 
      (source-filename-without-extension) 
      (if ext (string-append "." ext) ""))))
  

 
(define (laml-cd dir)
  (set-laml-startup-directory dir))

 
(define (laml-pwd)
  (startup-directory))

 
(define (laml-ls)
  (directory-list (startup-directory)))
  

 
(define (set-laml-source-file file)
  (fake-startup-parameters-prog-par-list
    file (startup-directory) (laml-program-parameters)))

 
(define (set-laml-program-parameters program-parameters)
  (fake-startup-parameters-prog-par-list
    (source-filename-without-extension) (startup-directory) program-parameters))

 
(define (full-source-path-with-extension ext)
  (string-append 
    (startup-directory)
    (source-filename-without-extension)
    "." ext))

; ---------------------------------------------------------------------------------------------------

;;; Programmatic loading of laml files. 
;;; Loading a LAML file invovles the setting of two pieces of context: The name of
;;; of the source file and the startup directory. The function laml-load sets these
;;; information and loads a file.
;;; .section-id prog-loading-section
 
(define (laml file-name . program-parameters)
 (let* ((init-path (file-name-initial-path file-name))
        (extension (file-name-extension file-name))
        (proper-name (file-name-proper file-name))
        (init-path-1 (if (empty-string? init-path) (startup-directory) init-path))
        (extension-1 (if (empty-string? extension) "laml" extension))
        (proper-name-1 proper-name))
 
   (if (and (empty-string? init-path) (not (startup-directory)))
       (error "Please use full file path or set the laml startup directory via set-laml-startup-directory"))

   (laml-load (string-append init-path-1 proper-name-1 "." extension-1) program-parameters)))

 
(define (laml-load full-file-path . optional-parameter-list)
 (let ((original-filename-without-extension (source-filename-without-extension))
       (original-startup-dir (startup-directory))
       (original-program-parameters (laml-program-parameters))
      )
  (let ((filename-without-extension (file-name-proper full-file-path))
        (startup-dir (file-name-initial-path full-file-path))
        (program-parameter-list (optional-parameter 1 optional-parameter-list '()))
       )
    (fake-startup-parameters-prog-par-list  filename-without-extension startup-dir program-parameter-list)
    (load full-file-path)
    ; restore originals
    (if (and original-filename-without-extension original-startup-dir)
        (fake-startup-parameters-prog-par-list original-filename-without-extension original-startup-dir original-program-parameters)))))



; ---------------------------------------------------------------------------------------------------
; It turns out that the loading stuff in the next section relies on case sensitive reading.
; Therefore the compatibility loading is placed here.

; Loads the scheme-system specific compatibility file and the LAML general library.
; Try most specifics first: 
;     scheme-system  and  platform  and  operating-system
;     scheme-system  and  platform  and  *
;     scheme-system  and  *         and  *


(let ((laml-lib-comp-file (lambda (nm) (string-append laml-dir "lib/compatibility/" nm)))
      (comp-file (lambda (nm) (string-append "compatibility/" nm)))
      (schemesys-platform-os (string-append (symbol->string laml-platform) "_" (symbol->string operating-system) "_" (symbol->string scheme-system) ".scm"))
      (schemesys-platform-star (string-append (symbol->string laml-platform) "_" "star" "_" (symbol->string scheme-system) ".scm"))
      (schemesys-star-star (string-append "star" "_" "star" "_" (symbol->string scheme-system) ".scm"))
     )
  (cond ((file-exists? (laml-lib-comp-file schemesys-platform-os))
             (lib-load (comp-file schemesys-platform-os)))
        ((file-exists? (laml-lib-comp-file schemesys-platform-star))
             (lib-load (comp-file schemesys-platform-star)))
        ((file-exists? (laml-lib-comp-file schemesys-star-star))
             (lib-load (comp-file schemesys-star-star)))
        (else (error (string-append "Compatibility loading: Cannot find compatibility file in lib/compatibility.")))))
        

; ---------------------------------------------------------------------------------------------------


;;; Interactive tool activation.
;;; The procedures in this section activate LAML tools. 
;;; It is recommended that you activate the commands from an interactive LAML (Scheme) prompt.
;;; From Emacs carry out the editor command <kbd> run-laml-interactively </kbd>.<p>
;;; All the commands below work relative to the LAML working directory, which is changed by the procedure
;;; <kbd> laml-cd </kbd>. Use the command <kbd> laml-pwd </kbd> to find out about the LAML working directory.
;;; .section-id interactive-tool-section
; Make documentation from a scheme source file.
; This procedure is meant to be called from a Scheme interpreter, in which LAML is loaded and available.
; The procedure utilizes the attributes, which are extracted from the introductory comment (the abstract comment) of the Scheme source file. 
; .form (schemedoc scheme-source-file [commenting-style])
; .parameter scheme-input-file The file name of the Scheme source file, including file extension.\
;    It can be an absolute file path.\
;    It can also be a simple file name (or relative file path) which is assumed to be relative to the so-called startup-directory of LAML.
; .parameter commenting-style   One of the symbols multi-semicolon or documentation-mark. The default value is multi-semicolon.
; .reference "Further info" "LAML Tutorial section" "../tutorial/schemedoc/schemedoc.html"
; (define (schemedoc scheme-input-file . optional-parameter-list)
;  (let* ((scheme-source-file (file-name-proper-and-extension scheme-input-file))
;         (commenting-style (as-symbol (optional-parameter 1 optional-parameter-list "multi-semicolon")))
;         (this-dir (if (absolute-file-path? scheme-input-file) (file-name-initial-path scheme-input-file) (startup-directory)))
;       )
;   (display-message "The LAML Schemedoc tool...")
;   (load (string-append software-directory "tools/schemedoc-extractor/schemedoc-extractor.scm"))
;   (set! scheme-documentation-commenting-style commenting-style)
;
;   (let* (
;          (doc-list (reverse (extract-documentation-from-scheme-file (string-append this-dir scheme-source-file))))
;          (destination-dir (string-append this-dir extracted-source-destination-delta))
;          (manual-title extracted-manual-title)
;          (manual-author-info (list extracted-manual-author extracted-manual-affiliation ))
;          (manual-abstract (if (empty-string? extracted-manual-abstract) "-" extracted-manual-abstract))
;          (manual-name-from-file (file-name-proper scheme-source-file))
;          (extracted-laml-resource-info extracted-laml-resource)
;          (extracted-css-prestylesheet-info extracted-css-prestylesheet)
;          (extracted-css-stylesheet-info extracted-css-stylesheet)
;          (extracted-css-stylesheet-copying-info extracted-css-stylesheet-copying)
;          (extracted-source-linking-info extracted-scheme-source-linking)
;         )
;
;     (laml-style "xml-in-laml/schemedoc-2/schemedoc" (string-append laml-dir "styles/") 'conservative-xhtml-loading)
;
;     (set! laml-manual-stuff (as-boolean extracted-laml-resource-info))
;     (set! the-manual-prestylesheet extracted-css-prestylesheet-info)
;     (set! the-manual-stylesheet extracted-css-stylesheet-info)
;     (set! copy-css-stylesheet? (as-boolean extracted-css-stylesheet-copying-info))
;
;     (set! css-stylesheet-schema 'local)
;     (set! the-manual-title manual-title) 
;     (set! the-manual-author manual-author-info)
;     (set! the-manual-abstract (if (not (empty-string? manual-abstract)) manual-abstract extracted-manual-abstract))
;     (set! manual-name manual-name-from-file)
; ;    (set! manual-index-width-list  (list 180 320 350))
;     (set! link-to-ep-source-program? (as-boolean extracted-source-linking-info))
;
;     (set! end-remark "This documentation has been extracted automatically from the Scheme source file.")
;
;     (make-manual doc-list 'manual-from-scheme-file destination-dir (string-append this-dir scheme-source-file))
;
;     (display-message 
;       (string-append "DONE. The manual of " scheme-source-file " is located in "
;                      destination-dir manual-name ".html. "))
; ;    (display-message (string-append "The file "  manual-name ".manlsp" " contains a useful internal format."))
;
;     )))

 
(define (schemedoc scheme-input-file . optional-parameter-list)
 (let* ((scheme-source-file (file-name-proper scheme-input-file))
        (scheme-source-file-plus (file-name-proper-and-extension scheme-input-file))
        (commenting-style (as-string (optional-parameter 1 optional-parameter-list "multi-semicolon")))
        (this-dir (if (absolute-file-path? scheme-input-file) (file-name-initial-path scheme-input-file) (startup-directory)))
        (temp-script-source-name "temp-script.sdoc")
        (loading-prefix (string-append "(load (string-append laml-dir \"laml.scm\")) (laml-style \"xml-in-laml/schemedoc-2/schemedoc\")"))
      )
  (display-message "The LAML Schemedoc tool...")

  ; Load SchemeDoc
  (laml-style "xml-in-laml/schemedoc-2/schemedoc" (string-append laml-dir "styles/") 'conservative-xhtml-loading)

  ; Generate SchemeDoc LAML script
  (let ((manual-ast 
          (manual 'internal:run-action-procedure "false"
	   (manual-front-matters
	    'documentation-commenting-style commenting-style
	    'manual-destination-name scheme-source-file
	    )

	   (manual-from-scheme-file 'src scheme-input-file)
	   )))
    (write-text-file
      (string-append loading-prefix (xml-render-as-laml manual-ast))
      (string-append this-dir temp-script-source-name)))

  ; Execute SchemeDoc LAML script
  (laml (string-append this-dir temp-script-source-name))

  ; Delete SchemeDoc LAML script
  (delete-file (string-append this-dir temp-script-source-name))

  (display-message 
    (string-append "DONE. The SchemeDoc manual of " scheme-source-file-plus " has been generated."))

))

 
(define (xml-dtd-manual dtd-path . optional-parameter-list)
 (let ((target-path (optional-parameter 1 optional-parameter-list (startup-directory)))
       (mirror-name-prefix (optional-parameter 2 optional-parameter-list ""))
      )
  (laml-style "manual/manual" (string-append laml-dir "styles/") 'conservative-xhtml-loading)
  (let* ((language-name (file-name-proper dtd-path))
         (doc-list 
           (map (manual-extend 'description (string-append "An XML element as defined in the " language-name " XML DTD."))
              (manual-from-parsed-dtd (file-read (string-append dtd-path "." "lsp")) mirror-name-prefix)))
       )
    (set-manual-abstract (string-append "An automatically generated LAML manual of the " language-name " XML DTD."))
    (set-manual-name language-name)
    (set-manual-title (string-append "The " language-name " XML DTD"))
    (make-manual (reverse doc-list) 'manual-from-xml-dtd target-path))))

 
(define (xml-dtd-parse dtd-file-name)
  (load (string-append laml-dir "tools/dtd-parser/dtd-parser-4.scm"))
  (parse-dtd dtd-file-name)
)

 
(define (generate-xml-mirror parsed-dtd-file-name language-name . optional-parameter-list)
 (let ((action-element-list (optional-parameter 1 optional-parameter-list '())))
  (load (string-append laml-dir "tools/xml-in-laml/xml-in-laml.scm"))
  (set! mirror-name (as-string language-name))
  (set! action-elements action-element-list)
  (let ((dtd-file (file-name-proper parsed-dtd-file-name)))
    (generate-mirror (string-append parsed-dtd-file-name ".lsp") (string-append (startup-directory) dtd-file "." "scm") language-name)
  ))) 


 
(define (xml-parse-file in-file-name xml-language . optional-parameters)
 (let* ((this-dir (startup-directory))
        (proper-file-name (file-name-proper in-file-name))
        (ext (file-name-extension in-file-name))
        (out-file-name (optional-parameter 1 optional-parameters #f))
        (in-path (if (absolute-file-path? in-file-name) 
                     in-file-name
                     (string-append this-dir proper-file-name (if (empty-string? ext) "" (string-append "." ext)))))
        (out-path (if out-file-name (string-append this-dir out-file-name) #f))
      )

  (load (string-append laml-dir "tools/xml-html-support/xml-support.scm"))
  (set! white-space-preserving-tags 
        (if (memq (as-symbol xml-language) (languages-in-use))
            (xml-preformatted-text-elements-in (as-symbol xml-language))
            '()))

  (let ((ast (parse-xml-to-ast in-path xml-language)))
    (if (language-in-use? (as-symbol xml-language))
        (begin
           (display-message "Validating AST")
           (validate-ast! ast (as-symbol xml-language)))
        (display-message "Validation not posssible. (Mirror of" xml-language "is not loaded)."))
    (if out-path
        (begin
          (if (file-exists? out-path) (delete-file out-path))
          (let ((op (open-output-file out-path)))
	    (write ast op)
	    (close-output-port op)
	    (display-message "AST written to" out-path)))
        ast))))
      

 
(define (xml-parse-string xml-string xml-language)

  (load (string-append laml-dir "tools/xml-html-support/xml-support.scm"))
  (set! white-space-preserving-tags (xml-preformatted-text-elements-in (as-symbol xml-language)))

  (let ((res (parse-xml-string-to-ast xml-string (as-symbol xml-language))))
    (if (language-in-use? (as-symbol xml-language))
        (begin
          (display-message "Validating AST")
          (validate-ast! res (as-symbol xml-language))
        )
        (display-message "Validation not possible (mirror of" xml-language "is not loaded)"))
    res))

 
(define (html-parse in-file-name . optional-parameters)
 (let* ((this-dir (startup-directory))
        (proper-file-name (file-name-proper in-file-name))
        (ext (file-name-extension in-file-name)) 
        (out-file-name (optional-parameter 1 optional-parameters (string-append proper-file-name "." "lsp"))) 
        (in-path (string-append this-dir proper-file-name (if (empty-string? ext) "" (string-append "." ext))))
        (out-path (string-append this-dir out-file-name))    
      )
  (load (string-append laml-dir "tools/xml-html-support/html-support.scm"))
  (parse-html-file in-path out-path)))

 
(define (xml-pp in-file-name . optional-parameters)
 (let* ((out-file-name (optional-parameter 1 optional-parameters in-file-name))
        (single-lining (optional-parameter 2 optional-parameters #t))
        (indentation (optional-parameter 3 optional-parameters 3))
        (max-width (optional-parameter 4 optional-parameters 80))
        (this-dir (startup-directory))
        (proper-in-file-name (file-name-proper in-file-name))
        (ext (file-name-extension in-file-name))
        (in-file-path (string-append this-dir in-file-name))
        (out-file-path (string-append this-dir out-file-name))
       )
  (load (string-append laml-dir "tools/xml-html-support/xml-support.scm"))

  (set! use-single-lining single-lining)
  (set! indentation-delta indentation)
  (set! prefered-maximum-width max-width)

  (write-text-file
    (pretty-print-xml-parse-tree 
      (if (equal? ext "lsp") (file-read in-file-path) (parse-xml in-file-path)))
    out-file-path)))

 
(define (html-pp in-file-name . optional-parameters)
 (let* ((out-file-name (optional-parameter 1 optional-parameters in-file-name))
        (single-lining (optional-parameter 2 optional-parameters #t))
        (indentation (optional-parameter 3 optional-parameters 3))
        (max-width (optional-parameter 4 optional-parameters 80))
        (this-dir (startup-directory))
        (proper-in-file-name (file-name-proper in-file-name))
        (ext (file-name-extension in-file-name))
        (in-file-path (string-append this-dir in-file-name))
        (out-file-path (string-append this-dir out-file-name))
       )
  (load (string-append laml-dir "tools/xml-html-support/html-support.scm"))

  (set! use-single-lining single-lining)
  (set! indentation-delta indentation)
  (set! prefered-maximum-width max-width)

  (write-text-file
    (pretty-print-html-parse-tree 
      (if (equal? ext "lsp") (file-read in-file-path) (parse-html in-file-path)))
    out-file-path)))



 
(define (bibtex file-name)
 (let ((this-dir (startup-directory))
       (proper-file-name (file-name-proper file-name))
       (ext (file-name-extension file-name))       
      )
  (lib-load "collect-skip.scm")
  (lib-load "file-read.scm")
  (load (string-append laml-dir "tools/bibtex/bibtex.scm"))
  (lib-load "time.scm")
  (lib-load "color.scm")
  (lib-load "html4.0-loose/basis.scm")
  (lib-load "html4.0-loose/surface.scm")
  (lib-load "html4.0-loose/convenience.scm")

  (parse-bibtex-file (string-append this-dir proper-file-name))
  (set! parse-result (reverse parse-result))

  (write-text-file
    (page 
      "Bibtex"
      (present-bibtex-entries parse-result (p)))
    (string-append this-dir proper-file-name ".html"))

  (display-message (string-append "The HTML output is in the file " (string-append this-dir proper-file-name ".html")))))

 
(define (scheme-pp in-file-name . optional-parameters)
 (let* ((out-file-name (optional-parameter 1 optional-parameters in-file-name))
        (single-lining (optional-parameter 2 optional-parameters #t))
        (indentation (optional-parameter 3 optional-parameters 3))
        (max-width (optional-parameter 4 optional-parameters 80))
        (this-dir (startup-directory))
        (proper-in-file-name (file-name-proper in-file-name))
        (ext (file-name-extension in-file-name))
        (in-file-path (string-append this-dir in-file-name))
        (out-file-path (string-append this-dir out-file-name))
        (in-file-path-temp (string-append (laml-temp-file-path) proper-in-file-name "-" "temp!!!" "." ext))
       )
  (lib-load "file-read.scm")
  (load (string-append laml-dir "tools/schemedoc-extractor/schemedoc-extractor.scm"))
  (set! COMMENT-FORM-START (string-append "(comment!!! "))
  (lib-load "scheme-pretty-printing.scm") 
  (set! use-single-lining single-lining)
  (set! indentation-delta indentation)
  (set! prefered-maximum-width max-width)
  (lexical-to-syntactical-comments! in-file-path in-file-path-temp) 
  (pretty-print-lisp-file in-file-path-temp out-file-path)
  (delete-file in-file-path-temp)
 )
)

 
(define (scheme-pp-simple in-file-name . optional-parameters)
 (let* ((out-file-name (optional-parameter 1 optional-parameters in-file-name))
        (single-lining (optional-parameter 2 optional-parameters #t))
        (indentation (optional-parameter 3 optional-parameters 3))
        (max-width (optional-parameter 4 optional-parameters 80))
        (this-dir (startup-directory))
        (proper-in-file-name (file-name-proper in-file-name))
        (ext (file-name-extension in-file-name))
        (in-file-path (string-append this-dir in-file-name))
        (out-file-path (string-append this-dir out-file-name))
       )
  (lib-load "file-read.scm")
  (lib-load "scheme-pretty-printing.scm") 
  (set! use-single-lining single-lining)
  (set! indentation-delta indentation)
  (set! prefered-maximum-width max-width)
  (pretty-print-lisp-file in-file-path out-file-path)
 )
)

 
(define (html-to-laml in-file-name out-file-name)
 (let* ((this-dir (startup-directory))
        (in-file-path (string-append this-dir in-file-name))
        (out-file-path (string-append this-dir out-file-name))
       )
  (load (string-append laml-dir "tools/xml-html-support/html-support.scm"))
  (lib-load "scheme-pretty-printing.scm") 
  (let* ((html-parse-tree (parse-html in-file-path)))
    (parse-tree-to-laml html-parse-tree out-file-path)
    (pretty-print-lisp-file out-file-path))))


 
(define (leno-xml leno-xml-file)
  (set-laml-source-file (file-name-proper leno-xml-file)) 
  (laml-tool-load "xml-html-support/xml-support.scm")
  (display "Parsing XML file") (newline)
  (let* ((parse-tr (parse-xml (string-append (startup-directory) leno-xml-file)))
         (element-str (parse-tree-to-element-structure parse-tr)))
    (display "Parsing OK.  LENO Processing starts.") (newline)
    (laml-style "lecture-notes/leno")  
    (leno-xml-process element-str)))



; ---------------------------------------------------------------------------------------------------
;;; Language settings.
;;; .section-id language-section
 
(define language-preference 'english) 

 
(define (text-choice danish english)
  (cond ((equal? language-preference 'english) english)
        ((equal? language-preference 'danish) danish)
        (else (error "Text: Problems in chosing language. Only 'english and 'danish are supported"))))

; ---------------------------------------------------------------------------------------------------
;;; LAML home URL and directories.
;;; The home directory of LAML is always the value of the variable laml-dir, which is defined a LAML installation time.
;;; In this directories there are useful URL and directory functions related to the LAML home directory.
;;; .section-id home-url-section

 
(define laml-absolute-url-prefix "http://www.cs.aau.dk/~normark/scheme/distribution/laml/")


 
(define (laml-home-url-prefix . optional-parameter-list)
 (let ((extra-level (optional-parameter 1 optional-parameter-list 0))
       (start-dir (optional-parameter 2 optional-parameter-list (startup-directory))))
  (cond ((boolean? extra-level) laml-absolute-url-prefix)
	((string? extra-level) extra-level)
	((number? extra-level) 
	   (if start-dir
	       (let ((dir-diff (directory-level-difference start-dir laml-dir)))
		 (cond ((and dir-diff (number? dir-diff) (>= dir-diff 0)) 
			(string-append (repeat-string "../" (+ dir-diff extra-level))))
		       (else laml-absolute-url-prefix)))
	       laml-absolute-url-prefix))
	(else (laml-error "laml-home-url: Problems with the type of extra-level parameter" extra-level)))))


 
(define (laml-dir-prefix . optional-parameter-list)
 (let ((dir (optional-parameter 1 optional-parameter-list (startup-directory))))
  (let* ((normalized-dir (normalize-file-path dir))
         (diff (directory-level-difference normalized-dir laml-dir))
        )
    (if diff 
        (repeat-string "../" diff)
        laml-dir))))

 
(define (laml-local-url-prefix . optional-parameter-list)
 (let ((dir (optional-parameter 1 optional-parameter-list (startup-directory))))
  (let* ((normalized-dir (normalize-file-path dir))
         (diff (directory-level-difference normalized-dir laml-dir))
        )
    (if diff 
        (repeat-string "../" diff)
        (string-append "file://" laml-dir)))))


 
(define (is-a-laml-directory? dir)
  (let ((dir-diff (directory-level-difference dir laml-dir)))
    (cond ((and (boolean? dir-diff) (not dir-diff)) #f)
          ((and (number? dir-diff) (< dir-diff 0)) #f)
          ((and (number? dir-diff) (>= dir-diff 0)) #t)
          (else (laml-error "is-a-laml-directory?: Should not happen:" dir-diff)))))

; ---------------------------------------------------------------------------------------------------
;;; Document prolog and epilog functions.
;;; This section contains definitions of document prolog and epilog functions.
;;; In addition, there are a number of more basic functions which return information about 
;;; the document. Several of these return empty strings, and they intended to be redefined in other contexts.
;;; .section-id prolog-epilog-section
 
(define (standard-prolog . optional-parameter-list)
 (let ((language (optional-parameter 1 optional-parameter-list #f)))
  (string-append
   (document-type-declaration)
   (if (not (empty-string? (document-type-declaration))) (as-string #\newline) "")
   (copyright-clause)
   (if (not (empty-string? (copyright-clause))) (as-string #\newline) ""))))

 
(define (standard-epilog . optional-parameter-list)
 (let ((language (optional-parameter 1 optional-parameter-list #f)))
  (string-append 
    (as-string #\newline)
    (laml-standard-comment) (as-string #\newline)
    (tracing-comment)))) 


 
(define (document-type-declaration . optional-parameter-list)
 (let ((language (optional-parameter 1 optional-parameter-list #f)))
   ""))


 
(define (copyright-clause)
  "")

 
(define  (laml-standard-comment)
  (html-comment 
    (string-append 
      "Generated from a LAML source file. " 
      laml-version ". "
      "LAML is designed and implemented by Kurt Nørmark, normark@cs.aau.dk. "
    )))

(define (html-comment comment)
  (string-append "<!-- " comment "-->"))

 
(define (tracing-comment) "")

    

; ---------------------------------------------------------------------------------------------------
;;; Cosmetic welcome, ending and copyright functions. 
;;; .section-id welcome-section

 
(define (laml-welcome)
  (let ((vers (read-text-file (string-append laml-dir "distribution-version"))))
    (display (string-append "Welcome to LAML " vers ".")) (newline)
    (display "(C) Kurt Normark, Aalborg University, Denmark.") (newline) ))

 
(define (end-laml)
 (let ((time-diff 
          (cond ((or (eq? scheme-system 'mzscheme) (eq? scheme-system 'mzscheme-200))
                    (- (current-process-milliseconds) start-laml-time))
                ((eq? scheme-system 'guile)
                    (inexact->exact (round (* (/ (- (get-internal-run-time) start-laml-time) internal-time-units-per-second) 1000))))
                (else #f))))
  (if time-diff
      (begin
       (display (string-append "LAML processing time: " (as-string time-diff) " milliseconds."))
       (newline)))

  (display "End of LAML processing") (newline)))

; The original end-laml function. 
; Used by other parts of LAML to get access to the original end-laml in laml.scm, for instance as part of redefining end-laml.
(define original-end-laml end-laml)


 
(define (credits system-dk system-eng . optional-parameter-list)
 (let* ((url (optional-parameter 1 optional-parameter-list #f))
        (anchor-text (text-choice system-dk system-eng))
        (anchor-clause (if url (a-tag url anchor-text) anchor-text))
       )
   (string-append 
     (text-choice 
         (con anchor-clause " er designet og programmeret af Kurt Nørmark (c), Aalborg Universitet, med brug af "
                       (a-tag "http://www.cs.aau.dk/~normark/laml/" (font-color black "LAML")) " teknologi.")
         (con anchor-clause " is designed and programmed by Kurt Nørmark (c), Aalborg University, Denmark using " 
                      (a-tag "http://www.cs.aau.dk/~normark/laml/" (font-color black "LAML")) " technology.")
                  ))))


 
(define (laml-power-icon . optional-parameter-list)
 (let ((extra-level (optional-parameter 1 optional-parameter-list 0))
       (icon-size   (as-symbol (optional-parameter 2 optional-parameter-list 'large)))
      )
   (a 'href "http://www.cs.aau.dk/~normark/laml/"
      (img 'border "0"
           'src (string-append (laml-home-url-prefix extra-level)
                              (cond ((eq? icon-size 'large) "images/laml-power-icon-4.gif")
                                    ((eq? icon-size 'small) "images/laml-mini-icon-1.gif")
                                    (else (laml-error "laml-power-icon: third parameter must either be large or small"))))
           'alt "Program Oriented Web Engineering - using LAML"))))


 
(define (laml-shortcut-icon laml-home-url-dir)
  (link 'rel "SHORTCUT ICON" 'href (string-append laml-home-url-dir "images/16-16-icon.ico")))



;;; XML file writing procedures.
;;; In this section we have a convenient and versatile function which can be used to write an XML expression in LAML to a text file.
;;; .section-id html-file-writing-section

 
(define (write-xml mode-0 xml-clause . optional-parameter-list)
 (let ((file-path-with-extension (optional-parameter 1 optional-parameter-list (full-source-path-with-extension "html")))
       (mode (cond ((symbol? mode-0) mode-0)
                   ((list? mode-0) (cond ((memq 'raw mode-0) 'raw)
                                         ((memq 'pp mode-0) 'pp)
                                         (else raw)))))
       (prolog? (cond ((list? mode-0) (cond ((memq 'prolog mode-0) #t)
                                           (else #f)))
                      (else #f)))
       (epilog? (cond ((list? mode-0) (cond ((memq 'epilog mode-0) #t)
                                           (else #f)))
                      (else #f)))
       
      )
  (cond 
        ((and (ast? xml-clause) (is-xml-ast? xml-clause) (eq? mode 'pp))
	 (if (file-exists? file-path-with-extension) (delete-file file-path-with-extension))
         (if (not (eq? xml-link-checking 'none)) (collect-links-for-later-checking-in-ast! xml-clause file-path-with-extension))
	 (let* ((op (open-output-file file-path-with-extension)))
           (pretty-render-to-output-port (expand-procedural-content-items-in-ast xml-clause) op (if prolog? 'prolog #f) (if epilog? 'epilog #f))
           (close-output-port op))
         (write-xml-post-process! file-path-with-extension)
         'done
        )

        ((and (ast? xml-clause) (is-xml-ast? xml-clause) (eq? mode 'raw))
	 (if (file-exists? file-path-with-extension) (delete-file file-path-with-extension))
         (if (not (eq? xml-link-checking 'none)) (collect-links-for-later-checking-in-ast! xml-clause file-path-with-extension))
	 (let* ((op (open-output-file file-path-with-extension)))
           (render-to-output-port (expand-procedural-content-items-in-ast xml-clause) op (if prolog? 'prolog #f) (if epilog? 'epilog #f))
           (close-output-port op))
         (write-xml-post-process! file-path-with-extension)
         'done
        )
	(else (laml-error "write-xml: Unsupported combination of xml-clause and writing mode" mode "Consider the procedure write-html.")))))

; Activate the XML post processor, as determined by the file extension of full-target-file-path-with-extension.
; Pass full-target-file-path-with-extension to the processor.
; Given an extension e, activate the function (string-append e "-" "process") if this name is bound in the current environment.
(define (write-xml-post-process! full-target-file-path-with-extension)
  (let* ((ext (file-name-extension full-target-file-path-with-extension))
         (processor-symbol (as-symbol (string-append ext "-" "process")))
        )
    (cond ((bound? processor-symbol)
             ((eval-cur-env processor-symbol) full-target-file-path-with-extension))
          (else 'do-nothing))))

 
(define (process-xml processing-specs file-path ast)
  (let ((init-path (file-name-initial-path file-path))
        (proper-name (file-name-proper file-path)))
  (for-each
    (lambda (spec)
      (let ((ext (first spec))
            (transformer (second spec))
            (mode-symbols (cddr spec)))
        (write-xml mode-symbols (transformer ast) (string-append init-path proper-name "." ext))))
    processing-specs
  )))
             

 
(define (write-html mode-0 html-clause . optional-parameter-list)
 (let ((file-path-with-extension (optional-parameter 1 optional-parameter-list (full-source-path-with-extension "html")))
       (mode (cond ((symbol? mode-0) mode-0)
                   ((list? mode-0) (cond ((memq 'raw mode-0) 'raw)
                                         ((memq 'pp mode-0) 'pp)
                                         (else raw)))))
       (prolog? (cond ((list? mode-0) (cond ((memq 'prolog mode-0) #t)
                                           (else #f)))
                      (else #f)))
       (epilog? (cond ((list? mode-0) (cond ((memq 'epilog mode-0) #t)
                                           (else #f)))
                      (else #f)))
       
      )
  (cond 
        ((and (ast? html-clause) (is-xml-ast? html-clause) (eq? mode 'pp))
	 (if (file-exists? file-path-with-extension) (delete-file file-path-with-extension))
         (if (not (eq? xml-link-checking 'none)) (collect-links-for-later-checking-in-ast! html-clause file-path-with-extension))
	 (let* ((op (open-output-file file-path-with-extension)))
           (pretty-render-to-output-port (expand-procedural-content-items-in-ast html-clause) op (if prolog? 'prolog #f) (if epilog? 'epilog #f))
           (close-output-port op))
        )

        ((and (ast? html-clause) (is-xml-ast? html-clause) (eq? mode 'raw))
	 (if (file-exists? file-path-with-extension) (delete-file file-path-with-extension))
         (if (not (eq? xml-link-checking 'none)) (collect-links-for-later-checking-in-ast! html-clause file-path-with-extension))
	 (let* ((op (open-output-file file-path-with-extension)))
           (render-to-output-port (expand-procedural-content-items-in-ast html-clause) op (if prolog? 'prolog #f) (if epilog? 'epilog #f))
           (close-output-port op))
        )

        ((and (ast? html-clause) (eq? mode 'pp))  ; non-xml ast - html4.01 presumably
         (load (string-append laml-dir "tools/xml-html-support/html-support.scm"))
         (let ((transformer (compose pretty-print-html-parse-tree ast-to-parse-tree)))
	   (write-text-file
	    (prolog-epilog-envelope (transformer html-clause) prolog? epilog?)
	    file-path-with-extension)))

	((and (ast? html-clause) (eq? mode 'raw))
	 (if (file-exists? file-path-with-extension) (delete-file file-path-with-extension))
	 (let* ((op (open-output-file file-path-with-extension)))
           (render-to-output-port html-clause op (if prolog? 'prolog #f) (if epilog? 'epilog #f))
           (close-output-port op))
        )

	((and (string? html-clause) (eq? mode 'pp))
         (load (string-append laml-dir "tools/xml-html-support/html-support.scm"))
	 (let ((transformer (compose pretty-print-html-parse-tree parse-html-string)))
	   (write-text-file
	    (prolog-epilog-envelope (transformer html-clause) prolog? epilog?)
	    file-path-with-extension)))

	((and (string? html-clause) (eq? mode 'raw))
         (write-text-file
	  (prolog-epilog-envelope html-clause prolog? epilog?)
	  file-path-with-extension))

	(else (laml-error "write-html: Unsupported combination of html-clause and writing mode" mode)))))



; Is x an XML AST, such as an XHTML AST.
; Non-XML ASTs do not have a language indication as last elements. Therefore
; we can distinguish XML asts from older HTML asts by the number of elements in the
; list AST representation.
(define (is-xml-ast? x)
  (and (ast? x)            ; hereby a proper list
       (>= (length x) 6))) 


; Surround html-text with the standard prolog and epilog, if signalled by the two boolean parameters.
; This function depends on the two parameterless functions standard-prolog and standard-epilog.
; .form (prolog-epilog-envelope html-text prolog? epilog? [language])
(define (prolog-epilog-envelope html-text prolog? epilog? . optional-parameter-list)
 (let ((language (optional-parameter 1 optional-parameter-list #f)))
  (let ((prolog-text (cond (prolog? (standard-prolog language))
                           (else "")))
	(epilog-text (cond (epilog? (standard-epilog language))
                           (else "")))
	)
    (string-append prolog-text html-text epilog-text))))




;;; The HTML character transformation table.
;;; This table is used by the HTML rendering function to transliterate char data to
;;; textual contents, as to be shown in a browser. You can use this table to perform
;;; transformation of national characters to HTML character entities, and to perform
;;; other character transliterations.
;;; .section-id char-trans-section
; Depends on make-list from general.scm

 
(define html-char-transformation-table
    (list->vector (make-list 256 #t)))

; The html-char-transformation-table is initialized in lib/xml-in-laml/xml-in-laml.scm

 
(define (set-html-char-transformation-entry! transformation-table index new-entry)
  (vector-set! transformation-table index new-entry))

; The actual mutations of the html character transformation table is done in the actual
; mirrors. The reason is that the HTML4 mirrors are less mature than the XHTML mirror with
; respect to character references. (The '&' character is not allowed to be character transformed
; in HTML4, but it need to be transformed in XHTML. See lib/xml-in-laml/xml-in-laml.scm and
; tools/validating-html-mirror-from-dtd/runtime/basic.scm).


; ---------------------------------------------------------------------------------------------------
; HTML char and text transformation using the html-char-transformation-table.
; html-char-transformation-table is defined in laml.scm, and possibly redefined in the .laml setup file.


; (define (html-text-transform str)
;  (html-text-transform-1 str (string-length str) 0 '())
; )
;
;
; (define (html-text-transform-1 str str-lgt i res)
;   (cond ((= i str-lgt) (list-to-string (reverse res) ""))
;         (else (html-text-transform-1 str str-lgt (+ i 1) (cons (html-char-transform (string-ref str i)) res)))))

 
(define (html-char-transform char . optional-parameter-list)
 (let ((transformation-table (optional-parameter 1 optional-parameter-list html-char-transformation-table)))
  (let* ((n (char->integer char))
         (res (if (and (>= n 0) (<= n 255))
	          (vector-ref transformation-table n)
                  (char->string char)))
        )
    (cond ((and (boolean? res) res) (char->string char))
          ((string? res) res)
          ((and (boolean? res) (not res)) "")
          ((char? res) (char->string res))
          ((and (integer? res) (>= res 0) (<= res 255)) (char->string (integer->char res)))
          (else (laml-error "html-char-transform: Unable to transform character: " char))))))

; ---------------------------------------------------------------------------------------------------------------

;;; R4RS and R5RS Scheme knowledge.
;;; The section contains accessor and loading functions to R4RS and R5RS Scheme knowledge files.
;;; The Scheme knowledge files are located in the r4rs and the r5rs directories of the full LAML distribution.
;;; The r4rs and r5rs directories each hold a HTML version of the Scheme Report.
;;; Overall, a Scheme knowledge file is a mapping from syntax/procedure name to an URL in the Scheme Report.
;;; More precisely, a Scheme knowledge file is a list of entries, each of which
;;; contains the name of a Scheme form, the categorization of the form, and the URL of place, where form
;;; is described (in a compact format). Scheme knowledge files have extensions lsp.
;;; .section-id scheme-knowledge
 
(define (read-scheme-knowledge scheme-version)
  (let* ((scheme-version-number (cond ((number? scheme-version)
				       scheme-version)
                                      ((and (symbol? scheme-version) (eq? scheme-version 'r4rs)) 4)
                                      ((and (symbol? scheme-version) (eq? scheme-version 'r5rs)) 5)
                                      (else (laml-error "read-scheme-knowledge: scheme-version must be an integer (4 or 5) or one of the symbols r4rs or r5rs:" scheme-version))))
        )
     (cond ((= scheme-version-number 4)
            (file-read (string-append laml-dir "r4rs/" "scheme-knowledge.lsp")))
	   ((= scheme-version-number 5)
            (file-read (string-append laml-dir "r5rs/" "scheme-knowledge.lsp")))
	   (else (laml-error (string-append "R" (as-string scheme-version-number) "RS") "is not supported.")))))

 
(define symbol-of-scheme-knowledge (make-selector-function 1 'symbol-of-scheme-knowledge))

 
(define category-of-scheme-knowledge (make-selector-function 2 'category-of-scheme-knowledge))

 
(define essentiality-of-scheme-knowledge (make-selector-function 3 'essentiality-of-scheme-knowledge))

 
(define file-number-of-scheme-knowledge (make-selector-function 4 'file-number-of-scheme-knowledge))

 
(define anchor-name-of-scheme-knowledge (make-selector-function 5 'anchor-name-of-scheme-knowledge))


 
(define (url-suffix-of-scheme-knowledge entry scheme-version)
  (let* ((scheme-version-number (cond ((number? scheme-version)
                                         scheme-version)
                                      ((and (symbol? scheme-version) (eq? scheme-version 'r4rs)) 4)
                                      ((and (symbol? scheme-version) (eq? scheme-version 'r5rs)) 5)
                                      (else (laml-error "url-suffix-of-scheme-knowledge: scheme-version must be an integer (4 or 5) or one of the symbols r4rs or r5rs:" scheme-version))))
         (rnrs (cond ((= scheme-version-number 4) "r4rs")
                     ((= scheme-version-number 5) "r5rs")
                     (else (laml-error (string-append "r" (as-string scheme-version-number) "rs") "is not supported.")))))
   (if (>= (length entry) 5)
       (string-append rnrs "_" 
                      (as-string (file-number-of-scheme-knowledge entry))
                      (cond ((= scheme-version-number 4)  ".htm")
                            ((= scheme-version-number 5)  ".html")
                            (else (laml-error (string-append "r" (as-string scheme-version-number) "rs") "is not supported.")))
                      "#" 
                      (anchor-name-of-scheme-knowledge entry))
       #f)))


;;; Miscellaneous.
 
(define (kn-manual-settings . optional-parameter-list)
 (let ((abstract-clause (optional-parameter 1 optional-parameter-list #f)))
  (list
    (manual-author (copyright-owner "Kurt Nørmark") "normark@cs.aau.dk" )
    (manual-affiliation "Department of Computer Science," "Aalborg University," "Denmark.")
    (if abstract-clause abstract-clause '())
    (laml-library-source-linking)
    'css-prestylesheet "compact"
    'css-stylesheet "argentina"
    'css-stylesheet-copying "true"
  )))

(define (kn-name) "Kurt Nørmark")
(define (kn-affiliation) (text-choice "Institut for Datalogi, Aalborg Universitet" "Department of Computer Science, Aalborg University, Denmark"))
(define (kn-home-url) "http://www.cs.aau.dk/~normark/")
(define (kn-email-address) "normark@cs.aau.dk")

(define (anchor-mail-prefix email-addr)
  (string-append "mailto:" email-addr))

 
(define (kn-xml-in-laml . optional-parameter-list)
 (let ((with-icon (optional-parameter 1 optional-parameter-list #f))
      )
  (if with-icon
      (table 'border "0"
         (tr 
            (td 'width "20%"
              (div (char-ref "nbsp") (br)
		   (kn-name) (br)
		   (a 'href (anchor-mail-prefix (kn-email-address)) (kn-email-address)) (br)
		   (a 'href (kn-home-url) (kn-home-url)) (br)
		   ))
            (td 'width "70%"  (div ""))
            (td 'width "10%" (laml-power-icon 0 'small))))

      (div (char-ref "nbsp") (br)
	   (kn-name) (br)
	   (a 'href (anchor-mail-prefix (kn-email-address)) (kn-email-address)) (br)
	   (a 'href (kn-home-url) (kn-home-url)) (br)
	   ))))

 
(define (laml-library-source-linking)
  (append
   (map                                 ; the LAML lib/ manuals 
    (lambda (key) 
      (scheme-source-linking-manual 
       (list 'key key)
       (list 'file-path (string-append  (laml-dir-prefix) "lib/man/" key))  
       )
      )
    (list "cgi" "collect-skip" "color" "crypt" "encode-decode" "file-read" "final-state-automaton" "general" "time" 
          "xhtml10-convenience")
    )
   (map                                 ; the LAML core library
    (lambda (key) 
      (scheme-source-linking-manual 
       (list 'key key)
       (list 'file-path (string-append (laml-dir-prefix) "man/" key))
       )
      )
    (list "laml")
    )
   (map                                 ; the XML-in-LAML library
    (lambda (key) 
      (scheme-source-linking-manual 
       (list 'key key)
       (list 'file-path (string-append (laml-dir-prefix) "lib/xml-in-laml/man/" key))
       )
      )
    (list "xml-in-laml")
    )
   (map                                 ; the XML-in-LAML library
    (lambda (key) 
      (scheme-source-linking-manual 
       (list 'key key)
       (list 'file-path (string-append (laml-dir-prefix) "lib/xml-in-laml/mirrors/man/" key))
       )
      )
    (list "xhtml10-transitional-mirror" "xhtml10-strict-mirror" "xhtml10-frameset-mirror")
    )

   ))