;; -*-theme-d-*-

;; Copyright (C) 2008-2025 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.

(define-body (standard-library list-utilities)
  
  (import (standard-library dynamic-list))
  
  (define-param-method uniform-list-ref (%type)
      (((l (:uniform-list %type))
        (i <integer>))
       %type pure)
    (cond
     ((= i 0)
      (match-type l
        ((<null>) (raise-simple 'uniform-list-ref:index-out-of-range))
        ((l1 (:nonempty-uniform-list %type))
         (car l1))))
     ((> i 0)
      (match-type l
        ((<null>) (raise-simple 'uniform-list-ref:index-out-of-range))
        ((l1 (:nonempty-uniform-list %type))
         (uniform-list-ref (cdr l1) (- i 1)))))
     (else (raise-simple 'uniform-list-ref:invalid-index))))
  
  (define-simple-method length (((l (:uniform-list <object>)))
                                <integer> pure)
    (match-type l
      ((<null>) 0)
      ((l1 (:nonempty-uniform-list <object>))
       (+ 1 (length (cdr l1))))))
  
  (define-param-method caar (%type)
      (((x (:pair (:pair %type <object>) <object>)))
       %type pure)
    (car (car x)))
  
  (define-param-method cadr (%type)
      (((x (:pair <object> (:pair %type <object>))))
       %type pure)
    (car (cdr x)))
  
  (define-param-method cdar (%type)
      (((x (:pair (:pair <object> %type) <object>)))
       %type pure)
    (cdr (car x)))
  
  (define-param-method cddr (%type)
      (((x (:pair <object> (:pair <object> %type))))
       %type pure)
    (cdr (cdr x)))
  
  (define-param-method caddr (%type)
      (((x (:pair <object> (:pair <object>
                                  (:pair %type <object>)))))
       %type pure)
    (car (cdr (cdr x))))
  
  (define-param-method cdddr (%type)
      (((x (:pair <object> (:pair <object>
                                  (:pair <object> %type)))))
       %type pure)
    (cdr (cdr (cdr x))))
  
  (define-param-method cadddr (%type)
      (((x (:pair <object>
                  (:pair <object>
                         (:pair <object>
                                (:pair %type <object>))))))
       %type pure)
    (car (cdr (cdr (cdr x)))))
  
  (define-param-method head (%type)
      (((l (:uniform-list %type))) %type pure)
    (match-type l
      ((<null>)
       (raise-simple 'head:empty-list))
      ((l1 (:nonempty-uniform-list %type))
       (car l1))))

  (define-param-method tail (%type)
      (((l (:uniform-list %type))) (:uniform-list %type) pure)
    (match-type l
      ((<null>)
       (raise-simple 'tail:empty-list))
      ((l1 (:nonempty-uniform-list %type))
       (cdr l1))))

  (define-param-method make-list (%type)
      (((i-len <integer>) (x %type)) (:uniform-list %type) pure)
    (assert (>= i-len 0))
    (if (equal? i-len 0)
        null
        (cons x (make-list (- i-len 1) x))))
        
  (define-param-method append (%types)
      (((l-l (splice (type-loop %type %types
                                (:uniform-list %type)))))
       (:uniform-list (:union (splice %types)))
       pure)
    (cast (:uniform-list (:union (splice %types))) (d-append0 l-l)))
  
  (define-param-method append-tuples (%tuples)
      (((l-l (splice %tuples)))
       (join-tuple-types (splice %tuples))
       pure)
    (cast (join-tuple-types (splice %tuples)) (d-append0 l-l)))
  
  (define-param-method append-uniform2 (%type)
      (((l1 (:uniform-list %type))
        (l2 (:uniform-list %type)))
       (:uniform-list %type)
       pure)
    (match-type l1
      ((<null>) l2)
      ((l1a (:nonempty-uniform-list %type))
       (cons (car l1a) (append-uniform2 (cdr l1a) l2)))))
  
  (define-param-method append-uniform0 (%type)
      (((l (:uniform-list (:uniform-list %type))))
       (:uniform-list %type)
       pure)
    (match-type l
      ((<null>) null)
      ((l1 (:nonempty-uniform-list (:uniform-list %type)))
       (append-uniform2 (car l1) (append-uniform0 (cdr l1))))))
  
  (define-param-method append-uniform (%type)
      (((l (rest (:uniform-list %type))))
       (:uniform-list %type)
       pure)
    (append-uniform0 l))
  
  (add-param-method-alt reverse (%type)
    (unchecked-prim-proc reverse ((:uniform-list %type))
                         (:uniform-list %type) pure))

  (define-param-method map1
      (%argtype %result-type)
      (((proc (:procedure (%argtype) %result-type pure))
        (lst (:uniform-list %argtype)))
       (:uniform-list %result-type)
       pure (optimize-proc-arg proc))
    (match-type lst
      ((<null>) null)
      ((lst1 (:nonempty-uniform-list %argtype))
       (cons (proc (car lst1))
             (map1 proc (cdr lst1))))))
  
  
  (define-param-method map-nonpure1
      (%argtype %result-type)
      (((proc (:procedure (%argtype) %result-type nonpure))
        (lst (:uniform-list %argtype)))
       (:uniform-list %result-type)
       nonpure (optimize-proc-arg proc))
    (match-type lst
      ((<null>) null)
      ((lst1 (:nonempty-uniform-list %argtype))
       (cons (proc (car lst1))
             (map-nonpure1 proc (cdr lst1))))))
  
  
  (define-param-method for-each1
      (%argtype)
      (((proc (:procedure (%argtype) <none> nonpure))
        (lst (:uniform-list %argtype)))
       <none>
       nonpure (optimize-proc-arg proc))
    (match-type lst
      ((<null>) null)
      ((lst1 (:nonempty-uniform-list %argtype))
       (proc (car lst1))
       (for-each1 proc (cdr lst1)))))
  
  
  (define-param-method for-all1? (%type)
      (((proc (:procedure (%type) <boolean> pure))
        (lst (:uniform-list %type)))
       <boolean>
       pure (optimize-proc-arg proc))
    (match-type lst
      ((<null>) #t)
      ((lst1 (:nonempty-uniform-list %type))
       (and (proc (car lst1))
            (for-all1? proc (cdr lst1))))))
  
  
  (define-param-method exists1? (%type)
      (((proc (:procedure (%type) <boolean> pure))
        (lst (:uniform-list %type)))
       <boolean>
       pure (optimize-proc-arg proc))
    (match-type lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (or (proc (car lst1))
           (exists1? proc (cdr lst1))))))
  
  
  (define-simple-method map-car0
      (((lists (:uniform-list <nonempty-list>)))
       <list>
       pure)
    (match-type lists
      ((<null>) null)
      ((lists1 (:nonempty-uniform-list <nonempty-list>))
       (cons (car (car lists1))
             (map-car0 (cdr lists1))))))
  
  
  (define-param-method map-car (%arglist)
      (((lists (type-loop %type %arglist (:nonempty-uniform-list %type))))
       %arglist
       pure)
    (cast %arglist (map-car0 lists)))
  
  
  
  (define-simple-method map-cdr0
      (((lists (:uniform-list <nonempty-list>)))
       <list>
       pure)
    (match-type lists
      ((<null>) null)
      ((lists1 (:nonempty-uniform-list <nonempty-list>))
       (cons (cdr (car lists1))
             (map-cdr0 (cdr lists1))))))
  
  
  (define-param-method map-cdr (%arglist)
      (((lists (type-loop %type %arglist (:nonempty-uniform-list %type))))
       (type-loop %type %arglist (:uniform-list %type))
       pure)
    (cast (type-loop %type %arglist (:uniform-list %type))
          (map-cdr0 lists)))
  
  
  (define-param-method map0
      (%arglist %result-type)
      (((proc (:procedure ((splice %arglist)) %result-type pure))
        (lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       (:uniform-list %result-type)
       pure (optimize-proc-arg proc))
    (match-type lists
      ((lists1 (type-loop %argtype %arglist (:nonempty-uniform-list %argtype))) 
       (let ((cars (map-car lists1))
             (cdrs (map-cdr lists1)))
         (cons
          (apply proc cars)
          (map0 proc cdrs))))
      (else null)))
  
  
  (define-param-method map
      (%arglist %result-type)
      (((proc (:procedure ((splice %arglist)) %result-type pure))
        (lists (splice (type-loop %argtype %arglist
                                  (:uniform-list %argtype)))))
       (:uniform-list %result-type)
       pure (optimize-proc-arg proc))
    (map0 proc lists))
  
  
  (define-param-method map-nonpure0
      (%arglist %result-type)
      (((proc (:procedure ((splice %arglist)) %result-type nonpure))
        (lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       (:uniform-list %result-type)
       nonpure (optimize-proc-arg proc))
    (match-type lists
      ((lists1 (type-loop %argtype %arglist (:nonempty-uniform-list %argtype))) 
       (let ((cars (map-car lists1))
             (cdrs (map-cdr lists1)))
         (cons
          (apply-nonpure proc cars)
          (map-nonpure0 proc cdrs))))
      (else null)))
  
  
  (define-param-method map-nonpure
      (%arglist %result-type)
      (((proc (:procedure ((splice %arglist)) %result-type nonpure))
        (lists (splice (type-loop %argtype %arglist
                                  (:uniform-list %argtype)))))
       (:uniform-list %result-type)
       nonpure (optimize-proc-arg proc))
    (map-nonpure0 proc lists))
  
  
  (define-param-method for-each0
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <none> nonpure))
        (lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       <none>
       nonpure (optimize-proc-arg proc))
    (match-type lists
      ((lists1 (type-loop %argtype %arglist (:nonempty-uniform-list %argtype))) 
       (let ((cars (map-car lists1))
             (cdrs (map-cdr lists1)))
         (apply-nonpure proc cars)
         (for-each0 proc cdrs)))
      (else null)))
  
  
  (define-param-method for-each
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <none> nonpure))
        (lists (splice (type-loop %argtype %arglist
                                  (:uniform-list %argtype)))))
       <none>
       nonpure (optimize-proc-arg proc))
    (for-each0 proc lists))
  
  
  (define-param-method for-all0?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> pure))
        (lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       <boolean>
       pure (optimize-proc-arg proc))
    (match-type lists
      ((lists1 (type-loop %argtype %arglist (:nonempty-uniform-list %argtype))) 
       (let ((cars (map-car lists1))
             (cdrs (map-cdr lists1)))
         (and
          (apply proc cars)
          (for-all0? proc cdrs))))
      (else #t)))
  
  
  (define-param-method for-all?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> pure))
        (lists (splice (type-loop %argtype %arglist
                                  (:uniform-list %argtype)))))
       <boolean>
       pure (optimize-proc-arg proc))
    (for-all0? proc lists))
  
  
  (define-param-method exists0?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> pure))
        (lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       <boolean>
       pure (optimize-proc-arg proc))
    (match-type lists
      ((lists1 (type-loop %argtype %arglist (:nonempty-uniform-list %argtype))) 
       (let ((cars (map-car lists1))
             (cdrs (map-cdr lists1)))
         (or
          (apply proc cars)
          (exists0? proc cdrs))))
      (else #f)))
  
  
  (define-param-method exists?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> pure))
        (lists (splice (type-loop %argtype %arglist
                                  (:uniform-list %argtype)))))
       <boolean>
       pure (optimize-proc-arg proc))
    (exists0? proc lists))
  
  (define-param-method for-all-nonpure0?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> nonpure))
        (lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       <boolean>
       nonpure (optimize-proc-arg proc))
    (match-type lists
      ((lists1 (type-loop %argtype %arglist (:nonempty-uniform-list %argtype))) 
       (let ((cars (map-car lists1))
             (cdrs (map-cdr lists1)))
         (and
          (apply-nonpure proc cars)
          (for-all-nonpure0? proc cdrs))))
      (else #t)))
  
  (define-param-method for-all-nonpure1? (%type)
      (((proc (:procedure (%type) <boolean> nonpure))
        (lst (:uniform-list %type)))
       <boolean>
       nonpure (optimize-proc-arg proc))
    (match-type lst
      ((<null>) #t)
      ((lst1 (:nonempty-uniform-list %type))
       (and (proc (car lst1))
            (for-all-nonpure1? proc (cdr lst1))))))
  
  (define-param-method for-all-nonpure?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> nonpure))
        (lists (splice (type-loop %argtype %arglist
                                  (:uniform-list %argtype)))))
       <boolean>
       nonpure (optimize-proc-arg proc))
    (for-all-nonpure0? proc lists))
  
  (define-param-method exists-nonpure0?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> nonpure))
        (lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       <boolean>
       nonpure (optimize-proc-arg proc))
    (match-type lists
      ((lists1 (type-loop %argtype %arglist (:nonempty-uniform-list %argtype))) 
       (let ((cars (map-car lists1))
             (cdrs (map-cdr lists1)))
         (or
          (apply-nonpure proc cars)
          (exists-nonpure0? proc cdrs))))
      (else #f)))
  
  (define-param-method exists-nonpure1? (%type)
      (((proc (:procedure (%type) <boolean> nonpure))
        (lst (:uniform-list %type)))
       <boolean>
       nonpure (optimize-proc-arg proc))
    (match-type lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (or (proc (car lst1))
           (exists-nonpure1? proc (cdr lst1))))))
  
  (define-param-method exists-nonpure?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> nonpure))
        (lists (splice (type-loop %argtype %arglist
                                  (:uniform-list %argtype)))))
       <boolean>
       nonpure (optimize-proc-arg proc))
    (exists-nonpure0? proc lists))
  
  (define-param-method map2 (%arg1 %arg2 %result)
      (((proc (:procedure (%arg1 %arg2) %result pure))
        (l1 (:uniform-list %arg1))
        (l2 (:uniform-list %arg2)))
       (:uniform-list %result)
       pure (optimize-proc-arg proc))
    (match-type l1
      ((<null>) null)
      ((l1a (:nonempty-uniform-list %arg1))
       (match-type l2
         ((<null>) null)
         ((l2a (:nonempty-uniform-list %arg2))
          (cons (proc (car l1a) (car l2a))
                (map2 proc (cdr l1a) (cdr l2a))))))))
  
  (define-param-method map-nonpure2 (%arg1 %arg2 %result)
      (((proc (:procedure (%arg1 %arg2) %result nonpure))
        (l1 (:uniform-list %arg1))
        (l2 (:uniform-list %arg2)))
       (:uniform-list %result)
       nonpure (optimize-proc-arg proc))
    (match-type l1
      ((<null>) null)
      ((l1a (:nonempty-uniform-list %arg1))
       (match-type l2
         ((<null>) null)
         ((l2a (:nonempty-uniform-list %arg2))
          (cons (proc (car l1a) (car l2a))
                (map-nonpure2 proc (cdr l1a) (cdr l2a))))))))
  
  (define-param-method for-each2 (%arg1 %arg2)
      (((proc (:procedure (%arg1 %arg2) <none> nonpure))
        (l1 (:uniform-list %arg1))
        (l2 (:uniform-list %arg2)))
       <none>
       nonpure (optimize-proc-arg proc))
    (match-type l1
      ((<null>) null)
      ((l1a (:nonempty-uniform-list %arg1))
       (match-type l2
         ((<null>) null)
         ((l2a (:nonempty-uniform-list %arg2))
          (begin (proc (car l1a) (car l2a))
                 (for-each2 proc (cdr l1a) (cdr l2a))))))))
  
  (define-param-method for-all2? (%arg1 %arg2)
      (((pred (:procedure (%arg1 %arg2) <boolean> pure))
        (l1 (:uniform-list %arg1))
        (l2 (:uniform-list %arg2)))
       <boolean>
       pure (optimize-proc-arg pred))
    (match-type l1
      ((<null>) #t)
      ((l1a (:nonempty-uniform-list %arg1))
       (match-type l2
         ((<null>) #t)
         ((l2a (:nonempty-uniform-list %arg2))
          (and (pred (car l1a) (car l2a))
               (for-all2? pred (cdr l1a) (cdr l2a))))))))
  
  (define-param-method for-all-nonpure2? (%arg1 %arg2)
      (((pred (:procedure (%arg1 %arg2) <boolean> nonpure))
        (l1 (:uniform-list %arg1))
        (l2 (:uniform-list %arg2)))
       <boolean>
       nonpure (optimize-proc-arg pred))
    (match-type l1
      ((<null>) #t)
      ((l1a (:nonempty-uniform-list %arg1))
       (match-type l2
         ((<null>) #t)
         ((l2a (:nonempty-uniform-list %arg2))
          (and (pred (car l1a) (car l2a))
               (for-all-nonpure2? pred (cdr l1a) (cdr l2a))))))))
  
  (define-param-method exists2? (%arg1 %arg2)
      (((pred (:procedure (%arg1 %arg2) <boolean> pure))
        (l1 (:uniform-list %arg1))
        (l2 (:uniform-list %arg2)))
       <boolean>
       pure (optimize-proc-arg pred))
    (match-type l1
      ((<null>) #f)
      ((l1a (:nonempty-uniform-list %arg1))
       (match-type l2
         ((<null>) #f)
         ((l2a (:nonempty-uniform-list %arg2))
          (or (pred (car l1a) (car l2a))
              (exists2? pred (cdr l1a) (cdr l2a))))))))
  
  (define-param-method exists-nonpure2? (%arg1 %arg2)
      (((pred (:procedure (%arg1 %arg2) <boolean> nonpure))
        (l1 (:uniform-list %arg1))
        (l2 (:uniform-list %arg2)))
       <boolean>
       nonpure (optimize-proc-arg pred))
    (match-type l1
      ((<null>) #f)
      ((l1a (:nonempty-uniform-list %arg1))
       (match-type l2
         ((<null>) #f)
         ((l2a (:nonempty-uniform-list %arg2))
          (or (pred (car l1a) (car l2a))
              (exists-nonpure2? pred (cdr l1a) (cdr l2a))))))))
  
  (define-param-method member-general?
      (%type)
      (((obj %type)
        (lst (:uniform-list %type))
        (my-eq? (:procedure (%type %type) <boolean> pure)))
       <boolean> pure (optimize-proc-arg my-eq?))
    (match-type lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (if (my-eq? obj (car lst1))
           #t
           (member-general? obj (cdr lst1) my-eq?)))))
  
  
  (define-param-method member-values?
      (%type)
      (((obj %type)
        (lst (:uniform-list %type)))
       <boolean> pure)
    (match-type lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (if (equal-values? obj (car lst1))
           #t
           (member-values? obj (cdr lst1))))))
  
  
  (define-param-method member-objects?
      (%type)
      (((obj %type)
        (lst (:uniform-list %type)))
       <boolean> pure)
    (match-type lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (if (equal-objects? obj (car lst1))
           #t
           (member-objects? obj (cdr lst1))))))
  
  
  (define-param-method member-contents?
      (%type)
      (((obj %type)
        (lst (:uniform-list %type)))
       <boolean> pure)
    (match-type lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (if (equal-contents? obj (car lst1))
           #t
           (member-contents? obj (cdr lst1))))))
  
  
  (define-param-method assoc-general
      (%type1 %type2 %default)
      (((key %type1)
        (lst (:alist %type1 %type2))
        (x-default %default)
        (my-eq? (:procedure (%type1 %type1) <boolean> pure)))
       (:union (:pair %type1 %type2) %default)
       pure (optimize-proc-arg my-eq?))
    (match-type lst
      ((<null>) x-default)
      ((lst1 (:nonempty-uniform-list (:pair %type1 %type2)))
       (let ((x-hd (car lst1))
             (x-tl (cdr lst1)))
         (if (my-eq? key (car x-hd))
             x-hd
             (assoc-general key x-tl x-default my-eq?))))))
  
  
  (define-param-method assoc
      (%type1 %type2 %default)
      (((key %type1)
        (lst (:alist %type1 %type2))
        (x-default %default))
       (:union (:pair %type1 %type2) %default)
       pure)
    (match-type lst
      ((<null>) x-default)
      ((lst1 (:nonempty-uniform-list (:pair %type1 %type2)))
       (let ((x-hd (car lst1))
             (x-tl (cdr lst1)))
         (if (equal? key (car x-hd))
             x-hd
             (assoc key x-tl x-default))))))
  
  
  (define-param-method assoc-values
      (%type1 %type2 %default)
      (((key %type1)
        (lst (:alist %type1 %type2))
        (x-default %default))
       (:union (:pair %type1 %type2) %default)
       pure)
    (match-type lst
      ((<null>) x-default)
      ((lst1 (:nonempty-uniform-list (:pair %type1 %type2)))
       (let ((x-hd (car lst1))
             (x-tl (cdr lst1)))
         (if (equal-values? key (car x-hd))
             x-hd
             (assoc-values key x-tl x-default))))))
  
  
  (define-param-method assoc-objects
      (%type1 %type2 %default)
      (((key %type1)
        (lst (:alist %type1 %type2))
        (x-default %default))
       (:union (:pair %type1 %type2) %default)
       pure)
    (match-type lst
      ((<null>) x-default)
      ((lst1 (:nonempty-uniform-list (:pair %type1 %type2)))
       (let ((x-hd (car lst1))
             (x-tl (cdr lst1)))
         (if (equal-objects? key (car x-hd))
             x-hd
             (assoc-objects key x-tl x-default))))))
  
  
  (define-param-method assoc-contents
      (%type1 %type2 %default)
      (((key %type1)
        (lst (:alist %type1 %type2))
        (x-default %default))
       (:union (:pair %type1 %type2) %default)
       pure)
    (match-type lst
      ((<null>) x-default)
      ((lst1 (:nonempty-uniform-list (:pair %type1 %type2)))
       (let ((x-hd (car lst1))
             (x-tl (cdr lst1)))
         (if (equal-contents? key (car x-hd))
             x-hd
             (assoc-contents key x-tl x-default))))))
  
  
  (define-param-method general-alist-delete (%key %value)
      (((x-key %key)
        (al (:alist %key %value))
        (pc-eq (:procedure (%key %key) <boolean> pure)))
       (:alist %key %value)
       pure (optimize-proc-arg pc-eq))
    (match-type al
      ((<null>) '())
      ((al1 (:nonempty-alist %key %value))
       (if (pc-eq (car (car al1)) x-key)
           (general-alist-delete x-key (cdr al1) pc-eq)
           (cons (car al1)
                 (general-alist-delete x-key (cdr al1) pc-eq))))))
  
  
  (define-param-method alist-delete (%key %value)
      (((x-key %key)
        (al (:alist %key %value)))
       (:alist %key %value)
       pure)
    (match-type al
      ((<null>) '())
      ((al1 (:nonempty-alist %key %value))
       (if (equal? (car (car al1)) x-key)
           (alist-delete x-key (cdr al1))
           (cons (car al1)
                 (alist-delete x-key (cdr al1)))))))
  
  
  (define-param-method value-alist-delete (%key %value)
      (((x-key %key)
        (al (:alist %key %value)))
       (:alist %key %value)
       pure)
    (match-type al
      ((<null>) '())
      ((al1 (:nonempty-alist %key %value))
       (if (equal-values? (car (car al1)) x-key)
           (value-alist-delete x-key (cdr al1))
           (cons (car al1)
                 (value-alist-delete x-key (cdr al1)))))))
  
  
  (define-param-method object-alist-delete (%key %value)
      (((x-key %key)
        (al (:alist %key %value)))
       (:alist %key %value)
       pure)
    (match-type al
      ((<null>) '())
      ((al1 (:nonempty-alist %key %value))
       (if (equal-objects? (car (car al1)) x-key)
           (object-alist-delete x-key (cdr al1))
           (cons (car al1)
                 (object-alist-delete x-key (cdr al1)))))))
  
  
  (define-param-method content-alist-delete (%key %value)
      (((x-key %key)
        (al (:alist %key %value)))
       (:alist %key %value)
       pure)
    (match-type al
      ((<null>) '())
      ((al1 (:nonempty-alist %key %value))
       (if (equal-contents? (car (car al1)) x-key)
           (content-alist-delete x-key (cdr al1))
           (cons (car al1)
                 (content-alist-delete x-key (cdr al1)))))))
  
  
  (define-param-method take (%type)
      (((lst (:uniform-list %type)) (i-count <integer>))
       (:uniform-list %type)
       pure)
    (cond
     ((< i-count 0)
      (raise-simple 'take:invalid-count))
     ((equal? i-count 0) null)
     (else
      (match-type lst
        ((<null>)
         (raise-simple 'take:invalid-list))
        ((lst1 (:nonempty-uniform-list %type))
         (cons (car lst1) (take (cdr lst1) (- i-count 1))))))))
  
  
  (define-param-method drop (%type)
      (((lst (:uniform-list %type)) (i-count <integer>))
       (:uniform-list %type)
       pure)
    (cond
     ((< i-count 0)
      (raise-simple 'drop:invalid-count))
     ((equal? i-count 0) lst)
     (else
      (match-type lst
        ((<null>)
         (raise-simple 'drop:invalid-list))
        ((lst1 (:nonempty-uniform-list %type))
         (drop (cdr lst1) (- i-count 1)))))))
  
  
  (define-param-method take-right0 (%type)
      (((lst (:uniform-list %type)) (i-count <integer>)
                                    (i-len <integer>))
       (:uniform-list %type)
       pure)
    (cond
     ((< i-count 0)
      (raise-simple 'take-right0:invalid-count))
     ((< i-len 0)
      (raise-simple 'take-right0:invalid-length))
     ((< i-len i-count)
      (raise-simple 'take-right0:index-out-of-range))
     ((equal? i-count i-len) lst)
     (else
      (match-type lst
        ((<null>)
         (raise-simple 'take-right0:internal-error))
        ((lst1 (:nonempty-uniform-list %type))
         (take-right0 (cdr lst1) i-count (- i-len 1)))))))
  
  
  (define-param-method take-right (%type)
      (((lst (:uniform-list %type)) (i-count <integer>))
       (:uniform-list %type)
       pure)
    (take-right0 lst i-count (length lst)))
  
  
  (define-param-method drop-right0 (%type)
      (((lst (:uniform-list %type)) (i-count <integer>)
                                    (i-len <integer>))
       (:uniform-list %type)
       pure)
    (cond
     ((< i-count 0)
      (raise-simple 'drop-right0:invalid-count))
     ((< i-len 0)
      (raise-simple 'drop-right0:invalid-length))
     ((< i-len i-count)
      (raise-simple 'drop-right0:index-out-of-range))
     ((equal? i-count i-len) null)
     (else
      (match-type lst
        ((<null>)
         (raise-simple 'drop-right0:internal-error))
        ((lst1 (:nonempty-uniform-list %type))
         (cons (car lst1)
               (drop-right0 (cdr lst1) i-count (- i-len 1))))))))
  
  
  (define-param-method drop-right (%type)
      (((lst (:uniform-list %type)) (i-count <integer>))
       (:uniform-list %type)
       pure)
    (drop-right0 lst i-count (length lst)))
  
  
  (define-param-method last (%type)
      (((lst (:nonempty-uniform-list %type)))
       %type
       pure)
    (let ((l-tail (cdr lst)))
      (match-type l-tail
        ((<null>) (car lst))
        ((l-tail1 (:nonempty-uniform-list %type))
         (last l-tail1)))))
  
  (define-param-method last0 (%type)
      (((lst (:uniform-list %type)))
       %type
       pure)
    (match-type lst
      ((<null>) (raise-simple 'last0:empty-list))
      ((lst1 (:nonempty-uniform-list %type))
       (let ((l-tail (cdr lst1)))
         (if (null? l-tail)
             (car lst1)
             (last0 l-tail))))))

  (define-param-method but-last (%element)
      (((l (:nonempty-uniform-list %element)))
       (:uniform-list %element)
       pure)
    (match-type (cdr l)
      ((<null>) null)
      ((l1 (:nonempty-uniform-list %element))
       (cons (car l) (but-last l1)))))

  (define-param-method but-last0 (%element)
      (((l (:uniform-list %element)))
       (:uniform-list %element)
       pure)
    (match-type l
      ((<null>) (raise-simple 'but-last0:empty-list))
      ((l1 (:nonempty-uniform-list %element))
       (but-last l1))))

  (define-param-method filter (%type)
      (((pred (:procedure (%type) <boolean> pure))
        (l (:uniform-list %type)))
       (:uniform-list %type)
       pure (optimize-proc-arg pred))
    (match-type l
      ((<null>) null)
      ((l1 (:nonempty-uniform-list %type))
       (let ((x-head (car l1)))
         (if (pred x-head)
             (cons x-head (filter pred (cdr l1)))
             (filter pred (cdr l1)))))))
  
  
  (define-param-method distinct-elements? (%type)
      (((l (:uniform-list %type))
        (pc-eq (:procedure (%type %type) <boolean> pure)))
       <boolean>
       pure (optimize-proc-arg pc-eq))
    (match-type l
      ((<null>) #t)
      ((l1 (:nonempty-uniform-list %type))
       (let ((l-tail (cdr l1)))
         (and
          (not (member-general? (car l1) l-tail pc-eq))
          (distinct-elements? l-tail pc-eq))))))
  
  
  (define-param-method find (%type %default)
      (((pred (:procedure (%type) <boolean> pure))
        (l (:uniform-list %type))
        (x-default %default))
       (:union %type %default)
       pure (optimize-proc-arg pred))
    (match-type l
      ((<null>) x-default)
      ((l1 (:nonempty-uniform-list %type))
       (let ((x1 (car l1)))
         (if (pred x1) x1 (find pred (cdr l1) x-default))))))
  
  
  (define-param-method count (%type)
      (((pred (:procedure (%type) <boolean> pure))
        (l (:uniform-list %type)))
       <integer> pure (optimize-proc-arg pred))
    (match-type l
      ((<null>) 0)
      ((l1 (:nonempty-uniform-list %type))
       (if (pred (car l1))
           (+ 1 (count pred (cdr l1)))
           (count pred (cdr l1))))))
  
  
  (define-param-method list-index (%type)
      (((pred (:procedure (%type) <boolean> pure))
        (l (:uniform-list %type)))
       <integer> pure (optimize-proc-arg pred))
    (match-type l
      ((<null>) -1)
      ((l1 (:nonempty-uniform-list %type))
       (if (pred (car l1))
           0
           (let ((i1 (list-index pred (cdr l1))))
             (if (>= i1 0)
                 (+ i1 1)
                 -1))))))

  (define-param-method fold1 (%component %result)
      (((proc (:procedure (%component %result) %result pure))
        (x-init %result)
        (l (:uniform-list %component)))
       %result pure)
    (match-type l
      ((<null>) x-init)
      ((l1 (:nonempty-uniform-list %component))
       (fold1 proc (proc (car l1) x-init) (cdr l1)))))

  (define-param-method fold-right1 (%component %result)
      (((proc (:procedure (%component %result) %result pure))
        (x-init %result)
        (l (:uniform-list %component)))
       %result pure)
    (match-type l
      ((<null>) x-init)
      ((l1 (:nonempty-uniform-list %component))
       (proc (car l1)
             (fold-right1 proc x-init (cdr l1))))))

  (define-param-method delete-duplicates (%type)
      (((l (:uniform-list %type))
        (pred-eq (:procedure (%type %type) <boolean> pure)))
       (:uniform-list %type)
       pure (optimize-proc-arg pred-eq))
    (match-type l
      ((<null>) null)
      ((l1 (:nonempty-uniform-list %type))
       (let ((x-head (car l1))
             (l-tail (cdr l1)))
         (if (member-general? x-head l-tail pred-eq)
             (delete-duplicates l-tail pred-eq)
             (cons x-head (delete-duplicates l-tail pred-eq)))))))

  (define-param-method union-of-lists (%type)
      (((l1 (:uniform-list %type))
        (l2 (:uniform-list %type))
        (pred-eq (:binary-predicate %type %type)))
       (:uniform-list %type) pure (optimize-proc-arg pred-eq))
    (match-type l1
      ((<null>) l2)
      ((l1b (:nonempty-uniform-list %type))
       (let ((x (car l1b)))
         (if (not (member-general? x l2 pred-eq))
             (cons x (union-of-lists (cdr l1b) l2 pred-eq))
             (union-of-lists (cdr l1b) l2 pred-eq))))))

  (define-param-method union-of-alists (%key %value)
      (((al1 (:alist %key %value))
        (al2 (:alist %key %value))
        (pred-eq (:binary-predicate %key %key)))
       (:alist %key %value) pure (optimize-proc-arg pred-eq))
    (match-type al1
      ((<null>) al2)
      ((al1b (:nonempty-uniform-list (:pair %key %value)))
       (let ((p (car al1b)))
         (if (not-object (assoc-general (car p) al2 #f pred-eq))
             (cons p (union-of-alists (cdr al1b) al2 pred-eq))
             (union-of-alists (cdr al1b) al2 pred-eq))))))

  (define-param-method list-set-diff (%type)
      (((l1 (:uniform-list %type))
        (l2 (:uniform-list %type))
        (pred-eq (:procedure (%type %type) <boolean> pure)))
       (:uniform-list %type)
       pure (optimize-proc-arg pred-eq))
    (fold-right1 (lambda (((x-elem %type) (x-prev (:uniform-list %type)))
                          (:uniform-list %type) pure)
                   (if (member-general? x-elem l2 pred-eq)
                       x-prev
                       (cons x-elem x-prev)))
                 '()
                 l1))

  (define-param-method delete (%type)
      (((x %type)
        (l (:uniform-list %type))
        (pred-eq (:binary-predicate %type %type)))
       (:uniform-list %type)
       pure (optimize-proc-arg pred-eq))
    (match-type l
      ((<null>) null)
      ((l1 (:nonempty-uniform-list %type))
       (let ((x-head (car l1)))
         (if (pred-eq x x-head)
             (delete x (cdr l1) pred-eq)
             (cons
              x-head
              (delete x (cdr l1) pred-eq))))))))