;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

(use goo/boot)
(use goo/fun)
(use goo/class)
(use goo/macros)
(use goo/types)
(use goo/any)
(use goo/log)
(use goo/chr)
(use goo/math)

(exported
 <col>
 <col.>
 (dg len (x|<col> => <int>))
 (dg elt (x|<col> k|<any> => <any>))
 (dg elt-or (x|<col> k|<any> default|<any> => <any>))
 (dg elt-type (x|<col> => <type>))
 (dg elt-default (x|<col> => <any>))
 (dg key-type (x|<col> => <type>))
 (dg key-test (x|<col> => <fun>))
 (dg elts (x|<col> keys|<col> => <col>))
 (dg nul? (x|<col> => <log>))
 (dg nul ((x (t< <col>)) => <col>))
 (dv empty? nul?) ;; TODO: DEPRECATED
 (dv empty nul)   ;; TODO: DEPRECATED
 (dg add (x|<col> y|<any> => <col>))
 (dg dup (x|<col> => <col>))
 (dg fab ((t (t< <col>)) s|<int> => <col>))
 (dg col ((t (t< <col>)) key-vals|...))
 (dg fabs ((x (t< <col>)) elts|... => <col>))
 (dg fill (x|<col> val|<any> => <col>))

 (dg any? (f|<fun> x|<col> => <log>))
 (dg all? (f|<fun> x|<col> => <log>))
 (dg fold (combine|<fun> init|<any> x|<col> => <any>))
 (dg fold+ (combine|<fun> x|<col> => <any>))
 (dg find-or (f|<fun> x|<col> default => <any>))
 (dg find (f|<fun> x|<col> => <any>))
 (dg del (x|<col> key|<any> => <col>))
 (dg zap (x|<col> => <col>))
 (dg do (f|<fun> x|<col>))
 (dg mem? (x|<col> y|<any> => <log>))
 (dg keys (c|<col> => <seq>))
 (dg items (c|<col> => <seq>))
 (dg col-res-type (c|<col> => <type>))

;; 3.7.1 ENUMERATION PROTOCOL
 (dc <enum> (<any>))
 (dg enum (x|<any> => <enum>))
 (dg fin? (e|<enum> => <log>))
 (dg nxt (e|<enum> => <enum>))
 (dg now (e|<enum> => <any>))
 (dg now-setter (v|<any> e|<enum>))
 (dg now-key (e|<enum> => <any>))

;; Deprecated
 (dg do-keyed (f|<fun> x|<col>))
 (dg map-keyed (f|<fun> x|<col> => <col>))
 (dg map (f|<fun> x|<col> => <col>))

;; Undocumented
 (dg fab-into (x|<col> y|<col> => <col>)) 
 (dg fab-fill! (x|<col> y => <col>)) 

 (dg low-elt (x|<col> k|<any> => <any>))
 (dg fab-elt-setter (v|<any> x|<col> k|<any>))
 (dg col-res (c|<col> x|<col> => <col>))
)

;;;;!! Implementation
(dm enum (x|<enum> => <enum>) x)

;;;; Creation protocol
(dm as ((t (t< <col>)) x|<col> => <col>)
  (if (== (class-of x) t)
      x
      (fab-into (fab t (len x)) x)))

(dm dup (x|<col> => <col>)
  (fab-into (fab (class-of x) (len x)) x))

;; no need to duplicate immutable collections
(dm dup (x|<col.> => <col.>)
  x)

;;;; Collection protocol default implementation

(dm len (x|<col> => <int>)
  (rep count ((e (enum x)) (i 0))
    (if (fin? e) i (count (nxt e) (+ i 1)))))

(dm elt-type (x|<col> => <type>) <any>)
(dm key-type (x|<col> => <type>) <any>)
(dm key-test (x|<col> => <fun>)  ==)

;; required: elt

;; required: elt-setter

(dm nul? (c|<col> => <log>)
  (= (len c) 0))

(dm nul ((c (t< <col>)) => <col>)
  (fab c 0))

