; FILE         "collect.oo"
; IMPLEMENTS    Sample collection operations
; AUTHOR        Ken Dickey
; DATE          1992 September 1
; LAST UPDATED  1992 September 2
; NOTES         Expository (optimizations & checks elided).

;               Requires YASOS (Yet Another Scheme Object System).

(require 'yasos)


;; COLLECTION INTERFACE

;; (collection? obj)  -- predicate
;;
;; (do-elts proc coll+)
;; (do-keys proc coll+)
;;
;; (map-elts proc coll+)
;; (map-keys proc coll+)
;;
;; (for-each-key coll proc)
;; (for-each-elt coll proc)
;;
;; (reduce proc seed coll+)
;; (any?   predicate coll+)
;; (every? predicate coll+)
;;
;; (empty? collection)
;; (size collection)
;;
;;=================
;; Collections must implement:
;;  collection?
;;  gen-elts
;;  gen-keys
;;  size
;;  print
;;
;; Collections should implement {typically faster}:
;;  for-each-key
;;  for-each-elt
;;

(define-operation (COLLECTION? obj)
 ;; default
  (cond
    ((or (list? obj) (vector? obj) (string obj)) #t)
    (else #f)
) )

(define (EMPTY? collection) (zero? (size collection)))

(define-operation (GEN-ELTS <collection>) ;; return element generator
  ;; default behavior
  (cond                      ;; see utilities, below, for generators
    ((vector? <collection>) (vector-gen-elts <collection>)) 
    ((list?   <collection>) (list-gen-elts   <collection>))
    ((string? <collection>) (string-gen-elts <collection>))
    (else 
      (error "Operation not supported: gen-elts " (print obj #f)))
) )

(define-operation (GEN-KEYS collection)
  (if (or (vector? collection) (list? collection) (string? collection))
      (let ( (max+1 (size collection)) (index 0) )
	 (lambda ()
            (cond
	      ((< index max+1)
	       (set! index (add1 index))
	       (sub1 index))
	      (else (error "no more keys in generator"))
      ) ) )
      (error "Operation not handled: GEN-KEYS " collection)
) )

(define (DO-ELTS <proc> . <collections>)
  (let ( (max+1 (size (car <collections>)))
         (generators (map gen-elts <collections>))
       )
    (let loop ( (counter 0) )
       (cond
          ((< counter max+1)
           (apply <proc> (map (lambda (g) (g)) generators))
           (loop (add1 counter))
          )
          (else 'unspecific)  ; done
    )  )
) )

(define (DO-KEYS <proc> . <collections>)
  (let ( (max+1 (size (car <collections>)))
         (generators (map gen-keys <collections>))
       )
    (let loop ( (counter 0) )
       (cond
          ((< counter max+1)
           (apply <proc> (map (lambda (g) (g)) generators))
           (loop (add1 counter))
          )
          (else 'unspecific)  ; done
    )  )
) )

(define (MAP-ELTS <proc> . <collections>)
  (let ( (max+1 (size (car <collections>)))
         (generators (map gen-elts <collections>))
         (vec (make-vector (size (car <collections>))))
       )
    (let loop ( (index 0) )
       (cond
          ((< index max+1)
           (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
           (loop (add1 index))
          )
          (else vec)  ; done
    )  )
) )

(define (MAP-KEYS <proc> . <collections>)
  (let ( (max+1 (size (car <collections>)))
         (generators (map gen-keys <collections>))
	 (vec (make-vector (size (car <collections>))))
       )
    (let loop ( (index 0) )
       (cond
          ((< index max+1)
           (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
           (loop (add1 index))
          )
          (else vec)  ; done
    )  )
) )

(define-operation (FOR-EACH-KEY <collection> <proc>)
   ;; default
   (do-keys <proc> <collection>)  ;; talk about lazy!
)

(define-operation (FOR-EACH-ELT <collection> <proc>)
   (do-elts <proc> <collection>)
)

(define (REDUCE <proc> <seed> . <collections>)
   (let ( (max+1 (size (car <collections>)))
          (generators (map gen-elts <collections>))
        )
     (let loop ( (count 0) )
       (cond
          ((< count max+1)
           (set! <seed> 
                 (apply <proc> <seed> (map (lambda (g) (g)) generators)))
           (loop (add1 count))
          )
          (else <seed>)
     ) )
)  )

;; pred true for every elt?
(define (EVERY? <pred?> . <collections>)
   (let ( (max+1 (size (car <collections>)))
          (generators (map gen-elts <collections>))
        )
     (let loop ( (count 0) )
       (cond
          ((< count max+1)
           (if (apply <pred?> (map (lambda (g) (g)) generators))
               (loop (add1 count))
               #f)
          )
          (else #t)
     ) )
)  )

;; pred true for any elt?
(define (ANY? <pred?> . <collections>)
   (let ( (max+1 (size (car <collections>)))
          (generators (map gen-elts <collections>))
        )
     (let loop ( (count 0) )
       (cond
          ((< count max+1)
           (if (apply <pred?> (map (lambda (g) (g)) generators))
               #t
               (loop (add1 count))
          ))
          (else #f)
     ) )
)  )


;; SAMPLE COLLECTION -- simple-table .. also a TABLE

(define-predicate TABLE?)
(define-operation (LOOKUP table key failure-object))
(define-operation (ASSOCIATE! table key value)) ;; returns key
(define-operation (REMOVE! table key))          ;; returns value

(define (MAKE-SIMPLE-TABLE)
  (let ( (table (list)) )
    (object
      ;; table behaviors
      ((TABLE? self) #t)
      ((SIZE self) (size table))
      ((PRINT self port) (format port "#<SIMPLE-TABLE>"))
      ((LOOKUP self key failure-object)
       (cond 
         ((assq key table) => cdr)
         (else failure-object)
      ))
      ((ASSOCIATE! self key value)
       (cond
         ((assq key table) => (lambda (bucket) (set-cdr! bucket value) key))
         (else 
           (set! table (cons (cons key value) table))
           key)
      ))
      ((REMOVE! self key) ;; returns old value
       (cond
         ((null? table) (error "TABLE:REMOVE! Key not found: " key))
         ((eq? key (caar table))
          (let ( (value (cdar table)) )
             (set! table (cdr table))
             value)
         )
         (else
           (let loop ( (last table) (this (cdr table)) )
             (cond
               ((null? this) (error "TABLE:REMOVE! Key not found: " key))
               ((eq? key (caar this))
                (let ( (value (cdar this)) )
                  (set-cdr! last (cdr this))
                 value)
               )
               (else
                (loop (cdr last) (cdr this)))
         ) ) )
      ))
      ;; collection behaviors
      ((COLLECTION? self) #t)
      ((GEN-KEYS self) (list-gen-elts (map car table)))
      ((GEN-ELTS self) (list-gen-elts (map cdr table)))
      ((FOR-EACH-KEY self proc)
       (for-each (lambda (bucket) (proc (car bucket))) table)
      )
      ((FOR-EACH-ELT self proc)
       (for-each (lambda (bucket) (proc (cdr bucket))) table)
      )
) ) )

;; MISC UTILITIES

;;(define (ZERO? obj) (= obj 0))
(define (ADD1 obj)  (+ obj 1))
(define (SUB1 obj)  (- obj 1))


;; Let lists be regular

;;(define (LIST-REF <list> <index>)
;;  (if (zero? <index>)
;;      (car <list>)
;;      (list-ref (cdr <list>) (sub1 <index>))
;;) )


;; return value of list-set! is the (altered) <list>

(define (LIST-SET! <list> <index> <value>)

  (define (set-loop last this idx)
     (cond
        ((zero? idx) 
         (set-cdr! last (cons <value> (cdr this)))
         <list>
        )
        (else (set-loop (cdr last) (cdr this) (sub1 idx)))
  )  )

  ;; main
  (if (zero? <index>)
      (begin (set-car! <list> <value>) <list>)  
      (set-loop <list> (cdr <list>) (sub1 <index>)))
)

(ADD-SETTER list-ref list-set!)  ; for (setter list-ref)


;; generator for list elements
(define (LIST-GEN-ELTS <list>)
  (lambda ()
     (if (null? <list>)
         (error "No more list elements in generator")
         (let ( (elt (car <list>)) )
           (set! <list> (cdr <list>))
           elt))
) )

(define (MAKE-VEC-GEN-ELTS <accessor>)
  (lambda (vec)
    (let ( (max+1 (size vec))
           (index 0)
         )
      (lambda () 
         (cond ((< index max+1)
                (set! index (add1 index))
                (<accessor> vec (sub1 index))
               )
               (else #f)
      )  )
  ) )
)

(define VECTOR-GEN-ELTS (make-vec-gen-elts vector-ref))

(define STRING-GEN-ELTS (make-vec-gen-elts string-ref))

;;                        --- E O F ---                    ;;