RosettaCodeData/Task/Associative-array-Iteration/Scheme/associative-array-iteration-3.ss

(cond-expand
  (r7rs)
  (chicken (import r7rs)))

(define-library (suspendable-procedures)

  (export &fail failure? success? suspend fail-forever
          make-generator-procedure)

  (import (scheme base))

  (begin

    (define-record-type <&fail>
      (make-the-one-unique-&fail-that-you-must-not-make-twice)
      do-not-use-this:&fail?)

    (define &fail
      (make-the-one-unique-&fail-that-you-must-not-make-twice))

    (define (failure? f) (eq? f &fail))
    (define (success? f) (not (failure? f)))
    (define *suspend* (make-parameter (lambda (x) x)))
    (define (suspend v) ((*suspend*) v))
    (define (fail-forever)
      (let loop ()
        (suspend &fail)
        (loop)))

    (define (make-generator-procedure thunk)
      ;; This is for making a suspendable procedure that takes no
      ;; arguments when resumed. The result is a simple generator of
      ;; values.
      (define (next-run return)
        (define (my-suspend v)
          (set! return (call/cc (lambda (resumption-point)
                                  (set! next-run resumption-point)
                                  (return v)))))
        (parameterize ((*suspend* my-suspend))
          (suspend (thunk))
          (fail-forever)))
      (lambda () (call/cc next-run)))

    )) ;; end library (suspendable-procedures)

