; =>man/general.sdoc

;;;; .title Reference Manual of the General LAML library
;;;; .schemedoc-dependencies  "man/color" "man/time" "compatibility/man/mzscheme-compat"
;;;; This is a library of common and generally useful Scheme functions, which are used in other LAML libraries,
;;;; in LAML styles, and in LAML tools. Far the majority of the functions can also be used outside LAML. 
; The LAML library and programs written by Kurt Normark, Aalborg University, Denmark.
; Copyright (C) 1999-2009  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

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

;;; Optional parameter handling.
;;; Given the function <kbd>(lambda (r1 r2 . optional-parameters) ...)</kbd> the function
;;; <kbd>optional-parameter</kbd> (see below) is able to extract optional parameter number n. Non-used optional parameter can
;;; either be passed as the #f value (false in Scheme) or not passed at all. 
;;; .section-id optional-parameter-section
 
(define (optional-parameter n optional-parameter-list . optional-default-value)
  (let ((optional-default-value-1 (if (null? optional-default-value) #f (car optional-default-value))))  ; the old fashioned way of handling it...
   (if (> n (length optional-parameter-list))
       optional-default-value-1
       (let ((candidate-value  (list-ref optional-parameter-list (- n 1))))
         (if (eq? candidate-value 'non-passed-value)
             optional-default-value-1
             candidate-value))))) 


;;; .section-id selection-generation
;;; List selection functions and their generators. 
;;; As an alternative to using car, cadr etc. we provide for generation of more general list selector functions.

 
(define (make-selector-function n . optional-parameter-list)
 (let ((selector-name (optional-parameter 1 optional-parameter-list #f)))
   (if (and (eq? laml-execution-mode 'safe) selector-name)
       (lambda (lst) 
         (cond ((list? lst)
                 (let ((lgt (length lst)))
		   (if (> n lgt)
		       (display-error (string-append "The selector function " (as-string selector-name) ": " 
						     "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)))))
               (else (display-error (string-append "The selector function " (as-string selector-name) ": " 
						   "The parameter  "  (as-string lst) "  is supposed to be a list. "
                                                   "In addition, it must have at least "
				                    (as-string n) " elements."
						     )))))
       (lambda (lst) (list-ref lst (- n 1))))))


 
(define (make-mutator-function n . optional-parameter-list)
 (let ((mutator-name (optional-parameter 1 optional-parameter-list)))
   (if mutator-name
       (lambda (lst new-value) 
         (let ((lgt (length lst)))
            (if (> n lgt)
                (display-error (string-append "The mutator function " (as-string mutator-name) ": " 
                                 "The list "  (as-string lst) " is is too short for mutator. "
                                 "It must have at least " (as-string n) " elements."
                               ))
                (let ((cons-pair (list-tail lst (- n 1))))
                  (set-car! cons-pair new-value)))))
      (lambda (lst new-value) 
         (let ((lgt (length lst)))
            (if (> n lgt)
                (display-error (string-append "Error in mutator:"
                                 "The list "  (as-string lst) " is is too short for mutator. "
                                 "It must have at least " (as-string n) " elements."))
                (let ((cons-pair (list-tail lst (- n 1))))
                  (set-car! cons-pair new-value))))))))


 
(define first car)

 
(define second cadr)

 
(define third caddr)

 
(define fourth cadddr)

 
(define fifth (make-selector-function 5))

 
(define sixth (make-selector-function 6))

 
(define seventh (make-selector-function 7))

 
(define eighth (make-selector-function 8))

 
(define nineth (make-selector-function 9))

 
(define tenth (make-selector-function 10))


;;; Association and property list functions. 
;;; Here follows a number of functions which work on alists, or make alists. Also a number of property list functions are provided.
 
(define (extend-a-list key value a-list)
 (cons (cons (as-symbol key) value) a-list))

 
(define (extend-prop-list key val prop-list)
  (cons key (cons val prop-list)))

 
(define (get key a-list)
  (let ((res (assq key a-list)))
    (if (pair? res) 
        (cdr res)
        (error (string-append "Get: Cannot find " (as-string key) " in " (as-string a-list))))))

 
(define (defaulted-get key alist default)
  (let ((res (assq key alist)))
    (if res
       (cdr res)
       default)))


 
(define (get-prop key p-list)
  (let ((res (find-in-property-list key p-list)))
    (if res
        (if (not (null? (cdr res)))
            (cadr res)
            (laml-error "Illformed property list:" (as-string p-list)))
        (laml-error "Get-prop: Cannot find" (as-string key) "in the property list" (as-string p-list)))))

 
(define (find-in-property-list key p-list)
  (cond ((null? p-list) #f)
        ((eq? key (car p-list)) p-list)
        ((not (null? (cdr p-list))) (find-in-property-list key (cddr p-list)))
        (else (laml-error "Illformed property list:" (as-string p-list)))))

 
(define (defaulted-get-prop key p-list default)
  (let ((res (find-in-property-list key p-list)))
    (if res
        (if (not (null? (cdr res)))
            (cadr res)
            (laml-error "Illformed property list:" (as-string p-list)))
        default)))

 
(define (remove-prop! key p-list)
  (cond ((null? p-list) '())
        ((eq? key (car p-list))
            (remove-prop! key (cddr p-list)))
        (else 
            (cons (car p-list) (cons (cadr p-list) (remove-prop! key (cddr p-list)))))))

 
(define (remove-props! key-list p-list)
  (cond ((null? p-list) '())
        ((memq (car p-list) key-list)
            (remove-props! key-list (cddr p-list)))
        (else 
            (cons (car p-list) (cons (cadr p-list) (remove-props! key-list (cddr p-list)))))))

 
(define (remove-associations key-list a-list)
  (cond ((null? a-list) '())
        ((memq (car (car a-list)) key-list)
            (remove-associations key-list (cdr a-list)))
        (else 
            (cons (car a-list) (remove-associations key-list (cdr a-list))))))

 
(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")))

(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)))))

 
(define (propertylist-to-alist plist)
  (let ((lgt (length plist)))
   (cond ((null? plist) '())
         ((= 1 lgt) (error "propertylist-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)))))))

 
(define (alist-to-propertylist alist)
  (cond ((null? alist) '())
        (else (cons (car (car alist)) (cons (cdr (car alist)) (alist-to-propertylist (cdr alist)))))))

 
(define (every-second-element lst)
  (cond ((null? lst) '())
        ((null? (cdr lst)) (list (car lst)))
        (else (cons (car lst) (every-second-element (cddr lst))))))

 
(define (but-props prop-list eliminations)
 (but-props-1 prop-list eliminations '()))

(define (but-props-1 prop-list eliminations res)
 (cond ((null? prop-list) (reverse res))
       ((null? (cdr prop-list)) (laml-error "but-props called with ill-formed property list (odd number of elements)"))
       (else (let ((name (car prop-list))
                   (val (cadr prop-list)))
               (if (memq name eliminations) 
                   (but-props-1 (cddr prop-list) eliminations res)
                   (but-props-1 (cddr prop-list) eliminations (cons val (cons name res))))))))

 
(define (property-subset prop-list keylist)
  (cond ((null? prop-list) '())
        ((memq (car prop-list) keylist)
         (cons (car prop-list) (cons (cadr prop-list) (property-subset (cddr prop-list) keylist))))
        (else (property-subset (cddr prop-list) keylist))))


 
(define (pair-up lst1 lst2)
  (pair-up-1 lst1 lst2 '()))

(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)))))

 
(define (symbolize-key key-value-pair)
 (cons (as-symbol (car key-value-pair)) (cdr key-value-pair)))


;;; Filter and accumulation functions. 
;;; This sections provides variants of the very useful higher order filtering function.
 
(define (filter pred lst)
  (reverse (filter-help pred lst '())))

 
(define (filter-no-ordering pred lst)
  (filter-help pred lst '()))

(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))))


; October 5, 2005: mapping-filter generalized to several lists (of equal lengths).

 
(define (mapping-filter pred . lists)
  (reverse (mapping-filter-help pred lists '())))

(define (mapping-filter-help pred lists res)
  (if (null? (car lists))
      res
      (let ((pred-appl (apply pred (map car lists))))
        (if pred-appl 
            (mapping-filter-help pred (map cdr lists) (cons pred-appl res))
            (mapping-filter-help pred (map cdr lists) res)))))

; accumulate-right contributed by ttn@iblet.glug.org, November 28, 2002.

 
(define (accumulate-right f init lst)
  (let loop ((lst (reverse lst)) (acc init))
    (if (null? lst)
	acc
	(loop (cdr lst) (f (car lst) acc)))))


;;; Mapping functions.
;;; Here is a set of generalized mapping functions. These functions are all similar to map (which may take an arbitrary number of lists).
;;; Notice however, that map2, map3, etc do not require all lists to be of equal lengths.
 
(define (map2 f lst1 lst2)
  (if (or (null? lst1) (null? lst2)) '()
      (cons (f (car lst1) (car lst2)) 
            (map2 f (cdr lst1) (cdr lst2)))))

 
(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)))))

 
(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)))))

 
(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)))))

;;; .section-id higher-order-bite-functions
;;; Higher-order bite functions.
;;; Mapping and filtering functions that operate on bites (sublists) of a list.
;;; A bite of a non-empty list is a non-empty prefix of the list. Consequtive bites of a list must append-accumulate to the original list.
;;; There exists a number of higher-order bite function creators, such as bite-while-element and bite-of-length, see <a href = "#bite-generators"> here </a>.

 
(define (map-bites make-bite bite-transf lst)
  (map-bites-1 make-bite bite-transf lst 1 '()))

(define (map-bites-1 make-bite bite-transf lst i res-lst)
  (cond ((null? lst) (apply append (reverse res-lst)))
        (else (let ((bite (make-bite lst i)))
                 (if (null? bite) (laml-error "map-bites-1: Encountered an empty bite"))
                 (map-bites-1 make-bite bite-transf (list-tail-flex lst (length bite)) (+ i 1) (cons (bite-transf bite) res-lst))))))

 
(define (map-n-bites make-bite bite-transf lst)
  (map-n-bites-1 make-bite bite-transf lst 1 '()))

(define (map-n-bites-1 make-bite bite-transf lst i res-lst)
  (cond ((null? lst) (apply append (reverse res-lst)))
        (else (let ((bite (make-bite lst i)))
                 (if (null? bite) (laml-error "map-bites-1: Encountered an empty bite"))
                 (map-n-bites-1 make-bite bite-transf (list-tail-flex lst (length bite)) (+ i 1) (cons (bite-transf bite i) res-lst) )))))   

 
(define (filter-bites make-bite bite-pred lst)
  (filter-map-bites-1 make-bite bite-pred id-1 lst 1 '()))

 
(define (filter-map-bites make-bite bite-pred bite-transf lst)
  (filter-map-bites-1 make-bite bite-pred bite-transf lst 1 '()))

(define (filter-map-bites-1 make-bite bite-pred bite-transf lst i res-lst)
  (cond ((null? lst) (apply append (reverse res-lst)))
        (else (let ((bite (make-bite lst i)))
                 (if (null? bite) (laml-error "filter-map-bites-1: Encountered an empty bite"))
                 (if (bite-pred bite)
                     (filter-map-bites-1 make-bite bite-pred bite-transf (list-tail-flex lst (length bite))
                                         (+ i 1) (cons (bite-transf bite) res-lst)) 
                     (filter-map-bites-1 make-bite bite-pred bite-transf (list-tail-flex lst (length bite))
                                         (+ i 1) res-lst))))))

 
(define (step-and-map-bites make-bite bite-pred bite-transf lst)
  (step-and-map-bites-1 make-bite bite-pred bite-transf lst (length lst) 1 '()))

(define (step-and-map-bites-1 make-bite bite-pred bite-transf lst lst-lgt i res-lst)
  (cond ((<= lst-lgt 0) (reverse res-lst))
        ((null? lst) (reverse res-lst))
        (else (let* ((first-bite (make-bite lst i))
                     (selection-count (bite-pred first-bite))
                    )
                (cond ((< selection-count 0)   ; the first bite is not selected. Prepare for next bite (- selection-count) ahead
                            (step-and-map-bites-1 make-bite bite-pred bite-transf (list-tail-flex lst (- selection-count)) (+ lst-lgt selection-count)
                                            i (append (reverse (list-part 1 (- selection-count) lst)) res-lst)))

                      ((> selection-count 0)   ; the first bite is selected. Transform and splice it. Prepare for next bite selection-count ahead
                          (let ((trans-res (bite-transf first-bite)))
                            (step-and-map-bites-1 make-bite bite-pred bite-transf (list-tail-flex lst selection-count) (- lst-lgt selection-count)
                                           (+ i 1) (append (reverse trans-res) res-lst))))

                      (((= selection-count 0) (laml-error "step-and-map-bites-1: Illegal filter result."))))))))


 
(define (step-and-map-n-bites make-bite bite-pred bite-transf lst)
  (step-and-map-n-bites-1 make-bite bite-pred bite-transf lst (length lst) 1 '()))

(define (step-and-map-n-bites-1 make-bite bite-pred bite-transf lst lst-lgt i res-lst)
  (cond ((<= lst-lgt 0) (reverse res-lst))
        ((null? lst) (reverse res-lst))
        (else (let* ((first-bite (make-bite lst i))
                     (selection-count (bite-pred first-bite))
                    )
                (cond ((< selection-count 0)   ; the first bite is not selected. Prepare for next bite (- selection-count) ahead
                            (step-and-map-n-bites-1 make-bite bite-pred bite-transf (list-tail-flex lst (- selection-count)) (+ lst-lgt selection-count)
                                            i (append (reverse (list-part 1 (- selection-count) lst)) res-lst)))

                      ((> selection-count 0)   ; the first bite is selected. Transform and splice it. Prepare for next bite selection-count ahead
                          (let ((trans-res (bite-transf first-bite i)))
                            (step-and-map-n-bites-1 make-bite bite-pred bite-transf (list-tail-flex lst selection-count) (- lst-lgt selection-count)
                                           (+ i 1) (append (reverse trans-res) res-lst))))

                      (((= selection-count 0) (laml-error "step-and-map-n-bites-1: Illegal filter result."))))))))
 

;;; Other higher-order functions.
 
(define (negate p)
  (lambda (x) 
    (if (p x) #f #t)))

 
(define (disjunction p q)
  (lambda (x)
    (or (p x) (q x))))

 
(define (conjunction p q)
  (lambda (x)
    (and (p x) (q x))))

; Old version of compose:
; Return a composed function which applies f on g
; Both f and g are supposed to take a single argument.
; (define (compose f g)
;  (lambda (x)
;    (f (g x))))

 
(define (compose . f-list)
  (cond ((= 1 (length f-list)) (car f-list))
        ((= 2 (length f-list))
	 (let ((f (car f-list)) 
	       (g (cadr f-list)))
	   (lambda (x) (f (g x)))))
        (else  (lambda (x)
		 ((car f-list)
		  ((apply compose (cdr f-list)) x))))))


 
(define (generate-leq enumeration-order selector . optional-parameter-list)
 (let ((el-eq? (optional-parameter 1 optional-parameter-list eq?)))
  (lambda (x y)
     ; x and y supposed to be elements in enumeration order
     (let ((x-index (list-index (selector x) enumeration-order el-eq?))
           (y-index (list-index (selector y) enumeration-order el-eq?)))
       (<= x-index y-index)))))

 
(define (make-comparator lt gt)
 (lambda (e1 e2)
  (cond ((lt e1 e2) -1)
        ((gt e1 e2) 1)
        (else 0))))

; A helping function of generate-leq.
; Return the position of e in lst. First is 1
; compare with el-eq?
; if e is not member of lst return (+ 1 (length lst))
(define (list-index e lst el-eq?)
 (cond ((null? lst) 1)
       ((el-eq? (car lst) e) 1)
       (else (+ 1 (list-index e (cdr lst) el-eq?)))))

 
(define (curry-generalized f)
  (lambda rest
    (cond ((= (length rest) 1) (lambda lst (apply f (cons (car rest) lst))))
          ((>= (length rest) 2) (apply f rest)))))

;;; List and Sexpr functions.
 
(define (number-interval f t)
 (if (<= f t) (cons f (number-interval (+ f 1) t)) '()))



 
(define (proper-part lst)
  (cond ((and (pair? lst) (pair? (cdr lst)))  (cons (car lst) (proper-part (cdr lst))))
        ((pair? lst) (cons (car lst) '()))
        (else '())))

 
(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 (make-list n el)
  (if (<= n 0) '() (cons el (make-list (- n 1) el))))

 
(define (replicate-to-length lst lgt)
  (reverse (replicate-to-length-1 lst lst '() 0 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
(define (replicate-to-length-1 original-lst lst res count 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)))


 
(define (flatten lst-of-lst)
  (accumulate-right append '() lst-of-lst))

 
(define (sum-list lst)
  (accumulate-right + 0 lst))



 
(define (merge-lists list1 list2 pred)
 (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)))))

 
(define (merge-lists-simple lst1 lst2)
 (merge-lists-simple-1 lst1 lst2 '()))

(define (merge-lists-simple-1 lst1 lst2 res)
  (cond ((null? lst1) (reverse (append (reverse lst2) res)))
        ((null? lst2) (reverse (append (reverse lst1) res)))
        (else (merge-lists-simple-1 (cdr lst1) (cdr lst2) (cons (car lst2) (cons (car lst1) res ))))))

 
(define (find-in-list pred lst)
  (cond ((null? lst) #f)
        ((pred (car lst)) (car lst))
        (else (find-in-list pred (cdr lst)))))

 
(define (find-tail-in-list pred lst)
  (cond ((null? lst) '())
        ((pred (car lst)) lst)
        (else (find-tail-in-list pred (cdr lst)))))

 
(define (find-but-tail-in-list pred lst)
   (find-but-tail-in-list-1 pred lst '()))

(define (find-but-tail-in-list-1 pred lst res-lst)
  (cond ((null? lst) '())
        ((pred (car lst)) (reverse res-lst))
        (else (find-but-tail-in-list-1 pred (cdr lst) (cons (car lst) res-lst)))))



 
(define (traverse-cons-cells pred cell)
  (cond ((not (pair? cell)) '())
        ((pred cell) (cons cell (traverse-cons-cells pred (cdr cell))))
        ((and (pair? (car cell)) (pair? (cdr cell)))
            (append (traverse-cons-cells pred (car cell)) (traverse-cons-cells pred (cdr cell))))
        ((pair? (car cell))
            (traverse-cons-cells pred (car cell)))
        ((pair? (cdr cell))
            (traverse-cons-cells pred (cdr cell)))
        (else '())))

 
(define (butlast lst)
  (reverse (cdr (reverse lst))))

 
(define (last lst)
  (car (reverse lst)))

 
(define (remove-duplicates lst)
 (remove-duplicates-help lst '()))

(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)))))

 
(define (remove-duplicates-with-selection lst selector)
 (remove-duplicates-with-selection-help lst '() '() selector))

(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 ))))

 
(define (element-before el lst selector . optional-parameter-list)
 (let ((eq-pred (optional-parameter 1 optional-parameter-list eq?)))
  (element-before-1 el lst selector (length lst) eq-pred)))

(define (element-before-1 el lst selector lgt eq-pred)
  (cond ((<= lgt 1) #f)
        ((eq-pred el (selector (car lst))) #f)
        ((eq-pred el (selector (cadr lst))) (car lst))
        (else (element-before-1 el (cdr lst) selector (- lgt 1) eq-pred))))

 
(define (element-after el lst selector . optional-parameter-list)
 (let ((eq-pred (optional-parameter 1 optional-parameter-list eq?)))
  (element-after-1 el lst selector (length lst) eq-pred)))

(define (element-after-1 el lst selector lgt eq-pred)
  (cond ((<= lgt 1) #f)
        ((eq-pred el (selector (car lst))) (cadr lst))
        (else (element-after-1 el (cdr lst) selector (- lgt 1) eq-pred))))


 
(define (list-difference lst1 lst2 . optional-parameter-list)
 (let ((is-eq? (optional-parameter 1 optional-parameter-list eq?)))
  (list-difference-1 lst1 lst2 '() is-eq?)))

(define (list-difference-1 lst1 lst2 res eq-pred)
  (cond ((null? lst1) (reverse res))
        ((member-by-predicate (car lst1) lst2 eq-pred) (list-difference-1 (cdr lst1) lst2 res eq-pred))
        (else (list-difference-1 (cdr lst1) lst2 (cons (car lst1) res) eq-pred))))


 
(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) (list lst))
        (else (sublist-by-rows-1 n lst 0 '() '())))))

(define (sublist-by-rows-1 n lst m res RESULT)
  (cond ((and (null? lst) (null? res)) (reverse RESULT))  ;  @a
        ((and (null? lst) (not (null? res))) (reverse (cons (reverse res) RESULT)))    ;  @b
        ((= m n ) (sublist-by-rows-1 n lst 0 '() (cons (reverse res) RESULT)))         ;  @c
        ((<= m n) (sublist-by-rows-1 n (cdr lst) (+ m 1) (cons (car lst) res) RESULT)) ;  @d
        (else (error "sublist-by-rows-1: Should not happen"))))                       

 
(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)) ;  @i
        )
    (map ;  @j
      (lambda (e1 e2) (list e1 e2))
      (car row-sublst) (cadr row-sublst)))))

 
(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
         (rows (if (multiplum-of lgt n) q (+ q 1)))
         (row-sublst (sublist-by-rows rows lst1)))
    (multi-pair row-sublst))))

 
(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))))))

 
(define (sublist-by-predicate lst p)
  (cond ((null? lst) '()) ;  @a
        ((= 1 (length lst)) (list lst))  ;  @bspecial case: sublist the only element.
        (else (sublist-by-predicate-1 (cdr lst) (car lst) p 1 (list (car lst)) '()))))


(define (sublist-by-predicate-1 lst previous-el p n res RESULT)
  (cond ((and (null? lst) (null? res)) (reverse RESULT)) ;  @d
        ((and (null? lst) (not (null? res))) (reverse (cons (reverse res) RESULT))) ;  @e
        ((p (car lst) previous-el n)   (sublist-by-predicate-1 (cdr lst) (car lst) p (+ n 1) (list (car lst)) (cons (reverse res) RESULT))) ;  @f
        (else                          (sublist-by-predicate-1 (cdr lst) (car lst) p (+ n 1) (cons (car lst) res) RESULT)))) ;  @g

 
(define (remove-duplicates-by-predicate lst p)
 (remove-duplicates-by-predicate-1 lst p '()))

(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)))))

 
(define (duplicates-by-predicate lst p)
  (duplicates-by-predicate-1 lst p '()))

(define (duplicates-by-predicate-1 lst p res)
  (cond ((null? lst) (reverse res))
        ((member-by-predicate (car lst) (cdr lst) p)
            (if (member-by-predicate (car lst) res p)        ; always detected as duplicate once
                (duplicates-by-predicate-1 (cdr lst) p res)
                (duplicates-by-predicate-1 (cdr lst) p (cons (car lst) res))))
        (else (duplicates-by-predicate-1 (cdr lst) p res))))  

 
(define (member-by-predicate el lst p)
  (cond ((null? lst) #f)
        ((p el (car lst)) lst)
        (else (member-by-predicate el (cdr lst) p))))

 
(define (list-intersection-by-predicate lst1 lst2 pred)
 (list-intersection-1 lst1 lst2 pred '()))

(define (list-intersection-1 lst1 lst2 pred res)
  (cond ((null? lst1) (remove-duplicates-by-predicate (reverse res) pred))
        (else (let* ((el (car lst1))
                     (el-member-lst2 (member-by-predicate el lst2 pred)))
                (list-intersection-1 (cdr lst1) lst2 pred (if el-member-lst2 (cons el res) res))))))
  

 
(define (cut-list-by-predicate lst pred)
  (cond ((null? lst) '())
        ((pred (car lst)) '())
        (else (cons (car lst) (cut-list-by-predicate (cdr lst) pred)))))


 
(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)))


 
(define (index-in-list-by-predicate lst el c)
 (letrec ((index-in-list-by-predicate-1 
            (lambda (lst count)
               (cond ((null? lst) #f)
                     ((c (car lst) el) count)
                     (else (index-in-list-by-predicate-1 (cdr lst) (+ count 1)))))))
  (index-in-list-by-predicate-1  lst 0)))


 
(define (sublistify lst sublist-length)
 (if (<= (length lst) sublist-length)
     (list lst)
     (let ((first-sublist (list-prefix lst sublist-length))
           (rest-lst (list-tail lst sublist-length)))
       (cons first-sublist
             (sublistify rest-lst sublist-length)))))

 
(define (front-sublist lst n)
 (if (>= n (length lst)) lst (front-sublist-1 lst n)))


; A helping operation to front-sublist
(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 (laml-error "front-sublist-1: Should not happen" lst n))))

 
(define (front-sublist-while lst ok? max-length)
  (front-sublist-while-1 lst ok? max-length   (length lst) '() 0))

(define (front-sublist-while-1 lst ok? max-length   lst-lgt res length-res)
  (cond ((= 0 lst-lgt) '())
        ((null? lst) (reverse res))
        ((= max-length length-res) (reverse res))
        ((ok? (first lst))
           (front-sublist-while-1 (cdr lst) ok? max-length
                                lst-lgt (cons (first lst) res) (+ 1 length-res)))
        (else (reverse res))))

 
(define (rear-sublist lst n)
  (let ((lst-lgt (length lst)))
    (if (>= n lst-lgt)
        lst
        (let ((prefix-lgt (- lst-lgt n)))
          (list-tail lst prefix-lgt)))))


; Return the list of the first n elements of lst.
; If n > (length lst) just return lst. 
; .misc This function is almost identical to front-sublist.
(define (list-prefix lst n)
  (if (< (length lst) n)
      lst
      (list-prefix-1 lst n)))

(define (list-prefix-1 lst n)
  (if (= n 0)
      '()
      (cons (car lst) (list-prefix-1 (cdr lst) (- n 1)))))

 
(define (list-prefix-while lst predicate)
  (list-prefix-while-1 lst predicate '()))

(define (list-prefix-while-1 lst predicate res-lst)
  (if (null? lst) 
      (reverse res-lst)
      (let ((el (car lst)))
        (if (predicate el)
            (list-prefix-while-1 (cdr lst) predicate (cons el res-lst))
            (reverse res-lst)))))


 
(define (list-part a b lst)
  (list-part-help a b lst 1 (length lst) '()))

(define (list-part-help a b lst  i lgt res)
 (cond ((> i lgt) (reverse res))
       ((> i b) (reverse res))
       ((and (>= i a) (<= i b) (not (null? lst))) (list-part-help a b (cdr lst) (+ i 1) lgt (cons (car lst) res)))
       ((and (<= i a) (not (null? lst)))  (list-part-help a b (cdr lst) (+ i 1) lgt res))
       ((null? lst) (error (string-append "list-part error: " (as-string i))))))

 
(define (sublist-of-list lst from-pred end-pred)
  (let ((lst-lgt (length lst))
        (i (find-index-in-list lst from-pred))
        (j (find-index-in-list lst end-pred)))
    (cond ((and i j)
            (list-part (+ i 1) j lst))
          ((and i (not j))
            (list-part (+ i 1) lst-lgt lst))
          (else '()))))

 
(define (sublist-until until-fn lst)
  (sublist-until-1 until-fn lst '())
)

(define (sublist-until-1 until-fn lst res-lst)
  (cond ((null? lst) (reverse res-lst))
        ((until-fn (car lst)) (reverse (cons (car lst) res-lst)))
        (else (sublist-until-1 until-fn (cdr lst) (cons (car lst) res-lst)))))





 
(define (list-tail-flex lst n)
  (cond ((= n 0) lst)
        ((null? lst) '())
        (else (list-tail-flex (cdr lst) (- n 1)))))

 
(define (find-index-in-list lst pred)
  (find-index-in-list-1 lst pred 0))

(define (find-index-in-list-1 lst pred i)
  (cond ((null? lst) #f)
        ((pred (car lst)) i)
        (else (find-index-in-list-1 (cdr lst) pred (+ i 1)))))

 
(define (shallow-copy-list lst)
  (cond ((pair? lst)
            (cons (car lst) (shallow-copy-list (cdr lst))))
        (else lst)))


 
(define (increasing-list-with-noice? comparator noice-fn lst)
  (let ((non-noice-lst (filter (negate noice-fn) lst)))
   (increasing-list? comparator non-noice-lst)))

 
(define (increasing-list? comparator lst)
   (if (or (null? lst) (null? (cdr lst)))
       #t
       (and (= (comparator (car lst) (cadr lst)) -1) (increasing-list? comparator (cdr lst)))))

 
(define (decreasing-list-with-noice? comparator noice-fn lst)
  (let ((non-noice-lst (filter (negate noice-fn) lst)))
   (decreasing-list? comparator non-noice-lst)))

 
(define (decreasing-list? comparator lst)
   (if (or (null? lst) (null? (cdr lst)))
       #t
       (and (= (comparator (car lst) (cadr lst)) 1) (decreasing-list? comparator (cdr lst)))))

 
(define (list-but-ref lst n)
  (cond ((null? lst) '())
        ((= n 0) (cdr lst))
        (else (cons (car lst) (list-but-ref (cdr lst) (- n 1))))))

 
(define (shuffle-list lst)
   (if (null? lst)
       '()
        (let* ((lst-lgt (length lst))
               (random-el-number (random lst-lgt)) ; 0 .. (- lst-lgt 1)
               (selected-element (list-ref lst random-el-number))
               (rest-elements (list-but-ref lst random-el-number)))
          (cons selected-element 
                (shuffle-list rest-elements)))))

;;; Vector functions.
 
(define (binary-search-in-vector v el sel el-eq? el-leq?)
 (let ((lgt (vector-length v)))
  (if (= 0 (vector-length v))
      #f
      (do ((up-idx   (- lgt 1))
	   (low-idx  0)
	   )
	  ((or (el-eq? el (sel (vector-ref v (quotient (+ up-idx low-idx) 2))))	; hit
	       (= up-idx low-idx) (= up-idx (+ 1 low-idx)) ; narrow interval
	       )
	   (cond ((el-eq? el (sel (vector-ref v (quotient (+ up-idx low-idx) 2)))) ; mid
		  (vector-ref v (quotient (+ up-idx low-idx) 2)))
		 ((el-eq? el (sel (vector-ref v low-idx))) ; low
		  (vector-ref v low-idx))
		 ((el-eq? el (sel (vector-ref v up-idx))) ; up
		  (vector-ref v up-idx))
		 (else #f)))
	(cond ((el-leq? el (sel (vector-ref v (quotient (+ up-idx low-idx) 2))))
               (set! up-idx (quotient (+ up-idx low-idx) 2)))
	      (else 
               (set! low-idx (quotient (+ up-idx low-idx) 2))))))))


;;; Conversion functions. 
;;; In this category we provide a number of useful conversion functions. Several of these are of the form (as-type xxx),
;;; where type determines the target type of the conversion.<p>
;;; This section includes a function number-in-base which converts a decimal number to a number in another number system.
 
(define (char->string ch)
  (make-string 1 ch))


 
(define (as-string x)
  (cond ((number? x) (number->string x))
        ((symbol? x) (symbol->string x))
        ((string? x) x)
        ((boolean? x) 
            (if x "true" "false"))   ; consider "#t" and "#f" as alternatives
        ((char? x) (char->string x))
        ((list? x)
            (string-append "(" 
               (string-merge (map as-string x) (make-list (- (length x) 1) " "))
               ")"))
        ((vector? x)
          (let ((lst (vector->list x)))
            (string-append "#(" 
               (string-merge (map as-string lst) (make-list (- (length lst) 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 "??")))

 
(define (as-quoted-string x)
  (cond ((number? x) (number->string x))
        ((symbol? x) (symbol->string x))
        ((string? x) (string-it x))
        ((boolean? x) 
            (if x "true" "false"))   ; consider "#t" and "#f" as alternatives
        ((char? x) (char->string x))
        ((list? x)
            (string-append "(" 
               (string-merge (map as-quoted-string x) (make-list (- (length x) 1) " "))
               ")"))
        ((pair? x)
            (string-append "(" 
               (apply string-append
                  (map (lambda (y) (string-append (as-quoted-string y) " ")) (proper-part x))
               )
               " . " (as-quoted-string (first-improper-part x))
               ")"))
        (else "??")))

 
(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)))

 
(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
         (error
          (string-append "Cannot convert to number "
                         (as-string x))))))


 
(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 #\?)))

 
(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)
        ((vector? x) (vector->list x)) 
        (else (list x))))

 
(define (string-to-list str element-separator-chars)
 (filter (negate empty-string?)
  (string-to-list-help str "" '() element-separator-chars (string-length str))))

(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 
         ((memv 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)))))))

 
(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"))))

 
(define (turn-into-boolean x)
  (if x #t #f))

 
(define (as-01-boolean x)
  (cond ((number? x)
          (if (= 0 x) 0 1))
        (else
          (if x 1 0))))

 
(define (list-to-string lst separator)
  (string-merge 
     (map as-string lst)
     (make-list (- (length lst) 1) separator)))

 
(define (string-append-with-separator str-lst separator)
  (letrec ((string-append-with-separator-1 
             (lambda (str-lst lgt-lst sep res)
                (cond ((= lgt-lst 0) res)
                      ((= lgt-lst 1) (string-append res (first str-lst)))
                      (else (string-append-with-separator-1 (cdr str-lst) (- lgt-lst 1) sep (string-append res (first str-lst) sep)))))))
    (string-append-with-separator-1 str-lst (length str-lst) (as-string separator) "")))


 
(define (number-in-base n base)
 (if (= n 0) "0"
  (let ((ciffer-list (reverse (ciffers-in-base n base))))
     (ciffer-output ciffer-list))))

(define (ciffers-in-base n base)
  (if (= n 0)
      '()
      (let ((rem (modulo n base))
            (newn (quotient n base)))
        (cons rem (ciffers-in-base newn base)))))

(define (ciffer-output ciffer-list)
 (apply string-append
    (map ciffer-translation ciffer-list)))

(define (ciffer-translation c)
  (cond ((<= c 9) (number->string c))
        ((and (> c 9) (< c 33)) (make-string 1 (integer->char (+ c 87))))
        (t "?")))


;;; String predicates.
; Is the string str empty
; (define (empty-string? str)
;  (= (string-length str) 0))

 
(define (empty-string? str)
  (string=? str ""))

 
(define white-space-char-list (list #\space (as-char 13) (as-char 10) #\tab))

 
(define (blank-string? str)
  (or (empty-string? str) 
      (string-of-char-list? str white-space-char-list)))

 
(define (numeric-string? str . optional-parameters)
 (let ((signed? (optional-parameter 1 optional-parameters #f)))
   (if signed?
       (and (or (eqv? (string-ref str 0) #\+) (eqv? (string-ref str 0) #\-))
            (string-of-char-list? (substring str 1 (string-length str) ) (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 )))
       (string-of-char-list? str (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 )))))

 
(define (string-of-char-list? str char-list)
  (string-of-char-list-1? str char-list 0 (string-length str)))

(define (string-of-char-list-1? str char-list i lgt)
  (if (= i lgt)
      #t
      (and (memv (string-ref str i) char-list)
           (string-of-char-list-1? str char-list (+ i 1) lgt))))


 
(define (string-of-negative-char-list? str char-list)
  (string-of-negative-char-list-1? str char-list 0 (string-length str)))

(define (string-of-negative-char-list-1? str char-list i lgt)
  (if (= i lgt)
      #t
      (and (not (memv (string-ref str i) char-list))
           (string-of-negative-char-list-1? str char-list (+ i 1) lgt))))

 
(define (looking-at-substring? str pos sub-str)
  (looking-at-substring-1? str pos sub-str 0 (string-length str) (string-length sub-str)))

(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) (eqv? (string-ref str a) (string-ref sub-str i)))
          (looking-at-substring-1? str pos sub-str (+ i 1) lgt1 lgt2))
        (else #f))))

 
(define (substring? s t)
  (let ((i (substring-index s 0 t)))
    (if i #t #f)))


;;; Other string functions.
;;; Among the functions in this section you will find string search and replacement functions. 

 
(define (split-on ch str)
 (let ((sp (split-point ch str)))
   (list (substring str 0 sp)
         (substring str (+ sp 1) (string-length str)))))

 
(define (split-point ch str)
 (call-with-current-continuation
  (lambda (exit)
   (cond ((equal? str "") #f)
         ((eqv? 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))))))))

 
(define (split-string-by-predicate str pred)
 (let ((p1 (find-in-string-by-predicate (negate pred) str 0)))
   (cond ((empty-string? str) '())
         ((not p1) '())
         (p1 (split-string-by-predicate-1 (substring str p1 (string-length str)) pred))
         (list str))))

(define (split-string-by-predicate-1 str pred)
 (let* ((strlen (string-length str))
        (p1 (find-in-string-by-predicate pred str 0))
        (p2 (find-in-string-by-predicate (negate pred) str p1)))
   (cond ((empty-string? str) '())
         ((and p1 p2)
            (cons (substring str 0 p1)
		  (split-string-by-predicate-1 (substring str p2 strlen) pred)))
         ((and p1 (not p2)) (list (substring str 0 p1)))
         ((and (not p1) (and (not p2))) (list str))
         (else '()))))


 
(define (find-in-string str ch . optional-parameter-list)
 (let ((start-pos (optional-parameter 1 optional-parameter-list 0)))
  (if (and (boolean? start-pos) (not start-pos))
      #f
     (find-in-string-1 str ch start-pos (string-length str)))))

(define (find-in-string-1 str ch i lgt)
  (cond ((>= i lgt) #f)
        ((eqv? ch (string-ref str i)) i)
        (else (find-in-string-1 str ch (+ i 1) lgt))))

 
(define (find-in-string-from-end str ch)
 (let ((lgt (string-length str)))
  (find-in-string-from-end-1 str ch (- lgt 1) lgt)))

(define (find-in-string-from-end-1 str ch i lgt)
  (cond ((< i 0) #f)
        ((eqv? ch (string-ref str i)) i)
        (else (find-in-string-from-end-1 str ch (- i 1) lgt))))

 
(define (find-in-string-by-predicate pred str . optional-parameter-list)
 (let ((start-pos (optional-parameter 1 optional-parameter-list 0)))
  (find-in-string-by-predicate-1 pred str start-pos start-pos (string-length str))))

(define (find-in-string-by-predicate-1 pred str start-pos i lgt)
  (cond ((and (boolean? start-pos) (not start-pos)) #f)
        ((>= i lgt) #f)
        ((pred (string-ref str i)) i)
        (else (find-in-string-by-predicate-1 pred str start-pos (+ i 1) lgt))))

 
(define (find-in-string-from-end-by-predicate pred str . optional-parameter-list)
 (let* ((str-lgt (string-length str))
        (start-pos (optional-parameter 1 optional-parameter-list (- str-lgt 1))))
  (find-in-string-from-end-by-predicate-1 pred str start-pos start-pos str-lgt)))

(define (find-in-string-from-end-by-predicate-1 pred str start-pos i lgt)
  (cond ((and (boolean? start-pos) (not start-pos)) #f)
        ((< i 0) #f)
        ((pred (string-ref str i)) i)
        (else (find-in-string-from-end-by-predicate-1 pred str start-pos (- i 1) lgt))))



 
(define (skip-chars-in-string str char-list start-pos)
  (skip-chars-in-string-1 str char-list start-pos (string-length str)))

(define (skip-chars-in-string-1 str char-list i lgt)
  (cond ((and (< i lgt) (memv (string-ref str i) char-list))
          (skip-chars-in-string-1 str char-list (+ i 1) lgt))
        ((and (< i lgt) (not (memv (string-ref str i) char-list)))
          i)
        (else i)))

 
(define (string-merge str-list-1 str-list-2)
 (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))))))

 
(define (transliterate in-string ch str)
 (let ((str-factor (max (string-length str) 1)))
  (transliterate-1 in-string 0 (string-length in-string) 
                  (make-string (* (string-length in-string) str-factor) #\space) 0
                  ch str)))

(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 (eqv? 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")) ))

 
(define (filter-string pred str)
 (letrec ((filter-string-1
	   (lambda (pred str-lgt str i result j)
	     (cond ((>= i str-lgt) (substring result 0 j))
		   ((pred (string-ref str i)) (filter-string-1 pred str-lgt str (+ i 1) result j))
		   (else (begin
			   (string-set! result j (string-ref str i))
			   (filter-string-1 pred str-lgt str (+ i 1) result (+ j 1))))))))   
   (let* ((str-lgt (string-length str))
	  (result (make-string str-lgt)))
     (filter-string-1 pred str-lgt str 0 result 0))))


 
(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)))


 
(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.
(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)))


  

 
(define (put-around-substring str pre-index pre-putin post-index post-putin)
 (put-into-string
    (put-into-string str post-index post-putin)
                         pre-index pre-putin))

 
(define (put-into-string str index putin-str)
 (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))

 
(define (embed-substring substring str embed-function)
  (let* ((i (substring-index str 0 substring)))
    (if i
        (let* ((pruned-str (delete-string-portion str i (string-length substring)))
	       (new-str (put-into-string pruned-str i (embed-function substring))))
          new-str)
        str)))

 
(define (copy-string-into! target i source)
  (copy-string-into-help! target i (string-length target) source 0 (string-length source)))

(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)))))

 
(define (substring-index str str-index find-str)
 (let ((str-length (string-length str))
       (find-str-length (string-length find-str)))
  (cond ((= 0 (string-length find-str)) str-index) 
        ((> 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)))))

; Return whether find-str matches at postion str-index at str.
; This function return boolean information
; 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 actual index of str.
(define (substring-index-help str str-index str-length find-str find-str-index find-str-length)
  (cond((= 0 find-str-length) #t)
       ((= str-index str-length) #f)
       ((eqv? (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)))


 
(define (extract-substrings str start-marker end-marker)
  (extract-substrings-1 str start-marker end-marker 0))

(define (extract-substrings-1 str start-marker end-marker from-pos)
  (let ((p1 (substring-index str from-pos start-marker)))
    (if p1
        (let ((p2 (substring-index str (+ p1 (string-length start-marker)) end-marker)))
           (if p2
               (cons (substring str (+ p1 (string-length start-marker)) p2)
                     (extract-substrings-1 str start-marker end-marker (+ p2 (string-length end-marker))))
               '()))
        '())))

 
(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)))

 
(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.
(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))

(define (min-special . numbers-or-nulls)
  (min-special-1 numbers-or-nulls #f))

(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))))

 
(define (strip-initial-characters char-list string)
  (if (= (string-length string) 0)
      ""
      (if (memv (string-ref string 0) char-list)
          (strip-initial-characters char-list (substring string 1 (string-length string)))
          string)))

 
(define (strip-trailing-characters char-list string)
 (letrec ((last-non-char-list-index 
	   (lambda (i)
	     (cond ((< i 0) i)
		   ((memv (string-ref string i) char-list)
                      (last-non-char-list-index (- i 1)))
		   (else i)))) ; char i is not in char-list
         )
   (let ((i (last-non-char-list-index (- (string-length string) 1)))
        )
     (if (< i 0)
	 ""
       (substring string 0 (+ i 1))))))


 
(define (strip-initial-spaces string)
  (strip-initial-characters 
     (list #\space (integer->char 10) (integer->char 13) (integer->char 9) (integer->char 12))
     string))
      

; con-par is in the html library file



(define quote-string (as-string #\"))

 
(define (string-it x)
  (string-append quote-string  x quote-string))

(define single-quote-string (as-string #\'))

 
(define (string-it-single x)
  (string-append single-quote-string x single-quote-string))

 
(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)))

 
(define (ensure-final-character str ch)
  (let ((lgt (string-length str)))
    (if (and (> lgt 0)
             (eqv? ch (string-ref str (- lgt 1))))
         str
         (string-append str (as-string ch)))))

 
(define (repeat-string str n)
  (cond ((< n 0) (error (string-append "repeat-string with negative repeat count is not supported: " (as-string n))))
        ((= n 0) "")
        (else (string-append str (repeat-string str (- n 1))))))

 
(define (unescape-text text esc-char)
 (let ((text-lgt (string-length text)))
  (unescape-1 text esc-char (make-string text-lgt) 0 0 text-lgt #f)))

; The procedure which does the real work of unescape-text.
; from-text is the original input text.
; esc-char is the escape character. 
; to-text is the resulting text, gradually mutated by this procedure.
; i is index in from-text and j is index in to-text
; from-text-length is the length of from-text.
; escape? is true if the next character in from-text is escaped. In that
; case, the next character will always appear in the to-text.
(define (unescape-1 from-text esc-char to-text i j from-text-lgt escape?)
 (cond ((= i from-text-lgt) (substring to-text 0 j))
       (escape?  ; previous char was escpae char.
          (string-set! to-text j (string-ref from-text i)) 
          (unescape-1 from-text esc-char to-text (+ i 1) (+ j 1) from-text-lgt #f))
       ((eqv? (string-ref from-text i) esc-char)
          (unescape-1 from-text esc-char to-text (+ i 1) j from-text-lgt #t))
       (else
          (string-set! to-text j (string-ref from-text i)) 
          (unescape-1 from-text esc-char to-text (+ i 1) (+ j 1) from-text-lgt #f))))

 
(define (rotate-string str n)
  (let* ((lgt (string-length str))
         (n1 (remainder n lgt)))
    (string-append (substring str n1 lgt) (substring str 0 n1))))

 
(define (string-to-list-of-lines str)
  (map no-cr-at-end
       (string-to-list-of-lines-1 str 0 '())))

(define (string-to-list-of-lines-1 str from res)
  (cond ((empty-string? str) (reverse res))
        (else
           (let* ((eol-pos (find-in-string str (as-char 10) from)))
             (if eol-pos
                 (string-to-list-of-lines-1 str (+ eol-pos 1) (cons (substring str from eol-pos) res))
                 (string-to-list-of-lines-1 "" 0 (cons (substring str from (string-length str)) res)))))))

 
(define (list-of-lines-to-string line-lst)
  (list-to-string line-lst (as-string (as-char 10))))


(define (no-cr-at-end str)
  (let ((cr-char (as-char 13))
        (lgt (string-length str)))
    (if (and (> lgt 0) (eqv? (string-ref str (- lgt 1)) cr-char))
        (substring str 0 (- lgt 1))
        str)))

 
(define (pad-string-to-length lgt str0 . optional-parameter-list)
 (let ((str (as-string str0))
       (justification (optional-parameter 1 optional-parameter-list 'left))
       (pad-char (optional-parameter 2 optional-parameter-list #\space)))
  (let ((str-lgt (string-length str)))
   (if (>= lgt str-lgt)
    (cond ((eq? justification 'left) (string-append str (make-string (- lgt str-lgt) pad-char)))
          ((eq? justification 'right) (string-append (make-string (- lgt str-lgt) pad-char) str))
          (else (laml-error "pad-string-to-length: Unknown justification" justification)))
    (cond ((eq? justification 'left)  (substring str 0 lgt))
          ((eq? justification 'right) (substring str 0 lgt))
          (t (laml-error "pad-string-to-length: Unknown justification" justification)))))))




;;; Functions that change letter case in string.
;;; Here comes a number of functions which changes the letter case of a string.
;;; In general we recommend use of the non-destructive versions of the functions, thus
;;; encouraging a clean, functional programming style. Due a difference between mutable and
;;; immutable strings, we have experienced problems with the destructive procedures in MzScheme.


;  Capitalizing characters and strings.

 
(define (capitalize-string str)
  (if (not (empty-string? str))
      (string-set! str 0 (capitalize-char (string-ref str 0))))
  str)

 
(define (capitalize-string-nd str)
  (let ((res (string-copy str)))
    (if (not (empty-string? str))
      (string-set! res 0 (capitalize-char (string-ref str 0))))
    res))

; if it makes sense, return the capital character corresponding to ch.
; else, just return ch
(define (capitalize-char 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)))

(define (lower-case-letter-code? n)
  (or (and (>= n 97) (<= n 122)) (= n 230) (= n 248) (= n 229)))

; in all cases, the distance between lower and upper case letters are -32 in the ASCII table
(define (small-capital-offset n)
 (cond ((and (>= n 97) (<= n 122)) -32)
       ((= n 230) -32)
       ((= n 248) -32)
       ((= n 229) -32)
       (else 0)))

; -----------------------------------------------------------------------------
; Upcasing all characters in a string

 
(define (upcase-string str)
  (let ((res (make-string (string-length str) #\space)))
    (upcase-string-help! str res 0 (string-length str))))

(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

 
(define (downcase-string str)
  (let ((res (make-string (string-length str) #\space)))
    (downcase-string-help! str res 0 (string-length str))))

(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.

 
(define (decapitalize-string str)
  (string-set! str 0 (decapitalize-char (string-ref str 0)))
  str)

 
(define (decapitalize-string-nd str)
  (let ((res (string-copy str)))
    (string-set! res 0 (decapitalize-char (string-ref str 0)))
    res))

; If it makes sense, return the lower case character corresponding to ch.
; else, just return ch.
(define (decapitalize-char 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)))

(define (upper-case-letter-code? n)
  (or (and (>= n 65) (<= n 90)) (= n 198) (= n 216) (= n 197)))

(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)))

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

;;; Byte string functions.
;;; In this section we provide low-level functions that access binary data in strings. 
;;; This section has been added to LAML version 32.
 
(define (byte-string-to-integer byte-str)
  (let* ((lgt (string-length byte-str)))
    (byte-string-to-integer-1 byte-str (- lgt 1) 0 1)))

(define (byte-string-to-integer-1 byte-str i res factor)
  (if (< i 0)
      res
      (byte-string-to-integer-1 byte-str (- i 1) (+ res (* (as-number (string-ref byte-str i)) factor)) (* factor 256))))

 
(define (int10-to-binary n number-of-bytes)
  (let* ((byte-list (binary-bytes-of-decimal-integer n))
         (lgt-byte-list (length byte-list)))
    (if (> lgt-byte-list number-of-bytes)
        (laml-error "int10-to-binary: Number does not fit in" number-of-bytes "byte(s): " n)
        (list->string (append
                         (make-list (- number-of-bytes lgt-byte-list) (as-char 0))    ; pad with initial zeros
                         byte-list)))))

(define (binary-bytes-of-decimal-integer n)
  (reverse (binary-bytes-of-decimal-integer-1 n)))

(define (binary-bytes-of-decimal-integer-1 n)
 (let ((rem (remainder n 256))
       (rest (quotient n 256)))
  (if (= rest 0)
      (list (as-char rem))
      (cons (as-char rem) (binary-bytes-of-decimal-integer-1 rest)))))
         
    
 
(define (make-char-2-hex hx1 hx2 )
  (as-char (+ (* hx1 16) hx2)))

 
(define (make-byte-string-from-hex-2 hx1 hx2)
  (list->string (list (make-char-2-hex hx1 hx2))))

 
(define (make-byte-string-from-hex-4 hx1 hx2 hx3 hx4)
  (list->string (list (make-char-2-hex hx1 hx2) (make-char-2-hex hx3 hx4) )))

 
(define (make-byte-string-from-hex-6 hx1 hx2 hx3 hx4 hx5 hx6 )
  (list->string (list (make-char-2-hex hx1 hx2) (make-char-2-hex hx3 hx4) (make-char-2-hex hx5 hx6))))

 
(define (make-byte-string-from-hex-8 hx1 hx2 hx3 hx4 hx5 hx6 hx7 hx8)
  (list->string (list (make-char-2-hex hx1 hx2) (make-char-2-hex hx3 hx4) (make-char-2-hex hx5 hx6) (make-char-2-hex hx7 hx8))))


 
(define (binary-to-hex-string byte-string)
 (let* ((res (binary-to-hex-string-1 byte-string 0 (string-length byte-string)))
        (res-length (string-length res)))
   (if (> res-length 0) (substring res 0 (- res-length 1)) res)  ; removes a trailing space
 )
)

(define (binary-to-hex-string-1 byte-string i lgt)  
  (if (= i lgt)
      ""
      (let* ((byte (as-number (string-ref byte-string i)))
             (low  (remainder byte 16))
             (high (quotient byte 16)))
        (string-append 
          (upcase-string (number->string high 16)) (upcase-string (number->string low 16)) " "
          (binary-to-hex-string-1 byte-string (+ i 1) lgt))) 
  )
)

 
(define (hex-to-binary-string-relaxed hex-string)
  (if (= (string-length hex-string) 0)
      ""
      (let ((hex-string-extended (string-append hex-string " ")))
        (hex-to-binary-string-relaxed-1 hex-string-extended 0 (string-length hex-string-extended)))))


(define (hex-to-binary-string-relaxed-1 hex-string i lgt)
 (let ((j (find-in-string-by-predicate (lambda (c) (not (memv (as-number c) (list 9 10 13 32)))) hex-string i)))
  (if (or (= i lgt) (not j))
      ""
      (let* ((high-hex (as-string (string-ref hex-string j))) ; "1" .. "f"      
             (low-hex  (as-string (string-ref hex-string (+ j 1)))) ; "1" .. "f"
             (high-decimal (string->number high-hex 16))
             (low-decimal  (string->number low-hex 16) )
             )
        (string-append (as-string (as-char (+ (* 16 high-decimal) low-decimal))) 
                       (hex-to-binary-string-relaxed-1 hex-string (+ j 2) lgt))))))


 
(define (hex-to-binary-string hex-string)
  (if (= (string-length hex-string) 0)
      ""
      (let ((hex-string-extended (string-append hex-string " ")))
        (hex-to-binary-string-1 hex-string-extended 0 (string-length hex-string-extended)))))

(define (hex-to-binary-string-1 hex-string i lgt)
  (if (= i lgt)
      ""
      (let* ((high-hex (as-string (string-ref hex-string i))) ; "1" .. "f"      
             (low-hex  (as-string (string-ref hex-string (+ i 1)))) ; "1" .. "f"
             (high-decimal (string->number high-hex 16))
             (low-decimal  (string->number low-hex 16) )
             )
        (string-append (as-string (as-char (+ (* 16 high-decimal) low-decimal))) 
                       (hex-to-binary-string-1 hex-string (+ i 3) lgt)))))


 
(define (as-two-complement-signed-number i n)
 (let* ((threshold (power 2 (- n 1)))
        (upper-limit (* 2 threshold)))
   (if (and (>= i 0) (< i upper-limit)) 
       (if (< i threshold)
           i 
           (- (- (* threshold 2) i)))
       (laml-error "as-two-complement-signed-number: Range error."))))


 
(define (byte-string-to-bit-list byte-str . optional-parameter-list)
 (let ((number-of-bits (optional-parameter 1 optional-parameter-list 8)))
  (let* ((res (byte-string-to-bit-list-int (byte-string-to-integer byte-str)))
         (number-of-zeros (- number-of-bits (length res))))
    (if (>= number-of-zeros 0)
        (append (make-list number-of-zeros 0) (reverse res))
        (reverse res)))))

(define (byte-string-to-bit-list-int i)
  (if (> i 0)
      (let* ((low-bit (remainder i 2))
             (rest (quotient i 2)))
        (cons low-bit (byte-string-to-bit-list-int rest)))
      '()))


 
(define (bit-list-to-byte-string bit-list)
  (let ((bit-list-lgt (length bit-list)))
    (if (= 0 (remainder bit-list-lgt 8))
        (bit-list-to-byte-string-1 bit-list)
        (laml-error "bit-list-to-byte-string: The length of the bit list must be a multiplum of 8."))))

(define (bit-list-to-byte-string-1 bit-list)
  (if (null? bit-list)
      ""
      (string-append (as-string (as-char (eight-bits-to-byte (front-sublist bit-list 8))))
                    (bit-list-to-byte-string-1 (rear-sublist bit-list (- (length bit-list) 8))))))

; Convert the 8-bit bit-list to a byte, represented as a character.
(define (eight-bits-to-byte bit-list)
  (accumulate-right + 0 (map (lambda (bit factor) (* bit factor)) bit-list (list 128 64 32 16 8 4 2 1))))





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



;;; Message displaying and error handling procedures.
;;; Most message or error functions accept a list of messages which are string-converted and
;;; space separated before outputted.
; Aggreate the messages in list to a single message-string.
; Applies as-string before space separated concatenation.
(define (laml-aggregate-messages message-list)
 (string-merge 
  (map as-string message-list)
  (make-list (- (length message-list) 1) " ")))

 
(define (display-warning . messages)
  (display (string-append "Warning: " (laml-aggregate-messages messages))) (newline))

 
(define (display-error . messages)
  (error (laml-aggregate-messages messages)))

 
(define (display-message . messages)
  (begin (display (string-append (laml-aggregate-messages messages))) (newline)))


 
(define (laml-error . messages)
  (error (laml-aggregate-messages messages)))


 
(define (errors-among-conditions . err-condition-message-list)
  (errors-among-conditions-1 err-condition-message-list #f '()))

(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, file path and URL functions.
;;; File paths are represented as strings in LAML. 
;;; As a convention, a non-empty relative file path always ends in a forward slash '/'.
;;; The empty string represents the empty relative file path.
;;; An absolute file path is recognized in both unix form (for instance "/x/y/") and Windows form (for instance "c:\x\").
;;; Internally in LAML, we work with unix representation of file paths (using forward slashes).

 
(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)))

 
(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 #\\))
        (max-slash-pos (cond ((and forward-slash-pos backward-slash-pos) (max forward-slash-pos backward-slash-pos))
                             (forward-slash-pos forward-slash-pos)
                             (backward-slash-pos backward-slash-pos)
                             (else -1)))
        (extension-pos-1 (if (and extension-pos (> extension-pos max-slash-pos)) extension-pos #f))
      )
  (substring
      file-name
      (+ max-slash-pos 1)
      (if extension-pos-1 extension-pos-1 (string-length file-name)))))

 
(define (file-name-proper-and-extension file-path)
  (let ((fnp (file-name-proper file-path))
        (fne (file-name-extension file-path)))
    (if (empty-string? fne)
        fnp
        (string-append fnp "." fne))))


 
(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 ""))))


 
(define (file-name-initial-path file-path)
 (let ((extension-pos (find-in-string-from-end file-path #\.))
       (forward-slash-pos (find-in-string-from-end file-path #\/))
       (backward-slash-pos (find-in-string-from-end file-path #\\)))
  (substring 
    file-path
    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))
  )))

 
(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)
               (or
                 (and (number? backward-slash-pos) (= 2 backward-slash-pos))
                 (and (number? forward-slash-pos) (= 2 forward-slash-pos)))))))


 
(define (absolute-url? x)
  (or (looking-at-substring? x 0 "http://")
      (looking-at-substring? x 0 "https://")
      (looking-at-substring? x 0 "file://")
      (looking-at-substring? x 0 "prospero://")
      (looking-at-substring? x 0 "wais://")
      (looking-at-substring? x 0 "telnet://")
      (looking-at-substring? x 0 "gopher://")
      (looking-at-substring? x 0 "news:")))

 
(define (relative-url? x)
  (and (string? x) (not (absolute-url? x)) (not (absolute-file-path? x))))

 
(define (parent-directory dir)
 (if (and (boolean? dir) (not dir))
     #f
     (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)))))

 
(define (directory-leave-name dir)
 (if (and (boolean? dir) (not dir))
     #f 
     (let* ((dir1 (ensure-final-character dir #\/))
	    (lgt (string-length dir1))
	    (dir2 (substring dir1 0 (max (- lgt 1) 0)))	; dir without ending slash
	    (res (file-name-proper dir2)))
       (if (or (empty-string? res) (eqv? #\: (string-ref dir2 (- (string-length dir2) 1))))
	   #f
	   res))))

 
(define (directory-level-difference dir1 dir2)
 (let ((dir1-lc (downcase-string dir1))
       (dir2-lc (downcase-string dir2)))
  (let ((res1 (directory-level-difference-1 dir1-lc dir2-lc 0))
        (res2 (directory-level-difference-1 dir2-lc dir1-lc 0)))
    (cond ((and res1 (number? res1)) res1)
          ((and res2 (number? res2)) (- res2))
          (else #f)))))

(define (directory-level-difference-1 dir1 dir2 n)
 (let ((parent-dir-1 (parent-directory dir1)))
   (cond ((and dir1 dir2 (equal? dir1 dir2)) n)
         ((and parent-dir-1 (string? parent-dir-1)) (directory-level-difference-1 parent-dir-1 dir2 (+ n 1)))
         ((not parent-dir-1) #f))))

 
(define (relative-path-to-path-list dir)
 (if (empty-string? dir)
     '()
     (let* ((dir1 (if (or (eqv? (string-ref dir (- (string-length dir) 1)) #\/) (eqv? (string-ref dir (- (string-length dir) 1)) #\\))
		      (substring dir 0 (- (string-length dir) 1))
		      dir))		; no trailing slash
	    (lgt (string-length dir1))
	    (forward-slash-pos (find-in-string dir1 #\/))
            (backward-slash-pos (find-in-string dir1 #\\))
            (slash-pos 
              (cond ((and forward-slash-pos backward-slash-pos)
                       (min forward-slash-pos backward-slash-pos))
                    (forward-slash-pos forward-slash-pos)
                    (backward-slash-pos backward-slash-pos)
                    (else #f)))
           )
       (if slash-pos
	   (cons (substring dir1 0 slash-pos)
		 (relative-path-to-path-list (substring dir1 (+ 1 slash-pos) lgt)))
	   (list dir1)))))

 
(define (path-list-to-relative-path path-list)
  (ensure-final-character (list-to-string path-list "/")  #\/))

 
(define (ensure-directory-existence! prefix-dir dir)
  (if (not (directory-exists? (string-append prefix-dir dir)))
      (make-directory-in-directory prefix-dir dir)))

 
(define (ensure-directory-path-existence! prefix-dir path)
 (let ((path-list (relative-path-to-path-list path)))
   (ensure-directory-path-existence-1! prefix-dir path-list)))

(define (ensure-directory-path-existence-1! prefix-dir path-list)
  (if (not (null? path-list))
      (let ((first-path (car path-list)))
         (ensure-directory-existence! prefix-dir first-path)
         (ensure-directory-path-existence-1! (string-append prefix-dir first-path "/") (cdr path-list)))))

 
(define (ensure-non-existing-file-in-dir f d)
 (if (not (file-exists? (string-append d f)))
     f
     (ensure-non-existing-file-in-dir-1 f d 1)))

(define (ensure-non-existing-file-in-dir-1 f d i)
 (let* ((pf (file-name-proper f))
        (ef (file-name-extension f))
        (nm (string-append pf "-" (as-string i) "." ef))
        (path (string-append d nm))
      )
 (if (not (file-exists? path))
     nm
     (ensure-non-existing-file-in-dir-1 f d (+ i 1)))))

 
(define (normalize-file-path path)
  (cond ((absolute-file-path? path) (normalize-absolute-file-path path))
        (else (normalize-relative-file-path path))))

 
(define (normalize-relative-file-path path)
  (let* ((path-list (relative-path-to-path-list path)))
     (normalize-relative-file-path-1 path-list '())))

; path-list is the relative path as a list.
; path-stack is a stack of already seen directories.
(define (normalize-relative-file-path-1 path-list path-stack)
  (cond ((null? path-list)                           
            (if (null? path-stack)
                ""
                (string-append (list-to-string (reverse path-stack) "/") "/")))
        ((and (equal? ".." (car path-list)) (not (null? path-stack)) (not (equal? ".." (car path-stack))))   
            (normalize-relative-file-path-1 (cdr path-list) (cdr path-stack)))                          
        ((and (equal? ".." (car path-list)) (not (null? path-stack)) (equal? ".." (car path-stack)))    
            (normalize-relative-file-path-1 (cdr path-list)  (cons ".." path-stack)))                   
        ((and (equal? ".." (car path-list)) (null? path-stack))                                         
            (normalize-relative-file-path-1 (cdr path-list) (cons ".." path-stack)))                    
        (else                                                                                           
            (normalize-relative-file-path-1 (cdr path-list) (cons (car path-list) path-stack)))         
  )
)

 
(define (normalize-absolute-file-path abs-path)
  (let* ((prefix (prefix-part-of-absolute-path abs-path))
         (suffix (relative-part-of-absolute-path abs-path))
         (res (normalize-relative-file-path suffix)))
    (if (and (>= (string-length res) 2) (equal? ".." (substring res 0 2)))
        (laml-error "normalize-absolute-file-path: Not possible to normalize the absolute file path" abs-path)
        (string-append prefix res))))


 
(define (relative-part-of-absolute-path abs-path)
  (let ((forward-slash-pos (find-in-string abs-path #\/))
        (backward-slash-pos (find-in-string abs-path #\\))
        (colon-pos (find-in-string abs-path #\:))
        (abs-path-length (string-length abs-path))
       )
    (cond ((and (number? forward-slash-pos) (= 0 forward-slash-pos))
             (substring abs-path 1 abs-path-length))
          ((and (number? colon-pos) (= 1 colon-pos)
                (or
                 (and (number? backward-slash-pos) (= 2 backward-slash-pos))
                 (and (number? forward-slash-pos) (= 2 forward-slash-pos))))
             (substring abs-path 3 abs-path-length))
          (else (laml-error "relative-part-of-absolute-path: The path" abs-path "is not an absolute file path.")))))


 
(define (prefix-part-of-absolute-path abs-path)
  (let ((forward-slash-pos (find-in-string abs-path #\/))
        (backward-slash-pos (find-in-string abs-path #\\))
        (colon-pos (find-in-string abs-path #\:))
        (abs-path-length (string-length abs-path))
       )
    (cond ((and (number? forward-slash-pos) (= 0 forward-slash-pos))
             "/")
          ((and (number? colon-pos) (= 1 colon-pos)
                (or
                 (and (number? backward-slash-pos) (= 2 backward-slash-pos))
                 (and (number? forward-slash-pos) (= 2 forward-slash-pos))))
             (substring abs-path 0 3))
          (else (laml-error "prefix-part-of-absolute-path: The path" abs-path "is not an absolute file path.")))))

 
(define (but-prefix-part-of-absolute-path abs-path)
  (let ((forward-slash-pos (find-in-string abs-path #\/))
        (backward-slash-pos (find-in-string abs-path #\\))
        (colon-pos (find-in-string abs-path #\:))
        (abs-path-length (string-length abs-path))
        (abs-path-lgt (string-length abs-path))
       )
    (cond ((and (number? forward-slash-pos) (= 0 forward-slash-pos))
             (substring abs-path 1 abs-path-lgt))
          ((and (number? colon-pos) (= 1 colon-pos)
                (or
                 (and (number? backward-slash-pos) (= 2 backward-slash-pos))
                 (and (number? forward-slash-pos) (= 2 forward-slash-pos))))
             (substring abs-path 3 abs-path-lgt))
          (else (laml-error "but-prefix-part-of-absolute-path: The path" abs-path "is not an absolute file path.")))))
            

 
(define (inverse-return-path path dir)
 (if (empty-string? path)
     ""
     (let ((path-list (relative-path-to-path-list path))
           (leave-of-dir (directory-leave-name dir))
           (par-dir (parent-directory dir)))
       (path-list-to-relative-path (reverse (inverse-return-path-1 path-list leave-of-dir par-dir))))))

(define (inverse-return-path-1 path-list leave-dir par-dir)
  (cond ((null? path-list) '())
        ((equal? (car path-list) "..") (cons leave-dir (inverse-return-path-1 (cdr path-list) (directory-leave-name par-dir) (parent-directory par-dir))))
        (else  (cons ".." (inverse-return-path-1 (cdr path-list) (directory-leave-name par-dir) (parent-directory par-dir))))))


;;; Other functions. 
;;; Here follows a set of miscellaneous functions.
 
(define (type-of x)
  (cond ((boolean? x) 'boolean) 
        ((symbol? x)  'symbol)
        ((char? x)    'char)
        ((procedure? x) 'procedure)
        ((pair? x) 'pair)
        ((number? x) 'number)
        ((string? x) 'string)
        ((port? x) 'port)
        (else (laml-error "Unknown type of" x))))

 
(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))))))

(define (max-int-list lst)
 (max-int-list-help lst 0))
 
(define (max-int-list-help lst res)
  (if (null? lst) 
      res
      (max-int-list-help (cdr lst) (max res (car lst)))))


 
(define CR (as-string #\newline))

 
(define (newline-string)
  (as-string #\newline))


; Functions earlier in the cgi library

 
(define (save-a-list alist filename)
  (if (file-exists? filename)   ; new 31.3.2000
       (delete-file filename))
  (with-output-to-file filename
     (lambda () (write alist))))

 
(define (unique-timed-file-name prefix)
  (string-append prefix (number->string (current-time))))

 
(define (file-append file-name x)
 (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))))

 
(define (file-read file-name . optional-parameter-list)
 (let ((n (optional-parameter 1 optional-parameter-list 1))
       (port (open-input-file file-name)))

   ; read n-1 forms
   (for-each (lambda (n)  (read port)) (number-interval 1 (- n 1)))

   (let ((contents (read port)))
     (close-input-port port)
     contents)))

 
(define (file-read-all file-name)
 (let* ((port (open-input-file file-name))
        (contents (file-read-all-1 port '())))
   (close-input-port port)
   (reverse contents)))

(define (file-read-all-1 port res)
 (let ((form (read port)))
   (if (eof-object? form)
       res
       (file-read-all-1 port (cons form res)))))

 
(define (file-write x file-name)
  (if (file-exists? file-name) (delete-file file-name))
  (let ((output-port (open-output-file file-name)))
    (write x output-port)
    (close-output-port output-port)))

 
(define (save-on-file x filename)
  (if (file-exists? filename) 
       (delete-file filename))
  (with-output-to-file filename
     (lambda () (display x))))


 
(define (id-1 x) x)




 
(define (multiplum-of a b)
  (= 0 (remainder a b)))



 
(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)))))


 
(define (copy-files files source-dir target-dir . optional-parameter-list)
 (let ((warn-if-non-existing-source (optional-parameter 1 optional-parameter-list #f)))
  (letrec ((copy-a-file 
            (lambda (f)
             (let ((target-file (string-append target-dir f))
                   (source-file (string-append source-dir f))
                  )
               (if (and (file-exists? target-file) (file-exists? source-file)) (delete-file target-file))
               (cond ((file-exists? source-file) (copy-file source-file target-file))
                     (warn-if-non-existing-source (display-warning (string-append "Could not copy the file " source-file)))
                     (else (laml-error "copy-file: Source does not exist:" source-file)))))))
   (for-each copy-a-file files))))


 
(define (min-max-limited x min max)
 (cond ((< x min) min)
        ((and (<= min x) (<= x max)) x)
        ((> x max) max)
        (else (laml-error "min-max-limited: Should not happen!" x min max))))
    
 
(define (log2 x)
  (* (/ 1 (log 2)) (log x)))

 
(define (power n m)
  (if (= m 0) 1 (* n (power n (- m 1)))))

 
(define (fac n) 
  (if (= n 0) 
      1
      (* n (fac (- n 1)))))


;;; .section-id bite-generators
;;; Bite Generators.
;;; This section contains higher-order bite generators, which can be used with the functions map-bites, filter-bites, and similar higher-order bite-processing functions,
;;; see <a href = "#higher-order-bite-functions"> here </a>.
;;; In this context a bite of a non-empty list is a non-empty prefix of the list. Consequtive bites of a list must append-accumulate to the original list.
;;; The first parameter of bite functions is the list from which a bite is taken.
;;; A second optional parameter denotes the number of this bite (one-based) as supplied by the computational context.
;;; Because of this second parameter, all bite functions (programmed or generated) should accept a second parameter, or a rest parameter: (lambda (lst . rest) ....)
 
(define (bite-of-length n . optional-parameters)
 (let ((noise-element (optional-parameter 1 optional-parameters (lambda (el) #f))))
  (lambda (lst . optional-parameters)
    (bite-of-length-1 n 0 noise-element lst '()))))

(define (bite-of-length-1 n i noise-element lst res-lst)
  (cond ((null? lst) (reverse res-lst))
        ((= i n)     (reverse res-lst))
        ((noise-element (car lst)) (bite-of-length-1 n i       noise-element (cdr lst) (cons (car lst) res-lst)))
        (else                      (bite-of-length-1 n (+ i 1) noise-element (cdr lst) (cons (car lst) res-lst)))))

 
(define (bite-of-varied-length f . optional-parameters)
 (let ((noise-element (optional-parameter 1 optional-parameters (lambda (el) #f))))
  (lambda (lst bite-number)
    (bite-of-length-1 (f bite-number) 0 noise-element lst '()))))

(define (bite-of-varied-length-1 f bite-number i noise-element lst res-lst)
  (cond ((null? lst) (reverse res-lst))
        ((= i (f bite-number))     (reverse res-lst))
        ((noise-element (car lst)) (bite-of-varied-length-1 f bite-number i       noise-element (cdr lst) (cons (car lst) res-lst)))
        (else                      (bite-of-varied-length-1 f bite-number (+ i 1) noise-element (cdr lst) (cons (car lst) res-lst)))))
  


 
(define (bite-while-element el-pred . attributes)
  (let ((sentinel (as-symbol (defaulted-get-prop 'sentinel attributes "last"))))
     (cond ((eq? sentinel 'last) 
               (lambda (lst . optional-parameters) (bite-while-element-sentinel-last el-pred lst '())))
           ((eq? sentinel 'first) 
               (lambda (lst . optional-parameters) (bite-while-element-sentinel-first el-pred lst '())))
           ((eq? sentinel 'alone) 
               (lambda (lst . optional-parameters) (bite-while-element-sentinel-alone el-pred lst '() 0)))
           (else (laml-error "bite-while-element: Unknown attribute in trailing property list. Must be first or last. Is:" sentinel)))))

(define (bite-while-element-sentinel-last el-pred lst res-lst)
  (cond ((null? lst) (reverse res-lst))
        ((el-pred (car lst)) (bite-while-element-sentinel-last el-pred (cdr lst) (cons (car lst) res-lst)))
        (else (reverse (cons (car lst) res-lst)))))

(define (bite-while-element-sentinel-first el-pred lst res-lst)
  (cond ((and (null? res-lst) (not (null? lst))) (bite-while-element-sentinel-first el-pred (cdr lst) (cons (car lst) res-lst)))
        ((null? lst) (reverse res-lst))
        ((el-pred (car lst)) (bite-while-element-sentinel-first el-pred (cdr lst) (cons (car lst) res-lst)))
        (else (reverse res-lst))))

(define (bite-while-element-sentinel-alone el-pred lst res-lst level)
  (cond ((null? lst) (reverse res-lst))
        ((and (= level 0) (not (el-pred (car lst)))) (list (car lst)))          ; a singular bite that does not fulfill the predicate.
        ((el-pred (car lst)) (bite-while-element-sentinel-alone el-pred (cdr lst) (cons (car lst) res-lst) (+ level 1)))
        (else (reverse res-lst))))


 
(define (bite-while-element-with-accumulation pred accumulator init-acc-val . optional-parameters)
 (let ((noise-element (optional-parameter 1 optional-parameters (lambda (el) #f))))
  (lambda (lst . optional-parameters)
   (cond ((null? lst) '())
         (else (bite-while-element-with-accumulation-1 pred accumulator init-acc-val
						       (if (noise-element (car lst)) init-acc-val (accumulator init-acc-val (car lst))) ; = cur-acc-val
						       noise-element (cdr lst) (list (car lst))))))))


(define (bite-while-element-with-accumulation-1 pred accumulator init-acc-val cur-acc-val noise-element lst res-lst)
   (cond ((null? lst) (reverse res-lst))
         (else (let ((el (car lst))
                     (rest (cdr lst)))
                 (cond ((noise-element el) 
                          (bite-while-element-with-accumulation-1 pred accumulator init-acc-val cur-acc-val noise-element rest (cons el res-lst)))
                       ((pred el cur-acc-val)
                          (bite-while-element-with-accumulation-1 pred accumulator init-acc-val (accumulator cur-acc-val el) noise-element rest (cons el res-lst)))
                       (else (reverse res-lst)))))))


 
(define (bite-while-prefix bite-pred)
  (lambda (lst . optional-parameters)
   (let ((bite-number (optional-parameter 1 optional-parameters #f)))
     (bite-while-prefix-1 bite-pred lst 2 bite-number (length lst)))
  ))

(define (bite-while-prefix-1 bite-pred lst i bite-number lst-lgt)
  (cond ((> i lst-lgt) lst)                        ; all prefixes fulfill bite-pred. 
        ((bite-pred (front-sublist lst i) bite-number)
            (bite-while-prefix-1 bite-pred lst (+ i 1) bite-number lst-lgt))
        ((= i 1) (laml-error "The bite predicate does not accept at least a bite of unity length"))
        (else (front-sublist lst (- i 1)))))


; Better name: bite-while-accumulate

 
(define (bite-while-accumulate bin-op init-val pred . optional-parameters)
 (let ((noise-element (optional-parameter 1 optional-parameters (lambda (el) #f))))
  (lambda (lst . optional-parameters)
     (if (null? lst)
         '()
         (let ((el (car lst)))
           (bite-while-accumulate-1 bin-op init-val pred (cdr lst) (if (noise-element el) init-val (bin-op init-val (car lst))) noise-element (list el)))))))

(define (bite-while-accumulate-1 bin-op init-val pred lst cur-val noise-element res-lst)
  (cond ((null? lst) (reverse res-lst))
        ((pred cur-val) (reverse res-lst))
        ((noise-element (car lst)) (bite-while-accumulate-1 bin-op init-val pred (cdr lst) cur-val                    noise-element (cons (car lst) res-lst)))
        (else                      (bite-while-accumulate-1 bin-op init-val pred (cdr lst) (bin-op cur-val (car lst)) noise-element (cons (car lst) res-lst)))))


 
(define (bite-while-compare el-relation . optional-parameters)
 (let ((noise-element (optional-parameter 1 optional-parameters (lambda (el) #f))))
   (lambda (lst . optional-parameters)
    (let ((bite-number (optional-parameter 1 optional-parameters #f)))
     (cond ((null? lst) '())
           ((null? (cdr lst)) lst)
           (else (bite-while-compare-1 el-relation noise-element (car lst) (not (noise-element (car lst))) (car lst) (cdr lst) bite-number)))))))


; The boolean remembered? tells if remember-el is located as a non-noise element.
(define (bite-while-compare-1 el-relation noise-element first remembered? remember-el non-empty-rest bite-number)
 (cons first
  (cond ((and (null? (cdr non-empty-rest)) remembered? (not (noise-element (car non-empty-rest))) (not (el-relation remember-el (car non-empty-rest))))   ; special termination condition
            '())
        ((null? (cdr non-empty-rest)) 
            non-empty-rest)
        ((and remembered? (not (noise-element (car non-empty-rest))) (el-relation remember-el (car non-empty-rest)))
            (bite-while-compare-1 el-relation noise-element (car non-empty-rest) 
                                  #t (car non-empty-rest) (cdr non-empty-rest) bite-number))
        ((and remembered? (not (noise-element (car non-empty-rest))) )
            '())
 
        (else
            (bite-while-compare-1 el-relation noise-element (car non-empty-rest) 
                                  (if remembered? remembered? (not (noise-element (car non-empty-rest))))
                                  (if remembered? remember-el (car non-empty-rest)) (cdr non-empty-rest) bite-number))))) 


 
(define (bite-while-monotone el-comparator . optional-parameters)
 (let ((noise-element (optional-parameter 1 optional-parameters (lambda (el) #f))))
   (lambda (lst . optional-parameters)
    (let ((bite-number (optional-parameter 1 optional-parameters #f)))
     (cond ((null? lst) '())
           ((null? (cdr lst)) lst)
           (else (bite-while-monotone-1 el-comparator noise-element 
                                        (car lst)   (not (noise-element (car lst))) (car lst) #f #f #f
                                        (cdr lst) bite-number)))))))

; e1? and e2? are boolean guards of e1 and e2. The guard tells if we have located the first/second non-noise element.
; direction is either -1 (e1 < e2), 0 (e1 = e2), or 1 (e1 > e2), or #f or undetermined.
(define (bite-while-monotone-1 el-comparator noise? first e1? e1 e2? e2 direction non-empty-rest bite-number)
 (cons first
  (cond 
         ((and (null? (cdr non-empty-rest)) e2? (not (noise? (car non-empty-rest))) direction (not (= (el-comparator e2 (car non-empty-rest)) direction)))  ; special termination condition
            '())

         ((null? (cdr non-empty-rest)) 
            non-empty-rest)

         (else (let ((e  (car non-empty-rest))
                     (nr (cdr non-empty-rest)))
 
                 (cond 
                  ((and (not e1?) (not e2?) (noise? e)) 
                    (bite-while-monotone-1 el-comparator noise? e  #f #f #f #f #f  nr bite-number))

                  ((and (not e1?) (not e2?) (not (noise? e))) 
                    (bite-while-monotone-1 el-comparator noise? e  #t e #f #f #f  nr bite-number))

                  ((and e1? (not e2?) (noise? e) ) 
                    (bite-while-monotone-1 el-comparator noise? e  #t e1 #f #f #f  nr bite-number))

                  ((and e1? (not e2?) (not (noise? e)) (not direction))   ; determine direction
                    (bite-while-monotone-1 el-comparator noise? e  #t e2 #t e (el-comparator e1 e)  nr bite-number))



                  ((and e1? e2? (not (noise? e)) direction   (not (= (el-comparator e2 e) direction))  )
                    '())

                  ((and e1? e2? (not (noise? e)) direction (= (el-comparator e2 e) direction))
                    (bite-while-monotone-1 el-comparator noise? e  #t e2 #t e direction   nr bite-number))

                  ((and e1? e2? (noise? e) direction)
                    (bite-while-monotone-1 el-comparator noise? e  #t e1 #t e2 direction  nr bite-number))

                  (else (laml-error "H"))
                 ))))))