4. Arrays

(define nested '("this" "that" "the" "other"))
(define nested '("this" "that" ("the" "other")))
(define tune '("The" "Star-Spangled" "Banner"))

(define a '("quick" "brown" "fox"))
(define a '("Why" "are" "you" "teasing" "me?"))

(use-modules (srfi srfi-13))
(define lines
  (map string-trim
       (string-tokenize "\
    The boy stood on the burning deck,
    It was as hot as glass."
                        #\newline)))

(define bigarray
  (with-input-from-file "mydatafile"
    (lambda ()
      (let loop ((lines '())
                 (next-line (read-line)))
        (if (eof-object? next-line)
            (reverse lines)
            (loop (cons next-line lines)
                  (read-line)))))))

(define banner "The Mines of Moria")

(define name "Gandalf")
(define banner
  (string-append "Speak, " name ", and enter!"))
(define banner
  (format #f "Speak, ~A, and welcome!" name))

;; Advanced shell-like function is provided by guile-scsh, the Guile
;; port of SCSH, the Scheme shell.  Here we roll our own using the
;; pipe primitives that come with core Guile.
(use-modules (ice-9 popen))

(define (drain-output port)
  (let loop ((chars '())
             (next (read-char port)))
    (if (eof-object? next)
        (list->string (reverse! chars))
        (loop (cons next chars)
              (read-char port)))))

(define (qx pipeline)
  (let* ((pipe (open-input-pipe pipeline))
         (output (drain-output pipe)))
    (close-pipe pipe)
    output))

(define his-host "www.perl.com")
(define host-info (qx (format #f "nslookup ~A" his-host)))

(define perl-info (qx (format #f "ps ~A" (getpid))))
(define shell-info (qx "ps $$"))

(define banner '("Costs" "only" "$4.95"))
(define brax    (map string (string->list "()<>{}[]")))
(define rings   (string-tokenize "Nenya Narya Vilya"))
(define tags    (string-tokenize "LI TABLE TR TD A IMG H1 P"))
(define sample
  (string-tokenize "The vertical bar (|) looks and behaves like a pipe."))
(define ships  '("Niña" "Pinta" "Santa María"))

(define array '("red" "yellow" "green"))

(begin
  (display "I have ")
  (for-each display array)
  (display " marbles.\n"))
;; I have redyellowgreen marbles.

(begin
  (display "I have ")
  (for-each (lambda (colour)
              (display colour)
              (display " "))
            array)
  (display "marbles.\n"))
;; I have red yellow green marbles.

;; commify - insertion of commas into list output
(define (commify strings)
  (let ((len (length strings)))
    (case len
      ((0) "")
      ((1) (car strings))
      ((2) (string-append (car strings) " and " (cadr strings)))
      ((3) (string-append (car strings) ", "
                          (cadr strings) ", and "
                          (caddr strings)))
      (else
       (string-append (car strings) ", "
                      (commify (cdr strings)))))))

(define lists '(("just one thing")
                ("Mutt" "Jeff")
                ("Peter" "Paul" "Mary")
                ("To our parents" "Mother Theresa" "God")
                ("pastrami" "ham and cheese" "peanut butter and jelly" "tuna")
                ("recycle tired, old phrases" "ponder big, happy thoughts")
                ("recycle tired, old phrases"
                 "ponder big, happy thoughts"
                 "sleep and dream peacefully")))

(for-each (lambda (list)
            (display "The list is: ")
            (display (commify list))
            (display ".\n"))
          lists)

;; The list is: just one thing.
;; The list is: Mutt and Jeff.
;; The list is: Peter, Paul, and Mary.
;; The list is: To our parents, Mother Theresa, and God.
;; The list is: pastrami, ham and cheese, peanut butter and jelly, and tuna.
;; The list is: recycle tired, old phrases and ponder big, happy thoughts.
;; The list is: recycle tired, old phrases, ponder big, happy thoughts, and
;; sleep and dream peacefully.

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

;; Scheme does not normally grow and shrink arrays in the way that
;; Perl can.  The more usual operations are adding and removing from
;; the head of a list using the `cons' and `cdr' procedures.
;; However ...
(define (grow/shrink list new-size)
  (let ((size (length list)))
    (cond ((< size new-size)
           (grow/shrink (cons "" list) new-size))
          ((> size new-size)
           (grow/shrink (cdr list) new-size))
          (else list))))

(define (element list i)
  (list-ref list (- (length list) i 1)))

(define (set-element list i value)
  (if (>= i (length list))
      (set! list (grow/shrink list (- i 1))))
  (set-car! (list-cdr-ref list (- (length list) i 1)))
  list)

(define (what-about list)
  (let ((len (length list)))
    (format #t "The array now has ~A elements.\n" len)
    (format #t "The index of the last element is ~A.\n" (- len 1))
    (format #t "Element #3 is `~A'.\n" (if (> len 3)
                                           (element list 3)
                                           ""))))

;; In the emulation of Perl arrays implemented here, the elements are
;; in reverse order when compared to normal Scheme lists.
(define people (reverse '("Crosby" "Stills" "Nash" "Young")))
(what-about people)
;;-----------------------------
;; The array now has 4 elements.
;; The index of the last element is 3.
;; Element #3 is `Young'.
;;-----------------------------
(set! people (grow/shrink people 3))
(what-about people)
;;-----------------------------
;; The array now has 3 elements.
;; The index of the last element is 2.
;; Element #3 is `'.
;;-----------------------------
(set! people (grow/shrink people 10001))
(what-about people)
;;-----------------------------
;; The array now has 10001 elements.
;; The index of the last element is 10000.
;; Element #3 is `'.
;;-----------------------------

; Using a 'list' i.e. chain of pairs
(define *mylist* '(1 2 3))

; Apply procedure to each member of 'mylist'
(for-each
  (lambda (item) (print item))
  *mylist*)

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

; Using a 'vector' i.e. one-dimensional array
(define *bad-users* '#("lou" "mo" "sterling" "john"))

(define (complain user)
  (print "You're a *bad user*," user))

(array-for-each
  (lambda (user) (complain user))
  *bad-users*)

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

; Could probably get away with sorting a list of strings ...
(define *sorted-environ*
  (sort (environ) string<?))

(for-each
  (lambda (var) (display var) (newline))
  *sorted-environ*)

;; ----

; ... but the intent here is to sort a hash table, so we'll use
; an 'assoc', Scheme's native dictionary type, which is really
; nothing more than a list of conses / dotted pairs [hash tables
; will be used in later examples]
(define (cons->env-string a)
  (string-append (car a) "=" (cdr a)))

(define (env-string->cons s)
  (let ((key-value (string-split s #\=)))
    (cons (car key-value) (cadr key-value))))

(define *sorted-environ-assoc*
  (sort
    (map
      (lambda (var) (env-string->cons var))
      (environ))
    (lambda (left right) (string<? (car left) (car right))) ))

(for-each
  (lambda (var)
    (print (car var) "=" (cdr var)))
  *sorted-environ-assoc*)

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

(define *MAX-QUOTA* 100)

(define (get-all-users) ...)
(define (get-usage user) ...)
(define (complain user) ...)

(for-each
  (lambda (user)
    (let ((disk-usage (get-usage user)))
      (if (> disk-usage *MAX-QUOTA*)
        (complain user))))
  (get-all-users))

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

(for-each
  (lambda (user) (if (string=? user "tchrist") (print user)))
  (string-split (qx "who|cut -d' ' -f1|uniq") #\newline))

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

(use-modules (srfi srfi-13) (srfi srfi-14))

(do ((line (read-line) (read-line)))
    ((eof-object? line))
  (for-each
    (lambda (word) (print (string-reverse word)))
    (string-tokenize line char-set:graphic)))

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

; Updates vector in-place [accepts variable number of vectors]
; See also the library function, 'array-map-in-order!' and its
; brethren
(define (vector-map-in-order! proc vec . rest)
  (let ((all-vec (cons vec rest)))
    (for-each
      (lambda (vec)
        (let ((end (vector-length vec)))
          (let loop ((idx 0))
            (cond
              ((= idx end) '())
              (else
                (vector-set! vec idx
                  (apply proc (list (vector-ref vec idx))))
                (loop (+ idx 1)))) )))
      all-vec)))

;; ----

; A non-mutating version - illustration only, as library routines
; [SRFI-43 and built-ins] should be preferred
(define (vector-map-in-order proc vec . rest)
  (let* ((all-vec (cons vec rest))
         (new-vec-len (reduce + 0 (map vector-length all-vec)))
         (new-vec (make-vector new-vec-len))
         (new-vec-idx 0))
    (let loop ((all-vec all-vec))
      (cond
        ((= new-vec-idx new-vec-len) new-vec)
        (else
          (array-for-each
            (lambda (element)
              (vector-set! new-vec new-vec-idx (apply proc (list element)))
              (set! new-vec-idx (+ new-vec-idx 1)))
            (car all-vec))
          (loop (cdr all-vec)) ))) ))

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

(define *array* '#(1 2 3))

(array-for-each
  (lambda (item)
    (print "i =" item))
  *array*)

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

(define *array* '#(1 2 3))

(array-for-each
  (lambda (item)
    (print "i =" item))
  *array*)

; Since a 'vector' is mutable, in-place updates allowed
(vector-map-in-order!
  (lambda (item) (- item 1))
  *array*)

(print *array*)

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

(define *a* '#(0.5 3))
(define *b* '#(0 1))

(vector-map-in-order!
  (lambda (item) (* item 7))
  *a* *b*)

(print *a* *b*)

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

; Using 'for-each' to iterate over several container items is a
; simple matter of passing a list of those items e.g. a list of
; strings, or of arrays etc.
;
; However, complications arise when:
; * Heterogenous list of items e.g. list contains all of arrays,
;   hashes, strings, etc. Necesitates different handling based on type
; * Item needs updating. It is not possible to alter the item reference
;   and updating an item's internals is only possible if the relevant
;   mutating procedures are implemented e.g. specified string characters
;   may be altered in-place, but character deletion requires a new be
;   created [i.e. altering the item reference], so is not possible

(define *scalar* "123 ")
(define *array* '#(" 123 " "456 "))
(define *hash* (list (cons "key1" "123 ") (cons "key2" " 456")))

; Illustrates iteration / handling of heterogenous types
(for-each
  (lambda (item)
    (cond
      ((string? item) (do-stuff-with-string item))
      ((vector? item) (do-stuff-with-vector item))
      ((pair? item) (do-stuff-with-hash item))
      (else (print "unknown type"))))
  (list *scalar* *array* *hash*))

; So, for item-replacement-based updating you need to use explicit
; iteration e.g. 'do' loop, or recursion [as is done in the code for
; 'vector-map-in-order!'] - examples in next section. Or, you could
; create a new 'for-each' type control structure using Scheme's
; macro facility [example not shown]

(define *array* '#(1 2 3))

;; ----

; Whilst a 'vector' is mutable, 'array-for-each' passes only a copy
; of each cell, thus there is no way to perform updates
(array-for-each
  (lambda (item)
    ;; ... do some non-array-mutating task with 'item'...
    '())
  *array*)

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

; For mutating operations, use one of the mutating 'array-map-...'
; routines or the custom, 'vector-map-in-order!'
(vector-map-in-order!
  (lambda (item)
    ;; ... do some array-mutating task with 'item'...
    '())
  *array*)

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

; Alternatively, use 'do' to iterate over the array and directly
; update 
(let ((vector-length (vector-length *array*)))
  (do ((i 0 (+ i 1)))
      ((= i vector-length))
    ;; ... do some array-mutating task with current element ...
    '()))

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

; Alternatively, use a 'named let' to iterate over array and
; directly update 
(let ((vector-length (vector-length *array*)))
  (let loop ((i 0))
    (cond
      ((= i vector-length) '())
      (else
        ;; ... do some array-mutating task with current element ...
        '()
        (loop (+ i 1)))) ))

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

(define *fruits* '#("Apple" "Blackberry"))

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

(array-for-each
  (lambda (fruit)
    (print fruit "tastes good in a pie."))
  *fruits*)

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

(let ((vector-length (vector-length *fruits*)))
  (do ((i 0 (+ i 1)))
      ((= i vector-length))
    (print (vector-ref *fruits* i) "tastes good in a pie.") ))

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

(define *rogue-cats* '("Blacky" "Ginger" "Puss"))

(define *name-list* (acons 'felines *rogue-cats* '()))

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

(for-each
  (lambda (cat)
    (print cat "purrs hypnotically.."))
  (cdr (assoc 'felines *name-list*)))

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

(let loop ((felines (cdr (assoc 'felines *name-list*))))
  (cond
    ((null? felines) '())
    (else
      (print (car felines) "purrs hypnotically..")
      (loop (cdr felines)))))

(use-modules (srfi srfi-1))

; Simplest [read: least code] means of removing duplicates is to
; use SRFI-1's 'delete-duplicates' routine

(define *non-uniq-num-list* '(1 2 3 1 2 3))
(define *uniq* (delete-duplicates *my-non-uniq-num-list*)

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

(use-modules (srfi srfi-1))

; Another simple alternative is to use SRFI-1's 'lset-union' routine.
; In general, the 'lset-...' routines:
; - convenient, but not fast; probably best avoided for 'large' sets
; - operate on standard lists, so simple matter of type-converting
;   arrays and such
; - care needs to be taken in choosing the needed equality function

(define *non-uniq-string-list* '("abc" "def" "ghi" "abc" "def" "ghi"))
(define *uniq*
  (lset-union string=? *non-uniq-string-list* *non-uniq-string-list*))

;; ----

(define *non-uniq-sym-list* '('a 'b 'c 'a 'b 'c))
(define *uniq*
  (lset-union equal? *my-non-uniq-sym-list* *my-non-uniq-sym-list*))

;; ----

(define *non-uniq-num-list* '(1 2 3 1 2 3))
(define *uniq*
  (lset-union = *my-non-uniq-num-list* *my-non-uniq-num-list*))

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

;; Perl Cookbook-based examples - illustrative only, *not*
;; recommended approaches

(use-modules (srfi srfi-1))

(define *list* '(1 2 3 1 2 7 8 1 8 2 1 3))
(define *seen* '())

; Use hash to filter out unique items
(for-each
  (lambda (item)
    (if (not (assoc-ref *seen* item))
      (set! *seen* (assoc-set! *seen* item #t))))
  *list*)

; Generate list of unique items
(define *uniq*
  (fold-right
    (lambda (pair accum) (cons (car pair) accum))
    '()
    *seen*))

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

(define *list* '(1 2 3 1 2 7 8 1 8 2 1 3))
(define *seen* '())

; Build list of unique items by checking set membership
(for-each
  (lambda (item)
    (if (not (member item *seen*))
      (set! *seen* (cons item *seen*))))
  *list*)

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

(define *users*
  (sort
    (string-split (qx "who|cut -d' ' -f1") #\newline)
    string<?))

(define *seen* '())

; Build list of unique users by checking set membership
(for-each
  (lambda (user)
    (if (not (member user *seen*))
      (set! *seen* (cons item *seen*))))
  *list*)

; All problems in this section involve, at core, set difference
; operations. Thus, the most compact and straightforward approach
; is to utilise SRFI-1's 'lset-difference' routine

(use-modules (srfi srfi-1))

(define *a* '(1 3 5 6 7 8))
(define *b* '(2 3 5 7 9))

; *difference* contains elements in *a* but not in *b*: 1 6 8
(define *difference* (lset-difference = *a* *b*))

; *difference* contains elements in *b* but not in *a*: 2 9
(set! *difference* (lset-difference = *b* *a*))

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

;; Perl Cookbook-based example - illustrative only, *not*
;; recommended approaches

(use-modules (srfi srfi-1))

(define *a* '(1 3 5 6 7 8))
(define *b* '(2 3 5 7 9))

(define *a-only* '())

; Build list of items in *a* but not in *b*
(for-each
  (lambda (item)
    (if (not (member item *b*))
      (set! *a-only* (cons item *a-only*))))
  *a*)

; The SRFI-1 'lset-xxx' routines are appropriate here

(use-modules (srfi srfi-1))

(define *a* '(1 3 5 6 7 8))
(define *b* '(2 3 5 7 9))

; Combined elements of *a* and *b* sans duplicates: 1 2 3 5 6 7 8 9
(define *union* (lset-union = *a* *b*))

; Elements common to both *a* and *b*: 3 5 7
(define *intersection* (lset-intersection = *a* *b*))

; Elements in *a* but not in *b*: 1 6 8
(define *difference* (lset-difference = *a* *b*))

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

;; Perl Cookbook-based example - illustrative only, *not*
;; recommended approaches

(use-modules (srfi srfi-1))

(define *a* '(1 3 5 6 7 8))
(define *b* '(2 3 5 7 9))

(define *union* '())
(define *isect* '())
(define *diff* '())

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

; Union and intersection
(for-each
  (lambda (item) (set! *union* (assoc-set! *union* item #t)))
  *a*)

(for-each
  (lambda (item)
    (if (assoc-ref *union* item)
      (set! *isect* (assoc-set! *isect* item #t)))
    (set! *union* (assoc-set! *union* item #t)))
  *b*)

; Difference *a* and *b*
(for-each
  (lambda (item)
    (if (not (assoc-ref *isect* item))
      (set! *diff* (assoc-set! *diff* item #t))))
  *a*)

(set! *union*
  (fold
    (lambda (pair accum) (cons (car pair) accum))
    '()
    *union*))

(set! *isect*
  (fold
    (lambda (pair accum) (cons (car pair) accum))
    '()
    *isect*))

(set! *diff*
  (fold
    (lambda (pair accum) (cons (car pair) accum))
    '()
    *diff*))

(print "Union count:       " (length *union*))
(print "Intersection count:" (length *isect*))
(print "Difference count:  " (length *diff*))

; Arrays, specifically vectors in the current context, are fixed-size
; entities; joining several such together requires copying of their
; contents into a new, appropriately-sized, array. This task may be
; performed:

; * Directly: loop through existing arrays copying elements into a
;   newly-created array

(define (vector-join vec . rest)
  (let* ((all-vec (cons vec rest))
         (new-vec-len (reduce + 0 (map vector-length all-vec)))
         (new-vec (make-vector new-vec-len))
         (new-vec-idx 0))
    (let loop ((all-vec all-vec))
      (cond
        ((= new-vec-idx new-vec-len) new-vec)
        (else
          (array-for-each
            (lambda (element)
              (vector-set! new-vec new-vec-idx element)
              (set! new-vec-idx (+ new-vec-idx 1)))
            (car all-vec))
          (loop (cdr all-vec)) ))) ))

;; ----

(define *array1* '#(1 2 3))
(define *array2* '#(4 5 6))

(define *newarray*
  (vector-join *array1* *array2*))

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

; * Indirectly; convert arrays to lists, append the lists, convert
;   resulting list back into an array

(define *array1* '#(1 2 3))
(define *array2* '#(4 5 6))

(define *newarray*
  (list->vector (append (vector->list *array1*) (vector->list *array2*)) ))

; Of course if random access is not required, it is probably best to simply
; use lists since a wealth of list manipulation routines are available

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

; While Perl offers an all-purpose 'splice' routine, a cleaner approach is
; to separate out such functionality; here three routines are implemented
; together offering an equivalent to 'splice'. The routines are:
; * vector-replace! [use with 'vector-copy' to avoid changing original]
;   e.g. (vector-replace! vec ...)
;        (set! new-vec (vector-replace! (vector-copy vec) ...))
; * vector-delete
; * vector-insert

(define (vector-replace! vec pos item . rest)
  (let* ((all-items (cons item rest))
         (pos (if (< pos 0) (+ (vector-length vec) pos) pos))
         (in-bounds
           (not (> (+ pos (length all-items)) (vector-length vec)))))
    (if in-bounds
      (let loop ((i pos) (all-items all-items))
        (cond
          ((null? all-items) vec)
          (else
            (vector-set! vec i (car all-items))
            (loop (+ i 1) (cdr all-items))) ))
    ;else
      vec)))

(define (vector-delete vec pos len)
  (let* ((new-vec-len (- (vector-length vec) len))
         (new-vec #f)
         (pos (if (< pos 0) (+ (vector-length vec) pos) pos)))
    (cond
      ((< new-vec-len 0) vec)
      (else
        (set! new-vec (make-vector new-vec-len))
        (let loop ((vec-idx 0) (new-vec-idx 0))
          (cond
            ((= new-vec-idx new-vec-len) new-vec)
            (else
              (if (= vec-idx pos) (set! vec-idx (+ vec-idx len)))
              (vector-set! new-vec new-vec-idx (vector-ref vec vec-idx))
              (loop (+ vec-idx 1) (+ new-vec-idx 1)) ))) )) ))

; This routine would probably benefit from having 'cmd' implemented as
; a keyword argument. However, 'cmd' implemented as a positional to keep
; example simple
(define (vector-insert vec pos cmd item . rest)
  (let* ((all-item-vec (list->array 1 (cons item rest)))
         (all-item-vec-len (vector-length all-item-vec))
         (vec-len (vector-length vec))
         (new-vec (make-vector (+ vec-len all-item-vec-len)))
         (pos (if (< pos 0) (+ (vector-length vec) pos) pos)))
    (if (eq? cmd 'after) (set! pos (+ pos 1)))
    (vector-move-left! vec 0 pos new-vec 0)
    (vector-move-left! all-item-vec 0 all-item-vec-len new-vec pos)
    (vector-move-left! vec pos vec-len new-vec (+ pos all-item-vec-len))
    new-vec))

;; ----

(define *members* '#("Time" "Flies"))
(define *initiates* '#("An" "Arrow"))

(set! *members* (vector-join *members* *initiates*))

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

(set! *members* (vector-insert *members* 1 'after "Like" *initiates*))
(print *members*)

(set! *members* (vector-replace *members* 0 "Fruit"))
(set! *members* (vector-replace *members* -2 "A" "Banana"))
(print *members*)

; was: '#("Time" "Flies" "An" "Arrow")
; now: '#("Fruit" "Flies" "Like" "A" "Banana")

; As for appending arrays, there is the choice of iterating through
; the array:
(define (vector-reverse! vec)
  (let loop ((i 0) (j (- (vector-length vec) 1)))
    (cond
      ((>= i j) vec)
      (else
        (vector-ref-swap! vec i j)
        (loop (+ i 1) (- j 1)))) ))

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

(define *array* '#(1 2 3))

(vector-reverse! *array*)

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

(define *array* '#(1 2 3))

(do ((i (- (vector-length *array*) 1) (- i 1)))
    ((< i 0))
  ;; ... do something with *array* ...
  '())

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

; or of converting to / from a list, performing any manipulation using
; the list routines

(define *array* '#(1 2 3))

(define *newarray*
  (list->vector (reverse (sort (vector->list *array*) <)) ))

(define *array* '#(1 2 3 4 5 6 7 8))

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

; Remove first 3 elements
(define *front* (vector-delete *array* 0 3))

; Remove last 3 elements
(define *end* (vector-delete *array* -1 3))

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

; Another helper routine
(define (vector-slice vec pos len)
  (let* ((vec-len (vector-length vec))
         (pos (if (< pos 0) (+ vec-len pos) pos))
         (in-bounds
           (not (> (+ pos len) vec-len))))
    (if in-bounds
      (let ((new-vec (make-vector len)))
        (let loop ((vec-idx pos) (new-vec-idx 0))
          (cond
            ((= new-vec-idx len) new-vec)
            (else
              (vector-set! new-vec new-vec-idx (vector-ref vec vec-idx))
              (loop (+ vec-idx 1) (+ new-vec-idx 1))) )))
    ;else
      vec)))

; Both the following use, 'values', to return two values; this approach
; is quite contrived and is taken to mimic the Perl examples, not
; because it is a recommended one [returning a single list would probably
; be more sensible]
(define (shift2 vec)
  (let ((vec (vector-slice vec 0 2)))
    (values (vector-ref vec 0) (vector-ref vec 1)) ))

(define (pop2 vec)
  (let ((vec (vector-slice vec -1 2)))
    (values (vector-ref vec 0) (vector-ref vec 1)) ))

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

(define *friends* '#('Peter 'Paul 'Mary 'Jim 'Tim))

(let-values ( ((this that) (shift2 *friends*)) )
  (print this ":" that))

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

(define *beverages* '#('Dew 'Jolt 'Cola 'Sprite 'Fresca))

(let-values ( ((d1 d2) (pop2 *beverages*)) )
  (print d1 ":" d2))

; SRFI-1 [list manipulation] routines are ideal for the types of task
; in this and the next section, in particular, 'for-each' and 'find',
; 'list-index', and many others for more specialist functions. The same
; applies to vectors with the SRFI-43 routines, 'vector-index' and
; 'vector-skip', though the approach taken in this chapter has been to
; implement functionally similar vector manipulation routines to more
; closely mimic the Perl examples

; Return #f, or first index for which 'pred' returns true
(define (vector-first-idx pred vec) 
  (let ((vec-len (vector-length vec)))
    (let loop ((idx 0))
      (cond
        ((= idx vec-len) #f)
        (else
          (if (pred (vector-ref vec idx))
            idx
          ;else
            (loop (+ idx 1))) )))))

; Return #f, or first index for which 'pred' returns true
(define (list-first-idx pred list)
  (let loop ((idx 0) (list list))
    (cond
      ((null? list) #f)
      (else
        (if (pred (car list))
          idx
        ;else
          (loop (+ idx 1) (cdr list))) ))))

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

(define *array* '#(1 2 3 4 5 6 7 8))

(print
  (vector-first-idx
    (lambda (x) (= x 9))
    *array*))

;; ----

(define *list* '(1 2 3 4 5 6 7 8))

(print
  (list-first-idx
    (lambda (x) (= x 4))
    *list*))

;; ----

(use-modules (srfi srfi-1))

(print
  (list-index
    (lambda (x) (= x 4))
    *list*))

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

; The Perl 'highest paid engineer' example isn't really a 'first match'
; type of problem - the routines shown earlier really aren't suited to
; this. Better suited, instead, are the SRFI-1 routines like 'fold',
; 'fold-right' and 'reduce', even old standbys like 'filter' and 'for-each'

(define +null-salary-rec+
  (list '() 0 '()))

(define *salaries*
  (list
    (list 'engineer 43000 'Bob)
    (list 'programmer 48000 'Andy)
    (list 'engineer 35000 'Champ) 
    (list 'engineer 49000 'Bubbles)
    (list 'programmer 47000 'Twig)
    (list 'engineer 34000 'Axel) ))

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

(define *highest-paid-engineer*
  (reduce
    (lambda (salary-rec acc)
      (if
        (and
          (eq? (car salary-rec) 'engineer)
          (> (cadr salary-rec) (cadr acc)))
        salary-rec
      ;else
        acc))
    +null-salary-rec+
    *salaries*))

(print *highest-paid-engineer*)

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

(define *highest-paid-engineer*
  (fold-right
    (lambda (salary-rec acc)
      (if (> (cadr salary-rec) (cadr acc))
        salary-rec
      ;else
        acc))
    +null-salary-rec+
    (filter
      (lambda (salary-rec)
        (eq? (car salary-rec) 'engineer))
      *salaries*)) )

(print *highest-paid-engineer*)

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

(define *highest-paid-engineer* +null-salary-rec+)

(for-each
  (lambda (salary-rec)
    (if
      (and
        (eq? (car salary-rec) 'engineer)
        (> (cadr salary-rec) (cadr *highest-paid-engineer*)))
      (set! *highest-paid-engineer* salary-rec)))
  *salaries*)

(print *highest-paid-engineer*)

; All tasks in this section consist of either generating a collection,
; or filtering a larger collection, of elements matching some criteria;
; obvious candidates are the 'filter' and 'array-filter' routines, though
; others like 'for-each' can also be applied

(define *list-matching* (filter PRED LIST))
(define *vector-matching* (array-filter PRED ARRAY))

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

(define *nums* '(1e7 3e7 2e7 4e7 1e7 3e7 2e7 4e7))

(define *bigs* 
  (filter
    (lambda (num) (> num 1000000))
    *nums*))

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

(define *users*
  (list
    '(u1 . 2e7)
    '(u2 . 1e7)
    '(u3 . 4e7)
    '(u4 . 3e7) ))

(define *pigs*
  (fold-right
    (lambda (pair accum) (cons (car pair) accum))
    '()
    (filter
      (lambda (pair) (> (cdr pair) 1e7))
      *users*)))

(print *pigs*)

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

(define *salaries*
  (list
    (list 'engineer 43000 'Bob)
    (list 'programmer 48000 'Andy)
    (list 'engineer 35000 'Champ) 
    (list 'engineer 49000 'Bubbles)
    (list 'programmer 47000 'Twig)
    (list 'engineer 34000 'Axel) ))

(define *engineers*
  (filter
    (lambda (salary-rec)
      (eq? (car salary-rec) 'engineer))
    *salaries*))

(print *engineers*)

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

(define *applicants*
  (list
    (list 'a1 26000 'Bob)
    (list 'a2 28000 'Andy)
    (list 'a3 24000 'Candy) ))

(define *secondary-assistance*
  (filter
    (lambda (salary-rec)
      (and
        (> (cadr salary-rec) 26000)
        (< (cadr salary-rec) 30000)))
    *applicants*))

(print *secondary-assistance*)

; Sorting numeric data in Scheme is very straightforward ...

(define *unsorted* '(5 8 1 7 4 2 3 6)) 

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

; Ascending sort - use '<' as comparator
(define *sorted* 
  (sort
    *unsorted*
    <))

(print *sorted*)

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

; Descending sort - use '>' as comparator
(define *sorted* 
  (sort
    *unsorted*
    >))

(print *sorted*)

; A customised lambda may be passed as comparator to 'sort', so
; sorting on one or more 'fields' is quite straightforward

(define *unordered* '( ... ))

; COMPARE is some comparator suited for the element type being
; sorted
(define *ordered*
  (sort
    *unordered*
    (lambda (left right)
      (COMPARE left right))))

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

(define *unordered*
  (list
    (cons 's 34)
    (cons 'e 12)
    (cons 'c 45)
    (cons 'q 11)
    (cons 'g 24) ))

(define *pre-computed*
  (map
    ; Here element is returned unaltered, but it would normally be
    ; transformed in som way
    (lambda (element) element)
    *unordered*))

(define *ordered-pre-computed*
  (sort
    *pre-computed*
    ; Sort on the first field [assume it is the 'key'] 
    (lambda (left right)
      (string<?
        (symbol->string (car left))
        (symbol->string (car right))))))

; Extract the second field [assume it is the 'value']
(define *ordered*
  (map 
    (lambda (element) (cdr element))
    *ordered-pre-computed*))

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

(define *employees*
  (list
    (list 'Bob 43000 123 42)
    (list 'Andy 48000 124 35)
    (list 'Champ 35000 125 37) 
    (list 'Bubbles 49000 126 34)
    (list 'Twig 47000 127 36)
    (list 'Axel 34000 128 31) ))

(define *ordered*
  (sort
    *employees*
    (lambda (left right)
      (string<?
        (symbol->string (car left))
        (symbol->string (car right))))))

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

(for-each
  (lambda (employee)
    (print (car employee) "earns $" (cadr employee)))
  (sort
    *employees*
    (lambda (left right)
      (string<?
        (symbol->string (car left))
        (symbol->string (car right))))))

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

(define *bonus*
  (list
    '(125 . 1000)
    '(127 . 1500) ))

(for-each
  (lambda (employee)
    (let ((bonus (assoc-ref *bonus* (caddr employee))))
      (if (not bonus)
        '()
      ;else
        (print (car employee) "earned bonus" bonus) )))
  (sort
    *employees*
    (lambda (left right)
      (string<?
        (symbol->string (car left))
        (symbol->string (car right))))))

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

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

(define *filename* "/etc/passwd")
(define *users* '())

(let ((port (open-input-file *filename*)))
  (let loop ((line&terminator (read-line port 'split)))
    (cond
      ((eof-object? (cdr line&terminator)) '())
      (else
        (set! *users*
          (assoc-set!
            *users*
            (car (string-split (car line&terminator) #\:))
            #t))
        (loop (read-line port 'split)) ))) 
  (close-input-port port))

(for-each
  (lambda (user) (print (car user)))
  (sort
    *users*
    (lambda (left right)
      (string<?
        (car left)
        (car right)))))

; Use SRFI-1's 'circular-list' routine to build a circular list
(use-modules (srfi srfi-1))

(define *processes* (circular-list 1 2 3 4 5))

(let loop ((processes *processes*))
  (print "Handling process" (car processes))
  (sleep 1)
  (loop (cdr processes)))

(use-modules (srfi srfi-1))

; Implements Fischer-Yates shuffle algorithm
(define (vector-shuffle! vec)
  (let ((vector-length (vector-length vec)))
    (let loop ((i vector-length) (j (+ 1 (random vector-length))))
      (cond
        ((= i 1) '())
        ((not (= i j))
          (vector-ref-swap! vec (- i 1) (- j 1))
          (loop (- i 1) (+ 1 (random (- i 1)))))
        (else
          (loop (- i 1) (+ 1 (random (- i 1))))) ))))

(define (vector-ref-swap! vec idx1 idx2)
  (let ((tmp (vector-ref vec idx1)))
    (vector-set! vec idx1 (vector-ref vec idx2))
    (vector-set! vec idx2 tmp)))

; Generate vector of values 1 .. 10
(define *irange* (list->vector (iota 10 1 1)))

; Shuffle array values
(vector-shuffle! *irange*)

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

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