(dm elt-default (x|<col> => <any>)
  #f)

;; required: fab

(dm fab-into (dst|<col> src|<col> => <col>)
  (rep in ((ss (enum src)))
    (if (fin? ss)
        dst
        (seq (set (fab-elt dst (now-key ss)) (now ss))
             (in (nxt ss))))))

(dm fabs (c|(t< <col>) objects|... => <col>)
  (fab-into (fab c (len objects)) objects))

(dm fab-fill! (dst|<col> src => <col>)
  (rep in ((ds (enum dst)))
    (if (fin? ds)
        dst
        (seq (set (fab-elt dst (now-key ds)) src)
             (in (nxt ds))))))

(dm fill (dst|<col> val => <col>)
  (fab-fill! (dup dst) val))

(dm any? (test|<fun> c|<col> => <log>)
  (rep fnd ((e (enum c)))
    (if (fin? e)
        #f
        (or (as-log (test (now e))) (fnd (nxt e))))))

(dm all? (test|<fun> c|<col> => <log>)
  (rep fnd ((e (enum c)))
    (or (fin? e)
        (and (test (now e)) (fnd (nxt e))))))

(dm fold (combine|<fun> init c|<col> => <any>)
  (rep red ((res init) (e (enum c)))
    (if (fin? e)
        res
        (red (combine res (now e)) (nxt e)))))

(dm fold+ (combine|<fun> c|<col> => <any>)
  (def e    (enum c))
  (def init (now e))
  (rep red ((res init) (e (nxt e)))
    (if (fin? e)
        res
        (red (combine res (now e)) (nxt e)))))

(dc <elt-default> (<any>))
(dv $elt-default (new <elt-default>))

(dm find-or (f|<fun> c|<col> default => <any>)
  (rep fnd ((e (enum c)))
    (if (fin? e)
        default
        (if (f (now e)) (now-key e) (fnd (nxt e))))))

(dm find (f|<fun> c|<col> => <any>)
  (def val (find-or f c $elt-default))
  (if (== val $elt-default) (range-error c f) val))

;;; (dm del (x|<col> key|<any> => <col>) ...)

(dm zap (x|<col> => <col>)
  (nul (class-of x)))

(dm do (f|<fun> c|<col>)
  (rep lop ((e (enum c)))
    (unless (fin? e)
      (f (now e)) (lop (nxt e)))))

(dm map (f|<fun> c|<col> => <col>)
  (rep con ((res (fab <tab> 0)) (e (enum c)))
    (if (fin? e)
        (col-res c res)
        (seq (set (fab-elt res (now-key e)) (f (now e)))
             (con res (nxt e))))))

(dm do-keyed (f|<fun> c|<col>)
  (rep lop ((e (enum c)))
    (unless (fin? e)
      (f (now-key e) (now e)) (lop (nxt e)))))

(dm map-keyed (f|<fun> c|<col> => <col>)
  (rep con ((res (fab <tab> 0)) (e (enum c)))
    (if (fin? e)
        (col-res c res)
        (let ((key (now-key e)))
          (set (fab-elt res key) (f key (now e)))
          (con res (nxt e))))))

(dm keys (c|<col> => <seq>)
  (rep con ((res '()) (e (enum c)))
    (if (fin? e)
        (rev! res)
        (con (add res (now-key e)) (nxt e)))))

(dm items (c|<col> => <seq>)
  (rep con ((res '()) (e (enum c)))
    (if (fin? e)
        (rev! res)
        (con (add res (tup (now-key e) (now e))) (nxt e)))))

(dm mem? (c|<col> x => <log>)
  (any? (fun (y) (== y x)) c))

(dm col-res-type (c|<col> => <type>)
  (class-of c))

;;;; Undocumented

(dm col-res (c|<col> x|<col> => <col>)
  (as (col-res-type c) x))

(dv $eq-nul '(eq-nul))

(dm = (c1|<col> c2|<col> => <log>)
  (and (= (len c1) (len c2))
       (rep eq ((e1 (enum c1)))
         (if (fin? e1)
             #t
             (and (= (now e1) (elt-or c2 (now-key e1) $eq-nul))
                  (eq (nxt e1)))))))

(dm (elt inline) (c|<col> key|<any> => <any>) 
  (def val (elt-or c key $elt-default))
  (if (== val $elt-default) (range-error c key) val))

;; get this from list.goo
(need-implementation add <tab> into)

