2007-05-05 05:22:15 -04:00
|
|
|
|
|
|
|
(library (ikarus lists)
|
2007-05-05 05:29:35 -04:00
|
|
|
(export $memq list? length list-ref reverse last-pair
|
2007-05-05 05:31:30 -04:00
|
|
|
memq memv member assq assv assoc)
|
2007-05-05 05:24:37 -04:00
|
|
|
(import
|
2007-05-05 05:29:35 -04:00
|
|
|
(only (scheme) $car $cdr $fx+ $fxsub1 $fxzero? $fx>=)
|
2007-05-05 05:24:37 -04:00
|
|
|
|
2007-05-05 05:31:30 -04:00
|
|
|
(except (ikarus) list? reverse last-pair length list-ref
|
|
|
|
memq memv member assq assv assoc))
|
2007-05-05 05:22:15 -04:00
|
|
|
|
|
|
|
(define $memq
|
|
|
|
(lambda (x ls)
|
|
|
|
(let f ([x x] [ls ls])
|
|
|
|
(and (pair? ls)
|
|
|
|
(if (eq? x (car ls))
|
|
|
|
ls
|
|
|
|
(f x (cdr ls)))))))
|
2007-05-05 05:24:37 -04:00
|
|
|
|
|
|
|
(define list?
|
|
|
|
(letrec ([race
|
|
|
|
(lambda (h t)
|
|
|
|
(if (pair? h)
|
|
|
|
(let ([h ($cdr h)])
|
|
|
|
(if (pair? h)
|
|
|
|
(and (not (eq? h t))
|
|
|
|
(race ($cdr h) ($cdr t)))
|
|
|
|
(null? h)))
|
|
|
|
(null? h)))])
|
|
|
|
(lambda (x) (race x x))))
|
|
|
|
|
2007-05-05 05:29:35 -04:00
|
|
|
(define length
|
|
|
|
(letrec ([race
|
|
|
|
(lambda (h t ls n)
|
|
|
|
(if (pair? h)
|
|
|
|
(let ([h ($cdr h)])
|
|
|
|
(if (pair? h)
|
|
|
|
(if (not (eq? h t))
|
|
|
|
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
|
|
|
|
(error 'length "circular list ~s" ls))
|
|
|
|
(if (null? h)
|
|
|
|
($fx+ n 1)
|
|
|
|
(error 'length "~s is not a proper list" ls))))
|
|
|
|
(if (null? h)
|
|
|
|
n
|
|
|
|
(error 'length "~s is not a proper list" ls))))])
|
|
|
|
(lambda (ls)
|
|
|
|
(race ls ls ls 0))))
|
|
|
|
|
|
|
|
(define list-ref
|
|
|
|
(lambda (list index)
|
|
|
|
(define f
|
|
|
|
(lambda (ls i)
|
|
|
|
(cond
|
|
|
|
[($fxzero? i)
|
|
|
|
(if (pair? ls)
|
|
|
|
($car ls)
|
|
|
|
(error 'list-ref "index ~s is out of range for ~s" index list))]
|
|
|
|
[(pair? ls)
|
|
|
|
(f ($cdr ls) ($fxsub1 i))]
|
|
|
|
[(null? ls)
|
|
|
|
(error 'list-rec "index ~s is out of range for ~s" index list)]
|
|
|
|
[else (error 'list-ref "~s is not a list" list)])))
|
|
|
|
(unless (and (fixnum? index) ($fx>= index 0))
|
|
|
|
(error 'list-ref "~s is not a valid index" index))
|
|
|
|
(f list index)))
|
|
|
|
|
2007-05-05 05:24:37 -04:00
|
|
|
(define reverse
|
|
|
|
(letrec ([race
|
|
|
|
(lambda (h t ls ac)
|
|
|
|
(if (pair? h)
|
|
|
|
(let ([h ($cdr h)] [ac (cons ($car h) ac)])
|
|
|
|
(if (pair? h)
|
|
|
|
(if (not (eq? h t))
|
|
|
|
(race ($cdr h) ($cdr t) ls (cons ($car h) ac))
|
|
|
|
(error 'reverse "~s is a circular list" ls))
|
|
|
|
(if (null? h)
|
|
|
|
ac
|
|
|
|
(error 'reverse "~s is not a proper list" ls))))
|
|
|
|
(if (null? h)
|
|
|
|
ac
|
|
|
|
(error 'reverse "~s is not a proper list" ls))))])
|
|
|
|
(lambda (x)
|
|
|
|
(race x x x '()))))
|
|
|
|
|
|
|
|
(define last-pair
|
|
|
|
(letrec ([race
|
|
|
|
(lambda (h t ls last)
|
|
|
|
(if (pair? h)
|
|
|
|
(let ([h ($cdr h)] [last h])
|
|
|
|
(if (pair? h)
|
|
|
|
(if (not (eq? h t))
|
|
|
|
(race ($cdr h) ($cdr t) ls h)
|
|
|
|
(error 'last-pair "~s is a circular list" ls))
|
|
|
|
last))
|
|
|
|
last))])
|
|
|
|
(lambda (x)
|
|
|
|
(if (pair? x)
|
|
|
|
(let ([d (cdr x)])
|
|
|
|
(race d d x x))
|
|
|
|
(error 'last-pair "~s is not a pair" x)))))
|
|
|
|
|
2007-05-05 05:26:38 -04:00
|
|
|
(define memq
|
|
|
|
(letrec ([race
|
|
|
|
(lambda (h t ls x)
|
|
|
|
(if (pair? h)
|
|
|
|
(if (eq? ($car h) x)
|
|
|
|
h
|
|
|
|
(let ([h ($cdr h)])
|
|
|
|
(if (pair? h)
|
|
|
|
(if (eq? ($car h) x)
|
|
|
|
h
|
|
|
|
(if (not (eq? h t))
|
|
|
|
(race ($cdr h) ($cdr t) ls x)
|
|
|
|
(error 'memq "circular list ~s" ls)))
|
|
|
|
(if (null? h)
|
|
|
|
'#f
|
|
|
|
(error 'memq "~s is not a proper list" ls)))))
|
|
|
|
(if (null? h)
|
|
|
|
'#f
|
|
|
|
(error 'memq "~s is not a proper list" ls))))])
|
|
|
|
(lambda (x ls)
|
|
|
|
(race ls ls ls x))))
|
|
|
|
|
|
|
|
(define memv
|
|
|
|
(letrec ([race
|
|
|
|
(lambda (h t ls x)
|
|
|
|
(if (pair? h)
|
|
|
|
(if (eqv? ($car h) x)
|
|
|
|
h
|
|
|
|
(let ([h ($cdr h)])
|
|
|
|
(if (pair? h)
|
|
|
|
(if (eqv? ($car h) x)
|
|
|
|
h
|
|
|
|
(if (not (eq? h t))
|
|
|
|
(race ($cdr h) ($cdr t) ls x)
|
|
|
|
(error 'memv "circular list ~s" ls)))
|
|
|
|
(if (null? h)
|
|
|
|
'#f
|
|
|
|
(error 'memv "~s is not a proper list" ls)))))
|
|
|
|
(if (null? h)
|
|
|
|
'#f
|
|
|
|
(error 'memv "~s is not a proper list" ls))))])
|
|
|
|
(lambda (x ls)
|
|
|
|
(race ls ls ls x))))
|
2007-05-05 05:22:15 -04:00
|
|
|
|
2007-05-05 05:26:38 -04:00
|
|
|
(define member
|
|
|
|
(letrec ([race
|
|
|
|
(lambda (h t ls x)
|
|
|
|
(if (pair? h)
|
|
|
|
(if (equal? ($car h) x)
|
|
|
|
h
|
|
|
|
(let ([h ($cdr h)])
|
|
|
|
(if (pair? h)
|
|
|
|
(if (equal? ($car h) x)
|
|
|
|
h
|
|
|
|
(if (not (eq? h t))
|
|
|
|
(race ($cdr h) ($cdr t) ls x)
|
|
|
|
(error 'member "circular list ~s" ls)))
|
|
|
|
(if (null? h)
|
|
|
|
'#f
|
|
|
|
(error 'member "~s is not a proper list" ls)))))
|
|
|
|
(if (null? h)
|
|
|
|
'#f
|
|
|
|
(error 'member "~s is not a proper list" ls))))])
|
|
|
|
(lambda (x ls)
|
|
|
|
(race ls ls ls x))))
|
|
|
|
|
2007-05-05 05:31:30 -04:00
|
|
|
(define assq
|
|
|
|
(letrec ([race
|
|
|
|
(lambda (x h t ls)
|
|
|
|
(if (pair? h)
|
|
|
|
(let ([a ($car h)] [h ($cdr h)])
|
|
|
|
(if (pair? a)
|
|
|
|
(if (eq? ($car a) x)
|
|
|
|
a
|
|
|
|
(if (pair? h)
|
|
|
|
(if (not (eq? h t))
|
|
|
|
(let ([a ($car h)])
|
|
|
|
(if (pair? a)
|
|
|
|
(if (eq? ($car a) x)
|
|
|
|
a
|
|
|
|
(race x ($cdr h) ($cdr t) ls))
|
|
|
|
(error 'assq "malformed alist ~s"
|
|
|
|
ls)))
|
|
|
|
(error 'assq "circular list ~s" ls))
|
|
|
|
(if (null? h)
|
|
|
|
#f
|
|
|
|
(error 'assq "~s is not a proper list" ls))))
|
|
|
|
(error 'assq "malformed alist ~s" ls)))
|
|
|
|
(if (null? h)
|
|
|
|
#f
|
|
|
|
(error 'assq "~s is not a proper list" ls))))])
|
|
|
|
(lambda (x ls)
|
|
|
|
(race x ls ls ls))))
|
|
|
|
|
|
|
|
(define assv
|
|
|
|
(letrec ([race
|
|
|
|
(lambda (x h t ls)
|
|
|
|
(if (pair? h)
|
|
|
|
(let ([a ($car h)] [h ($cdr h)])
|
|
|
|
(if (pair? a)
|
|
|
|
(if (eqv? ($car a) x)
|
|
|
|
a
|
|
|
|
(if (pair? h)
|
|
|
|
(if (not (eq? h t))
|
|
|
|
(let ([a ($car h)])
|
|
|
|
(if (pair? a)
|
|
|
|
(if (eqv? ($car a) x)
|
|
|
|
a
|
|
|
|
(race x ($cdr h) ($cdr t) ls))
|
|
|
|
(error 'assv "malformed alist ~s"
|
|
|
|
ls)))
|
|
|
|
(error 'assv "circular list ~s" ls))
|
|
|
|
(if (null? h)
|
|
|
|
#f
|
|
|
|
(error 'assv "~s is not a proper list" ls))))
|
|
|
|
(error 'assv "malformed alist ~s" ls)))
|
|
|
|
(if (null? h)
|
|
|
|
#f
|
|
|
|
(error 'assv "~s is not a proper list" ls))))])
|
|
|
|
(lambda (x ls)
|
|
|
|
(race x ls ls ls))))
|
|
|
|
|
|
|
|
(define assoc
|
|
|
|
(letrec ([race
|
|
|
|
(lambda (x h t ls)
|
|
|
|
(if (pair? h)
|
|
|
|
(let ([a ($car h)] [h ($cdr h)])
|
|
|
|
(if (pair? a)
|
|
|
|
(if (equal? ($car a) x)
|
|
|
|
a
|
|
|
|
(if (pair? h)
|
|
|
|
(if (not (eq? h t))
|
|
|
|
(let ([a ($car h)])
|
|
|
|
(if (pair? a)
|
|
|
|
(if (equal? ($car a) x)
|
|
|
|
a
|
|
|
|
(race x ($cdr h) ($cdr t) ls))
|
|
|
|
(error 'assoc "malformed alist ~s"
|
|
|
|
ls)))
|
|
|
|
(error 'assoc "circular list ~s" ls))
|
|
|
|
(if (null? h)
|
|
|
|
#f
|
|
|
|
(error 'assoc "~s is not a proper list" ls))))
|
|
|
|
(error 'assoc "malformed alist ~s" ls)))
|
|
|
|
(if (null? h)
|
|
|
|
#f
|
|
|
|
(error 'assoc "~s is not a proper list" ls))))])
|
|
|
|
(lambda (x ls)
|
|
|
|
(race x ls ls ls))))
|
2007-05-05 05:29:35 -04:00
|
|
|
|
|
|
|
|
2007-05-05 05:22:15 -04:00
|
|
|
)
|
|
|
|
|