diff options
Diffstat (limited to 'srfi-1.scm')
| -rw-r--r-- | srfi-1.scm | 253 |
1 files changed, 253 insertions, 0 deletions
diff --git a/srfi-1.scm b/srfi-1.scm new file mode 100644 index 0000000..1cebd9a --- /dev/null +++ b/srfi-1.scm @@ -0,0 +1,253 @@ +;;; "srfi-1.scm" SRFI-1 list-processing library -*-scheme-*- +; Copyright 2001 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +; Some pieces from: +;;; +;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with +;;; this code as long as you do not remove this copyright notice or +;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. +;;; -Olin + +;;@code{(require 'srfi-1)} +;;@ftindex srfi-1 +;; +;;@noindent +;;Implements the @dfn{SRFI-1} @dfn{list-processing library} as described +;;at @url{http://srfi.schemers.org/srfi-1/srfi-1.html} + +(require 'common-list-functions) +(require 'rev2-procedures) ;for append! +(require 'values) + +;;@subheading Constructors + +;;@body @code{(define (xcons d a) (cons a d))}. +(define (xcons d a) (cons a d)) + +;;@body Returns a list of length @1. Element @var{i} is @code{(@2 +;;@var{i})} for 0 <= @var{i} < @1. +(define (list-tabulate len proc) + (do ((i (- len 1) (- i 1)) + (ans '() (cons (proc i) ans))) + ((< i 0) ans))) + +;;@args obj1 obj2 +(define cons* comlist:list*) + +;;@args count start step +;;@args count start +;;@args count +;;Returns a list of @1 numbers: (@2, @2+@3, @dots{}, @2+(@1-1)*@3). +(define (iota count . args) + (let ((start (if (null? args) 0 (car args))) + (step (if (or (null? args) (null? (cdr args))) 1 (cadr args)))) + (list-tabulate count (lambda (idx) (+ start (* step idx)))))) + +;;@body +;;Returns a circular list of @1, @2, @dots{}. +(define (circular-list obj1 . obj2) + (let ((ans (cons obj1 obj2))) + (set-cdr! (last-pair ans) ans) + ans)) + +;;@subheading Predicates + +;;@args obj +(define proper-list? list?) + +;;@body +(define (circular-list? x) + (let lp ((x x) (lag x)) + (and (pair? x) + (let ((x (cdr x))) + (and (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (or (eq? x lag) (lp x lag)))))))) + +;;@body +(define (dotted-list? obj) + (not (or (proper-list? obj) (circular-list? obj)))) + +;;@args obj +(define null-list? null?) + +;;@body +(define (not-pair? obj) (not (pair? obj))) + +;;@body +(define (list= =pred . lists) + (or (null? lists) ; special case + (let lp1 ((list-a (car lists)) (others (cdr lists))) + (or (null? others) + (let ((list-b (car others)) + (others (cdr others))) + (if (eq? list-a list-b) ; EQ? => LIST= + (lp1 list-b others) + (let lp2 ((list-a list-a) (list-b list-b)) + (if (null-list? list-a) + (and (null-list? list-b) + (lp1 list-b others)) + (and (not (null-list? list-b)) + (=pred (car list-a) (car list-b)) + (lp2 (cdr list-a) (cdr list-b))))))))))) + +;;@subheading Selectors + +;;@args pair +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth obj) (car (cddddr obj))) +(define (sixth obj) (cadr (cddddr obj))) +(define (seventh obj) (caddr (cddddr obj))) +(define (eighth obj) (cadddr (cddddr obj))) +(define (ninth obj) (car (cddddr (cddddr obj)))) +(define (tenth obj) (cadr (cddddr (cddddr obj)))) + +;;@body +(define (car+cdr pair) (values (car pair) (cdr pair))) + +;;@body +(define (take lst k) (comlist:butnthcdr k lst)) +(define take! take) +(define (drop lst k) (comlist:nthcdr k lst)) + +;;@args lst k +(define take-right comlist:butlast) +(define drop-right comlist:last) +(define drop-right! drop-right) + +;;@body +(define (split-at lst k) (values (take lst k) (drop lst k))) +(define split-at! split-at) + +;;@args lst +;;(car (last-pair lst)) +(define (last lst . k) + (if (null? k) + (car (last-pair lst)) + (apply comlist:last lst k))) + +;;@subheading Miscellaneous + +;;@body +(define (length+ obj) (and (list? obj) (length obj))) + +;;Append and append! are provided by R4RS and rev2-procedures. + +;;@body +(define (concatenate lists) (reduce-right append '() lists)) +(define (concatenate! lists) (reduce-right append! '() lists)) + +;;Reverse is provided by R4RS. +;;@args lst +(define reverse! comlist:nreverse) + +;;@body +(define (append-reverse rev-head tail) + (let lp ((rev-head rev-head) (tail tail)) + (if (null-list? rev-head) tail + (lp (cdr rev-head) (cons (car rev-head) tail))))) +(define (append-reverse! rev-head tail) + (let lp ((rev-head rev-head) (tail tail)) + (if (null-list? rev-head) tail + (let ((next-rev (cdr rev-head))) + (set-cdr! rev-head tail) + (lp next-rev rev-head))))) + +;;@body +(define (zip list1 . list2) (apply map list list1 list2)) + +;;@body +(define (unzip1 lst) (map car lst)) +(define (unzip2 lst) (values (map car lst) (map cadr lst))) +(define (unzip3 lst) (values (map car lst) (map cadr lst) (map caddr lst))) +(define (unzip4 lst) (values (map car lst) (map cadr lst) (map caddr lst) + (map cadddr lst))) +(define (unzip5 lst) (values (map car lst) (map cadr lst) (map caddr lst) + (map cadddr lst) (map fifth lst))) + +;;@body +(define (count pred list1 . list2) + (cond ((null? list2) + (let mapf ((l list1) (count 0)) + (if (null? l) + count (mapf (cdr l) + (+ count (if (pred (car l)) 1 0)))))) + (else (let mapf ((l list1) (rest list2) (count 0)) + (if (null? l) + count + (mapf (cdr l) + (map cdr rest) + (+ count (if (apply pred (car l) (map car rest)) + 1 0)))))))) + +;;@subheading Fold and Unfold + +;;@subheading Filtering and Partitioning + +;;@subheading Searching + +;;@args pred list +(define find comlist:find-if) + +;;@args pred list +(define find-tail comlist:member-if) + + +;;@args obj list pred +;;@args obj list +;; +;;@0 returns the first sublist of @2 whose car is @1, where the sublists +;;of @2 are the non-empty lists returned by @t{(list-tail @2 @var{k})} +;;for @var{k} less than the length of @2. If @1 does not occur in @2, +;;then @t{#f} (not the empty list) is returned. The procedure @3 is +;;used for testing equality. If @3 is not provided, @samp{equal?} is +;;used. +(define member + (let ((old-member member)) + (lambda (obj list . pred) + (if (null? pred) + (old-member obj list) + (let ((pred (car pred))) + (find-tail (lambda (ob) (pred ob obj)) list)))))) + +;;@subheading Deleting + +;;@subheading Association lists + +;;@args obj alist pred +;;@args obj alist +;; +;;@2 (for ``association list'') must be a list of pairs. These +;;procedures find the first pair in @2 whose car field is @1, and +;;returns that pair. If no pair in @2 has @1 as its car, then @t{#f} +;;(not the empty list) is returned. The procedure @3 is used for +;;testing equality. If @3 is not provided, @samp{equal?} is used. +(define assoc + (let ((old-assoc assoc)) + (lambda (obj alist . pred) + (if (null? pred) + (old-assoc obj alist) + (let ((pred (car pred))) + (find (lambda (pair) (pred obj (car pair))) alist)))))) + +;;@subheading Set operations |