;;;; This is a library of generally useful Scheme functions which are used in many other libraries,
;;;; styles or tools.
; The LAML library and programs written by Kurt Normark, Aalborg University, Denmark.
; Copyright (C) 1999  Kurt Normark, normark@s.auc.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  US
;;; Generation of list selector functions.
;;; As an alternative to using car, cadr etc. we provide for generation of more general list selector functions.
;; Returns a function, which selects element number n in a list.
;; The second parameter, which is optional, is used for error message purposes.
;; In general, this parameter should be a string corresponding to the name of the selector function.
;; If the second parameter is given, we check whether the list is long enough for selection.
;; If not, we give a decent error message. We recommend use of the second parameter in order to
;; avoid meaningless error messages.
;; The first element is number 1.
;; (make-selector-function 1) corresponds to car, (make-selector-function 2) corresponds to cadr, etc.
Show source file in small font Link from make-selector-function to it's cross reference table entry 
(define (make-selector-function n . selector-name) (let ((selector-name-1 (if (null? selector-name) #f (car selector-name)))) (if selector-name-1 (lambda (lst) (let ((lgt (length lst))) (if (> n lgt) (display-error (string-append "The selector function " (as-string selector-name-1) ": " "The list " (as-string lst) " is is too short for selection. " "It must have at least " (as-string n) " elements." )) (list-ref lst (- n 1))))) (lambda (lst) (list-ref lst (- n 1)))))) ;; Return the first element of a list Show source file in small font Link from first to it's cross reference table entry 
(define first car) ;; Return the second element of a list Show source file in small font Link from second to it's cross reference table entry 
(define second cadr) ;; Return the third element of a list Show source file in small font Link from third to it's cross reference table entry 
(define third caddr) ;; Return the fourth element of a list Show source file in small font Link from fourth to it's cross reference table entry 
(define fourth cadddr) ;; Return the fifth element of a list Show source file in small font Link from fifth to it's cross reference table entry 
(define fifth (make-selector-function 5)) ;; Return the sixth element of a list Show source file in small font Link from sixth to it's cross reference table entry 
(define sixth (make-selector-function 6)) ;; Return the seventh element of a list Show source file in small font Link from seventh to it's cross reference table entry 
(define seventh (make-selector-function 7)) ;; Return the eighth element of a list Show source file in small font Link from eighth to it's cross reference table entry 
(define eighth (make-selector-function 8)) ;; Return the nineth element of a list Show source file in small font Link from nineth to it's cross reference table entry 
(define nineth (make-selector-function 9)) ;;; Association list functions. ;;; Here follows a number of functions which work on alists, or make alists. ;; A functions which converts the key position in an a-lists to symbols ;; key-value-pair is a pair, such as ("key" . "val"). Return (key . "val"). Show source file in small font Link from symbolize-key to it's cross reference table entry 
(define (symbolize-key key-value-pair) (cons (as-symbol (car key-value-pair)) (cdr key-value-pair))) ;; Add a key-value pair to a-list. Like acons in some systems. Show source file in small font Link from extend-a-list to it's cross reference table entry 
(define (extend-a-list key value a-list) (cons (cons (as-symbol key) value) a-list)) ;; Return a value from an alist. key is a symbol. Uses assq internally. Show source file in small font Link from get to it's cross reference table entry 
(define (get key a-list) (let ((res (assq key a-list))) (if (pair? res) (cdr res) (error (string-append "Cannot find " (as-string key) " in " (as-string a-list)))))) ;; Return the value of key (by means of cdr of assq). If no association is found return default. Show source file in small font Link from defaulted-get to it's cross reference table entry 
(define (defaulted-get key alist default) (let ((res (assq key alist))) (if res (cdr res) default))) ;; Make an alist from a key-list and a val-list. ;; Requires that the lengths of the two input lists are equal. Show source file in small font Link from alist-from-keys-and-values to it's cross reference table entry 
(define (alist-from-keys-and-values key-list val-list) (if (= (length key-list) (length val-list)) (alist-from-keys-and-values-1 key-list val-list) (error "alist-from-keys-and-values: key and val list do not have same lengths"))) Show source file in small font Link from alist-from-keys-and-values-1 to it's cross reference table entry 
(define (alist-from-keys-and-values-1 key-list val-list) (if (null? key-list) '() (cons (cons (car key-list) (car val-list)) (alist-from-keys-and-values-1 (cdr key-list) (cdr val-list))))) ;; Make and return an association list from a property list plist. Show source file in small font Link from propertylist-to-alist to it's cross reference table entry 
(define (propertylist-to-alist plist) (let ((lgt (length plist))) (cond ((null? plist) '()) ((= 1 lgt) (error "property-list-to-a-list called with list of odd length. A property list is always of even length")) ((>= lgt 2) (cons (cons (car plist) (cadr plist)) (propertylist-to-alist (cddr plist))))))) ;; Make and return a property list from an association list. Show source file in small font Link from alist-to-propertylist to it's cross reference table entry 
(define (alist-to-propertylist alist) (cond ((null? alist) '()) (else (cons (car (car alist)) (cons (cdr (car alist)) (alist-to-propertylist (cdr alist))))))) ;; Return every second element of list, starting with the first element. ;; This function is useful to extract the keys or values of a property list. Show source file in small font Link from every-second-element to it's cross reference table entry 
(define (every-second-element lst) (cond ((null? lst) '()) ((null? (cdr lst)) (list (car lst))) (else (cons (car lst) (every-second-element (cddr lst)))))) ;;; Filter functions. ;;; Variants of the very useful higher order filtering function. ;; Filter a list lst by means of the predicate pred. Only return those elements that fulfil pred. Show source file in small font Link from filter to it's cross reference table entry 
(define (filter pred lst) (reverse (filter-help pred lst '()))) ;; Like filter, but the ordering among elements in the resulting list is unknown and arbitrary. ;; Actually returns filtered list in reverse order. OK in situations, ;; where a boolean result is needed: Are there anything passing the filter? Show source file in small font Link from filter-no-ordering to it's cross reference table entry 
(define (filter-no-ordering pred lst) (filter-help pred lst '())) Show source file in small font Link from filter-help to it's cross reference table entry 
(define (filter-help pred lst res) (cond ((null? lst) res) ((pred (car lst)) (filter-help pred (cdr lst) (cons (car lst) res))) (else (filter-help pred (cdr lst) res)))) ;;; Mapping functions. ;;; Here is a set of generalized mapping functions ;; Like map, but maps f on two lists Show source file in small font Link from map2 to it's cross reference table entry 
(define (map2 f lst1 lst2) (if (or (null? lst1) (null? lst2)) '() (cons (f (car lst1) (car lst2)) (map2 f (cdr lst1) (cdr lst2))))) ;; Like map, but maps f on three lists Show source file in small font Link from map3 to it's cross reference table entry 
(define (map3 f lst1 lst2 lst3) (if (or (null? lst1) (null? lst2) (null? lst3)) '() (cons (f (car lst1) (car lst2) (car lst3)) (map3 f (cdr lst1) (cdr lst2) (cdr lst3))))) ;; Like map, but maps f on four lists Show source file in small font Link from map4 to it's cross reference table entry 
(define (map4 f lst1 lst2 lst3 lst4) (if (or (null? lst1) (null? lst2) (null? lst3) (null? lst4)) '() (cons (f (car lst1) (car lst2) (car lst3) (car lst4)) (map4 f (cdr lst1) (cdr lst2) (cdr lst3) (cdr lst4))))) ;; Like map, but maps f on five lists Show source file in small font Link from map5 to it's cross reference table entry 
(define (map5 f lst1 lst2 lst3 lst4 lst5) (if (or (null? lst1) (null? lst2) (null? lst3) (null? lst4) (null? lst5)) '() (cons (f (car lst1) (car lst2) (car lst3) (car lst4) (car lst5) ) (map5 f (cdr lst1) (cdr lst2) (cdr lst3) (cdr lst4) (cdr lst5))))) ;;; Conversion functions. ;;; In this category we provide a number of useful conversion functions. ;; Convert a character to a string Show source file in small font Link from char->string to it's cross reference table entry 
(define (char->string ch) (make-string 1 ch)) ;; Convert x to a string. Conversion of numbers, symbols, strings, booleans, characters, proper list and improper lists are supported. Show source file in small font Link from as-string to it's cross reference table entry 
(define (as-string x) (cond ((number? x) (number->string x)) ((symbol? x) (symbol->string x)) ((string? x) x) ((boolean? x) (if x "true" "false")) ((char? x) (char->string x)) ((list? x) (string-append "(" (string-merge (map as-string x) (make-list (- (length x) 1) " ")) ")")) ((pair? x) (string-append "(" (apply string-append (map (lambda (y) (string-append (as-string y) " ")) (proper-part x)) ) " . " (as-string (first-improper-part x)) ")")) (else "??"))) ;; Convert x to a symbol. String, symbols, booleans, and characters are supported Show source file in small font Link from as-symbol to it's cross reference table entry 
(define (as-symbol x) (cond ((symbol? x) x) ((string? x) (string->symbol x)) ((boolean? x) (if x (as-symbol "true") (as-symbol "false"))) ((char? x) (as-symbol (char->string x))) (else #f))) ;; Convert x to a number. Strings and numbers are supported Show source file in small font Link from as-number to it's cross reference table entry 
(define (as-number x) (cond ((string? x) (string->number x)) ((number? x) x) ((char? x) (char->integer x)) ((boolean? x) (if x 1 0)) ; false -> 0, true -> 1 (else (begin (set! problem-object x) (error (string-append "Cannot convert to number" (as-string x))))))) Show source file in small font Link from as-char to it's cross reference table entry 
(define (as-char x) (cond ((char? x) x) ((integer? x) (if (and (>= x 0) (<= x 255)) (integer->char x) #\?)) ((string? x) (string-ref x 0)) ((boolean? x) (if x #\t #\f)) ((symbol? x) (as-char (as-string x))) (else #\?))) ;; Convert x to a list. ;; In particular are strings converted to a list of elements separated by spaces, newlines, and tabs. Show source file in small font Link from as-list to it's cross reference table entry 
(define (as-list x) (cond ((string? x) (string-to-list x (list #\space (as-char 13) (as-char 10) #\tab))) ((list? x) x) ((pair? x) x) (else (list x)))) ;; Convert a string to a list. ;; The second parameter is a list of separator chararcters. Show source file in small font Link from string-to-list to it's cross reference table entry 
(define (string-to-list str element-separator-chars) (filter (negate empty-string?) (string-to-list-help str "" '() element-separator-chars (string-length str)))) Show source file in small font Link from string-to-list-help to it's cross reference table entry 
(define (string-to-list-help str next-el res-list element-separator-chars str-lgt) (if (= 0 str-lgt) (reverse (cons next-el res-list)) ; add last 'rest element: next-el (let ((next-char (string-ref str 0)) (rest-string (substring str 1 str-lgt))) (cond ((memq next-char element-separator-chars) (string-to-list-help rest-string "" (cons next-el res-list) element-separator-chars (- str-lgt 1))) (else (string-to-list-help rest-string (string-append next-el (as-string next-char)) res-list element-separator-chars (- str-lgt 1))))))) Show source file in small font Link from problem-object to it's cross reference table entry 
(define problem-object #f) Show source file in small font Link from as-boolean to it's cross reference table entry 
(define (as-boolean x) (cond ((string? x) (if (or (equal? x "false") (equal? x "no") (equal? x "NO")) #f #t)) ((boolean? x) x) (else (error "Cannot convert to boolean")))) ;; Is the string str empty Show source file in small font Link from empty-string? to it's cross reference table entry 
(define (empty-string? str) (= (string-length str) 0)) ;; A list of characters considered as blank space characters Show source file in small font Link from white-space-char-list to it's cross reference table entry 
(define white-space-char-list (list #\space (as-char 13) (as-char 10) #\tab)) ; Is the string str empty or blank (consists of white space) Show source file in small font Link from blank-string? to it's cross reference table entry 
(define (blank-string? str) (or (empty-string? str) (string-of-char-list? str white-space-char-list))) ;; Is the string str purely numeric. ;; More specifically, does it consist exclusively of the ciffes 0 through 9. Show source file in small font Link from numeric-string? to it's cross reference table entry 
(define (numeric-string? str) (string-of-char-list? str (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 ))) ;; Are all characters in str member of char-list (a list of characters). Show source file in small font Link from string-of-char-list? to it's cross reference table entry 
(define (string-of-char-list? str char-list) (string-of-char-list-1? str char-list 0 (string-length str))) Show source file in small font Link from string-of-char-list-1? to it's cross reference table entry 
(define (string-of-char-list-1? str char-list i lgt) (if (= i lgt) #t (and (memq (string-ref str i) char-list) (string-of-char-list-1? str char-list (+ i 1) lgt)))) ; --------------------------------------------------------------------------------------------------- ;;; Functions that change letter case. ;;; Here comes a number of functions which changes the letter case of a string ; Capitalizing characters and strings. Show source file in small font Link from capitalize-string to it's cross reference table entry 
(define (capitalize-string str) ;; Mutate str to have an initial capital character. ;; A destructive procedure. See capitalize-string-nd for a non-destructive variant. (string-set! str 0 (capitalize-char (string-ref str 0))) str) Show source file in small font Link from capitalize-string-nd to it's cross reference table entry 
(define (capitalize-string-nd str) ;; Return str with capital, initial character. ;; A non-destructive variant of capitalize-string (let ((res (string-copy str))) (string-set! res 0 (capitalize-char (string-ref str 0))) res)) Show source file in small font Link from capitalize-char to it's cross reference table entry 
(define (capitalize-char ch) ; if it makes sense, return the capital character corresponding to ch. ; else, just return ch (let ((char-code (char->integer ch))) (if (lower-case-letter-code? char-code) (let ((offset (small-capital-offset char-code))) (integer->char (+ char-code offset))) ch))) Show source file in small font Link from lower-case-letter-code? to it's cross reference table entry 
(define (lower-case-letter-code? n) (or (and (>= n 97) (<= n 122)) (= n 230) (= n 248) (= n 229))) Show source file in small font Link from small-capital-offset to it's cross reference table entry 
(define (small-capital-offset n) ; in all cases, the distance between lower and upper case letters are -32 in the ASCII table (cond ((and (>= n 97) (<= n 122)) -32) ((= n 230) -32) ((= n 248) -32) ((= n 229) -32) (else 0))) ; ----------------------------------------------------------------------------- ; Upcasing all characters in a string Show source file in small font Link from upcase-string to it's cross reference table entry 
(define (upcase-string str) ;; Upcase all characters in str (let ((res (make-string (string-length str) #\space))) (upcase-string-help! str res 0 (string-length str)))) Show source file in small font Link from upcase-string-help! to it's cross reference table entry 
(define (upcase-string-help! input output i lgt) (cond ((>= i lgt) output) (else (string-set! output i (capitalize-char (string-ref input i))) (upcase-string-help! input output (+ i 1) lgt)))) ; ----------------------------------------------------------------------------- ; ; Downcasing all characters in a string Show source file in small font Link from downcase-string to it's cross reference table entry 
(define (downcase-string str) ;; Downcase all characters in str (let ((res (make-string (string-length str) #\space))) (downcase-string-help! str res 0 (string-length str)))) Show source file in small font Link from downcase-string-help! to it's cross reference table entry 
(define (downcase-string-help! input output i lgt) (cond ((>= i lgt) output) (else (string-set! output i (decapitalize-char (string-ref input i))) (downcase-string-help! input output (+ i 1) lgt)))) ; ----------------------------------------------------------------------------- ; ; decapitalizing characters and strings. Show source file in small font Link from decapitalize-string to it's cross reference table entry 
(define (decapitalize-string str) ;; Mutate str to have lower case, initial character. ;; A destructive procedure. See decapitalize-string-nd for a non-destructive variant. (string-set! str 0 (decapitalize-char (string-ref str 0))) str) Show source file in small font Link from decapitalize-string-nd to it's cross reference table entry 
(define (decapitalize-string-nd str) ;; Return str with lower case, initial character. ;; A non-destructive variant of decapitalize-string. (let ((res (string-copy str))) (string-set! res 0 (decapitalize-char (string-ref str 0))) res)) Show source file in small font Link from decapitalize-char to it's cross reference table entry 
(define (decapitalize-char ch) ; if it makes sense, return the lower case character corresponding to ch. ; else, just return ch (let ((char-code (char->integer ch))) (if (upper-case-letter-code? char-code) (let ((offset (large-capital-offset char-code))) (integer->char (+ char-code offset))) ch))) Show source file in small font Link from upper-case-letter-code? to it's cross reference table entry 
(define (upper-case-letter-code? n) (or (and (>= n 65) (<= n 90)) (= n 198) (= n 216) (= n 197))) Show source file in small font Link from large-capital-offset to it's cross reference table entry 
(define (large-capital-offset n) ; in all cases, the distance between lower and upper case letters are -32 in the ASCII table (cond ((and (>= n 65) (<= n 90)) 32) ((= n 198) 32) ((= n 216) 32) ((= n 197) 32) (else 0))) ; -------------------------------------------------------------------------------------------------- ;;; Other functions. ;;; Here follows a set of miscellaneous functions ;; Return a list of all numbers from f to t. Empty if f is greater than t Show source file in small font Link from number-interval to it's cross reference table entry 
(define (number-interval f t) (if (<= f t) (cons f (number-interval (+ f 1) t)) '())) ;; Return a list of two strings taken from str. ch is a character. ;; The first is the prefix of str up to the first occurence of ch ;; The second is the suffix from ch to the end of str Show source file in small font Link from split-on to it's cross reference table entry 
(define (split-on ch str) (let ((sp (split-point ch str))) (list (substring str 0 sp) (substring str (+ sp 1) (string-length str))))) ;; Return the character position where ch occurs the first time in str. ;; If it does not appear, the procedure returns #f. ;; This function allocates some temporary strings, and as such it is not efficient. ;; Use find-in-string instead. Show source file in small font Link from split-point to it's cross reference table entry 
(define (split-point ch str) (call-with-current-continuation (lambda (exit) (cond ((equal? str "") #f) ((eq? ch (string-ref str 0)) 0) (else (let ((res (split-point ch (substring str 1 (string-length str))))) (if (not res) (exit #f) (+ 1 res)))))))) ;; Search linearly for the character ch in the string str. ;; An optional start postion start-post tells at which position to start the search (default is position 0). ;; Return the index of the first occurence of ch, or #f if it does not exist in str. ;; The index of the first character in a string is 0. Show source file in small font Link from find-in-string to it's cross reference table entry 
(define (find-in-string str ch . start-pos) (let ((start-pos-1 (if (null? start-pos) 0 (car start-pos)))) (find-in-string-1 str ch start-pos-1 (string-length str)))) Show source file in small font Link from find-in-string-1 to it's cross reference table entry 
(define (find-in-string-1 str ch i lgt) (cond ((>= i lgt) #f) ((eq? ch (string-ref str i)) i) (else (find-in-string-1 str ch (+ i 1) lgt)))) ;; Search linearly for the character ch in the string str, beginning from the rear end of str. ;; Return the index of the last occurence of ch, or #f if it does not exist in str. ;; The index of the first character in a string is 0. Show source file in small font Link from find-in-string-from-end to it's cross reference table entry 
(define (find-in-string-from-end str ch) (let ((lgt (string-length str))) (find-in-string-from-end-1 str ch (- lgt 1) lgt))) Show source file in small font Link from find-in-string-from-end-1 to it's cross reference table entry 
(define (find-in-string-from-end-1 str ch i lgt) (cond ((< i 0) #f) ((eq? ch (string-ref str i)) i) (else (find-in-string-from-end-1 str ch (- i 1) lgt)))) ;; Does str contain sub-str as substring, starting at position pos? ;; An efficient implementation without any string copying, only character comparsion Show source file in small font Link from looking-at-substring? to it's cross reference table entry 10.4. Extracting sectional names from comments.
(define (looking-at-substring? str pos sub-str) (looking-at-substring-1? str pos sub-str 0 (string-length str) (string-length sub-str))) Show source file in small font Link from looking-at-substring-1? to it's cross reference table entry 
(define (looking-at-substring-1? str pos sub-str i lgt1 lgt2) (let ((a (+ i pos))) (cond ((= i lgt2) #t) ((and (< a lgt1) (< i lgt2) (eq? (string-ref str a) (string-ref sub-str i))) (looking-at-substring-1? str pos sub-str (+ i 1) lgt1 lgt2)) (else #f)))) ;; Starting from char-pos, skip characters in string from char-list. ;; Return the first index higher or equal to start-pos, which contains ;; a character which is NOT in char-list. If start-pos is higher than ;; the maximum legal string index, return start-post. Show source file in small font Link from skip-chars-in-string to it's cross reference table entry 10.4. Extracting sectional names from comments.
(define (skip-chars-in-string str char-list start-pos) (skip-chars-in-string-1 str char-list start-pos (string-length str))) Show source file in small font Link from skip-chars-in-string-1 to it's cross reference table entry 
(define (skip-chars-in-string-1 str char-list i lgt) (cond ((and (< i lgt) (memq (string-ref str i) char-list)) (skip-chars-in-string-1 str char-list (+ i 1) lgt)) ((and (< i lgt) (not (memq (string-ref str i) char-list))) i) (else i))) ;; Return the proper part of an S-expression Show source file in small font Link from proper-part to it's cross reference table entry 3.2. The function bounded-names
(define (proper-part lst) (cond ((and (pair? lst) (pair? (cdr lst))) (cons (car lst) (proper-part (cdr lst)))) ((pair? lst) (cons (car lst) '())) (else '()))) ;; Return the first improper part of an S-expression Show source file in small font Link from first-improper-part to it's cross reference table entry 3.2. The function bounded-names
(define (first-improper-part lst) (cond ((and (pair? lst) (pair? (cdr lst))) (first-improper-part (cdr lst))) ((pair? lst) (cdr lst)) (else (error (string-append "Troubles in first-improper-part:" (as-string lst)))))) ; (define (as-string x) ; (cond ((number? x) (number->string x)) ; ((symbol? x) (symbol->string x)) ; ((string? x) x) ; ((boolean? x) ; (if x "true" "false")) ; ((char? x) (char->string x)) ; ((list? x) ; (string-append "(" ; (apply string-append ; (map (lambda (y) (string-append (as-string y) " ")) x)) ; ")")) ; ((pair? x) ; (string-append "(" ; (apply string-append ; (map (lambda (y) (string-append (as-string y) " ")) (proper-part x)) ; ) ; " . " (as-string (first-improper-part x)) ; ")")) ; (else "??"))) Show source file in small font Link from max-int-list to it's cross reference table entry 
(define (max-int-list lst) (max-int-list-help lst 0)) Show source file in small font Link from max-int-list-help to it's cross reference table entry 
(define (max-int-list-help lst res) (if (null? lst) res (max-int-list-help (cdr lst) (max res (car lst))))) ;; A quite special HTML line breaking function. ;; Html format str, either with br og p tags between lines. ;; depends on break-at-all from decoding stuff Show source file in small font Link from re-break to it's cross reference table entry 
(define (re-break str) (letrec ((line-breaker (break-at-all #\newline))) ; from decoding stuff (let* ((lines (line-breaker str)) (line-lengths (map string-length lines)) (max-line-length (max-int-list line-lengths))) (if (> max-line-length 120) (apply string-append (map (lambda (ln) (string-append ln "<p>")) lines)) (apply string-append (map (lambda (ln) (string-append ln "<br>")) lines)))))) Show source file in small font Link from string-merge to it's cross reference table entry 4.5. The accept functions
(define (string-merge str-list-1 str-list-2) ;; Merge str-list-1 with str-list-2, returning one string. ;; Strings from the first list are merged with the strings from the second list. ;; In case one list is shorter than the other, the strings from the longests lists ;; are concatenated and appended (cond ((null? str-list-1) (apply string-append str-list-2)) ((null? str-list-2) (apply string-append str-list-1)) (else (string-append (car str-list-1) (car str-list-2) (string-merge (cdr str-list-1) (cdr str-list-2)))))) ;; Return a string with the elements of str-lst separated by separator. ;; The first parameter str-lst is a list of strings, and separator is a string. Show source file in small font Link from list-to-string to it's cross reference table entry 
(define (list-to-string str-lst separator) (string-merge str-lst (make-list (- (length str-lst) 1) separator))) ; ----------------------------------------------------------------------------- ; Transliteration Show source file in small font Link from transliterate to it's cross reference table entry 
(define (transliterate in-string ch str) ;; In in-string, substitute each occurence of character ch with the string str (transliterate-1 in-string 0 (string-length in-string) (make-string (* (string-length in-string) (string-length str)) #\space) 0 ch str)) Show source file in small font Link from transliterate-1 to it's cross reference table entry 
(define (transliterate-1 in-string n in-length out-string m ch str) ; n is the position in the input ; m is the positin in the output (cond ((= n in-length) (substring out-string 0 m)) ((< n in-length) (let ((in-char (string-ref in-string n))) (if (eq? in-char ch) (begin (copy-string-into! out-string m str) (transliterate-1 in-string (+ n 1) in-length out-string (+ m (string-length str)) ch str)) (begin (copy-string-into! out-string m (as-string in-char)) (transliterate-1 in-string (+ n 1) in-length out-string (+ m 1) ch str))))) (else (error "transliterate error")) )) ; ---------------------------------------------------------------------------- ;; Delete the substring of length lgt from index i in the string str. ;; A non-destructive function which returns the result (a shorter string than the input). ;; i is supposed to be a valid index in str. If lgt is too long for str, we just delete to the end of str. ;; The first character is number 0. Show source file in small font Link from delete-string-portion to it's cross reference table entry 
(define (delete-string-portion str i lgt) (let* ((str-lgt (string-length str)) (prefix (substring str 0 (max i 0))) (suffix (substring str (min (+ i lgt) str-lgt) str-lgt))) (string-append prefix suffix))) ;; In str1 replace all occurences of str2 with str3 and return the resulting string. ;; str2 is not allowed to be empty. ;; A non-destructive function which leaves all input strings unaffected. Show source file in small font Link from replace-string to it's cross reference table entry 
(define (replace-string str1 str2 str3) (if (not (empty-string? str2)) (replace-string-1 0 str1 str2 str3) (error (string-append "replace-string: Cannot replace empty string in " str1)))) ; A helping function of replace-string which replaces from a given index i. Show source file in small font Link from replace-string-1 to it's cross reference table entry 
(define (replace-string-1 i str1 str2 str3) (let ((match-index (substring-index str1 i str2))) (if match-index (replace-string-1 (+ match-index (string-length str3)) (put-into-string (delete-string-portion str1 match-index (string-length str2)) match-index str3) str2 str3) str1))) Show source file in small font Link from put-around-substring to it's cross reference table entry 
(define (put-around-substring str pre-index pre-putin post-index post-putin) ;; Put pre-putin at pre-index, and post-putit at post-index in the string str. ;; Return the result. Str is not affected. ;; Assumed that pre-index is less than post-index (put-into-string (put-into-string str post-index post-putin) pre-index pre-putin)) Show source file in small font Link from put-into-string to it's cross reference table entry 
(define (put-into-string str index putin-str) ;; Before the character with index put in putin-str into str, and return the resulting, ;; extended string. I.e, make room in the resulting string for putin-str, and slide a suffix of str ;; to the right. Str is left unchanged. The first character is number 0. (let ((res (make-string (+ (string-length str) (string-length putin-str))))) (copy-string-into! res 0 (substring str 0 index)) (copy-string-into! res index putin-str) (copy-string-into! res (+ index (string-length putin-str)) (substring str index (string-length str))) res)) Show source file in small font Link from copy-string-into! to it's cross reference table entry 
(define (copy-string-into! target i source) ;; Copy source into target and overwrite a portion of target. ;; Both target and source are strings, and i is an integer index. ;; The first char of source becomes chararter number i in the target string. ;; The first character in a string is number 0. ;; Target is mutated by this procedure. ;; If there is not enough room for source in target, only part of the source is copied into a suffix of target. (copy-string-into-help! target i (string-length target) source 0 (string-length source))) Show source file in small font Link from copy-string-into-help! to it's cross reference table entry 
(define (copy-string-into-help! target i target-length source j source-length) ; A helping operation, doing the real work, of copy-string-into! (cond ((= i target-length) target) ((= j source-length) target) ((< j source-length) (begin (string-set! target i (string-ref source j)) (copy-string-into-help! target (+ 1 i) target-length source (+ 1 j) source-length))))) Show source file in small font Link from substring-index to it's cross reference table entry 10.4. Extracting sectional names from comments.
(define (substring-index str str-index find-str) ;; Return the index of the first occurence of find-str in str. ;; The search starts at str-index. ;; The first character in str has index 0. ;; If find-str is not a substring of str, starting the search at str-index, #f is returned. (let ((str-length (string-length str)) (find-str-length (string-length find-str))) (cond ((= 0 (string-length find-str)) str-index) ; new 10.9.98 ((> str-index (- str-length find-str-length)) #f) ((substring-index-help str str-index str-length find-str 0 find-str-length) str-index) (else (substring-index str (+ 1 str-index) find-str))))) Show source file in small font Link from substring-index-help to it's cross reference table entry 
(define (substring-index-help str str-index str-length find-str find-str-index find-str-length) ; return whether find-str matches at postion str-index at str. ; I.e., at boolean results from this function ; str-length is the length of str. ; find-str-length is the length of the remaining part of find-str to match. ; find-str-index is the actual index ind find-str. ; str-index is the actua index of str. (cond((= 0 find-str-length) #t) ((= str-index str-length) #f) ((eq? (string-ref str str-index) (string-ref find-str find-str-index)) (substring-index-help str (+ str-index 1) str-length find-str (+ 1 find-str-index) (- find-str-length 1))) (else #f))) ;; Return the first sentence in str (including a point). ;; The first sentence is running up to the first point followed by space or line termination. Show source file in small font Link from first-sentence-in-string to it's cross reference table entry 
(define (first-sentence-in-string str) (let* ((point-index (first-sentence-split-point str))) (if (number? point-index) (substring str 0 (+ 1 point-index)) str))) ;; Return all but the first sentence in str. Show source file in small font Link from but-first-sentence-of-string to it's cross reference table entry 
(define (but-first-sentence-of-string str) (let ((point-index (first-sentence-split-point str))) (if point-index (substring str (+ point-index 2) (string-length str)) ""))) ; Return the split point of the first sentence in str. ; If no split point can be located, return #f. Show source file in small font Link from first-sentence-split-point to it's cross reference table entry 
(define (first-sentence-split-point str) (let* ((point-index-0 (substring-index str 0 ". ")) (point-index-1 (substring-index str 0 (string-append "." (as-string (as-char 10))))) (point-index-2 (substring-index str 0 (string-append "." (as-string (as-char 13))))) (point-index-min (min-special point-index-0 point-index-1 point-index-2))) point-index-min)) Show source file in small font Link from min-special to it's cross reference table entry 
(define (min-special . numbers-or-nulls) (min-special-1 numbers-or-nulls #f)) Show source file in small font Link from min-special-1 to it's cross reference table entry 
(define (min-special-1 numbers-or-nulls res) (cond ((null? numbers-or-nulls) res) ((boolean? res) (min-special-1 (cdr numbers-or-nulls) (car numbers-or-nulls))) ((and (number? res) (number? (car numbers-or-nulls)) (< (car numbers-or-nulls) res)) (min-special-1 (cdr numbers-or-nulls) (car numbers-or-nulls))) ((and (number? res) (number? (car numbers-or-nulls)) (>= (car numbers-or-nulls) res)) (min-special-1 (cdr numbers-or-nulls) res)) (else (min-special-1 (cdr numbers-or-nulls) res)))) ;; Strip initial occurences of chars from char-list from string. Returns the empty string if given the empty string. ;; This function makes intermediate substrings, and as such it is not efficient. Show source file in small font Link from strip-initial-characters to it's cross reference table entry 
(define (strip-initial-characters char-list string) (if (= (string-length string) 0) "" (if (memq (string-ref string 0) char-list) (strip-initial-characters char-list (substring string 1 (string-length string))) string))) ;; Strip trailing occurences of chars from char-list from string. Returns the empty string if given the empty string. ;; This function makes intermediate substrings, and as such it is not efficient. Show source file in small font Link from strip-trailing-characters to it's cross reference table entry 
(define (strip-trailing-characters char-list string) (if (= (string-length string) 0) "" (let ((lgt (string-length string))) (if (memq (string-ref string (- lgt 1)) char-list) (strip-trailing-characters char-list (substring string 0 (max 0 (- lgt 2)))) string)))) Show source file in small font Link from strip-initial-spaces to it's cross reference table entry 
(define (strip-initial-spaces string) ;; Strip all initial space characters and lineshifting characters from string (strip-initial-characters (list #\space (integer->char 10) (integer->char 13) (integer->char 9) (integer->char 12)) string)) ; ----------------------------------------------------------------------------- ;; Return a CR string Show source file in small font Link from cr to it's cross reference table entry 
(define cr " ") ;; Return a CR string Show source file in small font Link from newline-string to it's cross reference table entry 
(define (newline-string) cr) ;; Return a list of n elements, each being el Show source file in small font Link from make-list to it's cross reference table entry 
(define (make-list n el) (if (<= n 0) '() (cons el (make-list (- n 1) el)))) ;; Concatenete a number of strings. Con is an alias of string-append Show source file in small font 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. Show source file in small font Link from con-space to it's cross reference table entry 
(define (con-space . string-list) ; like con, but insert a space between all strings in string-list (let ((space-list (make-list (- (length string-list) 1) " "))) (string-merge string-list space-list))) ; con-par in the html library file Show source file in small font Link from replicate-to-length to it's cross reference table entry 
(define (replicate-to-length lst lgt) ;; Replicate lst cyclically to a list of length lgt (reverse (replicate-to-length-1 lst lst '() 0 lgt))) Show source file in small font Link from replicate-to-length-1 to it's cross reference table entry 
(define (replicate-to-length-1 original-lst lst res count lgt) ; helping function to replicate-to-length ; original-lst is constant through this function. ; elements are taken out of lst ; the result is accumulated up in res ; count goes from 0 to lgt (cond ((null? lst) (replicate-to-length-1 original-lst original-lst res count lgt)) ((< count lgt) (replicate-to-length-1 original-lst (cdr lst) (cons (car lst) res) (+ 1 count) lgt)) (else res))) ;; A higher order functions which right accumulates a list Show source file in small font Link from accumulate-right to it's cross reference table entry 
(define (accumulate-right f init lst) (if (null? lst) init (f (car lst) (accumulate-right f init (cdr lst))))) ;; Flatten a list of lists to one list. Show source file in small font Link from flatten to it's cross reference table entry 
(define (flatten lst-of-lst) (accumulate-right append '() lst-of-lst)) ;; Add all elmenets in a list of numbers Show source file in small font Link from sum-list to it's cross reference table entry 
(define (sum-list lst) (accumulate-right + 0 lst)) ;; Return the first n elements of lst. ;; Just returns lst if n is equal or greater than the length of lst. ;; In other cases, a new 'copy' is returned. Show source file in small font Link from front-sublist to it's cross reference table entry 
(define (front-sublist lst n) (if (>= n (length lst)) lst (front-sublist-1 lst n))) ; A helping operation to front-sublist Show source file in small font Link from front-sublist-1 to it's cross reference table entry 
(define (front-sublist-1 lst n) (cond ((= n 0) '()) ((and (> n 0) (not (null? lst))) (cons (car lst) (front-sublist-1 (cdr lst) (- n 1)))) ((and (> n 0) (null? lst)) '()) (else (error "front-sublist-1: Should not happen")))) Show source file in small font Link from merge-lists to it's cross reference table entry 
(define (merge-lists list1 list2 pred) ;; Merge list1 and list2. Let e1 be the head of list1 and e2 the head of list2. ;; take e2 if (pred e1 e2) holds. Else e1 (cond ((null? list1) list2) ((null? list2) list1) ((pred (car list1) (car list2)) (cons (car list2) (merge-lists list1 (cdr list2) pred))) (else (cons (car list1) (merge-lists (cdr list1) list2 pred))))) Show source file in small font Link from turn-into-boolean to it's cross reference table entry 
(define (turn-into-boolean x) ;; If x is considered true return #t else #f. ;; See also as-boolean which is more versatile. ;; recall that (nearly all) expressions, conveniently, acts as true (if x #t #f)) ;; A very simple and basic list search function. ;; Return first element which matches lst. ;; If no element is found, return #f. ;; Tail recursive and iterative Show source file in small font Link from find-in-list to it's cross reference table entry 
(define (find-in-list pred lst) (cond ((null? lst) #f) ((pred (car lst)) (car lst)) (else (find-in-list pred (cdr lst))))) ;; quick and dirty butlast; Return all but the last element of a list Show source file in small font Link from butlast to it's cross reference table entry 
(define (butlast lst) (reverse (cdr (reverse lst)))) ;; quick and dirty last: Return the last element of a list. Show source file in small font Link from last to it's cross reference table entry 
(define (last lst) (car (reverse lst))) ; ---------------------------------------------------------------------------- ;; Duplicate removal - non-destructive. ;; This function uses equal for comparison of elements. Show source file in small font Link from remove-duplicates to it's cross reference table entry 
(define (remove-duplicates lst) (remove-duplicates-help lst '())) Show source file in small font Link from remove-duplicates-help to it's cross reference table entry 
(define (remove-duplicates-help lst res) (cond ((null? lst) (reverse res)) ((member (car lst) res) (remove-duplicates-help (cdr lst) res)) (else (remove-duplicates-help (cdr lst) (cons (car lst) res))))) ;; A variant of remove-duplicates with a selector function. ;; This function applies a selector function before comparisons and member is called. ;; This function uses equal for comparison of elements. Show source file in small font Link from remove-duplicates-with-selection to it's cross reference table entry 
(define (remove-duplicates-with-selection lst selector) (remove-duplicates-with-selection-help lst '() '() selector)) Show source file in small font Link from remove-duplicates-with-selection-help to it's cross reference table entry 
(define (remove-duplicates-with-selection-help lst res selected-res selector) (cond ((null? lst) (reverse res)) ((member (selector (car lst)) selected-res) (remove-duplicates-with-selection-help (cdr lst) res selected-res selector)) (else (remove-duplicates-with-selection-help (cdr lst) (cons (car lst) res) (cons (selector (car lst)) selected-res) selector )))) ;; Return the element of lst just before el, or #f if no such element exists. ;; Comparsion is done via application of selector on the elements of lst, and via eq?. ;; More precise return the element e of lst just before f, where (eq? (selector f) el). Show source file in small font Link from element-before to it's cross reference table entry 
(define (element-before el lst selector) (element-before-1 el lst selector (length lst))) Show source file in small font Link from element-before-1 to it's cross reference table entry 
(define (element-before-1 el lst selector lgt) (cond ((<= lgt 1) #f) ((eq? el (selector (car lst))) #f) ((eq? el (selector (cadr lst))) (car lst)) (else (element-before-1 el (cdr lst) selector (- lgt 1))))) ;; Return the element of lst just after el, or #f if no such element exists. ;; Comparsion is done via application of selector on the elements of lst, and via eq?. ;; More precise return the element e of lst just after f, where (eq? (selector f) el). Show source file in small font Link from element-after to it's cross reference table entry 
(define (element-after el lst selector) (element-after-1 el lst selector (length lst))) Show source file in small font Link from element-after-1 to it's cross reference table entry 
(define (element-after-1 el lst selector lgt) (cond ((<= lgt 1) #f) ((eq? el (selector (car lst))) (cadr lst)) (else (element-after-1 el (cdr lst) selector (- lgt 1))))) ; Functions earlier in the cgi library Show source file in small font Link from save-a-list to it's cross reference table entry 
(define (save-a-list alist filename) ;; Save the alist on a file named filename (with-output-to-file filename (lambda () (write alist)))) Show source file in small font Link from unique-timed-file-name to it's cross reference table entry 
(define (unique-timed-file-name prefix) ;; Return a unique file name with prefix. The suffic becomes the current-time i seconds representation (string-append prefix (number->string (current-time)))) Show source file in small font Link from file-append to it's cross reference table entry 
(define (file-append file-name x) ;; Write the list expression x at the end of the file named file-name (let* ((port (open-input-file file-name)) (contents (read port)) (new-contents (append (list x) contents))) (close-input-port port) (delete-file file-name) ; new! (let ((output-port (open-output-file file-name))) (write new-contents output-port) (close-output-port output-port)))) Show source file in small font Link from file-read to it's cross reference table entry 
(define (file-read file-name) ;; Read the (next) Lisp expression from file-name (let* ((port (open-input-file file-name)) (contents (read port))) (close-input-port port) contents)) Show source file in small font Link from file-write to it's cross reference table entry 
(define (file-write x file-name) ;; Write the list expression x at the file named file-name (if (file-exists? file-name) (delete-file file-name)) ; new! (let ((output-port (open-output-file file-name))) (write x output-port) (close-output-port output-port))) Show source file in small font Link from save-on-file to it's cross reference table entry 
(define (save-on-file x filename) ;; Displays the first parameter x on a file named filename (with-output-to-file filename (lambda () (display x)))) Show source file in small font Link from quote-string to it's cross reference table entry 
(define quote-string (as-string #\")) ;; embed the string x in double string quotes Show source file in small font Link from string-it to it's cross reference table entry 
(define (string-it x) (string-append quote-string x quote-string)) Show source file in small font Link from single-quote-string to it's cross reference table entry 
(define single-quote-string (as-string #\')) ;; embed the string x in single string quotes Show source file in small font Link from string-it-single to it's cross reference table entry 
(define (string-it-single x) (string-append single-quote-string x single-quote-string)) ;; The identify function of one parameter Show source file in small font Link from id-1 to it's cross reference table entry 
(define (id-1 x) x) ;; A higher order functions which negates the predicate p. Negate accepts a predicate and returns the negated predicate. Show source file in small font Link from negate to it's cross reference table entry 
(define (negate p) (lambda (x) (if (p x) #f #t))) ;; Return a composed function which applies f on g ;; Both f and g are supposed to take a single argument. Show source file in small font Link from compose to it's cross reference table entry 
(define (compose f g) (lambda (x) (f (g x)))) ;; Generate a less than or equal predicate from the enumeration-order. ;; If p is the generated predicate, (p x y) is true if and only if ;; (selector x) comes before (or at the same position) as (selector y) ;; in the enumeration-order. Thus, (selector x) is assumed to give a ;; value in enumeration-order. Comparison with elements in the enumeration-list ;; is done with eq? Show source file in small font Link from generate-leq to it's cross reference table entry 
(define (generate-leq enumeration-order selector) (lambda (x y) ; x and y supposed to be elements in enumeration order (let ((x-index (list-index (selector x) enumeration-order)) (y-index (list-index (selector y) enumeration-order))) (<= x-index y-index)))) ; A helping function of generate-leq. ; Return the position of e in lst. First is 1 ; compare with eq? ; if e is not member of lst return (+ 1 (length lst)) Show source file in small font Link from list-index to it's cross reference table entry 
(define (list-index e lst) (cond ((null? lst) 1) ((eq? (car lst) e) 1) (else (+ 1 (list-index e (cdr lst)))))) ;; Exchange destructively char n and m in str. First character is number 0. ;; Not a function, thus no return value. Show source file in small font Link from exchange-chars-in-str! to it's cross reference table entry 
(define (exchange-chars-in-str! str n m) (let ((remember-char (string-ref str m))) (string-set! str m (string-ref str n)) (string-set! str n remember-char))) ;; Remove the elements of lst2 from lst1. ;; A non-destructive function. ;; Uses eq? for comparison Show source file in small font Link from list-difference to it's cross reference table entry 
(define (list-difference lst1 lst2) (list-difference-1 lst1 lst2 '())) Show source file in small font Link from list-difference-1 to it's cross reference table entry 
(define (list-difference-1 lst1 lst2 res) (cond ((null? lst1) (reverse res)) ((memq (car lst1) lst2) (list-difference-1 (cdr lst1) lst2 res)) (else (list-difference-1 (cdr lst1) lst2 (cons (car lst1) res))))) ;; Return a list of pairs of elements from lst1 and lst2. ;; The list is as long as the shortest of lst1 and lst2. Show source file in small font Link from pair-up to it's cross reference table entry 
(define (pair-up lst1 lst2) (pair-up-1 lst1 lst2 '())) Show source file in small font Link from pair-up-1 to it's cross reference table entry 
(define (pair-up-1 lst1 lst2 res) (cond ((or (null? lst1) (null? lst2)) (reverse res)) (else (pair-up-1 (cdr lst1) (cdr lst2) (cons (cons (car lst1) (car lst2)) res))))) ;; Return a list of lists of elements from lst. ;; Each sub list is of length n. ;; Take elements consequtive (by rows) and put them into sublists. ;; The function sublist-by-predicate generalizes this function. Show source file in small font Link from sublist-by-rows to it's cross reference table entry 
(define (sublist-by-rows n lst) (let ((lgt (length lst))) (cond ((<= n 0) (error (string-append "sublist-by-rows: Cannot deal with row numbers less than or equal to zero: " (as-string n)))) ((< lgt n) (error (string-append "sublist-by-rows: Cannot deal with list of fewer elements than the sublist length:" (as-string lgt)))) (else (sublist-by-rows-1 n lst 0 '() '()))))) Show source file in small font Link from sublist-by-rows-1 to it's cross reference table entry 
(define (sublist-by-rows-1 n lst m res result) (cond ((and (null? lst) (null? res)) (reverse result)) ; A program source marker WITHOUT a link to the documentation ((and (null? lst) (not (null? res))) (reverse (cons (reverse res) result))) ; A program source marker WITHOUT a link to the documentation ((= m n ) (sublist-by-rows-1 n lst 0 '() (cons (reverse res) result))) ; A program source marker WITHOUT a link to the documentation ((<= m n) (sublist-by-rows-1 n (cdr lst) (+ m 1) (cons (car lst) res) result)) ; A program source marker WITHOUT a link to the documentation (else (error "sublist-by-rows-1: Should not happen")))) ;; Return sublists of lst in two column format. Thus each produced sublist is of length 2. ;; Good for presentation of the list in two columns, column by column. ;; In cases there is an uneven number of elements in lst, we add extra. Show source file in small font Link from sublist-by-2columns to it's cross reference table entry 
(define (sublist-by-2columns lst extra) (if (null? lst) '() (let* ((lgt (length lst)) (lst1 (if (even? lgt) lst (append lst (list extra)))) (row-sublst (sublist-by-rows (quotient (if (even? lgt) lgt (+ 1 lgt)) 2) lst1)) ; A program source marker WITHOUT a link to the documentation ) (map ; A program source marker WITHOUT a link to the documentation (lambda (e1 e2) (list e1 e2)) (car row-sublst) (cadr row-sublst))))) Show source file in small font Link from sublist-by-columns to it's cross reference table entry 
(define (sublist-by-columns n lst extra) (if (null? lst) '() (let* ((lgt (length lst)) (q (quotient lgt n)) (lst1 (if (multiplum-of lgt n) lst (append lst (make-list (- (* (+ q 1) n) lgt) extra)))) ; A program source marker WITHOUT a link to the documentation (rows (if (multiplum-of lgt n) q (+ q 1))) (row-sublst (sublist-by-rows rows lst1))) (multi-pair row-sublst)))) ;; lst-of-lst is a list of list. All first elements of the sublists are taken first, whereafter ;; we take all second elements, etc. ;; It is assumed that all sublists of lst-of-lst have the same lengths. Show source file in small font Link from multi-pair to it's cross reference table entry 
(define (multi-pair lst-of-lst) (cond ((null? (car lst-of-lst)) '()) (else (let ((cars (map car lst-of-lst)) (cdrs (map cdr lst-of-lst))) (cons cars (multi-pair cdrs)))))) ;; is a (the first par) a multiplum of b (the last par)? Show source file in small font Link from multiplum-of to it's cross reference table entry 
(define (multiplum-of a b) (= 0 (remainder a b))) ;; Return a list of sublists of elements from lst controlled by an element predicate p. ;; The sublists are formed consequtively by taking elements from lst. The predicate p decides ;; when to start a new sublist. Thus, when p evaluates to true, we start ;; a new sublist. The predicate p takes as parameters the current ;; elements, the previous element, and the number of elements before the ;; current one, p is not activated on (car lst). ;; This function generalizes sublist-by-rows. ;; p: (cur prev n) -> boolean Show source file in small font Link from sublist-by-predicate to it's cross reference table entry 7.2. Alphabetically organized cross reference indexes
(define (sublist-by-predicate lst p) (cond ((null? lst) '()) ; A program source marker WITHOUT a link to the documentation ((= 1 (length lst)) (list lst)) ; A program source marker WITHOUT a link to the documentation special case: sublist the only element. (else (sublist-by-predicate-1 (cdr lst) (car lst) p 1 (list (car lst)) '())))) Show source file in small font Link from sublist-by-predicate-1 to it's cross reference table entry 
(define (sublist-by-predicate-1 lst previous-el p n res result) (cond ((and (null? lst) (null? res)) (reverse result)) ; A program source marker WITHOUT a link to the documentation ((and (null? lst) (not (null? res))) (reverse (cons (reverse res) result))) ; A program source marker WITHOUT a link to the documentation ((p (car lst) previous-el n) (sublist-by-predicate-1 (cdr lst) (car lst) p (+ n 1) (list (car lst)) (cons (reverse res) result))) ; A program source marker WITHOUT a link to the documentation (else (sublist-by-predicate-1 (cdr lst) (car lst) p (+ n 1) (cons (car lst) res) result)))) ; A program source marker WITHOUT a link to the documentation ;; Remove duplicates from lst. ;; A duplicates satisfy the comparing predicate p. ;; (p element element) -> boolean. Show source file in small font Link from remove-duplicates-by-predicate to it's cross reference table entry 7.1. The cross reference index
(define (remove-duplicates-by-predicate lst p) (remove-duplicates-by-predicate-1 lst p '())) Show source file in small font Link from remove-duplicates-by-predicate-1 to it's cross reference table entry 
(define (remove-duplicates-by-predicate-1 lst p res) (cond ((null? lst) (reverse res)) ((member-by-predicate (car lst) res p) (remove-duplicates-by-predicate-1 (cdr lst) p res)) (else (remove-duplicates-by-predicate-1 (cdr lst) p (cons (car lst) res))))) ;; Return the duplicates in lst. ;; The duplicates are returned in the order of their fist occurence in lst. ;; Comparison of elements is done by the predicate (p element element) -> boolean. Show source file in small font Link from duplicates-by-predicate to it's cross reference table entry 
(define (duplicates-by-predicate lst p) (duplicates-by-predicate-1 lst p '())) Show source file in small font Link from duplicates-by-predicate-1 to it's cross reference table entry 
(define (duplicates-by-predicate-1 lst p res) (cond ((null? lst) (reverse res)) ((member-by-predicate (car lst) (cdr lst) p) (duplicates-by-predicate-1 (cdr lst) p (cons (car lst) res))) (else (duplicates-by-predicate-1 (cdr lst) p res)))) ;; Is el member of lst by means of the predicate p. ;; el is always passed as the first parameter to p. ;; If el is member, return the suffix of the list in which the first element (and el) satisfy the predicate. ;; Else return #f. ;; The element el and elements of lst are compared by p, el as the first one. ;; p: (el1, el2) -> boolean Show source file in small font Link from member-by-predicate to it's cross reference table entry 
(define (member-by-predicate el lst p) (cond ((null? lst) #f) ((p el (car lst)) lst) (else (member-by-predicate el (cdr lst) p)))) ;; Cut the tail of lst; The tail to be cutted starts with an element which fulfils pred. ;; Notice that the first element which fulfils the predicate is not included in the resulting list. Show source file in small font Link from cut-list-by-predicate to it's cross reference table entry 
(define (cut-list-by-predicate lst pred) (cond ((null? lst) '()) ((pred (car lst)) '()) (else (cons (car lst) (cut-list-by-predicate (cdr lst) pred))))) ;; Return whether every element in set-list-1 (a list) is a member of set-list-2, compared by the comparator comp. ;; This corresponds to a subset operations on sets, represented by a list. ;; comp: el x el -> boolean. Show source file in small font Link from subset-of-by-predicate to it's cross reference table entry 
(define (subset-of-by-predicate set-list-1 set-list-2 comp) (cond ((null? set-list-1) #t) ((member-by-predicate (car set-list-1) set-list-2 comp) (subset-of-by-predicate (cdr set-list-1) set-list-2 comp)) (else #f))) ; -------------------------------------------------------------------------------------------------- ;; Copy the text file in from-path to the file in to-path. ;; A quick and dirty solution by reading and writing strings to and from files. ;; If the destination file exists you must pass a third parameter, overwrite, with the value #t Show source file in small font Link from copy-text-file to it's cross reference table entry 
(define (copy-text-file from-path to-path overwrite?) (if (and (file-exists? to-path) overwrite?) (delete-file to-path)) (let ((contents (read-text-file from-path))) (if (not (file-exists? to-path)) (write-text-file contents to-path) (error (string-append "copy-a-file: Overwriting an existing file requires a third overwrite #t parameter: " to-path))))) ;; Copy each of the files in the list files from source-dir to target-dir. ;; Both source-dir and target-dir ends in a slash. Show source file in small font Link from copy-files to it's cross reference table entry 8.2. The icons
(define (copy-files files source-dir target-dir) (letrec ((copy-a-file (lambda (f) (let ((target-file (string-append target-dir f))) (if (file-exists? target-file) (delete-file target-file)) (copy-file (string-append source-dir f) target-file))))) (for-each copy-a-file files))) ;; Ensure that the last character in str (a string) is ch (a char) Show source file in small font Link from ensure-final-character to it's cross reference table entry 
(define (ensure-final-character str ch) (let ((lgt (string-length str))) (if (eq? #\/ (string-ref str (- lgt 1))) str (string-append str (as-string ch))))) ;;; Message displaying and error handling ;; Display a warning message line on standard output via the Scheme display function. ;; This is not a fatal error Show source file in small font Link from display-warning to it's cross reference table entry 
(define (display-warning message) (display (string-append "Warning: " message)) (newline)) ;; Display an error message and stop the program. ;; This is a fatal event. Show source file in small font Link from display-error to it's cross reference table entry 
(define (display-error message) (error message)) ;; Display a message on standard output. ;; Not a warning, and not fatal by any means. Show source file in small font Link from display-message to it's cross reference table entry 
(define (display-message message) (begin (display (string-append message)) (newline))) ;; Return a list of error message strings for those conditions that are true. ;; The function returns #f in case no errors are found. ;; There are no errors if all conditions evaluate to #f, and in this case returns the #f. ;; err-condition-message-list is a property list (of even length) of error-condition error messages pairs. ;; This function checks the conditions and returns a concatenated list of error messages. ;; If no error conditions are found, return #f. Show source file in small font Link from errors-among-conditions to it's cross reference table entry 
(define (errors-among-conditions . err-condition-message-list) (errors-among-conditions-1 err-condition-message-list #f '())) Show source file in small font Link from errors-among-conditions-1 to it's cross reference table entry 
(define (errors-among-conditions-1 err-condition-message-list errors-found accumulated-error-messages) (cond ((null? err-condition-message-list) (if errors-found (reverse accumulated-error-messages) #f)) (else (let ((error-condition (car err-condition-message-list)) (error-message (cadr err-condition-message-list))) (if error-condition (errors-among-conditions-1 (cddr err-condition-message-list) #t (cons error-message accumulated-error-messages)) (errors-among-conditions-1 (cddr err-condition-message-list) errors-found accumulated-error-messages)))) )) ;;; File name components ;; Return the filename component sans the final extension. ;; The extension, in a file name, is the part that follows the last `.'. ;; If no dot character is found the function returns file-name Show source file in small font Link from file-name-sans-extension to it's cross reference table entry 
(define (file-name-sans-extension file-name) (let ((extension-pos (find-in-string-from-end file-name #\.))) (if extension-pos (substring file-name 0 extension-pos) file-name))) ;; Return the part of file-name without extension and without an initial path. ;; Example: (file-name-proper "/xxx/yyy/zzz.eee") = "zzz". Show source file in small font Link from file-name-proper to it's cross reference table entry 
(define (file-name-proper file-name) (let ((extension-pos (find-in-string-from-end file-name #\.)) (forward-slash-pos (find-in-string-from-end file-name #\/)) (backward-slash-pos (find-in-string-from-end file-name #\\))) (substring file-name (cond ((and forward-slash-pos backward-slash-pos) (+ 1 (max forward-slash-pos backward-slash-pos))) (forward-slash-pos (+ 1 forward-slash-pos)) (backward-slash-pos (+ 1 backward-slash-pos)) (else 0)) (if extension-pos extension-pos (string-length file-name))))) ;; Return the extension of file-name. ;; The extension, in a file name, is the part that follows the last `.'. ;; This function handles dots in the initial path properly. Show source file in small font Link from file-name-extension to it's cross reference table entry 
(define (file-name-extension file-name) (let ((extension-pos (find-in-string-from-end file-name #\.)) (forward-slash-pos (find-in-string-from-end file-name #\/)) (backward-slash-pos (find-in-string-from-end file-name #\\))) (cond ((and extension-pos forward-slash-pos (> extension-pos forward-slash-pos)) (substring file-name (+ extension-pos 1) (string-length file-name))) ((and extension-pos forward-slash-pos (<= extension-pos forward-slash-pos)) "") ((and extension-pos backward-slash-pos (> extension-pos backward-slash-pos)) (substring file-name (+ extension-pos 1) (string-length file-name))) ((and extension-pos backward-slash-pos (<= extension-pos backward-slash-pos)) "") (extension-pos (substring file-name (+ extension-pos 1) (string-length file-name))) (else "")))) ;; Return the initial path of the file-name. ;; The initial path of a file name is the prefix of the file name without the proper file name ;; and without the extension. The initial path ends in a forward of backward slash, or it is empty. Show source file in small font Link from file-name-initial-path to it's cross reference table entry 
(define (file-name-initial-path file-name) (let ((extension-pos (find-in-string-from-end file-name #\.)) (forward-slash-pos (find-in-string-from-end file-name #\/)) (backward-slash-pos (find-in-string-from-end file-name #\\))) (substring file-name 0 (cond ((and forward-slash-pos backward-slash-pos) (+ 1 (max forward-slash-pos backward-slash-pos))) (forward-slash-pos (+ 1 forward-slash-pos)) (backward-slash-pos (+ 1 backward-slash-pos)) (else 0)) ))) ;; Return whether x - a string - represents an absolute path to a file. Show source file in small font Link from absolute-file-path? to it's cross reference table entry 
(define (absolute-file-path? x) (let ((forward-slash-pos (find-in-string x #\/)) (backward-slash-pos (find-in-string x #\\)) (colon-pos (find-in-string x #\:))) (or (and (number? forward-slash-pos) (= 0 forward-slash-pos)) (and (number? colon-pos) (= 1 colon-pos))))) ;; Return the name of the parent directory of dir (a string), or #f if dir is the root directory. Show source file in small font Link from parent-directory to it's cross reference table entry 
(define (parent-directory dir) (let* ((dir1 (ensure-final-character dir #\/)) (lgt (string-length dir1)) (dir2 (substring dir1 0 (max (- lgt 1) 0))) ; dir without ending slash (forward-slash-pos (find-in-string-from-end dir2 #\/)) (backward-slash-pos (find-in-string-from-end dir2 #\\))) (cond ((and forward-slash-pos backward-slash-pos (>= forward-slash-pos backward-slash-pos)) (substring dir2 0 (+ 1 forward-slash-pos))) ((and forward-slash-pos backward-slash-pos (>= backward-slash-pos forward-slash-pos)) (substring dir2 0 (+ 1 backward-slash-pos))) (forward-slash-pos (substring dir2 0 (+ 1 forward-slash-pos))) (backward-slash-pos (substring dir2 0 (+ 1 backward-slash-pos))) (else #f))))