199 lines
5.5 KiB
Scheme
199 lines
5.5 KiB
Scheme
;;;
|
|
;;; <misc.ss> ---- Miscellaneous list procedures
|
|
;;; Time-stamp: <02/03/01 13:52:22 noel>
|
|
;;;
|
|
;;; Copyright (C) 2002 by Noel Welsh.
|
|
;;;
|
|
;;; This file is part of SRFI-1.
|
|
|
|
;;; SRFI-1 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 2.1 of the License, or (at your option) any later version.
|
|
|
|
;;; SRFI-1 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 SRFI-1; if not, write to the Free Software
|
|
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
|
|
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
|
|
;;
|
|
;;
|
|
;; Commentary:
|
|
|
|
;; Based on the reference implementation by Olin Shiver and hence:
|
|
|
|
;; 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
|
|
|
|
(module misc
|
|
mzscheme
|
|
|
|
(require (lib "optional.ss" "srfi")
|
|
"predicate.ss"
|
|
"selector.ss"
|
|
"util.ss"
|
|
(only "fold.ss" reduce-right)
|
|
(rename "fold.ss" srfi-1:map map))
|
|
(require (lib "receive.ss" "srfi" "8"))
|
|
|
|
(provide length+
|
|
concatenate
|
|
(rename my-append! append!)
|
|
concatenate!
|
|
(rename my-reverse! reverse!)
|
|
append-reverse
|
|
append-reverse!
|
|
zip
|
|
unzip1
|
|
unzip2
|
|
unzip3
|
|
unzip4
|
|
unzip5
|
|
count)
|
|
|
|
|
|
;; count
|
|
;;;;;;;;
|
|
(define (count pred list1 . lists)
|
|
(check-arg procedure? pred 'count)
|
|
(if (pair? lists)
|
|
|
|
;; N-ary case
|
|
(let lp ((list1 list1) (lists lists) (i 0))
|
|
(if (null-list? list1) i
|
|
(receive (as ds) (%cars+cdrs lists)
|
|
(if (null? as) i
|
|
(lp (cdr list1) ds
|
|
(if (apply pred (car list1) as) (+ i 1) i))))))
|
|
|
|
;; Fast path
|
|
(let lp ((lis list1) (i 0))
|
|
(if (null-list? lis) i
|
|
(lp (cdr lis) (if (pred (car lis)) (+ i 1) i))))))
|
|
|
|
|
|
(define (length+ x) ; Returns #f if X is circular.
|
|
(let lp ((x x) (lag x) (len 0))
|
|
(if (pair? x)
|
|
(let ((x (cdr x))
|
|
(len (+ len 1)))
|
|
(if (pair? x)
|
|
(let ((x (cdr x))
|
|
(lag (cdr lag))
|
|
(len (+ len 1)))
|
|
(and (not (eq? x lag)) (lp x lag len)))
|
|
len))
|
|
len)))
|
|
|
|
|
|
|
|
(define (zip list1 . more-lists) (apply srfi-1:map list list1 more-lists))
|
|
|
|
;; Unzippers -- 1 through 5
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (unzip1 lis) (map car lis))
|
|
|
|
(define (unzip2 lis)
|
|
(let recur ((lis lis))
|
|
(if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle
|
|
(let ((elt (car lis))) ; dotted lists.
|
|
(receive (a b) (recur (cdr lis))
|
|
(values (cons (car elt) a)
|
|
(cons (cadr elt) b)))))))
|
|
|
|
(define (unzip3 lis)
|
|
(let recur ((lis lis))
|
|
(if (null-list? lis) (values lis lis lis)
|
|
(let ((elt (car lis)))
|
|
(receive (a b c) (recur (cdr lis))
|
|
(values (cons (car elt) a)
|
|
(cons (cadr elt) b)
|
|
(cons (caddr elt) c)))))))
|
|
|
|
(define (unzip4 lis)
|
|
(let recur ((lis lis))
|
|
(if (null-list? lis) (values lis lis lis lis)
|
|
(let ((elt (car lis)))
|
|
(receive (a b c d) (recur (cdr lis))
|
|
(values (cons (car elt) a)
|
|
(cons (cadr elt) b)
|
|
(cons (caddr elt) c)
|
|
(cons (cadddr elt) d)))))))
|
|
|
|
(define (unzip5 lis)
|
|
(let recur ((lis lis))
|
|
(if (null-list? lis) (values lis lis lis lis lis)
|
|
(let ((elt (car lis)))
|
|
(receive (a b c d e) (recur (cdr lis))
|
|
(values (cons (car elt) a)
|
|
(cons (cadr elt) b)
|
|
(cons (caddr elt) c)
|
|
(cons (cadddr elt) d)
|
|
(cons (car (cddddr elt)) e)))))))
|
|
|
|
|
|
;; append! append-reverse append-reverse! concatenate concatenate!
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (my-append! . lists)
|
|
;; First, scan through lists looking for a non-empty one.
|
|
(let lp ((lists lists) (prev '()))
|
|
(if (not (pair? lists)) prev
|
|
(let ((first (car lists))
|
|
(rest (cdr lists)))
|
|
(if (not (pair? first)) (lp rest first)
|
|
; ;; Now, do the splicing.
|
|
(let lp2 ((tail-cons (last-pair first))
|
|
(rest rest))
|
|
(if (pair? rest)
|
|
(let ((next (car rest))
|
|
(rest (cdr rest)))
|
|
(set-cdr! tail-cons next)
|
|
(lp2 (if (pair? next) (last-pair next) tail-cons)
|
|
rest))
|
|
first)))))))
|
|
|
|
|
|
;;(define (append-reverse rev-head tail) (fold cons tail rev-head))
|
|
|
|
;;(define (append-reverse! rev-head tail)
|
|
;; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair)
|
|
;; tail
|
|
;; rev-head))
|
|
|
|
;; Hand-inline the FOLD and PAIR-FOLD ops for speed.
|
|
|
|
(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)))))
|
|
|
|
|
|
(define (concatenate lists) (reduce-right append '() lists))
|
|
(define (concatenate! lists) (reduce-right my-append! '() lists))
|
|
|
|
(define (my-reverse! lis)
|
|
(let lp ((lis lis) (ans '()))
|
|
(if (null-list? lis) ans
|
|
(let ((tail (cdr lis)))
|
|
(set-cdr! lis ans)
|
|
(lp tail lis)))))
|
|
|
|
)
|
|
;;; misc.ss ends here
|