;; -*-theme-d-*-

;; Copyright (C) 2008-2019 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)

  (define-param-proc-alt uniform-list-ref (%type)
    (unchecked-prim-proc list-ref
			 ((:uniform-list %type) <integer>)
			 %type
			 pure))

  (define length
    (unchecked-prim-proc length ((:uniform-list <object>)) <integer> (pure)))

  (define-param-proc-alt append (%types)
    (unchecked-prim-proc append
			 ((splice (type-loop %type %types
					     (:uniform-list %type))))
			 (:uniform-list (:union (splice %types)))
			 pure))

  (define-param-proc-alt append-tuples (%tuples)
    (unchecked-prim-proc append
			 ((splice %tuples))
			 (join-tuple-types (splice %tuples))
			 pure))

  (define-param-proc reverse (%type)
		     (((lst (:uniform-list %type))) (:uniform-list %type) pure)
    (match-type-strong lst
      ((<null>) null)
      ((lst1 (:nonempty-uniform-list %type))
       (append (reverse (cdr lst1)) (list (car lst1))))))


  (define-param-proc map1
      (%argtype %result-type)
      (((proc (:procedure (%argtype) %result-type pure))
  	(lst (:uniform-list %argtype)))
       (:uniform-list %result-type)
       pure)
    (match-type-strong lst
      ((<null>) null)
      ((lst1 (:nonempty-uniform-list %argtype))
       (cons (proc (car lst1))
	     (map1 proc (cdr lst1))))))


  (define-param-proc map-nonpure1
      (%argtype %result-type)
      (((proc (:procedure (%argtype) %result-type nonpure))
  	(lst (:uniform-list %argtype)))
       (:uniform-list %result-type)
       nonpure)
    (match-type-strong lst
      ((<null>) null)
      ((lst1 (:nonempty-uniform-list %argtype))
       (cons (proc (car lst1))
	     (map-nonpure1 proc (cdr lst1))))))


  (define-param-proc for-each1
      (%argtype)
      (((proc (:procedure (%argtype) <none> nonpure))
  	(lst (:uniform-list %argtype)))
       <none>
       nonpure)
    (match-type-strong lst
      ((<null>) null)
      ((lst1 (:nonempty-uniform-list %argtype))
       (proc (car lst1))
       (for-each1 proc (cdr lst1)))))


  (define-param-proc and-map1? (%type)
		     (((proc (:procedure (%type) <boolean> pure))
		       (lst (:uniform-list %type)))
		      <boolean>
		      pure)
    (match-type-strong lst
      ((<null>) #t)
      ((lst1 (:nonempty-uniform-list %type))
       (and (proc (car lst1))
	    (and-map1? proc (cdr lst1))))))


  (define-param-proc or-map1? (%type)
		     (((proc (:procedure (%type) <boolean> pure))
		       (lst (:uniform-list %type)))
		      <boolean>
		      pure)
    (match-type-strong lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (or (proc (car lst1))
	   (or-map1? proc (cdr lst1))))))


  (define-simple-proc map-car0
    (((lists (:uniform-list <nonempty-list>)))
     <list>
     pure)
    (match-type-strong lists
      ((<null>) null)
      ((lists1 (:nonempty-uniform-list <nonempty-list>))
       (cons (car (car lists1))
  	     (map-car0 (cdr lists1))))))


  (define-param-proc map-car (%arglist)
    (((lists (type-loop %type %arglist (:nonempty-uniform-list %type))))
     %arglist
     pure)
    (cast %arglist (map-car0 lists)))



  (define-simple-proc map-cdr0
    (((lists (:uniform-list <nonempty-list>)))
     <list>
     pure)
    (match-type-strong lists
      ((<null>) null)
      ((lists1 (:nonempty-uniform-list <nonempty-list>))
       (cons (cdr (car lists1))
  	     (map-cdr0 (cdr lists1))))))


  (define-param-proc 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-proc map0
      (%arglist %result-type)
      (((proc (:procedure ((splice %arglist)) %result-type pure))
  	(lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       (:uniform-list %result-type)
       pure)
    (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-proc 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)
    (map0 proc lists))


  (define-param-proc 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)
    (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-proc 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)
    (map-nonpure0 proc lists))


  (define-param-proc for-each0
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <none> nonpure))
  	(lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       <none>
       nonpure)
    (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-proc for-each
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <none> nonpure))
  	(lists (splice (type-loop %argtype %arglist
  				  (:uniform-list %argtype)))))
       <none>
       nonpure)
    (for-each0 proc lists))


  (define-param-proc and-map0?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> pure))
  	(lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       <boolean>
       pure)
    (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)
	  (and-map0? proc cdrs))))
      (else #t)))


  (define-param-proc and-map?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> pure))
  	(lists (splice (type-loop %argtype %arglist
  				  (:uniform-list %argtype)))))
       <boolean>
       pure)
    (and-map0? proc lists))


  (define-param-proc or-map0?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> pure))
  	(lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       <boolean>
       pure)
    (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)
	  (or-map0? proc cdrs))))
      (else #f)))


  (define-param-proc or-map?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> pure))
  	(lists (splice (type-loop %argtype %arglist
  				  (:uniform-list %argtype)))))
       <boolean>
       pure)
    (or-map0? proc lists))

  (define-param-proc and-map-nonpure0?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> nonpure))
  	(lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       <boolean>
       nonpure)
    (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)
	  (and-map-nonpure0? proc cdrs))))
      (else #t)))

  (define-param-proc and-map-nonpure1? (%type)
		     (((proc (:procedure (%type) <boolean> nonpure))
		       (lst (:uniform-list %type)))
		      <boolean>
		      nonpure)
    (match-type-strong lst
      ((<null>) #t)
      ((lst1 (:nonempty-uniform-list %type))
       (and (proc (car lst1))
	    (and-map-nonpure1? proc (cdr lst1))))))

  (define-param-proc and-map-nonpure?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> nonpure))
  	(lists (splice (type-loop %argtype %arglist
  				  (:uniform-list %argtype)))))
       <boolean>
       nonpure)
    (and-map-nonpure0? proc lists))

  (define-param-proc or-map-nonpure0?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> nonpure))
  	(lists (type-loop %argtype %arglist (:uniform-list %argtype))))
       <boolean>
       nonpure)
    (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)
	  (or-map-nonpure0? proc cdrs))))
      (else #f)))

  (define-param-proc or-map-nonpure1? (%type)
		     (((proc (:procedure (%type) <boolean> nonpure))
		       (lst (:uniform-list %type)))
		      <boolean>
		      nonpure)
    (match-type-strong lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (or (proc (car lst1))
	   (or-map-nonpure1? proc (cdr lst1))))))

  (define-param-proc or-map-nonpure?
      (%arglist)
      (((proc (:procedure ((splice %arglist)) <boolean> nonpure))
  	(lists (splice (type-loop %argtype %arglist
  				  (:uniform-list %argtype)))))
       <boolean>
       nonpure)
    (or-map-nonpure0? proc lists))


  (define-param-proc member-general?
      (%type)
      (((obj %type)
	(lst (:uniform-list %type))
	(my-eq? (:procedure (%type %type) <boolean> pure)))
       <boolean> pure)
    (match-type-strong lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (if (my-eq? obj (car lst1))
	   #t
	   (member-general? obj (cdr lst1) my-eq?)))))


  (define-param-proc member-values?
      (%type)
      (((obj %type)
	(lst (:uniform-list %type)))
       <boolean> pure)
    (match-type-strong lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (if (equal-values? obj (car lst1))
	   #t
	   (member-values? obj (cdr lst1))))))


  (define-param-proc member-objects?
      (%type)
      (((obj %type)
	(lst (:uniform-list %type)))
       <boolean> pure)
    (match-type-strong lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (if (equal-objects? obj (car lst1))
	   #t
	   (member-objects? obj (cdr lst1))))))


  (define-param-proc member-contents?
      (%type)
      (((obj %type)
	(lst (:uniform-list %type)))
       <boolean> pure)
    (match-type-strong lst
      ((<null>) #f)
      ((lst1 (:nonempty-uniform-list %type))
       (if (equal-contents? obj (car lst1))
	   #t
	   (member-contents? obj (cdr lst1))))))


  (define-param-proc 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)
    (match-type-strong 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-proc assoc
      (%type1 %type2 %default)
      (((key %type1)
	(lst (:alist %type1 %type2))
	(x-default %default))
       (:union (:pair %type1 %type2) %default)
       pure)
    (match-type-strong 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-proc assoc-values
      (%type1 %type2 %default)
      (((key %type1)
	(lst (:alist %type1 %type2))
	(x-default %default))
       (:union (:pair %type1 %type2) %default)
       pure)
    (match-type-strong 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-proc assoc-objects
      (%type1 %type2 %default)
      (((key %type1)
	(lst (:alist %type1 %type2))
	(x-default %default))
       (:union (:pair %type1 %type2) %default)
       pure)
    (match-type-strong 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-proc assoc-contents
      (%type1 %type2 %default)
      (((key %type1)
	(lst (:alist %type1 %type2))
	(x-default %default))
       (:union (:pair %type1 %type2) %default)
       pure)
    (match-type-strong 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-proc general-alist-delete (%key %value)
		     (((x-key %key)
		       (al (:alist %key %value))
		       (pc-eq (:procedure (%key %key) <boolean> pure)))
		      (:alist %key %value)
		      pure)
    (match-type-strong 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-proc alist-delete (%key %value)
		     (((x-key %key)
		       (al (:alist %key %value)))
		      (:alist %key %value)
		      pure)
    (match-type-strong 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-proc value-alist-delete (%key %value)
		     (((x-key %key)
		       (al (:alist %key %value)))
		      (:alist %key %value)
		      pure)
    (match-type-strong 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-proc object-alist-delete (%key %value)
		     (((x-key %key)
		       (al (:alist %key %value)))
		      (:alist %key %value)
		      pure)
    (match-type-strong 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-proc content-alist-delete (%key %value)
		     (((x-key %key)
		       (al (:alist %key %value)))
		      (:alist %key %value)
		      pure)
    (match-type-strong 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-proc 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-strong lst
	((<null>)
	 (raise-simple 'take:invalid-list))
	((lst1 (:nonempty-uniform-list %type))
	 (cons (car lst1) (take (cdr lst1) (- i-count 1))))))))


  (define-param-proc 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-strong lst
	((<null>)
	 (raise-simple 'drop:invalid-list))
	((lst1 (:nonempty-uniform-list %type))
	 (drop (cdr lst1) (- i-count 1)))))))


  (define-param-proc 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-strong lst
	((<null>)
	 (raise-simple 'take-right0:internal-error))
	((lst1 (:nonempty-uniform-list %type))
	 (take-right0 (cdr lst1) i-count (- i-len 1)))))))


  (define-param-proc take-right (%type)
		     (((lst (:uniform-list %type)) (i-count <integer>))
		      (:uniform-list %type)
		      pure)
    (take-right0 lst i-count (length lst)))


  (define-param-proc 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-strong 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-proc drop-right (%type)
		     (((lst (:uniform-list %type)) (i-count <integer>))
		      (:uniform-list %type)
		      pure)
    (drop-right0 lst i-count (length lst)))


  (define-param-proc last (%type)
		     (((lst (:nonempty-uniform-list %type)))
		      %type
		      pure)
    (let ((l-tail (cdr lst)))
      (match-type-strong l-tail
	((<null>) (car lst))
	((l-tail1 (:nonempty-uniform-list %type))
	 (last l-tail1)))))

  (define-param-proc filter (%type)
		     (((pred (:procedure (%type) <boolean> pure))
		       (l (:uniform-list %type)))
		      (:uniform-list %type)
		      pure)
    (match-type-strong 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-proc distinct-elements? (%type)
		     (((l (:uniform-list %type))
		       (pc-eq (:procedure (%type %type) <boolean> pure)))
		      <boolean>
		      pure)
    (match-type-strong 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-proc find (%type %default)
		     (((pred (:procedure (%type) <boolean> pure))
		       (l (:uniform-list %type))
		       (x-default %default))
		      (:union %type %default)
		      pure)
    (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-proc count (%type)
		     (((pred (:procedure (%type) <boolean> pure))
		       (l (:uniform-list %type)))
		      <integer> pure)
    (match-type-strong l
      ((<null>) 0)
      ((l1 (:nonempty-uniform-list %type))
       (if (pred (car l1))
	   (+ 1 (count pred (cdr l1)))
	   (count pred (cdr l1)))))))