(define-library (avl-trees)
  ;;
  ;; Persistent (that is, ‘immutable’) AVL trees for R7RS Scheme.
  ;;
  ;; References:
  ;;
  ;;   * Niklaus Wirth, 1976. Algorithms + Data Structures =
  ;;     Programs. Prentice-Hall, Englewood Cliffs, New Jersey.
  ;;
  ;;   * Niklaus Wirth, 2004. Algorithms and Data Structures. Updated
  ;;     by Fyodor Tkachov, 2014.
  ;;

  (export avl-make-generator)
  (export avl avl? avl-empty? avl-insert avl-search-values)
  (export avl-check-usage)

  (import (scheme base))
  (import (scheme case-lambda))
  (import (scheme process-context))
  (import (scheme write))
  (import (suspendable-procedures))

  (begin

    (define-syntax avl-check-usage
      (syntax-rules ()
        ((_ pred msg)
         (or pred (usage-error msg)))))

    (define-record-type <avl>
      (%avl key data bal left right)
      avl?
      (key %key)
      (data %data)
      (bal %bal)
      (left %left)
      (right %right))

    (define avl-make-generator
      (case-lambda
        ((tree) (avl-make-generator tree 1))
        ((tree direction)
         (if (negative? direction)
             (make-generator-procedure
              (lambda ()
                (define (traverse p)
                  (unless (or (not p) (avl-empty? p))
                    (traverse (%right p))
                    (suspend (cons (%key p) (%data p)))
                    (traverse (%left p)))
                  &fail)
                (traverse tree)))
             (make-generator-procedure
              (lambda ()
                (define (traverse p)
                  (unless (or (not p) (avl-empty? p))
                    (traverse (%left p))
                    (suspend (cons (%key p) (%data p)))
                    (traverse (%right p)))
                  &fail)
                (traverse tree)))))))

    (define (avl) (%avl #f #f #f #f #f))

    (define (avl-empty? tree)
      (avl-check-usage
       (avl? tree)
       "avl-empty? expects an AVL tree as argument")
      (not (%bal tree)))

    (define (avl-search-values pred<? tree key)
      (define (search p)
        (if (not p)
            (values #f #f)
            (let ((k (%key p)))
              (cond ((pred<? key k) (search (%left p)))
                    ((pred<? k key) (search (%right p)))
                    (else (values (%data p) #t))))))
      (avl-check-usage
       (procedure? pred<?)
       "avl-search-values expects a procedure as first argument")
      (if (avl-empty? tree)
          (values #f #f)
          (search tree)))

    (define (avl-insert pred<? tree key data)
      (define (search p fix-balance?)
        (cond
         ((not p)
          (values (%avl key data 0 #f #f) #t))
         ((pred<? key (%key p))
          (let-values (((p1 fix-balance?)
                        (search (%left p) fix-balance?)))
            (cond
             ((not fix-balance?)
              (let ((p^ (%avl (%key p) (%data p) (%bal p)
                              p1 (%right p))))
                (values p^ #f)))
             (else
              (case (%bal p)
                ((1)
                 (let ((p^ (%avl (%key p) (%data p) 0
                                 p1 (%right p))))
                   (values p^ #f)))
                ((0)
                 (let ((p^ (%avl (%key p) (%data p) -1
                                 p1 (%right p))))
                   (values p^ fix-balance?)))
                ((-1)
                 (case (%bal p1)
                   ((-1)
                    (let* ((p^ (%avl (%key p) (%data p) 0
                                     (%right p1) (%right p)))
                           (p1^ (%avl (%key p1) (%data p1) 0
                                      (%left p1) p^)))
                      (values p1^ #f)))
                   ((0 1)
                    (let* ((p2 (%right p1))
                           (bal2 (%bal p2))
                           (p^ (%avl (%key p) (%data p)
                                     (- (min bal2 0))
                                     (%right p2) (%right p)))
                           (p1^ (%avl (%key p1) (%data p1)
                                      (- (max bal2 0))
                                      (%left p1) (%left p2)))
                           (p2^ (%avl (%key p2) (%data p2) 0
                                      p1^ p^)))
                      (values p2^ #f)))
                   (else (internal-error))))
                (else (internal-error)))))))

         ((pred<? (%key p) key)
          (let-values (((p1 fix-balance?)
                        (search (%right p) fix-balance?)))
            (cond
             ((not fix-balance?)
              (let ((p^ (%avl (%key p) (%data p) (%bal p)
                              (%left p) p1)))
                (values p^ #f)))
             (else
              (case (%bal p)
                ((-1)
                 (let ((p^ (%avl (%key p) (%data p) 0
                                 (%left p) p1)))
                   (values p^ #f)))
                ((0)
                 (let ((p^ (%avl (%key p) (%data p) 1
                                 (%left p) p1)))
                   (values p^ fix-balance?)))
                ((1)
                 (case (%bal p1)
                   ((1)
                    (let* ((p^ (%avl (%key p) (%data p) 0
                                     (%left p) (%left p1)))
                           (p1^ (%avl (%key p1) (%data p1) 0
                                      p^ (%right p1))))
                      (values p1^ #f)))
                   ((-1 0)
                    (let* ((p2 (%left p1))
                           (bal2 (%bal p2))
                           (p^ (%avl (%key p) (%data p)
                                     (- (max bal2 0))
                                     (%left p) (%left p2)))
                           (p1^ (%avl (%key p1) (%data p1)
                                      (- (min bal2 0))
                                      (%right p2) (%right p1)))
                           (p2^ (%avl (%key p2) (%data p2) 0
                                      p^ p1^)))
                      (values p2^ #f)))
                   (else (internal-error))))
                (else (internal-error)))))))
         (else
          (values (%avl key data (%bal p) (%left p) (%right p))
                  #f))))
      (avl-check-usage
       (procedure? pred<?)
       "avl-insert expects a procedure as first argument")
      (if (avl-empty? tree)
          (%avl key data 0 #f #f)
          (let-values (((p fix-balance?) (search tree #f)))
            p)))

    (define (internal-error)
      (display "internal error\n" (current-error-port))
      (emergency-exit 123))

    (define (usage-error msg)
      (display "Procedure usage error:\n" (current-error-port))
      (display "  " (current-error-port))
      (display msg (current-error-port))
      (newline (current-error-port))
      (exit 1))

    )) ;; end library (avl-trees)


(define-library (associative-arrays)
  ;;
  ;; Persistent associative ‘arrays’ for R7RS Scheme.
  ;;
  ;; The structure is not actually an array, but is made of AVL trees
  ;; and association lists. Given a good hash function, it should
  ;; average logarithmic performance.
  ;;

  (export assoc-array-make-pair-generator
          assoc-array-make-key-generator
          assoc-array-make-data-generator)
  (export assoc-array assoc-array? assoc-array-set assoc-array-ref)

  (import (scheme base))
  (import (scheme case-lambda))
  (import (scheme write))
  (import (suspendable-procedures))
  (import (avl-trees))

  (cond-expand
    (chicken (import (only (srfi 1) alist-delete)))
    ;; Insert whatever you need here for your Scheme.
    (else))

  (begin

    (define-record-type <assoc-array>
      (%assoc-array hashfunc pred=? default table)
      assoc-array?
      (hashfunc %hashfunc)
      (pred=? %pred=?)
      (default %default)
      (table %table))

    (define (assoc-array-make-generator array kind)
      (define tree-traverser (avl-make-generator (%table array)))
      (define get-desired-part
        (cond ((eq? kind 'key) (lambda (pair) (car pair)))
              ((eq? kind 'data) (lambda (pair) (cdr pair)))
              (else (lambda (pair) pair))))
      (make-generator-procedure
       (lambda ()
         (let traverse ()
           (let ((tree-entry (tree-traverser)))
             (when (success? tree-entry)
               (let scan-lst ((lst (cdr tree-entry)))
                 (when (pair? lst)
                   (suspend (get-desired-part (car lst)))
                   (scan-lst (cdr lst))))
               (traverse))))
         &fail)))

    (define (assoc-array-make-pair-generator array)
      (assoc-array-make-generator array 'pair))

    (define (assoc-array-make-key-generator array)
      (assoc-array-make-generator array 'key))

    (define (assoc-array-make-data-generator array)
      (assoc-array-make-generator array 'data))

    (define assoc-array
      (case-lambda
        ((hashfunc)
         (let ((pred=? equal?)
               (default #f))
           (assoc-array hashfunc pred=? default)))
        ((hashfunc pred=?)
         (let ((default #f))
           (assoc-array hashfunc pred=? default)))
        ((hashfunc pred=? default)
         (%assoc-array hashfunc pred=? default (avl)))))

    (define (assoc-array-set array key data)
      (let ((hashfunc (%hashfunc array))
            (pred=? (%pred=? array))
            (default (%default array))
            (table (%table array)))
        (let ((hash-value (hashfunc key)))
          (let*-values
              (((alst found?) (avl-search-values < table hash-value)))
            (cond
             (found?
              (let* ((alst (alist-delete key alst pred=?))
                     (alst `((,key . ,data) . ,alst))
                     (table (avl-insert < table hash-value alst)))
                (%assoc-array hashfunc pred=? default table)))
             (else
              (let* ((alst `((,key . ,data)))
                     (table (avl-insert < table hash-value alst)))
                (%assoc-array hashfunc pred=? default table))))))))

    (define (assoc-array-ref array key)
      (let* ((hashfunc (%hashfunc array))
             (hash-value (hashfunc key)))
        (let*-values
            (((alst found?)
              (avl-search-values < (%table array) hash-value)))
          (if found?
              (let ((pair (assoc key alst (%pred=? array))))
                (if pair
                    (cdr pair)
                    (%default array)))
              (%default array)))))

    )) ;; end library (associative-arrays)


(cond-expand
  (DEMONSTRATION
   (begin
     (import (scheme base))
     (import (scheme write))
     (import (suspendable-procedures))
     (import (associative-arrays))

     (define (hashfunc s)
       ;; Using Knuth’s random number generator to concoct a quick and
       ;; dirty and probably very bad hash function. It should be much
       ;; better to use something like SpookyHash, but this is a demo.
       (define a 6364136223846793005)
 	   (define c 1442695040888963407)
       (define M (expt 2 64))
       (let ((n (string-length s))
             (h 123))
         (do ((i 0 (+ i 1)))
             ((= i n))
           (let* ((x (char->integer (string-ref s i)))
                  (x (+ (* a (+ h x)) c)))
             (set! h (truncate-remainder x M))))
         h))

     (define a (assoc-array hashfunc))

     ;; Fill the associative array ‘a’ with (string . number)
     ;; associations.
     (do ((i 1 (+ i 1)))
         ((= i 11))
       (set! a (assoc-array-set a (number->string i) i)))

     ;; Go through the association pairs (in arbitrary order) with a
     ;; generator.
     (let ((gen (assoc-array-make-pair-generator a)))
       (do ((pair (gen) (gen)))
           ((failure? pair))
         (write pair) (display " "))
       (newline))

     ;; Go through the keys (in arbitrary order) with a generator.
     (let ((gen (assoc-array-make-key-generator a)))
       (do ((key (gen) (gen)))
           ((failure? key))
         (write key) (display " "))
       (newline))

     ;; Go through the values (in arbitrary order) with a generator.
     (let ((gen (assoc-array-make-data-generator a)))
       (do ((value (gen) (gen)))
           ((failure? value))
         (write value) (display " "))
       (newline))

     ))
  (else))