;;; srfi.69.strong.scm - Optional non-standard extensions
;
; Copyright (c) 2008-2021, The Chicken Team
; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer.
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution.
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.

(declare (usual-integrations))

(module (srfi 69 strong) (make-hash-table
                          hash-table?
                          hash-table-size
                          hash-table-equivalence-function
                          hash-table-hash-function
                          hash-table-min-load
                          hash-table-max-load
                          hash-table-weak-keys
                          hash-table-weak-values
                          hash-table-has-initial?
                          hash-table-initial
                          hash-table-copy
                          hash-table-update!
                          hash-table-update!/default
                          hash-table-set!
                          hash-table-ref
                          hash-table-ref/default
                          hash-table-exists?
                          hash-table-delete!
                          hash-table-remove!
                          hash-table-clear!
                          hash-table-merge!
                          hash-table-merge
                          hash-table-clean!
                          hash-table->alist
                          alist->hash-table
                          hash-table-keys
                          hash-table-values
                          hash-table-fold
                          hash-table-for-each
                          hash-table-map
                          hash-table-walk)

(import (scheme)
        (chicken base)
        (chicken fixnum)
        (only (chicken platform) register-feature!)
        (only (chicken format) sprintf))
(import (only (srfi 69 hash) wrap-hash/std))
;prefixing helps ensure <exporting-module>#<imported-name>
(import (prefix (srfi 69 record) im:))

(register-feature! 'srfi-69)

;;; Naming Conventions:

;; %foo - inline primitive
;; %%foo - local inline (no such thing but at least it looks different)
;; $foo - local macro
;; *foo - local unchecked variant of a checked procedure
;; ##sys#foo - public, but undocumented, un-checked procedure
;; foo - public checked procedure

;;; Hash-Tables:

(define-constant *mod-ht-kind* 'strong)

(include-relative "srfi.69.support.incl")

(define (entry-object-ctor wk? wv?)
  cons )

;; SRFI-69 & SRFI-90'ish.
;;
;; Argument list is the pattern
;;
;; (make-hash-table #!optional test hash size
;;                  #!key test hash size initial
;;                        min-load max-load weak-keys weak-values)
;;
;; where a keyword argument takes precedence over the corresponding optional
;; argument. Keyword arguments MUST come after optional & required
;; arugments.
;;
;; Wish DSSSL (extended) argument list processing Did-What-I-Want (DWIW).

(define (make-hash-table . args)
  (receive (test hash size min-load max-load weak-keys weak-values initial)
           (apply im:eval-make-hash-table-args args)
    ; Seek weakness elsewhere (FIXME issue w/ common SRFI-69 ctor)
    (when (or weak-keys weak-values)
      (warning 'make-hash-table "weak references unsupported, strong only")
      ;reset - unsupported
      (set! weak-keys #f)
      (set! weak-values #f) )
    (im:*make-hash-table wrap-hash/std entry-object-ctor
                         test hash size min-load max-load
                         weak-keys weak-values initial
                         *mod-ht-kind*
                         #f) ) )

;; Hash-Table Predicate:

(define (hash-table? obj)
  (and (im:hash-table? obj)
       (eq? *mod-ht-kind* (%ht-kind obj))) )

;; Hash-Table Properties:

(define hash-table-size im:hash-table-size)
(define hash-table-equivalence-function im:hash-table-equivalence-function)
(define hash-table-hash-function im:hash-table-hash-function)
(define hash-table-min-load im:hash-table-min-load)
(define hash-table-max-load im:hash-table-max-load)
(define hash-table-weak-keys im:hash-table-weak-keys)
(define hash-table-weak-values im:hash-table-weak-values)
(define hash-table-has-initial? im:hash-table-has-initial?)
(define hash-table-initial im:hash-table-initial)

;; hash-table-rehash!:

(define (hash-table-rehash! ht vec1 vec2 hash)
  (let ([len1 (%vector-length vec1)]
        [len2 (%vector-length vec2)] )
    (do ([i 0 (fx+ i 1)])
        [(fx>= i len1)]
      (let loop ([bucket (%vector-ref vec1 i)])
        (unless (null? bucket)
          (let* ([pare (%car bucket)]
                 [key (%car pare)]
                 [hshidx (hash key len2)] )
            (%vector-set! vec2 hshidx
                          (cons (cons key (%cdr pare)) (%vector-ref vec2 hshidx)))
            (loop (%cdr bucket)) ) ) ) ) ) )

;; hash-table-copy:

(define *hash-table-copy
  (let ((make-vector make-vector))
    (lambda (ht)
      (let* ((vec1 (%ht-vector ht))
             (len (%vector-length vec1))
             (vec2 (make-vector len '()))
             (ht2 (do ((i 0 (fx+ i 1)))
                      ((fx>= i len)
                       (im:*make-hash-table
                        wrap-hash/std entry-object-ctor
                        (%ht-equivalence-function ht) (%ht-hash-function ht)
                        (%ht-size ht)
                        (%ht-min-load ht) (%ht-max-load ht)
                        (%ht-weak-keys ht) (%ht-weak-values ht)
                        (%ht-initial ht)
                        (%ht-kind ht)
                        vec2))
                    (%vector-set! vec2 i
                                  (let copy-loop ((bucket (%vector-ref vec1 i)))
                                    (if (null? bucket)
                                        '()
                                        (let ((pare (%car bucket)))
                                          (cons (cons (%car pare) (%cdr pare))
                                                (copy-loop (%cdr bucket))))))) )))
        ;; Size, ctor & randomized hashing function are reset by *make-hash-table,
        ;; so we copy over the ones from the original hash table.
        (%ht-size-set! ht2 (%ht-size ht))
        (%ht-hash-set! ht2 (%ht-hash ht))
        (%ht-make-entry-set! ht2 (%ht-make-entry ht))
        ht2 ) ) ) )

(define (hash-table-copy ht)
  (*hash-table-copy (%check-hash-table/kind 'hash-table-copy ht)) )

;; hash-table-update!:
;;
;; This one was suggested by Sven Hartrumpf (and subsequently added in SRFI-69).
;; Modified for ht props min & max load.

(define hash-table-update!
  (let ([core-eq? eq?] )
    (lambda (ht key func
                #!optional
                (thunk
                 (let ([thunk (%ht-initial ht)])
                   (or thunk
                       (lambda ()
                         (##sys#signal-hook
                          #:access-error
                          'hash-table-update!
                          "hash-table does not contain key" key ht))))))
      (%check-hash-table/kind 'hash-table-update! ht)
      (%check-closure 'hash-table-update! func)
      (%check-closure 'hash-table-update! thunk)
      (let ([newsiz (fx+ (%ht-size ht) 1)] )
        (hash-table-check-resize! ht newsiz hash-table-rehash!)
        (let* ([hash (%ht-hash ht)]
               [test (%ht-equivalence-function ht)]
               [vec (%ht-vector ht)]
               [len (%vector-length vec)]
               [hshidx (hash key len)]
               [bucket0 (%vector-ref vec hshidx)] )
          (if (eq? core-eq? test)
              ; Fast path (eq? is rewritten by the compiler):
              (let loop ([bucket bucket0])
                (if (null? bucket)
                    (let ([val (func (thunk))])
                      (%vector-set! vec hshidx (cons (cons key val) bucket0))
                      (%ht-size-set! ht newsiz)
                      val )
                    (let ([pare (%car bucket)])
                       (if (eq? key (%car pare))
                           (let ([val (func (%cdr pare))])
                             (%set-cdr! pare val)
                             val)
                           (loop (%cdr bucket)) ) ) ) )
              ; Slow path
              (let loop ([bucket bucket0])
                (if (null? bucket)
                    (let ([val (func (thunk))])
                      (%vector-set! vec hshidx (cons (cons key val) bucket0))
                      (%ht-size-set! ht newsiz)
                      val )
                    (let ([pare (%car bucket)])
                       (if (test key (%car pare))
                           (let ([val (func (%cdr pare))])
                             (%set-cdr! pare val)
                             val )
                           (loop (%cdr bucket)) ) ) ) ) ) ) ) ) ) )

(define *hash-table-update!/default
  (let ([core-eq? eq?] )
    (lambda (ht key func def)
      (let ([newsiz (fx+ (%ht-size ht) 1)] )
        (hash-table-check-resize! ht newsiz hash-table-rehash!)
        (let* ([hash (%ht-hash ht)]
               [test (%ht-equivalence-function ht)]
               [vec (%ht-vector ht)]
               [len (%vector-length vec)]
               [hshidx (hash key len)]
               [bucket0 (%vector-ref vec hshidx)] )
          (if (eq? core-eq? test)
              ; Fast path (eq? is rewritten by the compiler):
              (let loop ([bucket bucket0])
                (if (null? bucket)
                    (let ([val (func def)])
                      (%vector-set! vec hshidx (cons (cons key val) bucket0))
                      (%ht-size-set! ht newsiz)
                      val )
                    (let ([pare (%car bucket)])
                       (if (eq? key (%car pare))
                           (let ([val (func (%cdr pare))])
                             (%set-cdr! pare val)
                             val)
                           (loop (%cdr bucket)) ) ) ) )
              ; Slow path
              (let loop ([bucket bucket0])
                (if (null? bucket)
                    (let ([val (func def)])
                      (%vector-set! vec hshidx (cons (cons key val) bucket0))
                      (%ht-size-set! ht newsiz)
                      val )
                    (let ([pare (%car bucket)])
                       (if (test key (%car pare))
                           (let ([val (func (%cdr pare))])
                             (%set-cdr! pare val)
                             val )
                           (loop (%cdr bucket)) ) ) ) ) ) ) ) ) ) )

(define (hash-table-update!/default ht key func def)
  (*hash-table-update!/default
   (%check-hash-table/kind 'hash-table-update!/default ht)
   key
   (%check-closure 'hash-table-update!/default func)
   def) )

(define hash-table-set!
  (let ([core-eq? eq?])
    (lambda (ht key val)
      (%check-hash-table/kind 'hash-table-set! ht)
      (let ([newsiz (fx+ (%ht-size ht) 1)])
        (hash-table-check-resize! ht newsiz hash-table-rehash!)
        (let* ([hash (%ht-hash ht)]
               [test (%ht-equivalence-function ht)]
               [vec (%ht-vector ht)]
               [len (%vector-length vec)]
               [hshidx (hash key len)]
               [bucket0 (%vector-ref vec hshidx)] )
          (if (eq? core-eq? test)
              ; Fast path (eq? is rewritten by the compiler):
              (let loop ([bucket bucket0])
                (if (null? bucket)
                    (begin
                      (%vector-set! vec hshidx (cons (cons key val) bucket0))
                      (%ht-size-set! ht newsiz) )
                    (let ([pare (%car bucket)])
                       (if (eq? key (%car pare))
                           (%set-cdr! pare val)
                           (loop (%cdr bucket)) ) ) ) )
              ; Slow path
              (let loop ([bucket bucket0])
                (if (null? bucket)
                    (begin
                      (%vector-set! vec hshidx (cons (cons key val) bucket0))
                      (%ht-size-set! ht newsiz) )
                    (let ([pare (%car bucket)])
                       (if (test key (%car pare))
                           (%set-cdr! pare val)
                           (loop (%cdr bucket)) ) ) ) ) )
            (void) ) ) ) ) )

;; Hash-Table Reference:

(define hash-table-ref
  (getter-with-setter
    (let ([core-eq? eq?])
      (lambda (ht key #!optional (def (lambda ()
                                        (##sys#signal-hook #:access-error
                                         'hash-table-ref
                                         "hash-table does not contain key" key ht))))
        (%check-hash-table/kind 'hash-table-ref ht)
        (%check-closure 'hash-table-ref def)
        (let* ([vec (%ht-vector ht)]
               [test (%ht-equivalence-function ht)]
               [hash (%ht-hash ht)]
               [hshidx (hash key (%vector-length vec))] )
          (if (eq? core-eq? test)
              ; Fast path (eq? is rewritten by the compiler):
              (let loop ([bucket (%vector-ref vec hshidx)])
                (if (null? bucket)
                    (def)
                    (let ([pare (%car bucket)])
                      (if (eq? key (%car pare))
                          (%cdr pare)
                          (loop (%cdr bucket)) ) ) ) )
              ; Slow path
              (let loop ([bucket (%vector-ref vec hshidx)])
                (if (null? bucket)
                    (def)
                    (let ([pare (%car bucket)])
                      (if (test key (%car pare))
                          (%cdr pare)
                          (loop (%cdr bucket)) ) ) ) ) ) ) ) )
   hash-table-set!
   "(hash-table-ref ht key . def)") )

(define hash-table-ref/default
  (let ([core-eq? eq?])
    (lambda (ht key def)
      (%check-hash-table/kind 'hash-table-ref/default ht)
      (let* ([vec (%ht-vector ht)]
             [test (%ht-equivalence-function ht)]
             [hash (%ht-hash ht)]
             [hshidx (hash key (%vector-length vec))] )
         (if (eq? core-eq? test)
             ; Fast path (eq? is rewritten by the compiler):
             (let loop ([bucket (%vector-ref vec hshidx)])
               (if (null? bucket)
                   def
                   (let ([pare (%car bucket)])
                     (if (eq? key (%car pare))
                         (%cdr pare)
                         (loop (%cdr bucket)) ) ) ) )
             ; Slow path
             (let loop ([bucket (%vector-ref vec hshidx)])
               (if (null? bucket)
                   def
                   (let ([pare (%car bucket)])
                     (if (test key (%car pare))
                         (%cdr pare)
                         (loop (%cdr bucket)) ) ) ) ) ) ) ) ) )

(define hash-table-exists?
  (let ([core-eq? eq?])
    (lambda (ht key)
      (%check-hash-table/kind 'hash-table-exists? ht)
      (let* ([vec (%ht-vector ht)]
             [test (%ht-equivalence-function ht)]
             [hash (%ht-hash ht)]
             [hshidx (hash key (%vector-length vec))] )
        (if (eq? core-eq? test)
             ; Fast path (eq? is rewritten by the compiler):
             (let loop ([bucket (%vector-ref vec hshidx)])
               (and (not (null? bucket))
                    (let ([pare (%car bucket)])
                      (or (eq? key (%car pare))
                          (loop (%cdr bucket)) ) ) ) )
             ; Slow path
             (let loop ([bucket (%vector-ref vec hshidx)])
               (and (not (null? bucket))
                    (let ([pare (%car bucket)])
                      (or (test key (%car pare))
                          (loop (%cdr bucket)) ) ) ) ) ) ) ) ) )

;; hash-table-delete!:

(define hash-table-delete!
  (let ([core-eq? eq?])
    (lambda (ht key)
      (%check-hash-table/kind 'hash-table-delete! ht)
      (let* ([vec (%ht-vector ht)]
             [len (%vector-length vec)]
             [hash (%ht-hash ht)]
             [hshidx (hash key len)]
             [test (%ht-equivalence-function ht)]
             [newsiz (fx- (%ht-size ht) 1)]
             [bucket0 (%vector-ref vec hshidx)] )
        (if (eq? core-eq? test)
            ; Fast path (eq? is rewritten by the compiler):
            (let loop ([prv #f] [bucket bucket0])
              (and (not (null? bucket))
                   (let ([pare (%car bucket)]
                         [nxt (%cdr bucket)])
                     (if (eq? key (%car pare))
                         (begin
                           (if prv
                               (%set-cdr! prv nxt)
                               (%vector-set! vec hshidx nxt) )
                           (%ht-size-set! ht newsiz)
                           #t )
                         (loop bucket nxt) ) ) ) )
            ; Slow path
            (let loop ([prv #f] [bucket bucket0])
              (and (not (null? bucket))
                   (let ([pare (%car bucket)]
                         [nxt (%cdr bucket)])
                     (if (test key (%car pare))
                         (begin
                           (if prv
                               (%set-cdr! prv nxt)
                               (%vector-set! vec hshidx nxt) )
                           (%ht-size-set! ht newsiz)
                           #t )
                         (loop bucket nxt) ) ) ) ) ) ) ) ) )

;; hash-table-remove!:

(define (hash-table-remove! ht func)
  (%check-hash-table/kind 'hash-table-remove! ht)
  (%check-closure 'hash-table-remove! func)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)]
         [siz (%ht-size ht)] )
    (do ([i 0 (fx+ i 1)])
        [(fx>= i len) (%ht-size-set! ht siz)]
      (let loop ([prv #f] [bucket (%vector-ref vec i)])
        (and (not (null? bucket))
             (let ([pare (%car bucket)]
                   [nxt (%cdr bucket)])
               (if (func (%car pare) (%cdr pare))
                   (begin
                     (if prv
                         (%set-cdr! prv nxt)
                         (%vector-set! vec i nxt) )
                     (set! siz (fx- siz 1))
                     #t )
                   (loop bucket nxt ) ) ) ) ) ) ) )

;; hash-table-clear!:

(define (hash-table-clear! ht)
  (%check-hash-table/kind 'hash-table-clear! ht)
  (vector-fill! (%ht-vector ht) '())
  (%ht-size-set! ht 0) )

;; Hash Table Merge:

(define (*hash-table-merge! ht1 ht2)
  (let* ([vec (%ht-vector ht2)]
         [len (%vector-length vec)] )
    (do ([i 0 (fx+ i 1)])
        [(fx>= i len) ht1]
      (do ([lst (%vector-ref vec i) (%cdr lst)])
          [(null? lst)]
        (let ([b (%car lst)])
          (*hash-table-update!/default ht1 (%car b) (lambda (x) x) (%cdr b)) ) ) ) ) )

(define (hash-table-merge! ht1 ht2)
  (*hash-table-merge!
   (%check-hash-table/kind 'hash-table-merge! ht1)
   (%check-hash-table/kind 'hash-table-merge! ht2)) )

(define (hash-table-merge ht1 ht2)
  (*hash-table-merge!
   (*hash-table-copy (%check-hash-table/kind 'hash-table-merge ht1))
   (%check-hash-table/kind 'hash-table-merge ht2)) )

(define (hash-table-clean! ht)
  (%check-hash-table/kind 'hash-table-clean! ht)
  (void) )

;; Hash-Table <-> Association-List:

(define (hash-table->alist ht)
  (%check-hash-table/kind 'hash-table->alist ht)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)] )
    (let loop ([i 0] [lst '()])
      (if (fx>= i len)
          lst
          (let loop2 ([bucket (%vector-ref vec i)]
                      [lst lst])
            (if (null? bucket)
                (loop (fx+ i 1) lst)
                (loop2 (%cdr bucket)
                       (let ([x (%car bucket)])
                         (cons (cons (%car x) (%cdr x)) lst) ) ) ) ) ) ) ) )

(define (alist->hash-table alist . rest)
  (##sys#check-list alist 'alist->hash-table)
  (let ([ht (apply make-hash-table rest)])
    (for-each
     (lambda (x)
       (##sys#check-pair x 'alist->hash-table)
       (*hash-table-update!/default  ht (%car x) (lambda (x) x) (%cdr x)) )
     alist)
    ht ) )

;; Hash-Table Keys & Values:

(define (hash-table-keys ht)
  (%check-hash-table/kind 'hash-table-keys ht)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)] )
    (let loop ([i 0] [lst '()])
      (if (fx>= i len)
          lst
          (let loop2 ([bucket (%vector-ref vec i)]
                      [lst lst])
            (if (null? bucket)
                (loop (fx+ i 1) lst)
                (loop2 (%cdr bucket)
                       (let ([x (%car bucket)])
                         (cons (%car x) lst) ) ) ) ) ) ) ) )

(define (hash-table-values ht)
  (%check-hash-table/kind 'hash-table-values ht)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)] )
    (let loop ([i 0] [lst '()])
      (if (fx>= i len)
          lst
          (let loop2 ([bucket (%vector-ref vec i)]
                      [lst lst])
            (if (null? bucket)
                (loop (fx+ i 1) lst)
                (loop2 (%cdr bucket)
                       (let ([x (%car bucket)])
                         (cons (%cdr x) lst) ) ) ) ) ) ) ) )

;; Mapping Over Hash-Table Keys & Values:
;;
;; hash-table-for-each:
;; hash-table-walk:
;; hash-table-fold:
;; hash-table-map:

(define (*hash-table-for-each ht proc)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)] )
    (do ([i 0 (fx+ i 1)] )
        [(fx>= i len)]
      (##sys#for-each (lambda (bucket) (proc (%car bucket) (%cdr bucket)))
                      (%vector-ref vec i)) ) ) )

(define (*hash-table-fold ht func init)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)] )
    (let loop ([i 0] [acc init])
      (if (fx>= i len)
          acc
          (let fold2 ([bucket (%vector-ref vec i)]
                      [acc acc])
            (if (null? bucket)
                (loop (fx+ i 1) acc)
                (let ([pare (%car bucket)])
                  (fold2 (%cdr bucket)
                         (func (%car pare) (%cdr pare) acc) ) ) ) ) ) ) ) )

(define (hash-table-fold ht func init)
  (*hash-table-fold
   (%check-hash-table/kind 'hash-table-fold ht)
   (%check-closure 'hash-table-fold func)
   init) )

(define (hash-table-for-each ht proc)
  (*hash-table-for-each
   (%check-hash-table/kind 'hash-table-for-each ht)
   (%check-closure 'hash-table-for-each proc)) )

(define (hash-table-walk ht proc)
  (*hash-table-for-each
   (%check-hash-table/kind 'hash-table-walk ht)
   (%check-closure 'hash-table-walk proc)) )

(define (hash-table-map ht func)
  (%check-closure 'hash-table-map func)
  (*hash-table-fold
   (%check-hash-table/kind 'hash-table-map ht)
   (lambda (k v a) (cons (func k v) a))
   '()) )

) ;module (srfi 69 strong)