srfi-1.scm

MSYS在windows下模拟了一个类unix的终端

(define (fold kons knil list1 . rest)
  (if (null? rest)
      (let f ((knil knil) (list1 list1))
	(if (null? list1)
	    knil
	    (f (kons (car list1) knil) (cdr list1))))
      (let f ((knil knil) (lists (cons list1 rest)))
	(if (any null? lists)
	    knil
	    (let ((cars (map1 car lists))
		  (cdrs (map1 cdr lists)))
	      (f (apply kons (append! cars (list knil))) cdrs))))))

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

(define (reduce f ridentity lst)
  (fold f ridentity lst))

(define (reduce-right f ridentity lst)
  (fold-right f ridentity lst))


;; Internal helper procedure.  Map `f' over the single list `ls'.
;;
(define (map1 f ls)
  (if (null? ls)
      ls
      (let ((ret (list (f (car ls)))))
        (let lp ((ls (cdr ls)) (p ret))         ; tail pointer
          (if (null? ls)
              ret
              (begin
                (set-cdr! p (list (f (car ls))))
                (lp (cdr ls) (cdr p))))))))

;; This `map' is extended from the standard `map'.  It allows argument
;; lists of different length, so that the shortest list determines the
;; number of elements processed.
;;
(define (map f list1 . rest)
  (if (null? rest)
    (map1 f list1)
    (let lp ((l (cons list1 rest)))
      (if (any1 null? l)
	'()
	(cons (apply f (map1 car l)) (lp (map1 cdr l)))))))

;; extended to lists of unequal length.
(define map-in-order map)

