5. Hashes

;; ---------------------------------------------------------------------
;; Scheme offers two dictionary types:
;;
;; * Association list [list of pairs e.g. '((k1 . v1) (k2 . v2) ...)]
;; * Hash table [vector of pairs plus hash algorithm]
;;
;; Implementation differences aside, they are remarkably similar in that
;; the functions operating on them are similar named, and offer the same
;; interface. Examples:
;;
;; * Retrieve an item: (assoc-ref hash key)
;;                     (hash-ref hash key)
;;
;; * Update an item:   (assoc-set! hash key value)
;;                     (hash-set! hash key value) 
;;
;; Hash tables would tend to be used where performance was critical e.g.
;; near constant-time lookups, or where entry updates are frequent,
;; whilst association lists would be used where table-level traversals
;; and manipulations require maximum flexibility
;;
;; Many of the sections include examples using both association lists
;; and hash tables. However, where only one of these is shown,
;; implementing the other is usually a trivial exercise. Finally, any
;; helper functions will be included in the Appendix
;; ---------------------------------------------------------------------

; Association lists
(define *age*
  (list
    (cons 'Nat 24)
    (cons 'Jules 25)
    (cons 'Josh 17)))

;; or, perhaps more compactly:
(define *age*
  (list
    '(Nat . 24)
    '(Jules . 25)
    '(Josh . 17)))

;; ------------

; Guile built-in association list support
(define *age* (acons 'Nat 24 '()))
(set! *age* (acons 'Jules 25 *age*))
(set! *age* (acons 'Josh 17 *age*))

;; ----

; SRFI-1 association list support
(use-modules (srfi srfi-1))

(define *age* (alist-cons 'Nat 24 '()))
(set! *age* (alist-cons 'Jules 25 *age*))
(set! *age* (alist-cons 'Josh 17 *age*))

;; ------------

(define *food-colour*
  (list
    '(Apple . "red")
    '(Banana . "yellow")
    '(Lemon . "yellow")
    '(Carrot . "orange")))

;; ----------------------------

; Hash tables. Guile offers an implementation, and it is also 
; possible to use SRFI-69 hash tables; only the former will be
; illustrated here

(define *age* (make-hash-table 20))
; or
(define *age* (make-vector 20 '()))

(hash-set! *age* 'Nat 24)
(hash-set! *age* 'Jules 25)
(hash-set! *age* 'Josh 17)

(hash-for-each
  (lambda (key value) (print key))
  *age*)

; or, if vector used as hash table, can also use:

(array-for-each
  (lambda (pair)
    (if (not (null? pair)) (print (car pair))))
  *age*)

;; ------------

(define *food-colour* (make-hash-table 20))

(hash-set! *food-colour* 'Apple "red")
(hash-set! *food-colour* 'Banana "yellow")
(hash-set! *food-colour* 'Lemon "yellow")
(hash-set! *food-colour* 'Carrot "orange")

(set! *hash* (acons key value *hash*))

;; ------------

(set! *food-colour* (acons 'Raspberry "pink" *food-colour*))

(print "Known foods:")
(for-each
  (lambda (pair) (print (car pair)))
  *food-colour*)

;; ----------------------------

(hash-set! *hash* key value)

;; ------------

(hash-set! *food-colour* 'Raspberry "pink")

(print "Known foods:")
(hash-for-each
  (lambda (key value) (print key))
  *food-colour*)

; 'assoc' returns the pair, (key . value)
(if (assoc key hash)
  ;; ... found ...
  '()
;else
  ;; ... not found ...
  '()

; 'assoc-ref' returns the value only
(if (assoc-ref hash key)
  ;; ... found ...
  '()
;else
  ;; ... not found ...
  '()

;; ------------

; *food-colour* association list from an earlier section

(for-each
  (lambda (name)
    (let ((pair (assoc name *food-colour*)))
      (if pair
        (print (symbol->string (car pair)) "is a food")
      ;else
        (print (symbol->string name) "is a drink") )))
  (list 'Banana 'Martini))

;; ----------------------------

; 'hash-get-handle' returns the pair, (key . value)
(if (hash-get-handle hash key)
  ;; ... found ...
  '()
;else
  ;; ... not found ...
  '()

; 'hash-ref' returns the value only
(if (hash-ref hash key)
  ;; ... found ...
  '()
;else
  ;; ... not found ...
  '()

;; ------------

; *food-colour* hash table from an earlier section

(for-each
  (lambda (name)
    (let ((value (hash-ref *food-colour* name)))
      (if value
        (print (symbol->string name) "is a food")
      ;else
        (print (symbol->string name) "is a drink") )))
  (list 'Banana 'Martini))

;; ----------------------------

(define *age* (make-hash-table 20))

(hash-set! *age* 'Toddler 3)
(hash-set! *age* 'Unborn 0)
(hash-set! *age* 'Phantasm '())

(for-each
  (lambda (thing)
    (let ((value (hash-ref *age* thing)))
      (display thing)
      (if value (display " Exists"))
      (if (and value (not (string-null? value))) (display " Defined"))
      ; Testing for non-zero as true is not applicable, so testing
      ; for non-equality with zero 
      (if (and value (not (eq? value 0))) (display " True"))
      (print "") ))
  (list 'Toddler 'Unborn 'Phantasm 'Relic))

(assoc-remove! hash key)

;; ------------

(use-modules (srfi srfi-1))

; *food-colour* association list from an earlier section

(define (print-foods)
  (let ((foods
          (fold-right
            (lambda (pair accum) (cons (car pair) accum))
            '()
            *food-colour*)))
    (display "Keys: ") (print foods)
    (print "Values:")
    (for-each
      (lambda (food)
        (let ((colour (assoc-ref *food-colour* food)))
          (cond
            ((string-null? colour) (display "(undef) "))
            (else (display (string-append colour " "))) )))
      foods))
    (newline))

(print "Initially:")
(print-foods)

(print "\nWith Banana undef")
(assoc-set! *food-colour* 'Banana "")
(print-foods)

(print "\nWith Banana deleted")
(assoc-remove! *food-colour* 'Banana)
(print-foods)

;; ----------------------------

(hash-remove! hash key)

;; ------------

(use-modules (srfi srfi-1))

; *food-colour* hash table from an earlier section

(define (print-foods)
  (let ((foods
          (hash-fold
            (lambda (key value accum) (cons key accum))
            '()
            *food-colour*)))
    (display "Keys: ") (print (reverse foods))
    (print "Values:")
    (for-each
      (lambda (food)
        (let ((colour (hash-ref *food-colour* food)))
          (cond
            ((string-null? colour) (display "(undef) "))
            (else (display (string-append colour " "))) )))
      foods))
    (newline))

(print "Initially:")
(print-foods)

(print "\nWith Banana undef")
(hash-set! *food-colour* 'Banana "")
(print-foods)

(print "\nWith Banana deleted")
(hash-remove! *food-colour* 'Banana)
(print-foods)

; Since an association list is nothing more than a list of pairs, it
; may be traversed using 'for-each'
(for-each
  (lambda (pair)
    (let ((key (car pair))
          (value (cdr pair)))
      ;; ... do something with key / value ...
      '()))
  hash)

;; ----------------------------

; A 'for-each'-like function is available for hash table traversal
(hash-for-each
  (lambda (key value)
    ;; ... do something with key / value ...
    '())
  hash)

; If the hash table is directly implemented as a vector, then it is
; also possible to traverse it using, 'array-for-each', though a 
; check for empty slots is needed 
(array-for-each
  (lambda (pair)
    (if (not (null? pair)) ... do something with key / value ...))
  hash)

;; ----------------------------

; *food-colour* association list from an earlier section

(for-each
  (lambda (pair)
    (let ((food (car pair))
          (colour (cdr pair)))
      (print (symbol->string food) "is" colour) ))
  *food-colour*)

;; ------------

; *food-colour* association list from an earlier section

(for-each
  (lambda (food)
    (print (symbol->string food) "is" (assoc-ref *food-colour* food)))
  (sort
    (fold-right
      (lambda (pair accum) (cons (car pair) accum))
      '()
      *food-colour*)
    (lambda (left right)
      (string<? (symbol->string left) (symbol->string right)))))

;; ----------------------------

(use-modules (srfi srfi-1) (ice-9 rdelim) (ice-9 regex))

(define *filename* "from.txt")
(define *from* '())

(let ((port (open-input-file *filename*)))
  (let loop ((line&terminator (read-line port 'split)))
    (cond
      ((eof-object? (cdr line&terminator)) '())
      (else
        (let* ((key (string->symbol
                      (match:substring
                        (string-match
                          "^From: (.*)" (car line&terminator))
                        1) ))
               (value (assoc-ref *from* key)))
          (if (not value) (set! value 0))
          (set! *from* (assoc-set! *from* key (+ 1 value))))
        (loop (read-line port 'split)) ))) 
  (close-input-port port))

(for-each
  (lambda (person)
    (print (symbol->string person) ":"
           (number->string (assoc-ref *from* person))))
  (sort
    (fold-right
      (lambda (pair accum) (cons (car pair) accum))
      '()
      *from*)
    (lambda (left right)
      (string<? (symbol->string left) (symbol->string right)))))

; All approaches shown in the previous section apply here also, so
; there is little to be gained by repeating those examples [i.e. the
; use of 'for-each' and similar]. It is always possible, of course,
; to directly recurse over an association list:

; *food-colour* association list from an earlier section

(define *sorted-food-colour*
  (sort
    *food-colour*
    (lambda (left right)
      (string<?
        (symbol->string (car left))
        (symbol->string (car right)))) ))

(let loop ((hash *sorted-food-colour*))
  (cond
    ((null? hash) '())
    (else  
      (print
        (symbol->string (car (car hash))) "=>" (cdr (car hash)) )
      (loop (cdr hash))) ))

; AFAIK, Scheme doesn't offer a facility similar to Perl's 'Tie::IxHash'.
; Therefore, use an association list if retrieval [from a dictionary
; type container] in insertion order is required.

(define *food-colour* (acons 'Banana "Yellow" '()))
(set! *food-colour* (acons 'Apple "Green" *food-colour*))
(set! *food-colour* (acons 'Lemon "yellow" *food-colour*))

(print "In insertion order, the foods are:")
(for-each
  (lambda (pair)
    (let ((food (car pair))
          (colour (cdr pair)))
      (print "  " (symbol->string food)) ))
  *food-colour*)

(print "Still in insertion order, the food's colours are:")
(for-each
  (lambda (pair)
    (let ((food (car pair))
          (colour (cdr pair)))
      (print (symbol->string food) "is coloured" colour) ))
  *food-colour*)

;; ----------------------------

; Of course, insertion order is lost if the association list is sorted,
; or elements removed, so if maintaining insertion order is vital, it
; might pay to associate data with a timestamp [e.g. create a timestamped
; record / structure], and manipulate those entities [no example given]

(define *ttys* '())

(for-each
  (lambda (user-tty-pair)
    (let* ((user-tty-pair (string-split user-tty-pair #\space))
           (user (string->symbol (car user-tty-pair)))
           (newtty (cadr user-tty-pair))
           (current-ttys (assoc-ref *ttys* user)))
      (set! *ttys*
        (assoc-set! *ttys* user
          (if (not current-ttys)
            newtty
            (string-append current-ttys " " newtty)) ))))
  (string-split (qx "who|cut -d' ' -f1,2") #\newline))

(for-each
  (lambda (user-ttys)
    (print (symbol->string (car user-ttys)) ":" (cdr user-ttys)))
  (sort
    *ttys*
    (lambda (left right)
      (string<?
        (symbol->string (car left))
        (symbol->string (car right))))) )

;; ----------------------------

(use-modules (ice-9 regex))

(define (multi-hash-delete hash key value)
  (let ((value-found (assoc-ref hash key)))
    (if value-found
      (assoc-ref hash key
        (regexp-substitute/global
          #f (string-match value value-found) 'pre "" 'post "")))))

; Alternate implementatons of a hash inversion function; both assume
; key is a symbol, value is a string

(define (assoc-invert assoc)
  (map
    (lambda (pair)
      (cons
        (string->symbol (cdr pair))
        (symbol->string (car pair))))
    assoc))

;; ------------

(define (assoc-invert assoc)
  (let loop ((assoc assoc) (new-assoc '()))
    (cond
      ((null? assoc) new-assoc)
      (else 
        (loop (cdr assoc)
              (acons
                (string->symbol (cdar assoc))
                (symbol->string (caar assoc)) new-assoc)) )) ))

;; ----------------------------

(define *surname*
  (list
    '(Mickey . "Mantle")
    '(Babe . "Ruth")))

(define *first-name* (assoc-invert *surname*))

(print (assoc-ref *first-name* 'Mantle))

;; ----------------------------

; foodfind

(define *given* (string->symbol (cadr (command-line))))

(define *colour*
  (list
    '(Apple . "red")
    '(Lemon . "yellow")
    '(Carrot . "orange")))

(define *food* (assoc-invert *colour*))

(if (assoc-ref *colour* *given*)
  (print
    (symbol->string *given*) 
    "is a food with colour"
    (assoc-ref *colour* *given*)))

(if (assoc-ref *food* *given*)
  (print
    (assoc-ref *food* *given*)
    "is a food with colour"
    (symbol->string *given*)))

; *food-colour* association list from an earlier section

; Use 'sort' to sort the entire hash, on key or on value, ascending or
; descending order
(define *sorted-on-key:food-colour*
  (sort
    *food-colour*
    (lambda (left right)
      (string<?
        (symbol->string (car left))
        (symbol->string (car right)))) ))

(define *sorted-on-value:food-colour*
  (sort
    *food-colour*
    (lambda (left right)
      (string<?
        (cdr left)
        (cdr right))) ))

;; ------------

(for-each
  (lambda (pair)
    (let ((food (car pair))
          (colour (cdr pair)))
      (print
        (symbol->string food)
        "is"
        colour)))
  *sorted-on-key:food-colour*)

;; ----------------------------

; Alternatively, generate a list of keys or values, sort as required,
; and use list to guide the hash traversal

(define *sorted-food-colour-keys*
  (sort
    (fold-right
      (lambda (pair accum) (cons (car pair) accum))
      '()
      *food-colour*)
    (lambda (left right)
      (string<?
        (symbol->string left)
        (symbol->string right))) ))

(define *sorted-food-colour-values*
  (sort
    (fold-right
      (lambda (pair accum) (cons (cdr pair) accum))
      '()
      *food-colour*)
    (lambda (left right)
      (string<? left right)) ))

;; ------------

(for-each
  (lambda (food)
    (print (symbol->string food) "is" (assoc-ref *food-colour* food)))
  *sorted-food-colour-keys*)

; If merging is defined as the combining of the contents of two or more
; hashes, then it is simply a matter of copying the contents of each
; into a new hash

; Association lists can simply be appended together
(define *food-colour*
  (list
    '(Apple . "red")
    '(Banana . "yellow")
    '(Lemon . "yellow")
    '(Carrot . "orange")))

(define *drink-colour*
  (list
    '(Galliano . "yellow")
    '(Mai Tai . "blue")))

(define *ingested-colour* (append *food-colour* *drink-colour*))

;; ----------------------------

; Hash tables built from vectors can be copied element by element into
; a new vector, or spliced together using 'vector-join' [see Chapter 4]

(define *food-colour* (make-vector 20 '())
; ...
(define *drink-colour* (make-vector 20 '())
; ...

(define *ingested-colour*
  (vector-join *food-colour* *drink-colour*))

(define *common* '())
(define *this-not-that* '())

;; ------------

(define *dict1*
  (list
    '(Apple . "red")
    '(Lemon . "yellow")
    '(Carrot . "orange")))

(define *dict2*
  (list
    '(Apple . "red")
    '(Carrot . "orange")))

;; ------------

; Find items common to '*dict1*' and '*dict2*'
(for-each
  (lambda (pair)
    (let ((key (car pair))
          (value (cdr pair)))
      (if (assoc-ref *dict2* key)
        (set! *common* (cons key *common*))) ))
  *dict1*)

;; ------------

; Find items in '*dict1*' but not '*dict2*'
(for-each
  (lambda (pair)
    (let ((key (car pair))
          (value (cdr pair)))
      (if (not (assoc-ref *dict2* key))
        (set! *this-not-that* (cons key *this-not-that*))) ))
  *dict1*)

;; ----------------------------

(define *non-citrus* '())

(define *citrus-colour*
  (list
    '(Lemon . "yellow")
    '(Orange . "orange")
    '(Lime . "green")))

(define *food-colour*
  (list
    '(Apple . "red")
    '(Banana . "yellow")
    '(Lemon . "yellow")
    '(Carrot . "orange")))

(for-each
  (lambda (pair)
    (let ((key (car pair))
          (value (cdr pair)))
      (if (not (assoc-ref *citrus-colour* key))
        (set! *non-citrus* (cons key *non-citrus*))) ))
  *food-colour*)

; All objects [including functions] are first class entities, so there
; is no problem / special treatment needed to use any object, including
; those classed as 'references' [e.g. file handles or ports] as keys

(use-modules (srfi srfi-1) (srfi srfi-13))

(define *ports* '())

(for-each
  (lambda (filename)
    (let ((port (open-input-file filename)))
      (set! *ports* (assoc-set! *ports* port filename)) ))
  '("/etc/termcap" "/vmlinux" "/bin/cat"))

(print
  (string-append "open files: "
    (string-drop
      (fold-right
        (lambda (pair accum) (string-append ", " (cdr pair) accum))
        ""
        *ports*)
      2)))

(for-each
  (lambda (pair)
    (let ((port (car pair))
          (filename (cdr pair)))
      (seek port 0 SEEK_END)
      (print filename "is" (number->string (ftell port)) "bytes long.")
      (close-input-port port) ))
  *ports*)

; An association list takes on the size of the number of elements with
; which it is initialised, so presizing is implicit

(define *hash* '())         ; zero elements

;; ------------

(define *hash*              ; three elements
  (list
    '(Apple . "red")
    '(Lemon . "yellow")
    '(Carrot . "orange")))

;; ----------------------------

; A size [i.e. number of entries] must be specified when a hash table
; is created, so presizing is implicit

(define *hash* (make-hash-table 100))

;; ------------

(define *hash* (make-vector 100 '()))

(define *array*
  (list 'a 'b 'c 'd 'd 'a 'a 'c 'd 'd 'e))

;; ----------------------------

(define *count* '())

(for-each
  (lambda (element)
    (let ((value (assoc-ref *count* element)))
      (if (not value) (set! value 0))
      (set! *count* (assoc-set! *count* element (+ 1 value)))))
  *array*)

;; ----------------------------

(define *count* (make-hash-table 20))

(for-each
  (lambda (element)
    (let ((value (hash-ref *count* element)))
      (if (not value) (set! value 0))
      (hash-set! *count* element (+ 1 value))))
  *array*)

(define *father*
  (list
    '(Cain . Adam)
    '(Abel . Adam)
    '(Seth . Adam)
    '(Enoch . Cain)
    '(Irad . Enoch)
    '(Mehujael . Irad)
    '(Methusael . Mehujael)
    '(Lamech . Methusael)
    '(Jabal . Lamech)
    '(Jubal . Lamech)
    '(Tubalcain . Lamech)
    '(Enos . Seth)))

;; ------------

(use-modules (srfi srfi-1) (ice-9 rdelim))

(let ((port (open-input-file *filename*)))
  (let loop ((line&terminator (read-line port 'split)))
    (cond
      ((eof-object? (cdr line&terminator)) '())
      (else
        (let ((person (string->symbol (car line&terminator))))
          (let loop ((father (assoc-ref *father* person)))
            (if father
            (begin
              (print father)
              (loop (assoc-ref *father* father)) )))
        (loop (read-line port 'split)) ))))
  (close-input-port port))

;; ------------

(use-modules (srfi srfi-1) (ice-9 rdelim))

(define (assoc-invert-N:M assoc)
  (let ((new-assoc '()))
    (for-each
      (lambda (pair)
        (let* ((old-key (car pair))
               (new-key (cdr pair))
               (new-key-found (assoc-ref new-assoc new-key)))
          (if (not new-key-found)
            (set! new-assoc (acons new-key (list old-key) new-assoc)) 
          ;else
            (set! new-assoc (assoc-set! new-assoc new-key
                            (cons old-key new-key-found))) )))
      assoc)
  new-assoc))

(define *children* (assoc-invert-N:M *father*))

(let ((port (open-input-file *filename*)))
  (let loop ((line&terminator (read-line port 'split)))
    (cond
      ((eof-object? (cdr line&terminator)) '())
      (else
        (let* ((person (string->symbol (car line&terminator)))
               (children-found (assoc-ref *children* person)))
          (print (symbol->string person) "begat:")
          (if (not children-found)
            (print "nobody")
          ;else
            (for-each
              (lambda (child) (print (symbol->string child) ","))
              children-found))
        (loop (read-line port 'split)) ))))
  (close-input-port port))

;; @@INCOMPLETE@@
;; @@INCOMPLETE@@