diff options
Diffstat (limited to 'module/srfi/srfi-1.scm')
| -rw-r--r-- | module/srfi/srfi-1.scm | 588 |
1 files changed, 588 insertions, 0 deletions
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm new file mode 100644 index 000000000..db21122b9 --- /dev/null +++ b/module/srfi/srfi-1.scm @@ -0,0 +1,588 @@ +;;; srfi-1.scm --- List Library + +;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de> +;;; Date: 2001-06-06 + +;;; Commentary: + +;; This is an implementation of SRFI-1 (List Library). +;; +;; All procedures defined in SRFI-1, which are not already defined in +;; the Guile core library, are exported. The procedures in this +;; implementation work, but they have not been tuned for speed or +;; memory usage. +;; +;; This module is fully documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-1) + :export ( +;;; Constructors + ;; cons <= in the core + ;; list <= in the core + xcons + ;; cons* <= in the core + ;; make-list <= in the core + list-tabulate + list-copy + circular-list + ;; iota ; Extended. + +;;; Predicates + proper-list? + circular-list? + dotted-list? + ;; pair? <= in the core + ;; null? <= in the core + null-list? + not-pair? + list= + +;;; Selectors + ;; car <= in the core + ;; cdr <= in the core + ;; caar <= in the core + ;; cadr <= in the core + ;; cdar <= in the core + ;; cddr <= in the core + ;; caaar <= in the core + ;; caadr <= in the core + ;; cadar <= in the core + ;; caddr <= in the core + ;; cdaar <= in the core + ;; cdadr <= in the core + ;; cddar <= in the core + ;; cdddr <= in the core + ;; caaaar <= in the core + ;; caaadr <= in the core + ;; caadar <= in the core + ;; caaddr <= in the core + ;; cadaar <= in the core + ;; cadadr <= in the core + ;; caddar <= in the core + ;; cadddr <= in the core + ;; cdaaar <= in the core + ;; cdaadr <= in the core + ;; cdadar <= in the core + ;; cdaddr <= in the core + ;; cddaar <= in the core + ;; cddadr <= in the core + ;; cdddar <= in the core + ;; cddddr <= in the core + ;; list-ref <= in the core + first + second + third + fourth + fifth + sixth + seventh + eighth + ninth + tenth + car+cdr + take + drop + take-right + drop-right + take! + drop-right! + split-at + split-at! + last + ;; last-pair <= in the core + +;;; Miscelleneous: length, append, concatenate, reverse, zip & count + ;; length <= in the core + length+ + ;; append <= in the core + ;; append! <= in the core + concatenate + concatenate! + ;; reverse <= in the core + ;; reverse! <= in the core + append-reverse + append-reverse! + zip + unzip1 + unzip2 + unzip3 + unzip4 + unzip5 + count + +;;; Fold, unfold & map + fold + fold-right + pair-fold + pair-fold-right + reduce + reduce-right + unfold + unfold-right + ;; map ; Extended. + ;; for-each ; Extended. + append-map + append-map! + map! + ;; map-in-order ; Extended. + pair-for-each + filter-map + +;;; Filtering & partitioning + ;; filter <= in the core + partition + remove + ;; filter! <= in the core + partition! + remove! + +;;; Searching + find + find-tail + take-while + take-while! + drop-while + span + span! + break + break! + any + every + ;; list-index ; Extended. + ;; member ; Extended. + ;; memq <= in the core + ;; memv <= in the core + +;;; Deletion + ;; delete ; Extended. + ;; delete! ; Extended. + delete-duplicates + delete-duplicates! + +;;; Association lists + ;; assoc ; Extended. + ;; assq <= in the core + ;; assv <= in the core + alist-cons + alist-copy + alist-delete + alist-delete! + +;;; Set operations on lists + lset<= + lset= + lset-adjoin + lset-union + lset-intersection + lset-difference + lset-xor + lset-diff+intersection + lset-union! + lset-intersection! + lset-difference! + lset-xor! + lset-diff+intersection! + +;;; Primitive side-effects + ;; set-car! <= in the core + ;; set-cdr! <= in the core + ) + :re-export (cons list cons* make-list pair? null? + car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + list-ref last-pair length append append! reverse reverse! + filter filter! memq memv assq assv set-car! set-cdr!) + :replace (iota map for-each map-in-order list-copy list-index member + delete delete! assoc) + ) + +(cond-expand-provide (current-module) '(srfi-1)) + +;; Load the compiled primitives from the shared library. +;; +(load-extension "libguile-srfi-srfi-1-v-4" "scm_init_srfi_1") + + +;;; Constructors + +;; internal helper, similar to (scsh utilities) check-arg. +(define (check-arg-type pred arg caller) + (if (pred arg) + arg + (scm-error 'wrong-type-arg caller + "Wrong type argument: ~S" (list arg) '()))) + +;; the srfi spec doesn't seem to forbid inexact integers. +(define (non-negative-integer? x) (and (integer? x) (>= x 0))) + + + +(define (circular-list elt1 . elts) + (set! elts (cons elt1 elts)) + (set-cdr! (last-pair elts) elts) + elts) + +(define (iota count . rest) + (check-arg-type non-negative-integer? count "iota") + (let ((start (if (pair? rest) (car rest) 0)) + (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1))) + (let lp ((n 0) (acc '())) + (if (= n count) + (reverse! acc) + (lp (+ n 1) (cons (+ start (* n step)) acc)))))) + +;;; Predicates + +(define (proper-list? x) + (list? x)) + +(define (circular-list? x) + (if (not-pair? x) + #f + (let lp ((hare (cdr x)) (tortoise x)) + (if (not-pair? hare) + #f + (let ((hare (cdr hare))) + (if (not-pair? hare) + #f + (if (eq? hare tortoise) + #t + (lp (cdr hare) (cdr tortoise))))))))) + +(define (dotted-list? x) + (cond + ((null? x) #f) + ((not-pair? x) #t) + (else + (let lp ((hare (cdr x)) (tortoise x)) + (cond + ((null? hare) #f) + ((not-pair? hare) #t) + (else + (let ((hare (cdr hare))) + (cond + ((null? hare) #f) + ((not-pair? hare) #t) + ((eq? hare tortoise) #f) + (else + (lp (cdr hare) (cdr tortoise))))))))))) + +(define (null-list? x) + (cond + ((proper-list? x) + (null? x)) + ((circular-list? x) + #f) + (else + (error "not a proper list in null-list?")))) + +(define (list= elt= . rest) + (define (lists-equal a b) + (let lp ((a a) (b b)) + (cond ((null? a) + (null? b)) + ((null? b) + #f) + (else + (and (elt= (car a) (car b)) + (lp (cdr a) (cdr b))))))) + (or (null? rest) + (let lp ((lists rest)) + (or (null? (cdr lists)) + (and (lists-equal (car lists) (cadr lists)) + (lp (cdr lists))))))) + +;;; Selectors + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) + +(define take list-head) +(define drop list-tail) + +;;; Miscelleneous: length, append, concatenate, reverse, zip & count + +(define (zip clist1 . rest) + (let lp ((l (cons clist1 rest)) (acc '())) + (if (any null? l) + (reverse! acc) + (lp (map1 cdr l) (cons (map1 car l) acc))))) + + +(define (unzip1 l) + (map1 first l)) +(define (unzip2 l) + (values (map1 first l) (map1 second l))) +(define (unzip3 l) + (values (map1 first l) (map1 second l) (map1 third l))) +(define (unzip4 l) + (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l))) +(define (unzip5 l) + (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l) + (map1 fifth l))) + +;;; Fold, unfold & map + +(define (fold-right kons knil clist1 . rest) + (if (null? rest) + (let f ((list1 clist1)) + (if (null? list1) + knil + (kons (car list1) (f (cdr list1))))) + (let f ((lists (cons clist1 rest))) + (if (any null? lists) + knil + (apply kons (append! (map1 car lists) (list (f (map1 cdr lists))))))))) + +(define (pair-fold kons knil clist1 . rest) + (if (null? rest) + (let f ((knil knil) (list1 clist1)) + (if (null? list1) + knil + (let ((tail (cdr list1))) + (f (kons list1 knil) tail)))) + (let f ((knil knil) (lists (cons clist1 rest))) + (if (any null? lists) + knil + (let ((tails (map1 cdr lists))) + (f (apply kons (append! lists (list knil))) tails)))))) + + +(define (pair-fold-right kons knil clist1 . rest) + (if (null? rest) + (let f ((list1 clist1)) + (if (null? list1) + knil + (kons list1 (f (cdr list1))))) + (let f ((lists (cons clist1 rest))) + (if (any null? lists) + knil + (apply kons (append! lists (list (f (map1 cdr lists))))))))) + +(define (unfold p f g seed . rest) + (let ((tail-gen (if (pair? rest) + (if (pair? (cdr rest)) + (scm-error 'wrong-number-of-args + "unfold" "too many arguments" '() '()) + (car rest)) + (lambda (x) '())))) + (let uf ((seed seed)) + (if (p seed) + (tail-gen seed) + (cons (f seed) + (uf (g seed))))))) + +(define (unfold-right p f g seed . rest) + (let ((tail (if (pair? rest) + (if (pair? (cdr rest)) + (scm-error 'wrong-number-of-args + "unfold-right" "too many arguments" '() + '()) + (car rest)) + '()))) + (let uf ((seed seed) (lis tail)) + (if (p seed) + lis + (uf (g seed) (cons (f seed) lis)))))) + + +;; Internal helper procedure. Map `f' over the single list `ls'. +;; +(define map1 map) + +(define (append-map f clist1 . rest) + (concatenate (apply map f clist1 rest))) + +(define (append-map! f clist1 . rest) + (concatenate! (apply map f clist1 rest))) + +;; OPTIMIZE-ME: Re-use cons cells of list1 +(define map! map) + +(define (pair-for-each f clist1 . rest) + (if (null? rest) + (let lp ((l clist1)) + (if (null? l) + (if #f #f) + (begin + (f l) + (lp (cdr l))))) + (let lp ((l (cons clist1 rest))) + (if (any1 null? l) + (if #f #f) + (begin + (apply f l) + (lp (map1 cdr l))))))) + +;;; Searching + +(define (any pred ls . lists) + (if (null? lists) + (any1 pred ls) + (let lp ((lists (cons ls lists))) + (cond ((any1 null? lists) + #f) + ((any1 null? (map1 cdr lists)) + (apply pred (map1 car lists))) + (else + (or (apply pred (map1 car lists)) (lp (map1 cdr lists)))))))) + +(define (any1 pred ls) + (let lp ((ls ls)) + (cond ((null? ls) + #f) + ((null? (cdr ls)) + (pred (car ls))) + (else + (or (pred (car ls)) (lp (cdr ls))))))) + +(define (every pred ls . lists) + (if (null? lists) + (every1 pred ls) + (let lp ((lists (cons ls lists))) + (cond ((any1 null? lists) + #t) + ((any1 null? (map1 cdr lists)) + (apply pred (map1 car lists))) + (else + (and (apply pred (map1 car lists)) (lp (map1 cdr lists)))))))) + +(define (every1 pred ls) + (let lp ((ls ls)) + (cond ((null? ls) + #t) + ((null? (cdr ls)) + (pred (car ls))) + (else + (and (pred (car ls)) (lp (cdr ls))))))) + +;;; Association lists + +(define alist-cons acons) + +(define (alist-delete key alist . rest) + (let ((k= (if (pair? rest) (car rest) equal?))) + (let lp ((a alist) (rl '())) + (if (null? a) + (reverse! rl) + (if (k= key (caar a)) + (lp (cdr a) rl) + (lp (cdr a) (cons (car a) rl))))))) + +(define (alist-delete! key alist . rest) + (let ((k= (if (pair? rest) (car rest) equal?))) + (alist-delete key alist k=))) ; XXX:optimize + +;;; Set operations on lists + +(define (lset<= = . rest) + (if (null? rest) + #t + (let lp ((f (car rest)) (r (cdr rest))) + (or (null? r) + (and (every (lambda (el) (member el (car r) =)) f) + (lp (car r) (cdr r))))))) + +(define (lset= = . rest) + (if (null? rest) + #t + (let lp ((f (car rest)) (r (cdr rest))) + (or (null? r) + (and (every (lambda (el) (member el (car r) =)) f) + (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r)) + (lp (car r) (cdr r))))))) + +(define (lset-union = . rest) + (let ((acc '())) + (for-each (lambda (lst) + (if (null? acc) + (set! acc lst) + (for-each (lambda (elem) + (if (not (member elem acc + (lambda (x y) (= y x)))) + (set! acc (cons elem acc)))) + lst))) + rest) + acc)) + +(define (lset-intersection = list1 . rest) + (let lp ((l list1) (acc '())) + (if (null? l) + (reverse! acc) + (if (every (lambda (ll) (member (car l) ll =)) rest) + (lp (cdr l) (cons (car l) acc)) + (lp (cdr l) acc))))) + +(define (lset-difference = list1 . rest) + (if (null? rest) + list1 + (let lp ((l list1) (acc '())) + (if (null? l) + (reverse! acc) + (if (any (lambda (ll) (member (car l) ll =)) rest) + (lp (cdr l) acc) + (lp (cdr l) (cons (car l) acc))))))) + +;(define (fold kons knil list1 . rest) + +(define (lset-xor = . rest) + (fold (lambda (lst res) + (let lp ((l lst) (acc '())) + (if (null? l) + (let lp0 ((r res) (acc acc)) + (if (null? r) + (reverse! acc) + (if (member (car r) lst =) + (lp0 (cdr r) acc) + (lp0 (cdr r) (cons (car r) acc))))) + (if (member (car l) res =) + (lp (cdr l) acc) + (lp (cdr l) (cons (car l) acc)))))) + '() + rest)) + +(define (lset-diff+intersection = list1 . rest) + (let lp ((l list1) (accd '()) (acci '())) + (if (null? l) + (values (reverse! accd) (reverse! acci)) + (let ((appears (every (lambda (ll) (member (car l) ll =)) rest))) + (if appears + (lp (cdr l) accd (cons (car l) acci)) + (lp (cdr l) (cons (car l) accd) acci)))))) + + +(define (lset-union! = . rest) + (apply lset-union = rest)) ; XXX:optimize + +(define (lset-intersection! = list1 . rest) + (apply lset-intersection = list1 rest)) ; XXX:optimize + +(define (lset-xor! = . rest) + (apply lset-xor = rest)) ; XXX:optimize + +(define (lset-diff+intersection! = list1 . rest) + (apply lset-diff+intersection = list1 rest)) ; XXX:optimize + +;;; srfi-1.scm ends here |