;;;; .title Bites of Lists - Mapping and Filtering Sublists ;;;; Bite filter and bite mapping functions, together with a number of bite generating functions. ;;;; Accompanies the paper "Bites of Lists - Mapping and Filtering Sublists" by Kurt NÝrmark, Aalborg University, 2010. ;;;; Please notice that there is access to the Scheme source code from the "See also" clauses of all documented functions.
; The content of this file has been extracted from the LAML general library on January 4, 2011.
; Copyright (C) 2010-2011, 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
;;; .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") 'do-nothing) (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") 'do-nothing) (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") 'do-nothing) (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."))))))))
;;; .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")) )))))) ; -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ; Helping functions.
; Stop the program with messages. ; This procedures takes an arbitrary number of parameters, which are string converted and string-appended ; to the final error message.
(define (laml-error . messages) (error (laml-aggregate-messages messages))) ; 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) " "))) ; Return the sublist of lst obtained by omitting the first n elements. Returns the empty list if n is larger than the length of lst. ; .parameter lst A list ; .parameter n A non-negative integer. ; .misc This function is like list-tail, but with a weaker precondition.
(define (list-tail-flex lst n) (cond ((= n 0) lst) ((null? lst) '()) (else (list-tail-flex (cdr lst) (- n 1))))) ; The identify function of one parameter
(define (id-1 x) x) ; Return element n of optional-parameter-list. The first element is number 1. ; In Scheme the optional parameters are captured as a list after the required parameters: <kbd>(define f (x y . optional-parameter-list) ...)</kbd>. ; Please notice that if you pass optional parameter number i, the optional parameters 1, 2, ..., i-1 must be passed explicitly. ; If you explicitly pass the symbol non-passed-value, this function will always return the default value, default-value. ; (This means, of course, that you cannot use the symbol non-passed-value as an 'ordinary value' in your program). ; If no optional third parameter - default-value - is given to the function optional-parameter the value #f serves as the default default-value. ; .form (optional-parameter n optional-parameter-list [default-value]) ; .pre-condition optional-parameter-list is a proper list.
(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))))) ; Convert x to a symbol. String, symbols, booleans, and characters are supported
(define (as-symbol x) (cond ((symbol? x) x) ((string? x) (string->symbol x)) ((boolean? x) (if x (as-symbol "true") (as-symbol "false"))) ((char? x) (as-symbol (char->string x))) (else #f))) ; Convert x to a string. ; Conversion of numbers, symbols, strings, booleans, characters, vectors, proper lists and improper lists are supported.
(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 "??"))) ; Generate and return a comparison function from a 'less than' function lt, and a 'greater than' function gt. ; If com is a comparison function, (com x y) returns -1 if (lt x y), (com x y) returns 1 if (gt x y), else it returns 0. ; .pre-condition If (lt x y) and (gt x y) cannot both be true.
(define (make-comparator lt gt) (lambda (e1 e2) (cond ((lt e1 e2) -1) ((gt e1 e2) 1) (else 0)))) ; Return the value of key in the property list p-list. If key is not present in p-list, return default. ; .internal-references "similar function" "get-prop" ; .pre-condition p-list is a list of even length
(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))) ; Does key exists as a property name in the property list p-list? ; If so, return a reference to the cons cell that holds key.
(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))))) ; A higher order functions which negates the predicate p. Negate accepts a predicate and returns the negated predicate.
(define (negate p) (lambda (x) (if (p x) #f #t))) ; Return a prefix of lst until, and including, the element accepted by until-fn. ; More precisely: apply until-fn on successive elements of lst, and return the longest possible prefix of list for which until-fn returns false on all elements ; followed by the element on which until-fn returns true. ; If until-fn returns false on all elements, return a shallow copy of lst. ; .parameter until-fn An element prediate function. Signature: element-type -> boolean ; .parameter lst A list.
(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))))) ; Return the sublist consisting of element a to element b of the list lst. ; If a is smaller than the length of the list, and b is larger than the length of the list, return from element number a and the rest of the list. ; If a is larger than the length of the list, return the empty list. ; Both element number a and b are included in the resulting list. The first element counts as element number 1. ; .example (list-part 3 5 '(a b c d e f g h)) = (c d e) ; .pre-condition a >= 1, a <= b and a and b are postive integers. ; .misc Please notice that the sligthly unusual convention that the first element of the list is number 1, not number 0.
(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)))))) ; Return a string with the elements of str-lst separated by separator. ; .parameter lst A list of elements, each of which is converted to a string by the function as-string. ; .parameter separator A string which is used to separate the list elements in the resulting string.
(define (list-to-string lst separator) (string-merge (map as-string lst) (make-list (- (length lst) 1) separator))) ; Return all but the last element of a list. Quick and dirty version.
(define (butlast lst) (reverse (cdr (reverse lst)))) ; Return the last element of a list. Quick and dirty version.
(define (last lst) (car (reverse lst))) ; Merge str-list-1 with str-list-2, returning one string. ; Strings from the first list are merged with the strings from the second list. ; In case one list is shorter than the other, the strings from the longests lists ; are concatenated and appended ; .example (string-merge (list "aa" "bb" "cc") (list "XX" "YY")) => "aaXXbbYYcc"
(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)))))) ; Return a list of n elements, each being el
(define (make-list n el) (if (<= n 0) '() (cons el (make-list (- n 1) el)))) (define (filter pred lst) (reverse (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))))