;;; Lists ;;; John David Stone ;;; Department of Computer Science ;;; Grinnell College ;;; created July 31, 1998 ;;; last revised January 9, 2017 (define-library (afp lists) (export first rest empty-list? non-empty-list? prepend deprepend list=? list-of list-of= sum catenate fold-list process-list unfold-list adjacent-pairs conditionally-unfold-list ^and extend-to-variable-arity ^or run extend-to-positive-arity extend-like-subtraction filter remp partition extract drop take sublist adapter for-all? exists? every at-least-one transpose zip unzip collect-map dispatch-return-all cross-return-all all-alike all-different position-in positional-weights separate-indices all-but-position matches-prefix?) (import (afp primitives) (only (afp arithmetic) add1 sub1) (only (afp procedure-sections) curry) (only (afp constant-procedures) values? constant create) (only (afp couplers) pipe dispatch cross) (only (afp adapters) >initial >next >all-but-initial converse ~initial ~each) (afp recursion-managers) (only (afp predicate-operations) ^not ^et ^vel ^if conditionally-combine) (only (afp natural-numbers) fold-natural) (only (afp pairs) decons) (only (afp boxes) box box? debox)) (begin ;; ===== first ======================================================== ;; list(alpha) -> alpha ;; ls ;; The first procedure selects the initial element of ls. ;; Precondition: ;; ls is not empty. (define first car) ;; ===== rest ========================================================= ;; list(alpha) -> list(alpha) ;; ls ;; The rest procedure return a list similar to ls, but lacking ;; its initial element. ;; Precondition: ;; ls is not empty. (define rest cdr) ;; ===== empty-list? ================================================== ;; list(any) -> Boolean ;; ls ;; The empty-list? predicate determines whether ls is empty (that is, ;; whether it has no elements). (define empty-list? null?) ;; ===== non-empty-list? ============================================== ;; list(any) -> Boolean ;; ls ;; The non-empty-list? predicate determines whether ls is non-empty ;; (that is, whether it has at least one element). (define non-empty-list? pair?) ;; ===== prepend ====================================================== ;; alpha, list(alpha) -> list(alpha) ;; something ls ;; The prepend procedure constructs a list with something as its ;; initial element and the elements of ls, in order, as its remaining ;; elements. (define prepend cons) ;; ===== deprepend ==================================================== ;; list(alpha) -> alpha, list(alpha) ;; ls ;; The deprepend procedure returns the initial element of ls and a list ;; similar to ls, but lacking its initial element. ;; Precondition: ;; ls is not empty. (define deprepend decons) ;; ===== list=? ======================================================= ;; list(any), list(any) -> Boolean ;; left right ;; The list=? procedure determines whether the elements of left and ;; right are equal in number and whether corresponding elements are the ;; same. (define (list=? left right) (or (and (empty-list? left) (empty-list? right)) (and (non-empty-list? left) (non-empty-list? right) (equal? (first left) (first right)) (list=? (rest left) (rest right))))) ;; ===== list-of ====================================================== ;; (any -> Boolean) -> (any -> Boolean) ;; right-type-of-element? something ;; The list-of procedure constructs a predicate that determines whether ;; something is a list, every element of which satisfies ;; right-type-of-element?. ;; Precondition: ;; right-type-of-element? can receive any value. (define (list-of right-type-of-element?) (check null? (^et pair? (pipe car right-type-of-element?)) cdr)) ;; ===== list-of= ===================================================== ;; (alpha, beta -> Boolean) -> (list(alpha), list(beta) -> Boolean) ;; element=? left right ;; The list-of= procedure constructs a predicate that determines ;; whether the elements of left and right are equal in number and ;; whether corresponding elements satisfy element=?. ;; Precondition: ;; element=? can receive any element of left and any element of ;; right. (define (list-of= element=?) (rec (equivalent? left right) (or (and (empty-list? left) (empty-list? right)) (and (non-empty-list? left) (non-empty-list? right) (element=? (first left) (first right)) (equivalent? (rest left) (rest right)))))) ;; ===== sum ========================================================== ;; list(number) -> number ;; ls ;; The sum procedure computes the sum of the elements of ls. (define (sum ls) (if (empty-list? ls) 0 (+ (first ls) (sum (rest ls))))) ;; ===== catenate ===================================================== ;; list(alpha), list(alpha) -> list(alpha) ;; left right ;; The catenate procedure constructs a list that contains all of the ;; elements of left, in their original order, followed by all of the ;; elements of right, in their original order. (define (catenate left right) (if (empty-list? left) right (prepend (first left) (catenate (rest left) right)))) ;; ===== fold-list ==================================================== ;; (-> alpha ...), (beta, alpha ... -> alpha ...) -> ;; base combiner ;; (list(beta) -> alpha ...) ;; ls ;; The fold-list procedure constructs a procedure that returns the ;; results of invoking base if ls is empty. If ls is non-empty, the ;; constructed procedure applies itself recursively to the rest of ls ;; and returns the results of applying combiner to the first of ls and ;; the results of the recursive invocation. ;; Preconditions: ;; If ls is non-empty, then combiner can receive the last element of ;; ls and the results of an invocation of base. ;; If ls is non-empty, then combiner can receive any but the last ;; element of ls and the results of an invocation of combiner. (define (fold-list base combiner) (rec (folder ls) (if (empty-list? ls) (base) (receive recursive-results (folder (rest ls)) (apply combiner (first ls) recursive-results))))) ;; ===== process-list ================================================= ;; (-> alpha ...), (beta, alpha ... -> alpha ...) -> ;; base combiner ;; (list(beta) -> alpha ...) ;; ls ;; The process-list procedure constructs a procedure that iteratively ;; applies combiner to an element of ls and the results of the previous ;; iteration (or to the results of invoking base, if there was no ;; previous iteration). The constructed procedure returns the results ;; of the last application of combiner. ;; Preconditions: ;; If ls is non-empty, then combiner can receive the initial element ;; of ls and the results of an invocation of base. ;; If ls is non-empty, combiner can receive any but the initial ;; element of ls and the results of an invocation of combiner. (define (process-list base combiner) (pipe (lambda (ls) (receive starters (base) (apply values ls starters))) (pipe (iterate (pipe >initial empty-list?) (lambda (sublist . results-so-far) (receive new-results (apply combiner (first sublist) results-so-far) (apply values (rest sublist) new-results)))) >all-but-initial))) ;; ===== unfold-list ================================================== ;; (alpha ... -> Boolean), (alpha ... -> beta), ;; final? producer ;; (alpha ... -> alpha ...) -> (alpha ... -> list(beta)) ;; step arguments ;; The unfold-list procedure constructs a procedure that first ;; determines whether the elements of arguments satisfy final?. If so, ;; the constructed procedure returns the empty list. Otherwise, it ;; returns a non-empty list in which the initial element is the result ;; of applying producer to the elements of arguments, and the remainder ;; of the list is the result of first applying step to the elements of ;; arguments and then applying the constructed procedure recursively to ;; the results. ;; Preconditions: ;; final? can receive the elements of arguments. ;; final? can receive the results of any invocation of step. ;; If the elements of arguments do not satisfy final?, then producer ;; can receive them. ;; If the results of an invocation of step do not satisfy final?, ;; then producer can receive them. ;; If the elements of arguments do not satisfy final?, then step can ;; receive them. ;; If the results of an invocation of step do not satisfy final?, ;; then step can receive them. (define (unfold-list final? producer step) (build final? (constant (list)) producer step prepend)) ;; ===== adjacent-pairs =============================================== ;; list(alpha) -> list(pair(alpha, alpha)) ;; ls ;; The adjacent-pairs procedure constructs a list containing pairs of ;; adjacent elements of ls. ;; Precondition: ;; ls is not empty. (define adjacent-pairs (unfold-list (pipe rest empty-list?) (pipe (dispatch first (pipe rest first)) cons) cdr)) ;; ===== conditionally-unfold-list ==================================== ;; (alpha ... -> Boolean), (alpha ... -> beta), (beta -> Boolean), ;; final? producer condition-met? ;; (alpha ... -> alpha ...) -> (alpha ... -> list(beta)) ;; step arguments ;; The conditionally-unfold-list procedure constructs a procedure that ;; first determines whether the elements of arguments satisfy final?. ;; If so, the constructed procedure returns the empty list. Otherwise, ;; it applies producer to those arguments and determines whether the ;; result satisfies condition-met?. If so, the constructed procedure ;; returns a non-empty list in which the initial element is the result ;; of the invocation of producer, and the remainder of the list is the ;; result of first applying step to the elements of arguments and then ;; applying the constructed procedure recursively to the results. If ;; the result of the invocation of producer does not satisfy ;; condition-met?, then the constructed procedure simply returns the ;; result of the recursive invocation described above. ;; Preconditions: ;; final? can receive the elements of arguments. ;; final? can receive the results of any invocation of step. ;; If the elements of arguments do not satisfy final?, then producer ;; can receive them. ;; If the results of an invocation of step do not satisfy final?, ;; then producer can receive them. ;; condition-met? can receive the result of any invocation of ;; producer. ;; If the elements of arguments do not satisfy final?, then step can ;; receive them. ;; If the results of an invocation of step do not satisfy final?, ;; then step can receive them. (define (conditionally-unfold-list final? condition-met? producer step) (build final? (constant (list)) (^if condition-met? (pipe producer box) (constant #f)) step (conditionally-combine box? (pipe (~initial debox) prepend)))) ;; ===== ^and ========================================================= ;; (alpha ... -> Boolean) ... -> (alpha ... -> Boolean) ;; predicates arguments ;; The ^and procedure constructs a predicate that determines whether ;; the elements of arguments satisfy every element of predicates. ;; Precondition: ;; Every element of predicates can receive the elements of arguments. (define ^and (pipe list (fold-list (create values?) ^et))) ;; ===== extend-to-variable-arity ===================================== ;; alpha, (beta, alpha -> alpha) -> (beta ... -> alpha) ;; id combiner arguments ;; The extend-to-variable-arity procedure constructs a procedure of ;; variable arity that returns id if arguments has no elements and ;; otherwise returns the result of applying combiner to the initial ;; element of arguments and the result of applying itself recursively ;; to the remaining elements of arguments. ;; Precondition: ;; combiner can receive any element of arguments as its first ;; argument. ;; combiner can receive id as its second argument. ;; combiner can receive any result of combiner as its second ;; argument. (define (extend-to-variable-arity id combiner) (pipe list (fold-list (create id) combiner))) ;; ===== ^or ========================================================== ;; (alpha ... -> Boolean) ... -> (alpha ... -> Boolean) ;; predicates arguments ;; The ^or procedure constructs a predicate that determines whether the ;; elements of arguments satisfy at least one element of predicates. ;; Precondition: ;; Every element of predicates can receive the elements of arguments. (define ^or (extend-to-variable-arity (constant #f) ^vel)) ;; ===== run ========================================================== ;; (alpha ... -> alpha ...) ... -> (alpha ... -> alpha ...) ;; sequence arguments ;; The run procedure constructs a procedure that returns the elements ;; of arguments if sequence has no elements, and otherwise applies ;; itself recursively to all but the initial element of sequence, ;; applies the procedure resulting from that recursive invocation to ;; the results of applying the initial element of sequence to the ;; elements of arguments, and returns the results of that final ;; invocation. ;; Preconditions: ;; If sequence has any elements, then its initial element can receive ;; the elements of arguments. ;; If sequence has any elements, then every element of sequence ;; except the initial one can receive the results of any invocation ;; of the preceding element of sequence. (define run (extend-to-variable-arity values pipe)) ;; ===== extend-to-positive-arity ===================================== ;; (alpha, alpha -> alpha) -> (alpha, alpha ... -> alpha) ;; combiner initial others ;; The extend-to-positive-arity procedure constructs a procedure that ;; returns initial if given one argument and otherwise returns the ;; result of applying combiner to initial and the results of applying ;; itself recursively to others. ;; Preconditions: ;; If others is not empty, then combiner can receive initial as its ;; first argument. ;; If others is not empty, then combiner can receive any element of ;; others except the last as its first argument. ;; If others is not empty, then combiner can receive the last element ;; of others as its second argument. ;; combiner can receive the result of any invocation of combiner as ;; its second argument. (define (extend-to-positive-arity combiner) (pipe list (recur (pipe rest empty-list?) first deprepend combiner))) ;; ===== extend-like-subtraction ====================================== ;; (alpha -> alpha), (alpha, beta -> alpha) -> ;; unary binary ;; (alpha, beta ... -> alpha) ;; initial others ;; The extend-like-subtraction procedure constructs a procedure that, ;; given one argument, applies unary to that argument and returns the ;; result; given two or more arguments, the constructed procedure ;; applies binary iteratively, operating at each step on the result of ;; the previous iteration (or on initial, if there was no previous ;; iteration) and the next element of others. ;; Preconditions: ;; If others has no elements, then unary can receive initial. ;; If others has at least one element, then binary can receive ;; initial as its first argument. ;; If others has at least one element, then binary can receive the ;; result of any invocation of binary as its first argument. ;; If others has at least one element, then binary can receive any ;; element of others as its second argument. (define (extend-like-subtraction unary binary) (lambda (initial . others) (if (empty-list? others) (unary initial) ((process-list (create initial) (converse binary)) others)))) ;; ===== filter ======================================================= ;; (alpha -> Boolean), list(alpha) -> list(alpha) ;; keep? ls ;; The filter procedure constructs a list comprising the elements of ls ;; that satisfy keep?. ;; Precondition: ;; keep? can receive any element of ls. (define (filter keep? ls) ((fold-list list (conditionally-combine keep? prepend)) ls)) ;; ===== remp ========================================================= ;; (alpha -> Boolean), list(alpha) -> list(alpha) ;; exclude? ls ;; The remp procedure constructs a list comprising the elements of ls ;; that do not satisfy exclude?. ;; Precondition: ;; exclude? can receive any element of ls. (define remp (pipe (~initial ^not) filter)) ;; ===== partition ==================================================== ;; (alpha -> Boolean), list(alpha) -> list(alpha), list(alpha) ;; condition-met? ls ;; The partition procedure constructs two lists, the first comprising ;; the elements of ls that satisfy condition-met?, the second ;; comprising the elements of ls that do not satisfy condition-met?. ;; Precondition: ;; condition-met? can receive any element of ls. (define (partition condition-met? ls) ((fold-list (create (list) (list)) (lambda (candidate ins outs) (if (condition-met? candidate) (values (prepend candidate ins) outs) (values ins (prepend candidate outs))))) ls)) ;; ===== extract ====================================================== ;; (alpha -> Boolean), list(alpha) -> ;; condition-met? ls ;; (box(alpha) | Boolean), list(alpha) ;; The extract procedure searches ls for an element that satisfies ;; condition-met?. If it finds one, it returns a box containing that ;; element and a list of the other elements of ls; otherwise, it ;; returns #f and ls. ;; Precondition: ;; condition-met? can receive any element of ls. (define (extract condition-met? ls) ((rec (extracter sublist) (if (empty-list? sublist) (values #f sublist) (receive (chosen others) (deprepend sublist) (if (condition-met? chosen) (values (box chosen) others) (receive (sought relicts) (extracter others) (values sought (cons chosen relicts))))))) ls)) ;; ===== drop ========================================================= ;; list(alpha), natural-number -> list(alpha) ;; ls count ;; The drop procedure returns a list similar to ls, but with the first ;; count elements removed. ;; Precondition: ;; count is less than or equal to the length of ls. (define (drop ls count) ((fold-natural (create ls) rest) count)) ;; ===== take ========================================================= ;; list(alpha), natural-number -> list(alpha) ;; ls count ;; The take procedure constructs a list comprising count elements from ;; the beginning of ls. ;; Precondition: ;; count is less than or equal to the length of ls. (define take (unfold-list (pipe >next zero?) (pipe >initial first) (cross rest sub1))) ;; ===== sublist ====================================================== ;; list(alpha), natural-number, natural-number -> list(alpha) ;; ls start finish ;; The sublist procedure returns the sublist of ls that starts at the ;; (zero-based) position specified by start and leaves off before the ;; position specified by finish. ;; Preconditions: ;; start is less than or equal to finish. ;; finish is less than or equal to the length of ls. (define (sublist ls start finish) (take (drop ls start) (- finish start))) ;; ===== adapter ====================================================== ;; natural-number ... -> (alpha ... -> alpha ...) ;; positions arguments ;; The adapter procedure constructs an adapter procedure that returns ;; the values that appear in the (zero-based) positions of arguments ;; specified by the elements of positions. ;; Precondition: ;; Every element of positions is less than the number of elements of ;; arguments. (define (adapter . positions) (lambda arguments (delist (map (sect list-ref arguments <>) positions)))) ;; ===== for-all? ===================================================== ;; (alpha -> Boolean), list(alpha) -> Boolean ;; condition-met? ls ;; The for-all? predicate determines whether all of the elements of ls ;; satisfy condition-met?. (define (for-all? condition-met? ls) ((check empty-list? (pipe first condition-met?) rest) ls)) ;; ===== exists? ====================================================== ;; (alpha -> Boolean), list(alpha) -> Boolean ;; condition-met? ls ;; The exists? predicate determines whether at least one element of ls ;; satisfies condition-met?. (define exists? (pipe (~initial ^not) (pipe for-all? not))) ;; ===== every ======================================================== ;; (alpha -> Boolean) -> (alpha ... -> Boolean) ;; condition-met? arguments ;; The every procedure constructs a predicate that determines whether ;; every element of arguments satisfies condition-met?. ;; Precondition: ;; condition-met? can receive any element of arguments. (define (every condition-met?) (lambda arguments (for-all? condition-met? arguments))) ;; ===== at-least-one ================================================= ;; (alpha -> Boolean) -> (alpha ... -> Boolean) ;; condition-met? arguments ;; The at-least-one procedure constructs a predicate that determines ;; whether at least one element of arguments satisfies condition-met?. ;; Precondition: ;; condition-met? can receive any element of arguments. (define (at-least-one condition-met?) (lambda arguments (exists? condition-met? arguments))) ;; ===== transpose ==================================================== ;; list(list(alpha)) -> list(list(alpha)) ;; ls ;; The transpose procedure constructs the transpose of ls, that is, the ;; list of lists of elements in corresponding positions in the elements ;; of ls. ;; Preconditions: ;; ls is not empty. ;; The lengths of the elements of ls are equal. (define transpose (sect apply map list <>)) ;; ===== zip ========================================================== ;; list(alpha), list(alpha) ... -> list(list(alpha)) ;; initial others ;; The zip procedure constructs a list of lists, each comprising ;; corresponding elements of initial and of the elements of others. ;; Preconditions: ;; The length of initial is equal to the length of every element of ;; others. (define zip (pipe list transpose)) ;; ===== unzip ======================================================= ;; list(list(alpha)) -> list(alpha), list(alpha) ... ;; The unzip procedure returns the lists of corresponding elements in ;; the elements of ls. ;; Preconditions: ;; ls is not empty. ;; The lengths of the elements of ls are equal. (define unzip (pipe transpose delist)) ;; ===== collect-map ================================================== ;; (alpha, beta ... -> gamma ...), list(alpha), list(beta) ... -> ;; procedure initial others ;; list(gamma) ;; The collect-map procedure applies procedure to corresponding ;; elements of one or more lists (initial and the elements of others), ;; collecting all of the results in a list. ;; Preconditions: ;; The length of initial and the lengths of the elements of others ;; are equal. ;; procedure can receive corresponding elements of initial and of the ;; elements of others. (define collect-map (run (~initial (sect pipe <> list)) map delist append)) ;; ===== dispatch-return-all ========================================== ;; (alpha ... -> beta ...) ... -> (alpha ... -> beta ...) ;; procedures arguments ;; The dispatch-return-all procedure constructs a procedure that ;; applies every element of procedures to the elements of arguments, ;; returning all of the results. ;; Preconditions: ;; Every element of procedures can receive the elements of arguments. (define dispatch-return-all (run (~each (sect pipe <> list)) dispatch (sect run <> append delist))) ;; ===== cross-return-all ============================================= ;; (alpha -> beta ...) ... -> (alpha ... -> beta ...) ;; procedures arguments ;; The cross-return-all procedure constructs a procedure that applies ;; each element of procedures to the corresponding element of ;; arguments, returning all of the results. ;; Preconditions: ;; Every element of procedures can receive the corresponding element ;; of arguments. (define cross-return-all (run (~each (sect pipe <> list)) cross (sect run <> append delist))) ;; ===== all-alike =================================================== ;; (alpha, alpha -> Boolean) -> (alpha ... -> Boolean) ;; equivalent? arguments ;; The all-alike procedure constructs a predicate that the elements of ;; arguments satisfy if, and only if, every two of them satisfy ;; equivalent?. ;; Preconditions: ;; equivalent? is an equivalence relation. ;; equivalent? can receive any elements of arguments. (define (all-alike equivalent?) (lambda arguments (or (empty-list? arguments) (receive (initial remaining) (deprepend arguments) (for-all? (sect equivalent? initial <>) remaining))))) ;; ===== all-different =============================================== ;; (alpha, alpha -> Boolean) -> (alpha ... -> Boolean) ;; equivalent? arguments ;; The all-different procedure constructs a predicate that the elements ;; of arguments satisfy if, and only if, no two of them satisfy ;; equivalent?. ;; Preconditions: ;; equivalent? is symmetric. ;; equivalent? can receive any elements of arguments. (define (all-different equivalent?) (pipe list (check empty-list? (run deprepend (~initial (curry equivalent?)) exists? not) rest))) ;; ===== position-in ================================================== ;; alpha, list(alpha) -> natural-number | Boolean ;; val ls ;; The position-in procedure determines the least position at which val ;; occurs in ls, returning #f if there is no such position. (define (position-in val ls) ((rec (searcher sublist count) (if (empty-list? sublist) #f (if (equal? (first sublist) val) count (searcher (rest sublist) (add1 count))))) ls 0)) ;; ===== positional-weights =========================================== ;; list(natural-number) -> list(natural-number) ;; numlist ;; The positional-weights procedure computes a list of the positional ;; weights of the digits in a mixed-base numeral, given a list, ;; numlist, of the bases. ;; Precondition: ;; Every element of numlist is positive. (define positional-weights (fold-list (create (list 1)) (lambda (element weights) (cons (* element (first weights)) weights)))) ;; ===== separate-indices ============================================= ;; natural-number, list(natural-number) -> list(natural-number) ;; number weights ;; The separate-indices procedure constructs a list of values of the ;; digits for the numeral for number in a mixed-base system of ;; numeration, using weights as the positional weights. ;; Precondition: ;; Every element of weights is positive. (define (separate-indices number weights) (if (empty-list? weights) (list) (receive (quot rem) (div-and-mod number (first weights)) (cons quot (separate-indices rem (rest weights)))))) ;; ===== all-but-position ============================================= ;; list(alpha), natural-number -> list(alpha) ;; ls position ;; The all-but-position procedure constructs a list comprising all of ;; the elements of ls except the one at position position. ;; Preconditions: ;; ls is not empty. ;; position is less than the length of ls. (define (all-but-position ls position) (if (zero? position) (rest ls) (prepend (first ls) (all-but-position (rest ls) (sub1 position))))) ;; ===== matches-prefix? ============================================== ;; list(alpha), list(alpha) -> Boolean ;; pattern text ;; The matches-prefix? predicate determines whether each element of ;; pattern is the same as the corresponding element of text. ;; Precondition: ;; The length of pattern is less than or equal to the length of text. (define matches-prefix? (check (pipe >initial empty-list?) (pipe (~each first) equal?) (~each rest))))) ;;; copyright (C) 2011, 2017 John David Stone ;;; This program is free software. You may redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation -- either version 3 of the License, or (at ;;; your option) any later version. A copy of the GNU General Public ;;; License is available on the World Wide Web at ;;; ;;; http://www.gnu.org/licenses/gpl.html ;;; ;;; 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.