;; This `for-each' is extended from the standard `for-each'.  It
;; allows argument lists of different length, so that the shortest
;; list determines the number of elements processed.
;;
(define (for-each f list1 . rest)
  (if (null? rest)
    (let lp ((l list1))
      (if (null? l)
	(if #f #f)			; Return unspecified value.
	(begin
	  (f (car l))
	  (lp (cdr l)))))
    (let lp ((l (cons list1 rest)))
      (if (any1 null? l)
	(if #f #f)
	(begin
	  (apply f (map1 car l))
	  (lp (map1 cdr l)))))))


(define (append-map f clist1 . rest)
  (if (null? rest)
    (let lp ((l clist1))
      (if (null? l)
	'()
	(append (f (car l)) (lp (cdr l)))))
    (let lp ((l (cons clist1 rest)))
      (if (any1 null? l)
	'()
	(append (apply f (map1 car l)) (lp (map1 cdr l)))))))


(define (append-map! f clist1 . rest)
  (if (null? rest)
    (let lp ((l clist1))
      (if (null? l)
	'()
	(append! (f (car l)) (lp (cdr l)))))
    (let lp ((l (cons clist1 rest)))
      (if (any1 null? l)
	'()
	(append! (apply f (map1 car l)) (lp (map1 cdr l)))))))

(define (map! f list1 . rest)
  (if (null? rest)
    (let lp ((l list1))
      (if (null? l)
	'()
	(begin
	  (set-car! l (f (car l)))
	  (set-cdr! l (lp (cdr l)))
	  l)))
    (let lp ((l (cons list1 rest)) (res list1))
      (if (any1 null? l)
	'()
	(begin
	  (set-car! res (apply f (map1 car l)))
	  (set-cdr! res (lp (map1 cdr l) (cdr res)))
	  res)))))

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

(define (filter-map f clist1 . rest)
  (if (null? rest)
    (let lp ((l clist1))
      (if (null? l)
	'()
	(let ((res (f (car l))))
	  (if res
	    (cons res (lp (cdr l)))
	    (lp (cdr l))))))
    (let lp ((l (cons clist1 rest)))
      (if (any1 null? l)
	'()
	(let ((res (apply f (map1 car l))))
	  (if res
	    (cons res (lp (map1 cdr l)))
	    (lp (map1 cdr l))))))))

;;; Filtering & partitioning

(define (filter pred list)
  (check-arg-type list? list "filter")  ; reject circular lists.
  (letrec ((filiter (lambda (pred rest result)
		      (if (null? rest)
			  (reverse! result)
			  (filiter pred (cdr rest)
				   (cond ((pred (car rest))
					  (cons (car rest) result))
					 (else
					  result)))))))
    (filiter pred list '())))

(define (partition pred list)
  (if (null? list)
    (values '() '())
    (if (pred (car list))
      (receive (in out) (partition pred (cdr list))
	       (values (cons (car list) in) out))
      (receive (in out) (partition pred (cdr list))
	       (values in (cons (car list) out))))))

(define (remove pred list)
  (filter (lambda (x) (not (pred x))) list))

(define (filter! pred list)
  (filter pred list))			; XXX:optimize

(define (partition! pred list)
  (partition pred list))		; XXX:optimize

(define (remove! pred list)
  (remove pred list))			; XXX:optimize

;;; Searching

(define (find pred clist)
  (if (null? clist)
    #f
    (if (pred (car clist))
      (car clist)
      (find pred (cdr clist)))))

(define (find-tail pred clist)
  (if (null? clist)
    #f
    (if (pred (car clist))
      clist
      (find-tail pred (cdr clist)))))

(define (take-while pred ls)
  (cond ((null? ls) '())
        ((not (pred (car ls))) '())
        (else
         (let ((result (list (car ls))))
           (let lp ((ls (cdr ls)) (p result))
             (cond ((null? ls) result)
                   ((not (pred (car ls))) result)
                   (else
                    (set-cdr! p (list (car ls)))
                    (lp (cdr ls) (cdr p)))))))))

(define (take-while! pred clist)
  (take-while pred clist))		; XXX:optimize

(define (drop-while pred clist)
  (if (null? clist)
    '()
    (if (pred (car clist))
      (drop-while pred (cdr clist))
      clist)))

(define (span pred clist)
  (if (null? clist)
    (values '() '())
    (if (pred (car clist))
      (receive (first last) (span pred (cdr clist))
	       (values (cons (car clist) first) last))
      (values '() clist))))

(define (span! pred list)
  (span pred list))			; XXX:optimize

(define (break pred clist)
  (if (null? clist)
    (values '() '())
    (if (pred (car clist))
      (values '() clist)
      (receive (first last) (break pred (cdr clist))
	       (values (cons (car clist) first) last)))))

(define (break! pred list)
  (break pred list))			; XXX:optimize

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

(define (list-index pred clist1 . rest)
  (if (null? rest)
    (let lp ((l clist1) (i 0))
      (if (null? l)
	#f
	(if (pred (car l))
	  i
	  (lp (cdr l) (+ i 1)))))
    (let lp ((lists (cons clist1 rest)) (i 0))
      (cond ((any1 null? lists)
	     #f)
	    ((apply pred (map1 car lists)) i)
	    (else
	     (lp (map1 cdr lists) (+ i 1)))))))

(define (member x list . rest)
  (let ((l= (if (pair? rest) (car rest) equal?)))
    (let lp ((l list))
      (if (null? l)
	#f
	(if (l= x (car l))
	  l
	  (lp (cdr l)))))))

;;; Deletion

(define (delete x list . rest)
  (let ((l= (if (pair? rest) (car rest) equal?)))
    (let lp ((l list))
      (if (null? l)
	'()
	(if (l= (car l) x)
	  (lp (cdr l))
	  (cons (car l) (lp (cdr l))))))))

(define (delete! x list . rest)
  (let ((l= (if (pair? rest) (car rest) equal?)))
    (delete x list l=)))		; XXX:optimize

(define (delete-duplicates list . rest)
  (let ((l= (if (pair? rest) (car rest) equal?)))
    (let lp0 ((l1 list))
      (if (null? l1)
	'()
	(if (let lp1 ((l2 (cdr l1)))
	      (if (null? l2)
		#f
		(if (l= (car l1) (car l2))
		  #t
		  (lp1 (cdr l2)))))
	  (lp0 (cdr l1))
	  (cons (car l1) (lp0 (cdr l1))))))))

(define (delete-duplicates list . rest)
  (let ((l= (if (pair? rest) (car rest) equal?)))
    (let lp ((list list))
      (if (null? list)
	'()
	(cons (car list) (lp (delete (car list) (cdr list) l=)))))))

(define (delete-duplicates! list . rest)
  (let ((l= (if (pair? rest) (car rest) equal?)))
    (delete-duplicates list l=)))	; XXX:optimize

;;; Association lists

(define (assoc key alist . rest)
  (let ((k= (if (pair? rest) (car rest) equal?)))
    (let lp ((a alist))
      (if (null? a)
	#f
	(if (k= key (caar a))
	  (car a)
	  (lp (cdr a)))))))

(define (alist-cons key datum alist)
  (acons key datum alist))

(define (alist-copy alist)
  (let lp ((a alist))
    (if (null? a)
      '()
      (acons (caar a) (cdar a) (lp (cdr a))))))

(define (alist-delete key alist . rest)
  (let ((k= (if (pair? rest) (car rest) equal?)))
    (let lp ((a alist))
      (if (null? a)
	'()
	(if (k= (caar a) key)
	  (lp (cdr a))
	  (cons (car a) (lp (cdr a))))))))

(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= = list1 . rest)
  (if (null? rest)
    #t
    (let lp ((f list1) (r rest))
      (or (null? r)
	  (and (every (lambda (el) (member el (car r) =)) f)
	       (every (lambda (el) (member el f =)) (car r))
	       (lp (car r) (cdr r)))))))

(define (lset-adjoin = list . rest)
  (let lp ((l rest) (acc list))
    (if (null? l)
      acc
      (if (member (car l) acc)
	(lp (cdr l) acc)
	(lp (cdr l) (cons (car l) acc))))))

(define (lset-union = . rest)
  (let lp0 ((l rest) (acc '()))
    (if (null? l)
      (reverse! acc)
      (let lp1 ((ll (car l)) (acc acc))
	(if (null? ll)
	  (lp0 (cdr l) acc)
	  (if (member (car ll) acc =)
	    (lp1 (cdr ll) acc)
	    (lp1 (cdr ll) (cons (car ll) 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-difference! = list1 . rest)
  (apply lset-difference = 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