;;; -*- scheme -*-

;;; @@PLEAC@@_NAME
;;; @@SKIP@@ Guile 1.8

;;; @@PLEAC@@_WEB
;;; @@SKIP@@ http://www.gnu.org/software/guile/

;;; @@PLEAC@@_INTRO
;;; @@SKIP@@ Sections 1 - 3, and 7 - 9, largely completed using Guile 1.5; subsequent additions use Guile 1.8.

;;; @@PLEAC@@_APPENDIX
;;; @@SKIP@@ General-purpose, custom functions that might be used in several sections, appear here 

;; Helper which aims to reduce code clutter by:
;; * Replacing the oft-used, '(display item) (newline)' combination
;; * Avoiding overuse of '(string-append)' for simple output tasks
(define (print item . rest)
  (let ((all-item (cons item rest)))
    (for-each
      (lambda (item) (display item) (display " "))      
      all-item))
  (newline))

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

;; Slightly modified version of '(qx)' from Chapter 4
(use-modules (ice-9 popen) (srfi srfi-1) (srfi srfi-13))

(define (drain-output port)
  (let loop ((chars '())
             (next (read-char port)))
    (if (eof-object? next)
        ; Modified to not return last 'line' with newline
        (list->string (reverse! (cdr 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))

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

;; @@PLEAC@@_1.0
(define string "\\n")                    ; two characters, \ and an n
(define string "\n")                     ; a "newline" character
(define string "Jon \"Maddog\" Orwant")  ; literal double quotes
(define string "Jon 'Maddog' Orwant")    ; literal single quotes

(define a "This is a multiline here document
terminated by a closing double quote")

;; @@PLEAC@@_1.1
;; Use substring

(substring str start end)
(substring str start)

;; You can fill portions of a string with another string

(substring-move-right! str start end newstring newstart)
(substring-move-left! str start end newstring newstart)

;; Guile has a separate character type, and you can treat strings as a
;; character array.

(string-ref str pos)
(string-set! str pos char)
(string-fill! str char)
(substring-fill! str start end char)

(define s "This is what you have")
(define first (substring s 0 1))                     ; "T"
(define start (substring s 5 7))                     ; "is"
(define rest  (substring s 13))                      ; "you have"
(define last  (substring s (1- (string-length s))))  ; "e"
(define end   (substring s (- (string-length s) 4))) ; "have"
(define piece (let ((len (string-length s)))
                (substring s (- len 8) (- len 5))))  ; "you"


;;; Or use the string library SRFI-13
(use-modules (srfi srfi-13))

(define s "This is what you have")
(define first (string-take s 1))                     ; "T"
(define start (xsubstring s 5 7))                    ; "is"
(define rest  (xsubstring s 13 -1))                  ; "you have"
(define last  (string-take-right s 1))               ; "e"
(define end   (string-take-right s 4))               ; "have"
(define piece (xsubstring s -8 -5))                  ; "you"

;; Mutation of different sized strings is not allowed.  You have to
;; use set! to change the variable.

(set! s (string-replace s "wasn't" 5 7))
;; This wasn't what you have
(set! s (string-replace s "ondrous" 13 25))
;; This wasn't wondrous
(set! s (string-take-right s (1- (string-length s))))
;; his wasn't wondrous
(set! s (string-take s 9))

;; @@PLEAC@@_1.2
(define a (or b c))
(define a (if (defined? b) b c))
(define a (or (and (defined? b) b) c))

;; @@PLEAC@@_1.3
;; This doesn't really make sense in Scheme... temporary variables are
;; a natural construct and cheap.  If you want to swap variables in a
;; block without introducing any new variable names, you can use let:

(let ((a b) (b a))
  ;; ...
  )

(let ((alpha beta) (beta production) (production alpha))
  ;; ...
  )

;; @@PLEAC@@_1.4
(define num (char->integer char))
(define char (integer->char num))

(use-modules (srfi srfi-13))
(let ((str "sample"))
  (display (string-join
            (map number->string
                 (map char->integer (string->list str))) " "))
  (newline))

(let ((lst '(115 97 109 112 108 101)))
  (display (list->string (map integer->char lst)))
  (newline))

(letrec ((next (lambda (c) (integer->char (1+ (char->integer c))))))
  (let* ((hal "HAL")
         (ibm (list->string (map next (string->list hal)))))
    (display ibm)
    (newline)))

;; @@PLEAC@@_1.5
;; Convert the string to a list of characters
(map proc
     (string->list str))

(use-modules (srfi srfi-1))
(format #t "unique chars are: ~A\n"
        (apply string (sort (delete-duplicates
                             (string->list "an apple a day")) char<?)))

(let* ((str "an apple a day")
       (sum (apply + (map char->integer (string->list str)))))
  (format #t "sum is ~A\n" sum))

;;; or use string-fold/string-map/string-for-each from SRFI-13
(use-modules (srfi srfi-13))

(let* ((str "an apple a day")
       (sum (string-fold (lambda (c acc) (+ acc (char->integer c)))
                         0 str)))
  (format #t "sum is ~A\n" sum))

#!/usr/local/bin/guile -s
!#
;; sum - compute 16-bit checksum of all input files
(use-modules (srfi srfi-13))
(define (checksum p)
  (let loop ((line (read-line p 'concat)) (sum 0))
    (if (eof-object? line)
      (format #t "~A ~A\n" sum (port-filename p))
      (let ((line-sum (string-fold (lambda (c acc)
                                     (+ acc (char->integer c)))
                                   0 line)))
        (loop (read-line p 'concat) (modulo (+ sum line-sum)
                                            (1- (expt 2 16))))))))
(let ((args (cdr (command-line))))
  (if (null? args)
    (checksum (current-input-port))
    (for-each (lambda (f) (call-with-input-file f checksum)) args)))

#!/usr/local/bin/guile -s
!#
;; slowcat - emulate a  s l o w  line printer
(use-modules (ice-9 regex) (srfi srfi-2) (srfi srfi-13))
(define args (cdr (command-line)))
(define delay 1)
(and-let* ((p (pair? args))
           (m (string-match "^-([0-9]+)$" (car args))))
  (set! delay (string->number (match:substring m 1)))
  (set! args (cdr args)))
(define (slowcat p)
  (let loop ((line (read-line p 'concat)))
    (cond ((not (eof-object? line))
           (string-for-each
            (lambda (c) (display c) (usleep (* 5 delay))) line)
           (loop (read-line p 'concat))))))
(if (null? args)
  (slowcat (current-input-port))
  (for-each (lambda (f) (call-with-input-file f slowcat)) args))

;; @@PLEAC@@_1.6
(define revbytes (list->string (reverse (string->list str))))

;;; Or from SRFI-13
(use-modules (srfi srfi-13))
(define revbytes (string-reverse str))
(string-reverse! str) ; modifies in place

(define revwords (string-join (reverse (string-tokenize str)) " "))

(with-input-from-file "/usr/share/dict/words"
  (lambda ()
    (do ((word (read-line) (read-line)))
        ((eof-object? word))
      (if (and (> (string-length word) 5)
               (string=? word (string-reverse word)))
        (write-line word)))))

;; A little too verbose on the command line
;; guile --use-srfi=13 -c
;; '(with-input-from-file "/usr/share/dict/words"
;; (lambda () (do ((word (read-line) (read-line))) ((eof-object? word))
;; (if (and (> (string-length word) 5) (string=? word (string-reverse word)))
;; (write-line word)))))'

;; @@PLEAC@@_1.7
;; Use regexp-substitute/global
(regexp-substitute/global
 #f "([^\t]*)(\t+)" str
 (lambda (m)
   (let* ((pre-string (match:substring m 1))
          (pre-len (string-length pre-string))
          (match-len (- (match:end m 2) (match:start m 2))))
     (string-append
      pre-string
      (make-string
       (- (* match-len 8)
          (modulo pre-len 8))
       #\space))))
 'post)

;; @@PLEAC@@_1.8
;; just interpolate $abc in strings:
(define (varsubst str)
  (regexp-substitute/global #f "\\$(\\w+)" str
   'pre (lambda (m) (eval (string->symbol (match:substring m 1))
                          (current-module)))
   'post))

;; interpolate $abc with error messages:
(define (safe-varsubst str)
  (regexp-substitute/global #f "\\$(\\w+)" str
   'pre (lambda (m)
          (catch #t
            (lambda () (eval (string->symbol (match:substring m 1))
                             (current-module)))
            (lambda args
              (format #f "[NO VARIABLE: ~A]" (match:substring m 1)))))
   'post))

;; interpolate ${(any (scheme expression))} in strings:
(define (interpolate str)
  (regexp-substitute/global #f "\\${([^{}]+)}" str
   'pre (lambda (m) (eval-string (match:substring m 1))) 'post))

;; @@PLEAC@@_1.9
(use-modules (srfi srfi-13))

(string-upcase "bo beep")     ; BO PEEP
(string-downcase "JOHN")      ; john
(string-titlecase "bo")       ; Bo
(string-titlecase "JOHN")     ; John

(string-titlecase "thIS is a loNG liNE")  ; This Is A Long Line

#!/usr/local/bin/guile -s
!#
;; randcap: filter to randomly capitalize 20% of the time
(use-modules (srfi srfi-13))
(seed->random-state (current-time))
(define (randcap p)
  (let loop ((line (read-line p 'concat)))
    (cond ((not (eof-object? line))
           (display (string-map (lambda (c)
                                  (if (= (random 5) 0)
                                    (char-upcase c)
                                    (char-downcase c)))
                                line))
           (loop (read-line p 'concat))))))
(let ((args (cdr (command-line))))
  (if (null? args)
    (randcap (current-input-port))
    (for-each (lambda (f) (call-with-input-file f randcap)) args)))

;; @@PLEAC@@_1.10
;; You can do this with format.  Lisp/Scheme format is a little
;; different from what you may be used to with C/Perl style printf
;; (actually far more powerful) , but if you keep in mind that we use
;; ~ instead of %, and , instead of . for the prefix characters, you
;; won't have trouble getting used to Guile's format.

(format #f "I have ~A guanacos." n)

;; @@PLEAC@@_1.11
(define var "
        your text
        goes here")

(use-modules (ice-9 regexp))
(set! var (regexp-substitute/global #f "\n +" var 'pre "\n" 'post))

(use-modules (srfi srfi-13))
(set! var (string-join (map string-trim (string-tokenize var #\newline)) "\n"))

(use-modules (ice-9 regexp) (srfi srfi-13) (srfi srfi-14))
(define (dequote str)
  (let* ((str (if (char=? (string-ref str 0) #\newline)
                (substring str 1) str))
         (lines (string-tokenize str #\newline))
         (rx (let loop ((leader (car lines)) (lst (cdr lines)))
               (cond ((string= leader "")
                      (let ((pos (or (string-skip (car lines)
                                                  char-set:whitespace) 0)))
                        (make-regexp (format #f "^[ \\t]{1,~A}" pos)
                                     regexp/newline)))
                     ((null? lst)
                      (make-regexp (string-append "^[ \\t]*"
                                                  (regexp-quote leader))
                                   regexp/newline))
                     (else
                      (let ((pos (or (string-prefix-length leader (car lst))
                                      0)))
                        (loop (substring leader 0 pos) (cdr lst))))))))
    (regexp-substitute/global #f rx str 'pre 'post)))

;; @@PLEAC@@_1.12
(use-modules (srfi srfi-13))

(define text "Folding and splicing is the work of an editor,
not a mere collection of silicon
and
mobile electrons!")

(define (wrap str max-col)
  (let* ((words (string-tokenize str))
         (all '())
         (first (car words))
         (col (string-length first))
         (line (list first)))
    (for-each
     (lambda (x)
       (let* ((len (string-length x))
              (new-col (+ col len 1)))
         (cond ((> new-col max-col)
                (set! all (cons (string-join (reverse! line) " ") all))
                (set! line (list x))
                (set! col len))
               (else
                (set! line (cons x line))
                (set! col new-col)))))
     (cdr words))
    (set! all (cons (string-join (reverse! line) " ") all))
    (string-join (reverse! all) "\n")))

(display (wrap text 20))

;; @@PLEAC@@_1.13
(define str "Mom said, \"Don't do that.\"")
(set! str (regexp-substitute/global #f "['\"]" str 'pre "\\"
                                    match:substring 'post))
(set! str (regexp-substitute/global #f "[^A-Z]" str 'pre "\\"
                                    match:substring 'post))
(set! str (string-append "this " (regexp-substitute/global
                                  #f "\W" "is a test!" 'pre "\\"
                                  match:substring 'post)))

;; @@PLEAC@@_1.14
(use-modules (srfi srfi-13))

(define str "  space  ")
(string-trim str)          ; "space  "
(string-trim-right str)    ; "  space"
(string-trim-both str)     ; "space"

;; @@PLEAC@@_1.15
(use-modules (srfi srfi-2) (srfi srfi-13) (ice-9 format))

(define parse-csv
  (let* ((csv-match (string-join '("\"([^\"\\\\]*(\\\\.[^\"\\\\]*)*)\",?"
                                   "([^,]+),?"
                                   ",")
                                 "|"))
         (csv-rx (make-regexp csv-match)))
    (lambda (text)
      (let ((start 0)
            (result '()))
        (let loop ((start 0))
          (and-let* ((m (regexp-exec csv-rx text start)))
            (set! result (cons (or (match:substring m 1)
                                   (match:substring m 3))
                               result))
            (loop (match:end m))))
        (reverse result)))))

(define line "XYZZY,\"\",\"O'Reilly, Inc\",\"Wall,
             Larry\",\"a \\\"glug\\\" bit,\",5,\"Error, Core Dumped\"")

(do ((i 0 (1+ i))
     (fields (parse-csv line) (cdr fields)))
    ((null? fields))
  (format #t "~D : ~A\n" i (car fields)))

;; @@PLEAC@@_1.16
(use-modules (srfi srfi-13) (srfi srfi-14))

;; Knuth's soundex algorithm from The Art of Computer Programming, Vol 3
(define soundex
  (letrec ((chars "AEIOUYBFPVCGJKQSXZDTLMNR")
           (nums "000000111122222222334556")
           (skipchars (string->char-set "HW"))
           (trans (lambda (c)
                    (let ((i (string-index chars c)))
                      (if i (string-ref nums i) c)))))
    (lambda (str)
      (let* ((ustr (string-upcase str))
             (f (string-ref ustr 0))
             (skip (trans f)))
        (let* ((mstr (string-map trans (string-delete ustr skipchars 1)))
               (dstr (string-map (lambda (c)
                                   (cond ((eq? c skip) #\0)
                                         (else (set! skip c) c)))
                                 mstr))
               (zstr (string-delete dstr #\0)))
          (substring (string-append (make-string 1 f) zstr "000") 0 4))))))

(soundex "Knuth")  ; K530
(soundex "Kant")   ; K530
(soundex "Lloyd")  ; L300
(soundex "Ladd")   ; L300

;; @@PLEAC@@_1.17
#!/usr/local/bin/guile -s
!#

(use-modules (srfi srfi-13)
             (srfi srfi-14)
             (ice-9 rw)
             (ice-9 regex))

(define data "analysed        => analyzed
built-in        => builtin
chastized       => chastised
commandline     => command-line
de-allocate     => deallocate
dropin          => drop-in
hardcode        => hard-code
meta-data       => metadata
multicharacter  => multi-character
multiway        => multi-way
non-empty       => nonempty
non-profit      => nonprofit
non-trappable   => nontrappable
pre-define      => predefine
preextend       => pre-extend
re-compiling    => recompiling
reenter         => re-enter
turnkey         => turn-key")

(define input (if (null? (cdr (command-line)))
                (current-input-port)
                (open-input-file (cadr (command-line)))))

(let* ((newline-char-set (string->char-set "\n"))
       (assoc-char-set (string->char-set " =>"))
       (dict (map
              (lambda (line)
                (string-tokenize line assoc-char-set))
              (string-tokenize data newline-char-set)))
       (dict-match (string-join (map car dict) "|")))
  (let loop ((line (read-line input)))
    (cond ((not (eof-object? line))
           (regexp-substitute/global
            (current-output-port) dict-match line
            'pre
            (lambda (x)
              (cadr (assoc (match:substring x 0) dict)))
            'post)
           (loop (read-line input 'concat))))))

(close-port input)

;; @@PLEAC@@_2.1
;; Strings and numbers are separate data types in Scheme, so this
;; isn't as important as it is in Perl.  More often you would use the
;; type predicates, string? and number?.

(if (string-match "[^\\d]" str) (display "has nondigits"))
(or (string-match "^\\d+$" str) (display "not a natural number"))
(or (string-match "^-?\\d+$" str) (display "not an integer"))
(or (string-match "^[\\-+]?\\d+$" str) (display "not an integer"))
(or (string-match "^-?\\d+\.?\d*$" str) (display "not a decimal number"))
(or (string-match "^-?(\d+(\.\d*)?|\.\d+)$" str)
    (display "not a decimal number"))
(or (string-match "^([+-]?)(\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$" str)
    (display "not a C float"))

(define num1 (string->number str))

(define num2 (read))

;; @@PLEAC@@_2.2
;; (approx-equal? num1 num2 accuracy) : returns #t if num1 and num2 are
;;   equal to accuracy number of decimal places
(define (approx-equal? num1 num2 accuracy)
  (< (abs (- num1 num2)) (expt 10.0 (- accuracy))))

(define wage 536)                     ;; $5.36/hour
(define week (* 40 wage))             ;; $214.40
(format #t "One week's wage is: $~$\n" (/ week 100.0))

;; @@PLEAC@@_2.3
(round num)                           ;; rounds to inexact whole number
(inexact->exact num)                  ;; rounds to exact integer

;; You can also use format to convert numbers to more precisely
;; formatted strings.  Note Guile has a builtin format which is a more
;; limited version of that found in the (ice-9 format) module, to save
;; load time.  Basically, if you are doing anything you couldn't do
;; with a series of (display), (write) and (newline), then you'll need
;; to use the module.
(use-modules (ice-9 format))

(define a 0.255)
(define b (/ (round (* 100.0 a)) 100.0))
(format #t "Unrounded: ~F\nRounded: ~F\n" a b)
(format #t "Unrounded: ~F\nRounded: ~,2F\n" a a)

(define a '(3.3 3.5 3.7 -3.3))
(display "number\tint\tfloor\tceil\n")
(for-each
 (lambda (n)
   (format #t "~,1F\t~,1F\t~,1F\t~,1F\n"
           n (round n) (floor n) (ceiling n)))
 a)

;; @@PLEAC@@_2.4
;; numbers are radix independent internally, so you usually only
;; convert on output, however to convert strings:
(define (dec->bin num)
  (number->string (string->number num 10) 2))

(define (bin->dec num)
  (number->string (string->number num 2) 10))

(define num (bin->dec "0110110"))  ; 54
(define binstr (dec->bin "54"))    ; 110110

;; @@PLEAC@@_2.5
;; do is the most general loop iterator
(do ((i x (1+ i)))   ; var  init-value  step-value
    ((> i y))        ; end when true
  ;; i is set to every integer from x to y, inclusive
  ;; ...
  )

;; Guile also offers a while loop
(let ((i x))
  (while (<= i y)
         ;; i is set to every integer from x to y, inclusive
         ; ...
         (set! i (1+ i))))

;; named let is another common loop
(let loop ((i x))
  (cond ((<= i y)
         ;; i is set to every integer from x to y, step-size 7
         ;; ...
         (loop (+ i 7)))))  ; tail-recursive call

(display "Infancy is: ")
(do ((i 0 (1+ i)))
    ((> i 2))
  (format #t "~A " i))
(newline)

(display "Toddling is: ")
(let ((i 3))
  (while (<= i 4)
         (format #t "~A " i)
         (set! i (1+ i))))
(newline)

(display "Childhood is: ")
(let loop ((i 5))
  (cond ((<= i 12)
         (format #t "~A " i)
         (loop (1+ i)))))
(newline)

;; @@PLEAC@@_2.6
;; format can output roman numerals - use ~:@R

(use-modules (ice-9 format))

(format #t "Roman for ~R is ~:@R\n" 15 15)

;; @@PLEAC@@_2.7
(random 5)        ; an integer from 0 to 4
(random 5.0)      ; an inexact real in the range [0,5)

;; char sets from SRFI-14 and string-unfold from SRFI-13 make a quick
;; way to generate passwords

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

(define chars (char-set->string char-set:graphic))
(define size (char-set-size char-set:graphic))
(define password
  (string-unfold (lambda (x) (= x 8))
                 (lambda (x) (string-ref chars (random size)))
                 1+ 0))

;; @@PLEAC@@_2.8
;; if you're working with random numbers you'll probably want to set
;; the random seed

(seed->random-state (current-time))

;; you can also save random states and pass them to any of the above
;; random functions

(define state (copy-random-state))
(random:uniform)
;; 0.939377327721761
(random:uniform state)
;; 0.939377327721761

;; @@PLEAC@@_2.9
;; @@INCOMPLETE@@
;; very inefficient
(use-modules (ice-9 rw))
(define make-true-random
  (letrec ((bufsize 8)
           (accum (lambda (c acc) (+ (* 256 acc)
                                     (char->integer c))))
           (getbuf (lambda ()
                     (call-with-input-file "/dev/urandom"
                       (lambda (p)
                         (let ((buf (make-string bufsize)))
                           (read-string!/partial buf p)
                           buf))))))
    (lambda (rand-proc)
      (lambda args
        (let ((state (seed->random-state (string-fold accum 0 (getbuf)))))
          (apply rand-proc (append args (list state))))))))

(define urandom (make-true-random random))
(define urandom:exp (make-true-random random:exp))
(define urandom:normal (make-true-random random:normal))
(define urandom:uniform (make-true-random random:uniform))

;; @@PLEAC@@_2.10
;; Guile offers a number of random distributions

(random:exp)      ; an inexact real in an exponential dist with mean 1
(random:normal)   ; an inexact real in a standard normal distribution
(random:uniform)  ; a uniformly distributed inexact real in [0,1)

;; There are also functions to fill vectors with random distributions

;; Fills vector v with inexact real random numbers the sum of whose
;; squares is equal to 1.0.
(random:hollow-sphere! v)

;; Fills vector v with inexact real random numbers that are
;; independent and standard normally distributed (i.e., with mean 0
;; and variance 1).
(random:normal-vector! v)

;; Fills vector v with inexact real random numbers the sum of whose
;; squares is less than 1.0.
(random:solid-sphere! v)

;; @@PLEAC@@_2.11
;; Guile's trigonometric functions use radians.

(define pi 3.14159265358979)

(define (degrees->radians deg)
  (* pi (/ deg 180.0)))

(define (radians->degrees rad)
  (* 180.0 (/ rad pi)))

(define (degree-sine deg)
  (sin (degrees->radians deg)))

;; @@PLEAC@@_2.12

;; Guile provides the following standard trigonometric functions (and
;; their hyperbolic equivalents), defined for all real and complex
;; numbers:

(sin z)
(cos z)
(tan z)
(asin z)
(acos z)
(atan z)

(acos 3.7)  ; 0.0+1.9826969446812i

;; @@PLEAC@@_2.13
;; Guile provides log in base e and 10 natively, defined for any real
;; or complex numbers:

(log z)    ; natural logarithm
(log10 z)  ; base-10 logarithm

;; For other bases, divide by the log of the base:

(define (log-base n z)
  (/ (log z) (log n)))

;; To avoid re-computing (log n) for a base you want to use
;; frequently, you can create a custom log function:

(define (make-log-base n)
  (let ((divisor (log n)))
    (lambda (z) (/ (log z) divisor))))

(define log2 (make-log-base 2))

(log2 1024)

;; @@PLEAC@@_2.14
;; In addition to simple vectors, Guile has builtin support for
;; uniform arrays of an arbitrary dimension.

;; a rows x cols integer matrix
(define a (make-array 0 rows cols))
(array-set! a 3 row col)
(array-ref a row col)

;; a 3D matrix of reals
(define b (make-array 0.0 x y z))

;; a literal boolean truth table for logical and
'#2((#f #f) (#f #t))

;; simple matrix multiplication

(define (matrix-mult m1 m2)
  (let* ((d1 (array-dimensions m1))
         (d2 (array-dimensions m2))
         (m1rows (car d1))
         (m1cols (cadr d1))
         (m2rows (car d2))
         (m2cols (cadr d2)))
    (if (not (= m1cols m2rows))
      (error 'index-error "matrices don't match"))
    (let ((result (make-array 0 m1rows m2cols)))
      (do ((i 0 (1+ i)))
          ((= i m1rows))
        (do ((j 0 (1+ j)))
            ((= j m2cols))
          (do ((k 0 (1+ k)))
              ((= k m1cols))
            (array-set! result (+ (array-ref result i j)
                                  (* (array-ref m1 i k)
                                     (array-ref m2 k j)))
                        i j))))
      result)))

(matrix-mult '#2((3 2 3) (5 9 8)) '#2((4 7) (9 3) (8 1)))

;; @@PLEAC@@_2.15
;; Guile has builtin support for complex numbers:

(define i 0+1i)       ; 0.0+1.0i
(define i (sqrt -1))  ; 0.0+1.0i

(complex? i)          ; #t
(real-part i)         ; 0.0
(imag-part i)         ; 1.0

(* 3+5i 2-2i)         ; 16+4i
(sqrt 3+4i)           ; 2+i

;; Classic identity:  -e^(pi*i) => 1
(inexact->exact (real-part (- (exp (* pi 0+1i))))) ; 1

;; @@PLEAC@@_2.16
;; You can type in literal numbers in alternate radixes:

#b01101101     ; 109 in binary
#o155          ; 109 in octal
#d109          ; 109 in decimal
#x6d           ; 109 in hexadecimal

;; number->string and string->number also take an optional radix:

(define number (string->number hexadecimal 16))
(define number (string->number octal 8))

;; format will also output in different radixes:

(format #t "~B ~O ~D ~X\n" num num num num)

;; converting Unix file permissions read from stdin:

(let loop ((perm (read-line)))
  (cond ((not (eof-object? perm))
         (format #t "The decimal value is ~D\n" (string->number perm 8))
         (loop (read-line)))))

;; @@PLEAC@@_2.17
;; once again, format is our friend :)
(use-modules (ice-9 format))

;; the : prefix to the D directive causes commas to be output every
;; three digits.
(format #t "~:D\n" (random 10000000000000000))
; => 2,301,267,079,619,540

;; the third prefix arg to the D directive is the separator character
;; to use instead of a comma, useful for European style numbers:
(format #t "~,,'.:D\n" (random 10000000000000000))
; => 6.486.470.447.356.534

;; the F directive, however, does not support grouping by commas.  to
;; achieve this, we can format the integer and fractional parts
;; separately:
(define (commify num)
  (let ((int (inexact->exact (truncate num))))
    (if (= num int)
      (format #f "~:D" int)
      (string-append (format #f "~:D" int)
                     (let ((str (format #f "~F" num)))
                       (substring str (or (string-index str #\.)
                                          (string-length str))))))))

;; @@PLEAC@@_2.18
;; format can handle simple 's' plurals with ~p, and 'y/ies' plurals
;; with the @ prefix:

(format #t "It took ~D hour~P\n" hours hours)

(format #t "It took ~D centur~@P\n" centuries centuries)

(define noun-plural
  (let* ((suffixes '(("ss"  . "sses")
                     ("ph"  . "phes")
                     ("sh"  . "shes")
                     ("ch"  . "ches")
                     ("z"   . "zes")
                     ("ff"  . "ffs")
                     ("f"   . "ves")
                     ("ey"  . "eys")
                     ("y"   . "ies")
                     ("ix"  . "ices")
                     ("s"   . "ses")
                     ("x"   . "xes")
                     ("ius" . "ii")))
        (suffix-match
         (string-append "(" (string-join (map car suffixes) "|") ")$"))
        (suffix-rx (make-regexp suffix-match)))
    (lambda (noun)
      (let ((m (regexp-exec suffix-rx noun)))
        (if m
          (string-append (regexp-substitute #f m 'pre)
                         (cdr (assoc (match:substring m) suffixes)))
          (string-append noun "s"))))))

;; @@PLEAC@@_2.19
#!/usr/local/bin/guile -s
!#

;; very naive factoring algorithm
(define (factor n)
  (let ((factors '())
        (limit (inexact->exact (round (sqrt n))))
        (twos 0))
    ;; factor out 2's
    (while (even? n)
           (set! n (ash n -1))
           (set! twos (1+ twos)))
    (if (> twos 0) (set! factors (list (cons 2 twos))))
    ;; factor out odd primes
    (let loop ((i 3))
      (let ((r (remainder n i)))
        (cond ((= r 0)
               (set! n (quotient n i))
               (let* ((old-val (assv i factors))
                      (new-val (if old-val (1+ (cdr old-val)) 1)))
                 (set! factors (assv-set! factors i new-val)))
               (loop i))
              ((< i limit)
               (loop (+ 2 i))))))
    ;; remainder
    (if (> n 1) (set! factors (cons (cons n 1) factors)))
    (reverse! factors)))

;; pretty print a term of a factor
(define (pp-term pair)
  (if (= (cdr pair) 1)
    (number->string (car pair))
    (format #f "~A^~A" (car pair) (cdr pair))))

;; factor each number given on the command line
(for-each
 (lambda (n)
   (let ((factors (factor n)))
     (format #t "~A = ~A" n (pp-term (car factors)))
     (for-each
      (lambda (x) (format #t " * ~A" (pp-term x)))
      (cdr factors))
     (newline)))
 (map string->number (cdr (command-line))))

;; @@PLEAC@@_3.0
;; Use the builtin POSIX time functions

;; get the current time
(current-time)   ; number of seconds since the epoch
(gettimeofday)   ; pair of seconds and microseconds since the epoch

;; create a time object from an integer (e.g. returned by current-time)
(localtime time) ; in localtime
(gmtime time)    ; in UTC

;; get/set broken down components of a time object

(tm:sec time)    (set-tm:sec time secs)    ; seconds (0-59)
(tm:min time)    (set-tm:min time mins)    ; minutes (0-59)
(tm:hour time)   (set-tm:hour time hours)  ; hours (0-23)
(tm:mday time)   (set-tm:mday time mday)   ; day of the month (1-31)
(tm:mon time)    (set-tm:mon time month)   ; month (0-11)
(tm:year time)   (set-tm:year time year)   ; year minus 1900 (70-)
(tm:wday time)   (set-tm:wday time wday)   ; day of the week (0-6)
                                           ; where Sunday is 0
(tm:yday time)   (set-tm:yday time yday)   ; day of year (0-365)
(tm:isdst time)  (set-tm:isdst time isdst) ; daylight saving indicator
                                           ; 0 for "no", > 0 for "yes",
                                           ; < 0 for "unknown"
(tm:gmtoff time) (set-tm:gmtoff time off)  ; time zone offset in seconds
                                           ; west of UTC (-46800 to 43200)
(tm:zone time)   (set-tm:zone time zone)   ; Time zone label (a string),
                                           ; not necessarily unique.

(format #t "Today is day ~A of the current year.\n"
        (tm:yday (localtime (current-time))))

;; Or use SRFI-19 - Time and Date Procedures
(use-modules (srfi srfi-19))

(define now (current-date))  ; immutable once created

(date-nanosecond now)        ; 0-9,999,999
(date-second now)            ; 0-60 (60 represents a leap second)
(date-minute now)            ; 0-59
(date-hour now)              ; 0-23
(date-day now)               ; 0-31
(date-month now)             ; 1-12
(date-year now)              ; integer representing the year
(date-year-day now)          ; day of year (Jan 1 is 1, etc.)
(date-week-day now)          ; day of week (Sunday is 0, etc.)
(date-week-number now start) ; week of year, ignoring a first partial week
                             ; start is the first day of week as above
(date-zone-offset now)       ; integer number of seconds east of GMT

(format #t "Today is day ~A of the current year.\n"
        (date-year-day (current-date)))

;; @@PLEAC@@_3.1
;; using format and POSIX time components
(use-modules (ice-9 format))
(let ((now (localtime (current-time))))
  (format #t "The current date is ~4'0D ~2'0D ~2'0D\n"
          (+ 1900 (tm:year now)) (tm:mon now) (tm:mday now)))

;; using format and SRFI-19 time components
(use-modules (srfi srfi-19) (ice-9 format))
(let ((now (current-date)))
  (format #t "The current date is ~4'0d-~2'0D-~2'0D\n"
          (date-year now) (date-month now) (date-day now)))

;; using POSIX strftime with a libc time format string
(display (strftime "%Y-%m-%d\n" (localtime (current-time))))

;; @@PLEAC@@_3.2
;; set the individual components of a time struct and use mktime
(define time (localtime (current-time)))
(set-tm:mday time mday)
(set-tm:mon time mon)
(set-tm:year time year)
(car (mktime time))  ; mktime returns a (epoch-seconds . time) pair

;; or use SRFI-19's make-date and date->time-monotonic
(use-modules (srfi srfi-19))
(date->time-monotonic
 (make-date nanosecond second minute hour day month year zone-offset))

;; @@PLEAC@@_3.3
;; use localtime or gmtime with the accessors mentioned in the
;; introduction to this chapter
(let ((time (localtime seconds)))  ; or gmtime
  (format #t "Dateline: ~2'0d:~2'0d:~2'0d-~4'0d/~2'0d/~2'0d\n"
          (tm:hour time) (tm:min time) (tm:sec time)
          (+ 1900 (tm:year time)) (1+ (tm:mon time)) (tm:mday time)))

;; or use SRFI-19
(use-modules (srfi srfi-19))
(let* ((time (make-time time-monotonic nanosecond second)))
  (display (date->string (time-monotonic->date time) "~T-~1\n")))

;; @@PLEAC@@_3.4
;; just add or subtract epoch seconds
(define when (+ now difference))
(define then (- now difference))

;; if you have DMYHMS values, you can convert them to times or add
;; them as seconds:
(define birthtime 96176750)
(define interval (+ 5                  ; 5 seconds
                    (* 17 60)          ; 17 minutes
                    (* 2 60 60)        ; 2 hours
                    (* 55 60 60 24)))  ; and 55 days
(define then (+ birthtime interval))
(format #t "Then is ~A\n" (strftime "%a %b %d %T %Y" (localtime then)))

;; @@PLEAC@@_3.5
;; subtract the epoch seconds:
(define bree 361535725)
(define nat 96201950)
(define difference (- bree nat))
(format #t "There were ~A seconds between Nat and Bree\n" difference)

;; or use SRFI-19's time arithmetic procedures:
(use-modules (srfi srfi-19))
(define time1 (make-time time-monotonic nano1 sec1))
(define time2 (make-time time-monotonic nano2 sec2))
(define duration (time-difference time1 time2))
(time=? (subtract-duration time1 duration) time2) ; #t
(time=? (add-duration time2 duration) time1)      ; #t

;; @@PLEAC@@_3.6
;; convert to a SRFI-19 date and use the accessors
(use-modules (srfi srfi-19))
(date-day date)
(date-year-day date)
(date-week-day date)
(date-week-number date start-day-of-week)

;; @@PLEAC@@_3.7
;; use the strptime function:
(define time-pair (strptime "%Y-%m-%d" "1998-06-03"))
(format #t "Time is ~A\n." (strftime "%b %d, %Y" (car time-pair)))

;; or use SRFI-19's string->date:
(use-modules (srfi srfi-19))
(define date (string->date "1998-06-03" "~Y-~m-~d"))
(format #t "Time is ~A.\n" (date->string date))

;; @@PLEAC@@_3.8
;; use the already seen strftime:
(format #t "strftime gives: ~A\n"
        (strftime "%A %D" (localtime (current-time))))

;; or SRFI-19's date->string:
(use-modules (srfi srfi-19))
(format #t "default date->string gives: ~A\n" (date->string (current-date)))
(format #t "date->string gives: ~A\n"
        (date->string (current-date) "~a ~b ~e ~H:~M:~S ~z ~Y"))

;; @@PLEAC@@_3.9
;; gettimeofday will return seconds and microseconds:
(define t0 (gettimeofday))
;; do your work here
(define t1 (gettimeofday))
(format #t "You took ~A seconds and ~A microseconds\n"
        (- (car t1) (car t0)) (- (cdr t1) (cdr t0)))

;; you can also get more detailed info about the real and processor
;; times:
(define runtime (times))
(tms:clock runtime)  ; the current real time
(tms:utime runtime)  ; the CPU time units used by the calling process
(tms:stime runtime)  ; the CPU time units used by the system on behalf
                     ; of the calling process.
(tms:cutime runtime) ; the CPU time units used by terminated child
                     ; processes of the calling process, whose status
                     ; has been collected (e.g., using `waitpid').
(tms:cstime runtime) ; the CPU times units used by the system on
		     ; behalf of terminated child processes

;; you can also use the time module to time execution:
(use-modules (ice-9 time))
(time (sleep 3))
;; clock utime stime cutime cstime gctime
;; 3.01  0.00  0.00   0.00   0.00   0.00
;; 0

;; @@PLEAC@@_3.10
(sleep i)   ; sleep for i seconds
(usleep i)  ; sleep for i microseconds (not available on all platforms)

;; @@PLEAC@@_4.0
(define nested '("this" "that" "the" "other"))
(define nested '("this" "that" ("the" "other")))
(define tune '("The" "Star-Spangled" "Banner"))

;; @@PLEAC@@_4.1
(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"))

;; @@PLEAC@@_4.2
(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.

;; @@PLEAC@@_4.3
;;-----------------------------

;; 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 `'.
;;-----------------------------

;; @@PLEAC@@_4.4
; 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]

;; @@PLEAC@@_4.5
(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)))))

;; @@PLEAC@@_4.6
(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*)

;; @@PLEAC@@_4.7
; 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*)

;; @@PLEAC@@_4.8
; 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*))

;; @@PLEAC@@_4.9
; 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")

;; @@PLEAC@@_4.10
; 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*) <)) ))

;; @@PLEAC@@_4.11
(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))

;; @@PLEAC@@_4.12
; 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*)

;; @@PLEAC@@_4.13
; 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*)

;; @@PLEAC@@_4.14
; 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*)

;; @@PLEAC@@_4.15
; 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)))))

;; @@PLEAC@@_4.16
; 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)))

;; @@PLEAC@@_4.17
(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*)

;; @@PLEAC@@_4.18
;; @@INCOMPLETE@@
;; @@INCOMPLETE@@

;; @@PLEAC@@_4.19
;; @@INCOMPLETE@@
;; @@INCOMPLETE@@

;; @@PLEAC@@_5.0
;; ---------------------------------------------------------------------
;; 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")

;; @@PLEAC@@_5.1
(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*)

;; @@PLEAC@@_5.2
; '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))

;; @@PLEAC@@_5.3
(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)

;; @@PLEAC@@_5.4
; 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)))))

;; @@PLEAC@@_5.5
; 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))) ))

;; @@PLEAC@@_5.6
; 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]

;; @@PLEAC@@_5.7
(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 "")))))

;; @@PLEAC@@_5.8
; 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*)))

;; @@PLEAC@@_5.9
; *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*)

;; @@PLEAC@@_5.10
; 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*))

;; @@PLEAC@@_5.11
(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*)

;; @@PLEAC@@_5.12
; 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*)

;; @@PLEAC@@_5.13
; 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 '()))

;; @@PLEAC@@_5.14
(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*)

;; @@PLEAC@@_5.15
(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))

;; @@PLEAC@@_5.16
;; @@INCOMPLETE@@
;; @@INCOMPLETE@@

;; @@PLEAC@@_7.0
;; use (open-input-file filename) or (open filename O_RDONLY)

(define input (open-input-file "/usr/local/widgets/data"))
(let loop ((line (read-line input 'concat)))
  (cond ((not (eof-object? line))
         (if (string-match "blue" line)
           (display line))
         (loop (read-line input 'concat)))))
(close input)

;; Many I/O functions default to the logical STDIN/OUT

;; You can also explicitly get the standard ports with
;; [set-]current-{input,output,error}-port.

;; format takes a port as the first argument.  If #t is given, format
;; writes to stdout, if #f is given, format returns a string.

(let loop ((line (read-line)))     ; reads from stdin
  (cond ((not (eof-object? line))
         (if (not (string-match "[0-9]" line))
           ;; writes to stderr
           (display "No digit found.\n" (current-error-port))
           ;; writes to stdout
           (format #t "Read: ~A\n" line))
         (loop (read-line)))))

;; use open-output-file

(define logfile (open-output-file "/tmp/log"))

;; increasingly specific ways of closing ports (it's safe to close a
;; closed port)

(close logfile)                ; #t
(close-port logfile)           ; #f (already closed)
(close-output-port logfile)    ; unspecified

;; you can rebind standard ports with set-current-<foo>-port:

(let ((old-out (current-output-port)))
  (set-current-output-port logfile)
  (display "Countdown initiated ...\n")
  (set-current-output-port old-out)
  (display "You have 30 seconds to reach minimum safety distance.\n"))

;; or

(with-output-to-file logfile
  (lambda () (display "Countdown initiated ...\n")))
(display "You have 30 seconds to reach minimum safety distance.\n")


;; @@PLEAC@@_7.1
(define source (open-input-file path))
(define sink (open-output-file path))

(define source (open path O_RDONLY))
(define sink (open path O_WRONLY))

;;-----------------------------
(define port (open-input-file path))
(define port (open-file path "r"))
(define port (open path O_RDONLY))
;;-----------------------------
(define port (open-output-file path))
(define port (open-file path "w"))
(define port (open path (logior O_WRONLY O_TRUNC O_CREAT)))
;;-----------------------------
(define port (open path (logior O_WRONLY O_EXCL O_CREAT)))
;;-----------------------------
(define port (open-file path "a"))
(define port (open path (logior O_WRONLY O_APPEND O_CREAT)))
;;-----------------------------
(define port (open path (logior O_WRONLY O_APPEND)))
;;-----------------------------
(define port (open path O_RDWR))
;;-----------------------------
(define port (open-file path "r+"))
(define port (open path (logior O_RDWR O_CREAT)))
;;-----------------------------
(define port (open path (logior O_RDWR O_EXCL O_CREAT)))
;;-----------------------------

;; @@PLEAC@@_7.2
;; Nothing different needs to be done with Guile

;; @@PLEAC@@_7.3
(define expand-user
  (let ((rx (make-regexp "^\\~([^/]+)?")))
    (lambda (filename)
      (let ((m (regexp-exec rx filename)))
        (if m
          (string-append
           (if (match:substring m 1)
             (passwd:dir (getpwnam (match:substring m 1)))
             (or (getenv "HOME") (getenv "LOGDIR")
                 (passwd:dir (getpwuid (cuserid))) ""))
           (substring filename (match:end m)))
          filename)))))

;; @@PLEAC@@_7.4
(define port (open-file filename mode))  ; raise an exception on error

;; use catch to trap errors
(catch 'system-error ; the type of error thrown
  (lambda () (set! port (open-file filename mode))) ; thunk to try
  (lambda (key . args)  ; exception handler
    (let ((fmt (cadr args))
          (msg&path (caddr args)))
      (format (current-error-port) fmt (car msg&path) (cadr msg&path))
      (newline))))

;; @@PLEAC@@_7.5
;; use the POSIX tmpnam
(let ((name (tmpnam)))
  (call-with-output-file name
    (lambda (port)
      ;; ... output to port
      '())))

;; better to test and be sure you have exclusive access to the file
;; (temp file name will be available as (port-filename port))
(define (open-temp-file)
  (let loop ((name (tmpnam)))
    (catch 'system-error
      (lambda () (open name (logior O_RDWR O_CREAT O_EXCL)))
      (lambda (key . args) (loop (tmpnam))))))

;; or let mkstemp! do the work for you:
(define port (mkstemp! template-string-ending-in-XXXXXX))

(let* ((tmpl "/tmp/programXXXXXX")
       (port (mkstemp! tmpl)))
  ;; tmpl now contains the name of the temp file,
  ;; e.g. "/tmp/programhVoEzw"
  (do ((i 0 (1+ i)))
      ((= i 10))
    (format port "~A\n" i))
  (seek port 0 SEEK_SET)
  (display "Tmp file has:\n")
  (do ((line (read-line port 'concat) (read-line port 'concat)))
      ((eof-object? line))
    (display line))
  (close port))

;; @@PLEAC@@_7.6
;; string ports are ideal for this

(define DATA "
your data goes here
")

(call-with-input-string
 DATA
 (lambda (port)
   ;; ... process input from port
   '()))

;; or

(with-input-from-string DATA
  (lambda ()
    ;; ... stdin now comes from DATA
    '()))

;; @@PLEAC@@_7.7
;; to process lines of current-input-port:
(do ((line (read-line) (read-line)))
    ((eof-object? line))
  ;; ... do something with line
  '())

;; a general filter template:

(define (body)
  (do ((line (read-line) (read-line)))
      ((eof-object? line))
    (display line)
    (newline)))

(let ((args (cdr (command-line))))
  ;; ... handle options here
  (if (null? args)
    (body)     ; no args, just call body on stdin
    (for-each  ; otherwise, call body with stdin set to each arg in turn
     (lambda (file)
       (catch 'system-error
         (lambda ()
           (with-input-from-file file
             body))
         (lambda (key . args)
           (format (current-error-port) (cadr args) (caaddr args)
                   (car (cdaddr args)))
           (newline (current-error-port)))))
     args)))

;; example: count-chunks:
(use-modules (srfi srfi-1) (srfi srfi-13) (ice-9 format) (ice-9 regex))

;; also use directory-files from 9.5 and globbing functions from 9.6

;; can use (ice-9 getopt-long) described in chapter 15, or process
;; options by hand
(define opt-append 0)
(define opt-ignore-ints 0)
(define opt-nostdout 0)
(define opt-unbuffer 0)

(define args (cdr (command-line)))

(do ((opts args (cdr opts)))
    ((or (null? opts) (not (eq? (string-ref (car opts) 0) #\-)))
     (set! args opts))
  (let ((opt (car opts)))
    (cond ((string=? opt "-a") (set! opt-append (1+ opt-append)))
          ((string=? opt "-i") (set! opt-ignore-ints (1+ opt-ignore-ints)))
          ((string=? opt "-n") (set! opt-nostdout (1+ opt-nostdout)))
          ((string=? opt "-u") (set! opt-unbuffer (1+ opt-unbuffer)))
          (else (throw 'usage-error "Unexpected argument: ~A" opt)))))

;; default to all C source files
(if (null? args) (set! args (glob "*.[Cch]" ".")))

(define (find-login)
  (do ((line (read-line) (read-line)))
      ((eof-object? line))
    (cond ((string-match "login" line)
           (display line)
           (newline)))))

(define (lowercase)
  (do ((line (read-line) (read-line)))
      ((eof-object? line))
    (display (string-downcase line))
    (newline)))

(define (count-chunks)
  (do ((line (read-line) (read-line))
       (chunks 0))
      ((or (eof-object? line)
           (string=? line "__DATA__") (string=? line "__END__"))
       (format #t "Found ~A chunks\n" chunks))
    (let ((tokens
           (string-tokenize (string-take line (or (string-index line #\#)
                                                  (string-length line))))))
      (set! chunks (+ chunks (length tokens))))))

(if (null? args)
  (count-chunks)     ; or find-login, lowercase, etc.
  (for-each
   (lambda (file)
     (catch 'system-error
       (lambda ()
         (with-input-from-file file
           count-chunks))
       (lambda (key . args)
         (format (current-error-port) (cadr args) (caaddr args)
                 (car (cdaddr args)))
         (newline (current-error-port)))))
   args))

;; @@PLEAC@@_7.8
;; write changes to a temporary file then rename it
(with-input-from-file old
  (lambda ()
    (with-output-to-file new
      (lambda ()
        (do ((line (read-line) (read-line)))
            ((eof-object? line))
          ;; change line, then...
          (write-line line))))))
(rename-file old (string-append old ".orig"))
(rename-file new old)

;; @@PLEAC@@_7.9
;; no -i switch

;; @@PLEAC@@_7.10
;; open the file in read/write mode, slurp up the contents, modify it,
;; then write it back out:
(let ((p (open-file file "r+"))
      (lines '()))
  ;; read in lines
  (do ((line (read-line p) (read-line p)))
      ((eof-object? line))
    (set! lines (cons line lines)))
  ;; modify (reverse lines)
  (seek p 0 SEEK_SET)
  ;; write out lines
  (for-each (lambda (x) (write-line x p)) lines)
  ;; truncate the file
  (truncate-file p)
  (close p))

(let ((p (open-file "foo" "r+"))
      (lines '())
      (date (date->string (current-date))))
  (do ((line (read-line p 'concat) (read-line p 'concat)))
      ((eof-object? line))
    (set! lines (cons line lines)))
  (seek p 0 SEEK_SET)
  (for-each
   (lambda (x)
     (regexp-substitute/global p "DATE" x 'pre date 'post))
   (reverse lines))
  (truncate-file p)
  (close p))

;; @@PLEAC@@_7.11
(define p (open-file path "r+"))
(flock p LOCK_EX)
;; update the file, then...
(close p)

;; to increment a number in a file
(define p (open "numfile" (logior O_RDWR O_CREAT)))
(flock p LOCK_EX)
;; Now we have acquired the lock, it's safe for I/O
(let* ((obj (read p))
       (num (if (eof-object? obj) 0 obj)))
  (seek p 0 SEEK_SET)
  (truncate-file p)
  (write (1+ num) p)
  (newline p))
(close p)

;; @@PLEAC@@_7.12
;; use force-output
(force-output p)

;; flush all open ports
(flush-all-ports)

;; @@PLEAC@@_7.13
;; use select
(select inputs outputs exceptions seconds)
(select (list p1 p2 p3) '() '())

(let* ((nfound (select (list inport) '() '()))
       (inputs (car nfound)))
  (if (not (null? inputs))
      (let ((line (read-line inport)))
        (format #t "I read ~A\n" line))))

;; or use char-ready? if you only need a single character
(if (char-ready? p)
  (format #t "I read ~A\n" (read-char p)))

;; @@PLEAC@@_7.14
;; use the O_NONBLOCK option with open
(define modem (open "/dev/cua0" (logior O_RDWR O_NONBLOCK)))

;; or use fcntl if you already have a port
(let ((flags (fcntl p F_GETFD)))
  (fcntl p F_SETFD (logior flags O_NONBLOCK)))

;; @@PLEAC@@_7.15
;; use stat
(let ((buf (make-string (stat:size (stat p)))))
  (read-string!/partial buf input))

;; @@PLEAC@@_7.16
;; not needed - ports are first class objects

;; @@PLEAC@@_7.18
;; use for-each on the list of ports:
(for-each (lambda (p) (display stuff-to-print p)) port-list)

;; or, if you don't want to keep track of the port list and know you
;; want to print to all open output ports, you can use port-for-each:
(port-for-each (lambda (p) (if (output-port? p) (display stuff p))))

;; @@PLEAC@@_7.19
;; use fdopen:
(define p (fdopen num mode))
(define p (fdopen 3 "r"))

(define p (fdopen (string->number (getenv "MHCONTEXTFD")) "r"))
;; after processing
(close p)

;; @@PLEAC@@_7.20
;; ports are first class objects and can be aliased and passed around
;; like any other non-immediate variables:
(define alias original)
(define old-in (current-input-port))

;; or you can open two separate ports on the same file:
(define p1 (open-input-file path))
(define p2 (open-input-file path))

;; or use fdopen:
(define copy-of-p (fdopen (fileno p) mode))

(define old-out (current-output-port))
(define old-err (current-error-port))

(define new-out (open-output-file "/tmp/program.out"))

(set-current-output-port new-out)
(set-current-error-port new-out)

(system joe-random-program)

(close new-out)

(set-current-output-port old-out)
(set-current-error-port old-out)

;; @@PLEAC@@_8.0
;; open the file and loop through the port with read-line:
(let ((p (open-input-file file)))
  (do ((line (read-line p) (read-line p)))
      ((eof-object? line))
    (format #t "~A\n" (string-length line)))
  (close p))

;; you can use with-input-from-file to temporarily rebind stdin:
(with-input-from-file file
  (lambda ()
    (do ((line (read-line) (read-line)))
        ((eof-object? line))
      (format #t "~A\n" (string-length line)))))

;; or define a utility procedure to do this
(define (for-each-line proc file)
  (with-input-from-file file
    (lambda ()
      (do ((line (read-line) (read-line)))
          ((eof-object? line))
        (proc line)))))
(for-each-line (lambda (x) (format #t "~A\n" (string-length line))) file)

;; read in the file as a list of lines
(define (read-lines file)
  (let ((ls '()))
    (with-input-from-file file
      (lambda ()
        (do ((line (read-line) (read-line)))
            ((eof-object? line))
          (set! ls (cons line ls)))
        (reverse ls)))))

;; read in the file as a single string
(define (file-contents file)
  (call-with-input-file file
    (lambda (p)
      (let* ((size (stat:size (stat p)))
             (buf (make-string size)))
        (read-string!/partial buf p)
        buf))))

;; use display to print human readable output
(display '("One" "two" "three") port)  ; (One two three)
(display "Baa baa black sheep.\n")     ; Sent to default output port

;; use write to print machine readable output
(write '("One" "two" "three") port)    ; ("One" "two" "three")

;; use (ice-9 rw) to read/write fixed-length blocks of data:
(use-modules (ice-9 rw))
(let ((buffer (make-string 4096)))
  (read-string!/partial buffer port 4096))

;; truncate-file
(truncate-file port length)  ; truncate to length
(truncate-file port)         ; truncate to current pos

;; ftell
(define pos (ftell port))
(format #t "I'm ~A bytes from the start of DATAFILE.\n" pos)

;; seek
(seek log-port 0 SEEK_END)      ; seek to end
(seek data-port pos SEEK_SET)   ; seek to pos
(seek out-port -20 SEEK_CUR)    ; seek back 20 bytes

;; block read/write
(use-modules (ice-9 rw))
(write-string/partial mystring data-port (string-length mystring))
(read-string!/partial block 256 5)

;; @@PLEAC@@_8.1
(let ((rx (make-regexp "(.*)\\\\$"))) ; or "(.*)\\\\\\s*$"
  (with-input-from-file file
    (lambda ()
      (let loop ((line (read-line)))
        (if (not (eof-object? line))
          (let ((m (regexp-exec rx line))
                (next (read-line)))
            (cond ((and m (not (eof-object? next)))
                   (loop (string-append (match:substring m 1) next)))
                  (else
                   ;; else process line here, then recurse
                   (loop next)))))))))

;; @@PLEAC@@_8.2
(do ((line (read-line p) (read-line p))
     (i 0 (1+ i)))
    ((eof-object? line) i))

;; fastest way if your terminator is a single newline
(use-modules (ice-9 rw) (srfi srfi-13))
(let ((buf (make-string (expt 2 16)))
      (count 0))
  (do ((len (read-string!/partial buf p) (read-string!/partial buf p)))
      ((not len) count)
    (set! count (+ count (string-count buf #\newline 0 len)))))

;; or use port-line
(let loop ((line (read-line p)))
  (if (eof-object? line) (port-line p) (loop (read-line p))))

;; @@PLEAC@@_8.3
;; default behaviour of string-tokenize is to split on whitespace:
(use-modules (srfi srfi-13))
(let loop ((line (read-line p)))
  (cond ((not eof-object? line)
         (for-each some-function-of-word (string-tokenize line))
         (loop (read-line p)))))

(let ((table (make-hash-table 31)))
  (let loop ((line (read-line p)))
    (cond ((not (eof-object? line))
           (for-each
            (lambda (w) (hash-set! table w (1+ (hash-ref table w 0))))
            (string-tokenize line))
           (loop (read-line p)))))
  (hash-fold (lambda (k v p) (format #t "~5D ~A\n" v k)) #f table))

;; @@PLEAC@@_8.4
;; build up the list the reverse it or fold over it:
(define lines (read-lines file))
(for-each (lambda (word) do-something-with-word) (reverse lines))
(fold (lambda (word acc) do-something-with-word) #f lines)

;; @@PLEAC@@_8.5
;; save the current position and reseek to it
(define (tail file)
  (call-with-input-file file
    (lambda (p)
      (let loop ((line (read-line p)))
        (cond ((eof-object? line)
               (sleep sometime)
               (let ((pos (ftell p)))
                 (seek p 0 SEEK_SET)
                 (seek p pos SEEK_SET)))
              (else
               ;; process line
               ))
        (loop (read-line p))))))

;; @@PLEAC@@_8.6
(let ((rand-line #f))
  (let loop ((line (read-line p)))
    (cond ((not (eof-object? line))
           (if (= 0 (random (port-line p)))
             (set! rand-line line))
           (loop (read-line p)))))
  ;; rand-line is the random line
  )

;; @@PLEAC@@_8.7
(define (shuffle list)
  (let ((v (list->vector list)))
    (do ((i (1- (vector-length v)) (1- i)))
        ((< i 0) (vector->list v))
      (let ((j (random (1+ i))))
        (cond ((not (= i j))
               (let ((temp (vector-ref v i)))
                 (vector-set! v i (vector-ref v j))
                 (vector-set! v j temp))))))))

(define rand-lines (shuffle (read-lines file))

;; @@PLEAC@@_8.8
;; looking for line number desired-line-number
(do ((line (read-line p) (read-line p)))
    ((= ((port-line p) desired-line-number) line)))
;; or read into a list
(define lines (read-lines file))
(list-ref lines desired-line-number)

;; @@INCOMPLETE@@
; (define (build-index data-file index-file)
;   )

; (define (line-with-index data-file index-file line-number)
;   )

;; @@PLEAC@@_8.9
;; use string-tokenize with an appropriate character set
(use-modules (srfi srfi-13) (srfi srfi-14))
(define fields (string-tokenize line (string->charset "+-")))
(define fields (string-tokenize line (string->charset ":")))
(define fields (string-tokenize line))

;; @@PLEAC@@_8.10
(let ((p (open-file file "r+")))
  (let ((pos 0))
    (let loop ((line (read-line p)))
      (cond ((eof-object? (peek-char p))
             (seek p 0 SEEK_SET)
             (truncate-file p pos)
             (close p))
            (else
             (set! pos (ftell p))
             (loop (read-line p)))))))

;; @@PLEAC@@_8.11
;; no equivalent - don't know how Guile under windows handles this

;; @@PLEAC@@_8.12
(let* ((address (* recsize recno))
       (buf (make-string recsize)))
  (seek p address SEEK_SET)
  (read-string!/partial buf p)
  buf)

;; @@PLEAC@@_8.13
(let* ((address (* recsize recno))
       (buf (make-string recsize)))
  (seek p address SEEK_SET)
  (read-string!/partial buf p)
  ;; modify buf, then write back with
  (seek p address SEEK_SET)
  (write-string/partial buf p)
  (close p))

;; @@INCOMPLETE@@
;; weekearly

;; @@PLEAC@@_8.14
(seek p addr SEEK_SET)
(define str (read-delimited (make-string 1 #\nul) p))

#!/usr/local/bin/guile -s
!#
;; bgets -- get a string from an address in a binary file
(use-modules (ice-9 format))

(define args (cdr (command-line)))
(define file (car args))
(define addrs (map string->number (cdr args)))
(define delims (make-string 1 #\nul))

(call-with-input-file file
  (lambda (p)
    (for-each
     (lambda (addr)
       (seek p addr SEEK_SET)
       (format #t "~X ~O ~D ~S\n" addr addr addr
               (read-delimited delims p)))
     addrs)))

;; @@INCOMPLETE@@
;; strings

;; @@PLEAC@@_9.0
(define entry (stat "/usr/bin/vi"))
(define entry (stat "/usr/bin"))
(define entry (stat port))

(use-modules (ice-9 posix))

(define inode (stat "/usr/bin/vi"))
(define ctime (stat:ctime inode))
(define size (stat:size inode))

(define F (open-input-file filename))
;; no equivalent - what defines -T?
; unless (-s F && -T _) {
;     die "$filename doesn't have text in it.\n";
; }

(define dir (opendir "/usr/bin"))
(do ((filename (readdir dir) (readdir dir)))
    ((eof-object? filename))
  (format #t "Inside /usr/bin is something called ~A\n" filename))
(closedir dir)

;; @@PLEAC@@_9.1
(define inode (stat filename))
(define readtime (stat:atime inode))
(define writetime (stat:mtime inode))

(utime newreadtime newwritetime filename)

(define seconds-per-day (* 60 60 24))
(define inode (stat file))
(define atime (stat:atime inode))
(define mtime (stat:mtime inode))
(set! atime (- atime (* 7 seconds-per-day)))
(set! mtime (- mtime (* 7 seconds-per-day)))
(utime file atime mtime)

;; mtime is optional
(utime file (current-time))
(utime file (stat:atime (stat file)) (current-time))

#!/usr/local/bin/guile -s
!#
;; uvi - vi a file without changing its access times

(define file (cadr (command-line)))
(define inode (stat file))
(define atime (stat:atime inode))
(define mtime (stat:mtime inode))
(system (string-append (or (getenv "EDITOR")  "vi") " " file))
(utime file atime mtime)

;; @@PLEAC@@_9.2
(delete-file file)

(let ((count 0))
  (for-each
   (lambda (x)
     (catch #t
       (lambda () (delete-file x) (set! count (1+ count)))
       (lambda (err . args) #f)))
   file-list)
  (if (not (= count (length file-list)))
    (format (current-error-port) "could only delete ~A of ~A files"
            count (length file-list))))

;; @@PLEAC@@_9.3
;; use builtin copy-file
(copy-file oldfile newfile)
(rename-file oldfile newfile)

;; or do it by hand (clumsy, error-prone)
(use-modules (ice-9 rw) (ice-9 posix))
(with-input-from-file oldfile
  (lambda ()
    (call-with-output-file newfile
      (lambda (p)
        (let* ((inode (stat oldfile))
               (blksize (if inode (stat:size inode) 16384))
               (buf (make-string blksize)))
          (let loop ((len (read-string!/partial buf)))
            (cond ((and len (> len 0))
                   (write-string/partial buf p 0 len)
                   (loop (read-string!/partial buf))))))))))

;; or call out to the system (non-portable, insecure)
(system (string-append "cp " oldfile " " newfile))    ; unix
(system (string-append "copy " oldfile " " newfile))  ; dos, vms

;; @@PLEAC@@_9.4
;; use a hash lookup of inodes
(use-modules (ice-9 posix))
(let ((seen (make-hash-table 31)))
  (for-each
   (lambda (file)
     (let* ((stats (stat file))
            (key (cons (stat:dev stats) (stat:ino stats)))
            (val (hash-ref seen key 0)))
       (cond ((= val 0)
              ;; do something with new file
              ))
       (hash-set! seen key (1+ val))))
   file-names))

(let ((seen (make-hash-table 31)))
  (for-each
   (lambda (file)
     (let* ((stats (stat file))
            (key (cons (stat:dev stats) (stat:ino stats)))
            (val (hash-ref seen key '())))
       (hash-set! seen key (cons file val))))
   file-names)
  (hash-fold
   (lambda (key value prior)
     ;; process key == (dev . inode), value == list of filenames
     )
   '() seen))

;; @@PLEAC@@_9.5
;; use opendir, readdir, closedir
(let ((p (opendir dir)))
  (let loop ((file (readdir p)))
    (if (eof-object? file)
      (close p)
      ;; do something with file
      )))

;; or define a utility function for this
(define (directory-files dir)
  (if (not (access? dir R_OK))
    '()
    (let ((p (opendir dir)))
      (do ((file (readdir p) (readdir p))
           (ls '()))
          ((eof-object? file) (closedir p) (reverse! ls))
        (set! ls (cons file ls))))))

;; to skip . and ..
(cddr (directory-files dir))

;; probably better to implement full Emacs style directory-files
(use-modules (ice-9 posix))
(define plain-files
  (let ((rx (make-regexp "^\\.")))
    (lambda (dir)
      (sort (filter (lambda (x) (eq? 'regular (stat:type (stat x))))
                    (map (lambda (x) (string-append dir "/" x))
                         (remove (lambda (x) (regexp-exec rx x))
                                 (cddr (directory-files dir)))))
            string<))))

;; @@PLEAC@@_9.6
(define (glob->regexp pat)
  (let ((len (string-length pat))
        (ls '("^"))
        (in-brace? #f))
    (do ((i 0 (1+ i)))
        ((= i len))
      (let ((char (string-ref pat i)))
        (case char
          ((#\*) (set! ls (cons "[^.]*" ls)))
          ((#\?) (set! ls (cons "[^.]" ls)))
          ((#\[) (set! ls (cons "[" ls)))
          ((#\]) (set! ls (cons "]" ls)))
          ((#\\)
           (set! i (1+ i))
           (set! ls (cons (make-string 1 (string-ref pat i)) ls))
           (set! ls (cons "\\" ls)))
          (else
           (set! ls (cons (regexp-quote (make-string 1 char)) ls))))))
    (string-concatenate (reverse (cons "$" ls)))))

(define (glob pat dir)
  (let ((rx (make-regexp (glob->regexp pat))))
    (filter (lambda (x) (regexp-exec rx x)) (directory-files dir))))

(define files (glob "*.c" "."))
(define files (glob "*.[ch]" "."))

;; Not sure if the Schwartzian Transform would really be more
;; efficient here... perhaps with a much larger directory where very
;; few files matched.
(define dirs (filter
              (lambda (x) (eq? 'directory (stat:type (stat x))))
              (map (lambda (x) (string-append dir "/" x))
                   (sort (filter (lambda (x) (string-match "^[0-9]+$" x))
                                 (directory-files dir))
                         (lambda (a b)
                           (< (string->number a) (string->number b)))))))

;; @@PLEAC@@_9.7
(define (find proc . dirs)
  (cond ((pair? dirs)
         (for-each proc (map (lambda (x) (string-append (car dirs) "/" x))
                             (directory-files (car dirs))))
         (apply find proc (cdr dirs)))))

(find (lambda (x) (format #t "~A~A\n" x
                          (if (equal? (stat:type (stat x)) 'directory)
                            "/" ""))) ".")

(define saved-size -1)
(define saved-name "")
(define (biggest file)
  (let ((stats (stat file)))
    (if (eq? (stat:type stats) 'regular)
      (let ((size (stat:size (stat file))))
        (cond ((> size saved-size)
               (set! saved-size size)
               (set! saved-name file)))))))
(apply find biggest (cdr (command-line)))
(format #t "Biggest file ~A in ~A is ~A bytes long.\n"
        saved-name (cdr (command-line)) saved-size)

#!/usr/local/bin/guile -s
!#
;; fdirs - find all directories
(define (print-dirs f)
  (if (eq? (stat:type (stat f)) 'directory)
    (write-line f)))
(apply find print-dirs (cdr (command-line)))

;; @@PLEAC@@_9.8
#!/usr/local/bin/guile -s
!#
;; rmtree - remove whole directory trees like rm -f
(define (finddepth proc . dirs)
  (cond ((pair? dirs)
         (apply finddepth proc (cdr dirs))
         (for-each proc (map (lambda (x) (string-append (car dirs) "/" x))
                             (directory-files (car dirs)))))))
(define (zap f)
  (let ((rm (if (eq? (stat:type (stat f)) 'directory) rmdir delete-file)))
    (format #t "deleting ~A\n" f)
    (catch #t
      (lambda () (rm f))
      (lambda args (format #t "couldn't delete ~A\n" f)))))
(let ((args (cdr (command-line))))
  (if (null? args)
    (error "usage: rmtree dir ..\n")
    (apply finddepth zap args)))

;; @@PLEAC@@_9.9
(for-each
 (lambda (file)
   (let ((newname (function-of file)))
     (catch #t
       (lambda () (rename-file file newname))
       (lambda args (format (current-error-port)
                            "couldn't rename ~A to ~A\n" file newname)))))
 names)

#!/usr/local/bin/guile -s
!#
;; rename - Guile's filename fixer
(use-modules (ice-9 regex)) ; not needed, but often useful here
(define args (cdr (command-line)))
(if (null? args) (error "usage: rename expr [files]\n"))
(define proc (eval-string (car args)))
(for-each
 (lambda (old)
   (let ((new (proc old)))
     (if (not (string=? old new))
       (catch #t
         (lambda () (rename-file old new))
         (lambda args (format (current-error-port)
                              "couldn't rename ~A to ~A\n" old new))))))
 (cdr args))

;; command-line examples:
;; rename '(lambda (x) (regexp-substitute/global
                        #f "\\.orig\$" x (quote pre)))' *.orig
;; rename string-downcase *
;; rename '(lambda (x) (if (string-match "^Make" x)
                           x
                           (string-downcase x)))' *
;; rename '(lambda (x) (string-append x ".bad"))' *.pl
;; rename '(lambda (x) (format #t "~a: ") (read-line))' *

;; @@PLEAC@@_9.10
(define base (basename path))
(define base (dirname path ext))
(define dir (dirname path))

(define path "/usr/lib/libc.a")
(define file (basename path))
(define dir (dirname path))

(format #t "dir is ~A, file is ~A\n" dir file)

(basename path ".a") ; libc

(use-modules (ice-9 regex))
(define (file-parse path . args)
  (let* ((ext (if (null? args) "\\..*" (car args)))
         (rx1 (string-append "^((.*)/)?(.*)?(" ext ")$"))
         (rx2 (string-append "^((.*)/)?(.*)?()$")))
    (let ((m (or (string-match rx1 path) (string-match rx2 path))))
      (list (match:substring m 2) (match:substring m 3)
            (match:substring m 4)))))

(define (extension path . args)
  (caddr (apply file-parse path args)))

;; @@PLEAC@@_10.0
; Note: Some of the examples will show code blocks in this style:
;
;  (define
;    ... code here ...
;  )
;
; This is not generally considered good style, and is not recommended;
; it is only used here to more clearly highlight block scope 

; By convention a 'global variable' i.e. a variable that is defined at
; the top-level, and as such, visible within any scope, is named with
; beginning and ending asterisks [and one to be used as a constant
; with beginning and ending plus signs]

(define *greeted* 0)

(define (hello)
  (set! *greeted* (+ *greeted* 1))
  (print "hi there!, this procedure has been called" *greeted* "times"))

(define (how-many-greetings) *greeted*)

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

(hello)

(define *greetings* (how-many-greetings))

(print "bye there!, there have been" *greetings* "greetings so far")

;; @@PLEAC@@_10.1
; Subroutine parameters are named [whether directly, or indirectly in
; the case of variable arguments - see next example]; this is the only
; means of access [This contrasts with languages like Perl and REXX which
; allow access to arguments via array subscripting, and function calls,
; respectively]
(define (hypotenuse side1 side2)
  (sqrt (sum (* side1 side1) (* side2 side2))))

(define *diag* (hypotenuse 3 4))

;; ----

; 'other-sides' is the name of a list of containing any additional
; parameters. Note that a name is still used to access values
(define (hypotenuse side1 . other-sides)
  (let ((all-sides (cons side1 other-sides)))
    (for-each
      (lambda (side) 
        ;; ...
        '())
      all-sides)
  ;; ...
  '()))

;; ----

(define *diag* (hypotenuse 3 4))

;; ----

; Possible to pack parameters into a single structure [e.g. list or
; array], and access values contained therein
(define (hypotenuse sides)
  (let ((side1 (car sides)) (side2 (caar sides)))
    (sqrt (sum (* side1 side1) (* side2 side2)))))

;; ----

(define *args* '(3 4))
(define *diag* (hypotenuse *args*))

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

; Parameters passed by reference, however, whether original object is
; modified depends on choice of functions used to manipulate them
; [most functions create copies and return these; mutating versions of
; same functions may also exist [see next example] 
(define *nums* (vector 1.4 3.5 6.7))

(define (int-all vec)
  (vector-map-in-order
    (lambda (element) (inexact->exact (round element)))
    vec))

; Copy created
(define *ints* (int-all *nums*))

(print *nums*)
(print *ints*)

;; ----

(define *nums* (vector 1.4 3.5 6.7))

(define (trunc-all vec)
  (array-map-in-order!
    (lambda (element) (inexact->exact (round element)))
    vec))

; Original modified
(trunc-all *nums*)

;; @@PLEAC@@_10.2
; Scheme is lexically-scoped; variables defined within a block are
; visible only within that block. Whilst nested / subordinate blocks
; have access to those variables, neither the caller, nor any called
; procedures have direct access to those same variables

(define (some-func parm1 parm2 parm3)
  ;; ... paramaters visible here ...

  (let ((var1 1) (var2 2) (var3 3))
    ;; ... parameters also visible here, but variables, 'var1' etc
    ;;     only visible within this block ...
  )
  ;; ... paramaters also visible here, but still within procedure body ...
)

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

; Top-level definitions - accessable globally 
(define *name* (caar (command-line)))
(define *age* (cadr (command-line)))

(define *start* (fetch-time))

;; ----

; Lexical binding - accessable only within this block
(let ((name (caar (command-line)))
      (age (cadr (command-line)))
      (start (fetch-time)))
   ;; ... variables only visible here ...
   '()
)

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

(define *pair* '(1 . 2))

; 'a' and 'b' need to be dereferenced and separately defined [Also,
; since globally defined, should really be named, '*a*', '*b*', etc]
(define a (car *pair*))
(define b (cdr *pair*))
(define c (fetch-time))

(define (run-check)
  ;; ... do something with 'a', 'b', and 'c' ...
  '()
)

(define (check-x x y)
  (if (run-check)
    (print "got" x)))

; Calling 'check-x'; 'run-check' has access to 'a', 'b', and 'c'
(check-x 1 2)

;; ----

; If defined within a block, variables 'a', 'b', and 'c' are no longer
; accessable anywhere except that scope. Therefore, 'run-check' as
; defined above can no longer access these variables [in fact, the code
; will fail because variables 'a', 'b', and 'c' do not exist when
; 'run-check' is defined]
(let ((a (car *pair*))
      (b (cdr *pair*))
      (c (fetch-time)))
   ;; ...
   (check-x 1 2)  
   ;; ...
   '()
)

;; ----

; The procedures, 'run-check' and 'check-x' are defined within the
; same block as variables, 'a', 'b', and 'c', so have direct access to
; them
(let* ((a (car *pair*))
       (b (cdr *pair*))
       (c (fetch-time))

       (run-check
         (lambda () 
           ;; ... do something with 'a', 'b', and 'c' ...
           '()))

       (check-x
         (lambda (x y)
           (if (run-check)
             (print "got" x)))) )
   ;; ...
   (check-x 1 2)  
   ;; ...
   '()
)

;; @@PLEAC@@_10.3
; Ordinarily, a variable must be initialised when it is defined,
; whether at the top-level: 
(define *variable* 1)

; ... or within a 'let' binding
(let* ((variable 1)
       (mysub
         (lambda () 
           ;; ... accessing 'variable' ...
         '())))
  ;; ... do stuff ...
  '()
)

; However, since Scheme allows syntactic extensions via 'macros' [of
; which there are two varieties: hygenic and LISP-based], it is
; possible to create new forms which alter this behaviour. For example,
; in this tutorial: http://home.comcast.net/~prunesquallor/macro.txt
; there is a macro implementation equivalent to 'let, 'called,
; 'bind-values', which allows variables to be defined without initial
; values; an example follows:

; Initialisation values for 'a' and 'b' not specified
(bind-values ((a) b (c (+ *global* 5)))
  ;; ... do stuff ...
  '()
)

; In Scheme many things are possible, but not all those things are
; offered as standard features :) !

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

(let* ((counter 42)
       (next-counter
         (lambda () (set! counter (+ counter 1)) counter))
       (prev-counter
         (lambda () (set! counter (- counter 1)) counter)))

  ;; ... do stuff with 'next-counter' and 'prev-counter' ...
  '()
)

;; ----

; A more complete, and practical, variation of the above code:

; 'counter' constructor
(define (make-counter start)
  (let* ((counter 42)
         (next-counter
           (lambda () (set! counter (+ counter 1)) counter))
         (prev-counter
           (lambda () (set! counter (- counter 1)) counter)))
  (lambda (op)
    (cond
      ((eq? op 'prev) prev-counter)
      ((eq? op 'next) next-counter)
      (else (lambda () (display "error:counter"))) ))))

; Interface functions to 'counter' functionality
(define (prev-counter counter) (apply (counter 'prev) '()))
(define (next-counter counter) (apply (counter 'next) '()))

; Create a 'counter'
(define *counter* (make-counter 42))

; Use the 'counter' ...
(print (prev-counter *counter*))
(print (prev-counter *counter*))
(print (next-counter *counter*))

;; @@PLEAC@@_10.4
; Scheme interpreters generally provide a rich collection of procedure
; metadata, as well as easy access to a program's current 'execution
; state'. Put simply, provision of a powerful, highly customisable
; debugging / tracing facility is almost taken for granted. However, using
; it to perform as trivial a task as obtaining the current function name
; is less than trivial [at least it seems so in Guile] as it appears to
; require quite some setup work. Additionally, the documentation talks
; about facilities e.g. trap installation, that don't appear to be
; available [at least, I couldn't find them].
;
; Example below uses in-built debugging facilities to dump a backtrace
; to a string port and extract the caller's name from the resulting
; string. Not exactly elegant ...

; Execute using: guile --debug ... else no useful output seen
(use-modules (ice-9 debug))

(define (child num)
  ; Create stack [i.e. activation record] object, discarding
  ; irrelevant frames
  (let ((s (make-stack #t 3 1))
        (trace-string-port (open-output-string))
        (parent-name ""))

    ; Dump backtrace to string port
    (display-backtrace s trace-string-port)

    ; Extract caller's name from backtrace data
    ; [shamefully crude - don't do this at home !]
    (set! parent-name
      (caddr (string-tokenize
               (cadr (string-split
                       (get-output-string trace-string-port)
                       #\newline))
               char-set:graphic)))

    ; Who's your daddy ?
    (print parent-name)))

; Each invocation of 'child' should see 'parent' displayed as
; the caller
(define (parent)
  (child 1)
  (child 2)
  (child 3))

(parent) 

;; @@PLEAC@@_10.5
; Procedure parameters are references to entities, so there is no special
; treatment required. If an argument represents a mutable object such
; as an array, then care should be taken to not mutate the object within
; the procedure, or a copy of the object be made and used

(array-diff *array1* *array2*)

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

(define (add-vector-pair x y)
  (let* ((vector-length (vector-length x))
         (new-vec (make-vector vector-length)))
    (let loop ((i 0))
      (cond 
        ((= i vector-length) new-vec)
        (else
          (vector-set! new-vec i (+ (vector-ref x i) (vector-ref y i)))
          (loop (+ i 1)) ))) ))

;; ----

(define *a* '#(1 2))
(define *b* '#(5 8))

(define *c* (add-vector-pair *a* *b*))

(print *c*)

;; ----

  ;; ...

  (if (and (vector? a1) (vector? a2))
    (print (add-vector-pair a1 a2))
  ;else
    (print "usage: add-vector-pair a1 a2"))

  ;; ...

;; @@PLEAC@@_10.6
; AFAIK there is no Scheme equivalent to Perl's 'return context' where
; it is possible to use language primitives [e.g. 'wantarray'] to 
; dynamically specify the return type of a procedure. It is, however,
; possible to:
; * Return one of several types from a procedure, whether based on 
;   processing results [e.g. 'false' on error, numeric on success], or
;   perhaps specified via control argument
; * Check procedure return type and take appropriate action

(define (my-sub)
  (let* ((datatype (vector '() 7 '(1 2 3) "abc" 'sym)))
    (vector-ref datatype (random (vector-length datatype))) ))

;; ----

; '*result*' is bound to a randomly chosen datatype
(define *result* (my-sub))

(cond
  ; It is common to return an empty list to represent 'void'
  ((null? *result*) (print "void context"))

  ((list? *result*) (print "list context"))
  ((number? *result*) (print "scalar context"))
  ((string? *result*) (print "string context"))
  ((symbol? *result*) (print "atom context"))
  (else (print "Unknown type")))

;; @@PLEAC@@_10.7
; Keyword parameters are fully supported. Note that pairs have
; replaced Perl strings in the examples since they are easier to
; manipulate

(use-modules (ice-9 optargs))

(define* (the-func #:key (increment (cons 10 's))
                         (finish (cons 0 'm))
                         (start (cons 0 'm)))
  (print increment)
  (print finish)
  (print start))

(the-func)
(the-func
  #:increment (cons 20 's) #:start (cons 5 'm) #:finish (cons 30 'm))
(the-func #:start (cons 5 'm) #:finish (cons 30 'm))
(the-func #:finish (cons 30 'm))
(the-func #:start (cons 5 'm) #:increment (cons 20 's))

;; @@PLEAC@@_10.8
;; @@INCOMPLETE@@
;; @@INCOMPLETE@@

;; @@PLEAC@@_10.9
; The return of multiple values, whether arrays or other items, may be 
; achieved via:
; * Packaging return items as a single list, structure or array, an
;   approach which is usable across many languages, though can be
;   clunky because the procedure caller must manually extract all
;   items
; * The 'values' procedure, a more Schemish idiom, is usually used in
;   conjunction with the 'call-with-values' procedure [the former combines
;   multiple values, the latter captures and cleanly extracts them]. It
;   comes into its own, however, when used to create a 'macro' [an
;   extension to the Scheme language] like 'let-values', a variation of
;   the 'let' form that allows multiple return values to be placed directly
;   into separate variables. Implementation shown here is from 'The
;   Scheme Programming Language, 3rd Edition' by R. Kent Dybvig, though
;   there exists a more standard implementation in SRFI-11. There is also
;   the 'receive' functionality accessable via: (use-modules (ice-9 receive))

; [1] Implementation of 'somefunc' returning muliple values via packaging
; items within a list that is returned
(define (somefunc)
  (let ((a (make-vector 5))
        (h (make-hash-table 5)))
    (list a h) ))

; Retrieving procedure values requires that the return list be captured
; and each contained item separately extracted ['let*' used in place of
; 'let' to ensure correct retrieval order]
(let* ((return-list (somefunc))
       (a (car return-list))
       (b (cadr return-list)))

  ;; ... do something with 'a' and 'b' ...
  '())

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

; [2] Implementation of 'somefunc' returning muliple values using the
; 'values' procedure 

(use-syntax (ice-9 syncase)) 

; 'let-values' from: http://www.scheme.com/tspl3/syntax.html#fullletvalues
(define-syntax let-values
  (syntax-rules ()
    ((_ () f1 f2 ...) (let () f1 f2 ...))
    ((_ ((fmls1 expr1) (fmls2 expr2) ...) f1 f2 ...)
     (lvhelp fmls1 () () expr1 ((fmls2 expr2) ...) (f1 f2 ...))))) 

(define-syntax lvhelp
  (syntax-rules ()
    ((_ (x1 . fmls) (x ...) (t ...) e m b)
     (lvhelp fmls (x ... x1) (t ... tmp) e m b))
    ((_ () (x ...) (t ...) e m b)
     (call-with-values
       (lambda () e)
       (lambda (t ...)
         (let-values m (let ((x t) ...) . b)))))
    ((_ xr (x ...) (t ...) e m b)
     (call-with-values
       (lambda () e)
       (lambda (t ... . tmpr)
         (let-values m (let ((x t) ... (xr tmpr)) . b))))))) 

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

(define (somefunc)
  (let ((a (make-vector 5))
        (h (make-hash-table 5)))
    (values a h) ))

; Multiple return items placed directly into separate variables
(let-values ( ((a h) (somefunc)) )
  (print (array? a))
  (print (hash-table? h)))

;; @@PLEAC@@_10.10
; Like most modern languages, Scheme supports exceptions for handling
; failure, something that will be illustrated in another section. However,
; conventions exist as to the choice of value used to indicate failure:
; * Empty list i.e. '() is often used for this task, as is it's string
;   counterpart, "", the empty string
; * Return false i.e. #f to indicate failed / not found etc, and a valid
;   value otherwise [e.g. testing set membership: if not a member, return
;   #f, but if a member, return the item itself rather than #t]

; Return empty list as indicating 'failure'
(define (sub-failed) '())

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

(define (look-for-something)
  ...
  (if (something-found)
    ; Item found, return the item
    something
  ;else
    ; Not found, indicate failure
    #f
  ))

;; ----

(if (not (look-for-something))
  (print "Item could not be found ...")
;else
  ;; do something with item ...
  ;; ...
  '()

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

; An interesting variation on returning #f as a failure indicator is
; in using the, 'false-if-exception' procedure whereby a procedure is
; executed, any exceptions it may throw caught, and handled by simply
; returning #f. See example in section on Exception Handling below.

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

(define (ioctl) 
  ;; ...
  #f)

(or (ioctl) (begin (print "can't ioctl") (exit 1)))

;; @@PLEAC@@_10.11
; Whether Scheme is seen to support prototyping depends on the definition
; of this term used:
; * Prototyping along the lines used in Ada, Modula X, and even C / C++,
;   in which a procedure's interface is declared separately from its
;   implementation, is *not* supported
; * Prototyping in which, as part of the procedure definition, parameter 
;   information must be supplied. This is a requirement in Scheme in that
;   parameter number and names must be given, though there is no need to
;   supply type information [optional and keyword parameters muddy the
;   waters somewhat, but the general principle applies]

(define (func-with-no-arg) ...)
(define (func-with-one-arg arg1) ...)
(define (func-with-two-arg arg1 arg2) ...)
(define (func-with-three-arg arg1 arg2 arg3) ...)

;; @@PLEAC@@_10.12
; Not exactly like the Perl example, but a way of immediately
; exiting from an application
(define (die msg . error-code)
  (display (string-append msg "\n") (current-error-port))
  (exit (if (null? error-code) 1 (car error-code))))

;; ----

(die "some message")

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

; An exception is thrown via 'throw'; argument must be a symbol
(throw 'some-exception)

; Invalid attempts - these, themselves force a 'wrong-type-arg
; exception to be thrown
(throw #t)
(throw "my message")
(throw 1)

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

; Example of a 'catch all' handler - 'proc' is executed, and any
; exception thrown is handled, in this case by simply returning false
(define (false-if-exception proc)
  (catch #t
    proc
    (lambda (key . args) #f)))

(define (func)
  (print "Starting 'func' ...")
  (throw 'myexception 1)
  (print "Leaving 'func' ..."))

;; ----

(if (not (false-if-exception main))
  (print "'func' raised an exception")
  (print "'func' executed normally"))

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

; More typical exception handling example in which:
; * 'func' is executed
; * 'catch' either:
;   - returns return value of 'func' [if successful]
;   - executes handler(s)

(define (full-moon-exception-handler key . args)
  (print "I'm executing after stack unwound !"))

(define (full-moon-exception-prewind-handler key . args)
  (print "I'm executing with the stack still intact !"))

(define (func)
  (print "Starting 'func' ...")
  (throw 'full-moon-exception 1)
  (print "Leaving 'func' ..."))

(catch 'full-moon-exception
   func
   full-moon-exception-handler
   full-moon-exception-prewind-handler)

;; @@PLEAC@@_10.13
; Scheme is lexically-scoped, so same-name, higher-level variables
; are merely shadowed in lower-level blocks. Upon exit from those
; blocks the higher-level values are again available. Therefore, the
; saving of global variables, as required by Perl, is not necessary

; Global variable
(define age 18)

; Procedure definition creates a closure - it captures the earlier
; version of, age', and will retain it
(define (func)
  (print age))

(if (condition)
  ; New 'local' variable created which acts to shadow the global
  ; version
  (let ((age 23))

    ; Prints 23 because the global variable is shadowed within 
    ; this block 
    (print age)

    ; However, lexical-scoping ensures 'func' still accesses the
    ; 'age' which was active when it was defined
    (func) ))

; The use of 'fluid-let' allows for similar behaviour to Perl's i.e.
; it mimics dynamic scope, but it does so cleanly in that once its
; scope ends any affected global variables are restored to previous
; values
(if (condition)

  ; This does not create a new 'local' variables but temporarily
  ; sets the global variable, 'age' to 23
  (fluid-let ((age 23))

    ; Prints 23 because it is accessing the global version of 'age'
    (print age)

    ; Prints 23 because it is its lexically-scoped version of 'age'
    ; that has its value altered, albeit temporarily
    (func) ))

;; @@PLEAC@@_10.14
; Define two procedures, bind them to identifiers
(define (grow) (print "grow"))
(define (shrink) (print "shrink"))

; Separate procedures executed
(grow)
(shrink)

; Rebind identifier; now acts as alias for latter
(define grow shrink)

; Same procedure executed in both cases
(grow)
(shrink)

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

; As for previous except that rebinding is localised and
; ends once local scope exited
(let ((grow shrink))
  (grow)
  (shrink))

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

; Example of dynamically creating [from text data] and binding
; procedures. The example here is conceptually similar to the Perl
; example in that it makes use of an 'eval' type of facility to
; generate code from text. In Scheme such tasks are generally better
; dealt with using macros 

; List of procedure name / first argument pairs
(define *colours*
  (list
    '("red" . "baron")
    '("blue" . "zephyr")
    '("green" . "beret")
    '("yellow" . "ribbon")
    '("orange" . "county")
    '("purple" . "haze")
    '("violet" . "temper") ))

; Build a series of procedures dynamically by traversing the
; *colours* list and obtaining:
; * Procedure name from first item of pair
; * Procedure argument from second item of pair
(for-each
  (lambda (colour)
    (let ((proc-string
            (string-append
              "(define " (car colour) " (lambda () "
              "\"<FONT COLOR=" (car colour) ">" (cdr colour)
              "</FONT>\"))" )))
      (eval-string proc-string)))
   *colours*)

; Apply each of the dynamically-built procedures
(for-each
  (lambda (colour)
    (print (apply (string->procedure (car colour)) '())))
  *colours*)

;; @@PLEAC@@_10.15
; AFAICT Guile doesn't implement an AUTOLOAD facility in which a
; 'replacement' function is available should another one fail to
; load [though there is an autoload feature available with modules
; which is a load-on-demand facility aimed at conserving memory and
; speeding up initial program load time].
;
; One might think it would be feasable, however, to use exception
; handling to provide roughly similar functionality:

; Catch all exceptions
(catch #t
  ; Undefined procedure, 'x'
  x
  ; Exception handler could load missing code ?
  (lambda (key . args) ... ))

; However, an undefined function call is reported as:
;
;    ERROR: Unbound variable: ...
;
; and this situation doesn't appear to be user-trappable. 
;

;; @@PLEAC@@_10.16
; Both implementations below  are correct, and exhibit identical
; behaviour 

(define (outer arg)
  (let* ((x (+ arg 35))
         (inner (lambda () (* x 19))))
    (+ x (inner))))

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

(define (outer arg)
  (let ((x (+ arg 35)))
    (define (inner) (* x 19))
    (+ x (inner))))

;; @@PLEAC@@_10.17
;; @@INCOMPLETE@@
;; @@INCOMPLETE@@

;; @@PLEAC@@_12.0
; Modules searched for by name in pre-configured paths [refer documentation
; for details]. For testing it is probably easiest to place them, and
; all other source files, in the current directory, and specify search
; path on command-line:
;
;     guile -L ./ -s testprog.scm
;
; Here, 'testprog.scm' [see example] and modules reside in current the
; directory

; Load modules
(use-modules ((alpha)
              ; Optionally specify item(s) to use
              :select (name)
              ; Optionally attach a 'module alias' to distinguish items
              :renamer (symbol-prefix-proc 'alpha:)) )

(use-modules ((omega)
              :select (name)
              :renamer (symbol-prefix-proc 'omega:)) )

; Access module members
(print
  (string-append "Alpha is " alpha:name ", Omega is " omega:name))

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

; Module name and source file names match -> alpha.scm
(define-module (alpha))
(define-public name "first")

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

; Module name and source file names match -> omega.scm
(define-module (omega))
(define-public name "last")

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

; Guile doesn't distinguish between compile-time and run-time as far
; as module handling is concerned. A module is loaded when:

; * A (use-modules ...) is encountered

(use-modules ((omega))

; * A reference is made to an item in a module specified as being
; autoloaded

(define-module (new-module)
               #:autoload (mod-x) (mod-y))
               ;; ...

; Module code loaded at this point
(if (item-from-mod-x item)
  ;; ...
  #t
  ; else
  ;; ...
  #f)

;; @@PLEAC@@_12.1
; All bindings within a module are private to it unless specifically
; exported, something which is accomplished via:
;
; * Use of (define-public ...) in place of (define ...) for each export
;   item
;

; Module name and source file names match -> your-module.scm
(define-module (your-module))

; Module's 'interface' - set of exported / publically-accessable items
(define-public version "1.2")

(define-public (a-public-proc arg) "a-public-proc")
(define-public (another-public-proc arg) "another-public-proc")

; Module's 'implementation', its internals
(define a-private-var "...")
(define (a-private-proc arg) '())

;
; or via:
;
; * Create an export list via: (export item1 item2 ...)
;

; Module name and source file names match -> your-module.scm
(define-module (your-module))

(define version "1.2")

(define (a-public-proc arg) "a-public-proc")
(define (another-public-proc arg) "another-public-proc")

; Module's 'interface' - set of exported / publically-accessable items
(export version a-public-proc another-public-proc)

; Module's 'implementation', its internals
(define a-private-var "...")
(define (a-private-proc arg) '())

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

; Load module, allowing access to all exported items, and uses
; specified prefix, 'ym:, to refer to module items
(use-modules ((your-module)
              :renamer (symbol-prefix-proc 'ym:)) )

; Access module members
(print ym:version)

(print (ym:a-public-proc 'x))
(print (ym:another-public-proc 'x))

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

; Load module, allowing access to all exported items, and uses no
; prefix for module items - they are identified as named within the
; module, something which may cause name-clash problems
(use-modules (your-module))

; Access module members
(print version)

(print (a-public-proc 'x))
(print (another-public-proc 'x))

;; @@PLEAC@@_12.2
; The module-handling procedures offer some reflective capabilities,
; including the ability to obtain a module's export list, and 
; dynamically load / create a module. Here, a custom function is used
; to obtain a module's export list; since success indicates said module
; exists, it may be used to check module availability without the module
; being loaded. Note: this approach works, but since the documentation
; is rather sparse, I'm not sure whether this is *the* best approach to
; this problem

(define (module-available? module-name)
  (catch #t
    (lambda () (resolve-interface module-name) #t)
    (lambda (key . args) #f)))

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

; Is module available ?
(if (module-available? '(alpha))
  ; Yes ? Load it for use, else report the problem
  (use-modules ((alpha)
                :renamer (symbol-prefix-proc 'alpha:)) )
;else
  (print "Module does not exist / not in load path"))

;; ...

; Use module item(s) [assuming load was successful]
(print alpha:aa)

;; @@PLEAC@@_12.3
; Guile doesn't distinguish between compile-time and run-time as far
; as module handling is concerned. A module is loaded when:

; * A (use-modules ...) is encountered

; (use-modules ((...))

; * A reference is made to an item in a module specified as being
; autoloaded

; (define-module (...)
;               #:autoload (mod-x) (...))
;               ...

; Module code loaded at this point
; (if (item-from-mod-x ...) ...)

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

(let ((num1 #f) (num2 #f))
  (cond
    ((and 
      (= (length (command-line)) 3)
      (begin (set! num1 (string->number (cadr (command-line)))) num1)
      (begin (set! num2 (string->number (caddr (command-line)))) num2))

      ; Command-line processing successful - load modules to do some
      ; real work
      (use-modules ((some-module)
                    :renamer (symbol-prefix-proc 'some:)) )

      (use-modules ((another-module)
                    :renamer (symbol-prefix-proc 'another:)) )

      ...)
    (else 
      (die
        (string-append
          "usage: guile -s " (car (command-line)) " num1 num2")) )))

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

(cond
  (opt-b
    (use-modules ((bigmath)
                  :renamer (symbol-prefix-proc 'bigmath:)) )
  ;; ...
    ; use module
  ;; ...)
  (else
    ;; ...
    ; work without module
    ;; ...))

;; @@PLEAC@@_12.4
; Variables are private to a module unless exported

; Module name and source file names match -> alpha.scm
(define-module (alpha))

; If 'define' instead of 'define-public' used, then items remain
; private
(define-public aa 10)
(define-public x "azure")

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

; Module name and source file names match -> beta.scm
(define-module (beta))

; If 'define' instead of 'define-public' used, then items remain
; private
(define-public bb 20)
(define-public x "blue")

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

; Load modules
(use-modules ((alpha)
              :renamer (symbol-prefix-proc 'alpha:)) )

(use-modules ((beta)
              :renamer (symbol-prefix-proc 'beta:)) )

; Access module items
(print 
  (string-append 
    (number->string alpha:aa) ", "
    (number->string beta:bb) ", "
    alpha:x ", "
    beta:x))

;; @@PLEAC@@_12.5
; caller's package 
; ??? backtrace trap
@@INCOMPLETE@@
@@INCOMPLETE@@

;; @@PLEAC@@_12.6
; automating module cleanup
; ??? hooks, guardians
@@INCOMPLETE@@
@@INCOMPLETE@@

;; @@PLEAC@@_12.7
; The directories Guile should search for modules are available in the
; global variable, '%load-path' based on configuration data supplied 
; at installation time. Additional search directories may be specified
; using:
;
; * Command-line Option:   -L DIRNAME
; * Environment Variable:  GUILE_LOAD_PATH
;
; which act to prepend search data to the %load-path variable so that
; user modules will be processed before non-core system modules
;
; Following standalone code could be loaded in several ways - probably
; easiest to place it in a file and execute via: guile -s FILENAME
; Use 'guile --help' for more execution options
;

#!
!#

(define (print item . rest)
  (let ((all-item (cons item rest)))
    (for-each
      (lambda (item) (display item) (display " "))      
      all-item))
  (newline))

(define (for-each-idx proc list . start-idx)
  (let loop ((i (if (null? start-idx)
                  0
                  (car start-idx)))
             (list list))
    (cond
      ((null? list) '())
      (else
        (proc i (car list))
        (loop (+ i 1) (cdr list)))) ))

(for-each-idx 
  (lambda (i item)
    (print i item))
  %load-path)

; Output:
;
; 0 /usr/local/share/guile/site
; 1 /usr/local/share/guile/1.8
; 2 /usr/local/share/guile

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

; To specify the location of user modules from outside the execution
; environment use any of the earlier mentioned approaches

; guile -L /projects/spectre/lib/ -s SCRIPTNAME ...

; Append:
;   set GUILE_LOAD_PATH=$GUILE_LOAD_PATH:/projects/spectre/lib/
; or prepend:
;   set GUILE_LOAD_PATH=/projects/spectre/lib/:$GUILE_LOAD_PATH
; export GUILE_LOAD_PATH

;; @@PLEAC@@_12.8
; Module distribution can be:
;
; * Informal, consisting of nothing more than copying all
;   relevant [.scm] files somewhere into the load path [see
;   previous section]. This task could be performed manually,
;   or automated using a custom installation script.
;
;   This approach would appear reasonable for very small one
;   or two [.scm] file systems, or where no additional libraries
;   [e.g. C static and dynamic libraries] are needed, but probably
;   not suitable for larger system distribution 
;
; * Formal, using some published distribution means. AFAIK there
;   are no utilities such as Perl's 'h2xs' to automate this process.
;   However, major Guile packages appear to use the GNU Build System
;   [i.e. autoconf, automake et al] for distribution. Since this
;   system is well known it is recommended that a suitable tutorial
;   be consulted. A later section will include a simple example
;

;; @@PLEAC@@_12.9
; Guile has no equivalent to Perl's 'selfloader' facility, thus this
; section could not be implemented

;; @@PLEAC@@_12.10
; Guile has no equivalent to Perl's 'autoloader' facility. The use
; of the 'autoload' keyword with modules serves to ensure a module
; is loaded [if not already in memory] if specified module items
; are accessed. In other words, a 'load-on-demand' facility which
; is, I believe, a somewhat different mechanism to Perl's, therefore,
; the examples in this section could not be implemented
;

;; @@PLEAC@@_12.11
; In Scheme, a built-in function [BIF] is no more than an object
; encapsulating a block of code [a 'lambda'] that is bound to an
; identifier. Since identifier bindings can be readily altered, simply
; rebinding the identifier to a replacement lambda overrides the
; built-in version

; Show current time using built-in, 'current-time'
(print (current-time))

; Override built-in by rebinding identifier with new lambda
(define current-time
  (lambda () "This isn't the current time !"))

; Does this show the current time ?
(print (current-time))

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

; However, if overriding of built-ins occurs within a module:
;
; * All module code will see overidden code [assuming it occurs
;   early in the module]; this is as expected
; * Override will only affect module users if the same identifier
;   is exported [i.e. no module prefix is used]

(define-module (override))

; Override 'current-time'
(define-public current-time
  (lambda () "This isn't the current time !"))

(define-public (return-current-time)
  ; Uses overriden version of, 'current-time' 
  (current-time))

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

; Import module using prefix
(use-modules ((override)
              :renamer (symbol-prefix-proc 'override:)) )

; Use overidden version
(print (override:current-time))

; Top-level binding retained
(print (current-time))

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

; Import module - no prefix
(use-modules (override))

; Top-level binding overidden
(print (current-time))

;; @@PLEAC@@_12.12
; Simple custom error reporter mimicing Perl's 'die'
(define (die msg . error-code)
  (display (string-append msg "\n") (current-error-port))
  (exit (if (null? error-code) 1 (car error-code))))

(define (even-only num)
  (or (= (modulo num 2) 0)
      (die (string-append (number->string num) " is not even"))))

; Ok for the following:
(even-only 2)      ; ==> #t
(even-only 3)      ; ==> exits with error message and return code, 1

; However, the following applications:
(even-only '$)     ; ==> wrong type arg exception thrown 
(even-only "34")   ; ==> ditto

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

; Built-ins use the exception handling mechanism to trap and
; handle errors

(define (even-only num)
  ; Catch all exceptions
  (catch #t
    ; Execute our 'work code'
    (lambda () (= (modulo num 2) 0))

    ; Make sure our error handler doesn't, itself, fail :) !
    (lambda (key . args)
      (let* ((snum
        (cond
          ((number? num) (number->string num))
          ((symbol? num) (symbol->string num))
          ((string? num) (string-append "\"" num "\""))
          (else "???") )))
        (print (string-append snum " is not even"))
        #f))))

; Ok for all the following:
(even-only 2)      ; ==> #t
(even-only 3)      ; ==> #f
(even-only '$)     ; ==> #f
(even-only "34")   ; ==> #f

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

; Shorter, but coarser-grained version of the above

(define (false-if-exception proc)
  (catch #t
    proc
    (lambda (key . args) #f)))

(define (even-only num)
  (false-if-exception
    (lambda () (= (modulo num 2) 0)) ))

; Ok for all the following:
(even-only 2)      ; ==> #t
(even-only 3)      ; ==> #f
(even-only '$)     ; ==> #f
(even-only "34")   ; ==> #f

;; @@PLEAC@@_12.13
; It is, of course, possible to dynamically generate module names
; and procedures, and gain access to those items indirectly; this is
; done via macros and 'eval'

; Some helper procedures
(define (load-module module-name)
  (let ((name (string->symbol module-name))
        (prefix (string->symbol (string-append module-name ":"))))
    (primitive-eval
      `(use-modules ((,name) :renamer (symbol-prefix-proc ',prefix)))) ))

(define (string->procedure proc-name)
  (primitive-eval (string->symbol proc-name)))

(define (make-prefixed-proc prefix proc-name)
  (string->procedure (string-append prefix ":" proc-name)))

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

; Example from earlier using 'indirect' module loading and module
; procedure access

; Load a module 'indirectly' i.e. name could be a string obtained
; from the user at runtime
(load-module "override")

; Execute module procedure using runtime-generated names
(print (apply (make-prefixed-proc "override" "current-time") '()))

; This approach:

(print (override:current-time))

; cannot be used because neither the module name nor the module
; procedure are known until runtime

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

; Module 'main'
(define-module (main))

(define-public (log n) ...)

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

; Module name
(define module-name "main")

; Load the module
(load-module module-name)

; Conveneience procedure - alias for module procedure
(define log-proc (make-prefixed-proc module-name "log"))

; Apply module procedure ...
(let loop ((i 2))
  (cond
    ((= i 1000) '())
    (else
      (print (apply log-proc (list i)))
      (loop (+ i 1))) ))  

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

; Bind module items to top-level identifiers
(define blue colours:blue)
(define main-blue colours:azure)

;; @@PLEAC@@_12.14
; This section appears to illustrate access to shared library code
; from Perl. Guile offers several methods of doing the same,
; including:
;
; * The 'dynamic-link', 'dynamic-unlink', 'dynamic-call', and
;   'dynamic-call-with-args' primitives which, together, provide
;   a simple [if crude] means of accessing functions in shared
;   libraries ['.so' files]
;
; * The 'libffi' facility, a cross-language facility for accessing 
;   'foreign' [i.e. non-Scheme] functions. A Guile implementation is
;   available, though it does need some fine-tuning when installing
;   [see: http://www.mail-archive.com/guile-devel@gnu.org/msg00951.html
;   for more details]
;
; * Creating and installing new Guile compiled C primitives. This
;   process boils down to:
;
;   - Writing C worker function(s) to perform whatever is required
;   - Writing C wrapper function(s) for the workers i.e. glue code
;     that packs / unpacks and conerts arguments and return values
;   - Compiling using: #include <libguile.h>, and placing code into a
;     shared library ['.so']
;   - Loading shared library in Guile via the 'load-extension' primitive
;

; !!! dynamic-link example goes here
@@INCOMPLETE@@

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

; !!! libffi example goes here
; ./configure --disable-deprecated --disable-discouraged 
@@INCOMPLETE@@

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

; !!! libguile.h example goes here
@@INCOMPLETE@@

;; @@PLEAC@@_12.15
; !!!
; This section appears to illustrate how a Perl module, in particular,
; one using C code, is built, ready for distribution. The Guile example
; will use the GNU Build system ...
@@INCOMPLETE@@
@@INCOMPLETE@@

;; @@PLEAC@@_12.16
; Possibly the simplest means of documenting Guile code,
; aside, of course, from manually inserting commentary, is
; via the use of "docstrings" in procedure definitions:

    (define (sample-proc)
    "This procedure does this, that, and the other ..."
      ... procedure code ...)

; With the code loaded, the docstring for a procedure may be
; accessed via:

    (procedure-documentation sample-proc)

; Several packages for documenting Scheme / Guile code are
; available, and which may be roughly catergorised as:
;
; * Producing HTML-based documention [ala JavaDoc]
;   http://www.cs.auc.dk/~normark/schemedoc/
;
; * Generating TexInfo source for subsequent processing
;   http://swissnet.ai.mit.edu/~jaffer/Docupage/schmooz.html
;
; Both varieties rely on processing specially-formatted comment
; blocks, or other commen-embedded tags
;

;; @@PLEAC@@_12.17
; The Guile website hosts a libraries / projects page:
;
; http://www.gnu.org/software/guile/gnu-guile-projects.html#Libraries
;
; General installation procedure [assumes *NIX-based system and
; superuser privelages]:
;
; 1. Click on a link, follow download instructions
; 2. tar -zxvf newlibrary-x.y.z.tar.gz
; 3. cd newlibrary-x.y.z
; 4. ./configure
; 5. make
; 6. make check
; 7. make install
;
; A simple, Guile source-only library would simply see source files
; copied to the default Guile modules directory, and any relevant
; documentation installed, whilst a more complex library would also
; see native code libraries built and installed
;
; Notes:
;
; * Libraries may be available in other forms e.g. RPM's, Debian
;   packages, Window's installers or .zips - follow relevant
;   instructions
;
; * A simple, Guile source-only library may be manually copied
;   into the default modules directory or placed into an arbitrary
;   directory and location information passed to the interpreter
;   via environment variables or command-line. For example, for a
;   quick look one could copy relevant module .scm files into
;   the current directory and load them via:
;
;       guile -L ./ -s tester.scm
;

;; @@PLEAC@@_12.18
; The format of a Guile module really is quite simple; it is a
; source file:
;
; * Containing a 'define-module' definition which serves to
;   name the module [the name would match the source file
;   basename (if a single name is used), or the last name
;   in a name list (preceding names are subdirectory names)]
;
; * A list of bindings to be exported, either via individual
;   'define-public' definitions, or via an 'export' list
;
; Documentation is optional [but useful :)], as is any runtime
; accessable data such as version number or author name, or any
; special routines such as a module cleanup routine [just
; 'define-public' whatever variable or procedure you want, and
; adopt a convention for its use]
; 

; module.scm
(define-module (module))

; ---

; Module implementation
(define private-variable "...")

(define (private-procedure arg1 arg2)
  ;; ...
  '())

; ---

; Module interface
(define-public exported-variable "...")

(define-public (exported-procedure arg1 arg2)
  ;; ...
  '())

;; @@PLEAC@@_13.0
;; Guile OOP is in the (oop goops) module (based on CLOS).  All
;; following sections assume you have (oop goops loaded).
(use-modules (oop goops))
(define-class <data-encoder> ())
(define obj (make <data-encoder>))

(define obj #(3 5))
(format #t "~A ~A\n" (class-of obj) (array-ref obj 1))
(change-class v <human-cannibal>) ; has to be defined
(format #t "~A ~A\n" (slot-ref obj stomach) (slot-ref obj name))

(slot-ref obj 'stomach)
(slot-set! obj 'stomach "Empty")
(name obj)
(set! (name obj) "Thag")

;; inheritance
(define-class <lawyer> (<human-cannibal>))

(define lector (make <human-cannibal>))
(feed lector "Zak")
(move lector "New York")

;; @@PLEAC@@_13.1
(define-class <my-class> ()
  (start #:init-form (current-time))
  (age #:init-value 0))

;; classes must have predefined slots, but you could use one as a
;; dictionary:
(define-class <my-class> ()
  (start #:init-form (current-time))
  (age #:init-value 0)
  (properties #:init-value '()))
(define (initialize (m <my-class>) initargs)
  (and-let* ((extra (memq #:extra initargs)))
    (slot-set! m 'properties (cdr extra))))

;; @@PLEAC@@_13.2
;; For smobs (external C objects), you can specify a callback to be
;; performed when the object is garbage collected with the C API
;; function `scm_set_smob_free'.  This solves the problem of cleaning up
;; after external objects and connections.  Guile doesn't use reference
;; count garbage collection, so circular data structures aren't a
;; problem.

;; @@PLEAC@@_13.3
;; either use slot-ref/set!
(slot-ref obj 'name)
(slot-set! obj 'name value)

;; or define the class with accessors
(define-class <my-class> ()
  (name #:accessor name))
(name obj)
(set! (name obj) value)

;; or use getters/setters to implement read/write-only slots
(define-class <my-class> ()
  (name #:getter name)
  (age #:setter age))
(name obj)
(set! (age obj) value)

;; or implement getters/setters manually
(define-method ((setter name) (obj <my-class>) value)
  (cond ((string-match "[^-\\w0-9']" value)
         (warn "funny characters in name"))
        ((string-match "[0-9]" value)
         (warn "numbers in name"))
        ((not (string-match "\\w+\\W+\\w+" value))
         (warn "prefer multiword names"))
        ((not (string-match "\\w" value))
         (warn "name is blank")))
  (slot-set! obj 'name (string-downcase value)))

;; @@PLEAC@@_13.4
;; override the initialize method
(define body-count 0)

(define-method (initialize (obj <person>) initargs)
  (set! body-count (1+ body-count))
  (next-method))

(define people '())
(do ((i 1 (1+ i)))
    ((> i 10))
  (set! people (cons (make <person>) people)))

(format #t "There are ~A people alive.\n" body-count)

(define him (make <person>))
(slot-set! him 'gender "male")

(define her (make <person>))
(slot-set! her 'gender "female")

;; use the :class allocation method
(slot-set! (make <fixed-array>) 'max-bounds 100) ; set for whole class
(define alpha (make <fixed-array>))
(format #t "Bound on alpha is ~D\n" (slot-ref alpha 'max-bounds))
;; 100

(define beta (make <fixed-array>))
(slot-set! beta 'max-bounds 50)          ; still sets for whole class
(format #t "Bound on alpha is ~D\n" (slot-ref alpha 'max-bounds))
;; 50

;; defined simply as
(define-class <fixed-array> ()
  (max-bounds #:init-value 7 #:allocation #:class))

;; @@PLEAC@@_13.5
;; Guile classes are basically structs by definition.  If you don't care
;; about OO programming at all, you can use records, which are portable
;; across most Schemes.  This is, however, an OO chapter so I'll stick
;; to classes.
(define-class <person> () name age peers)

(define p (make <person>))
(slot-set! p 'name "Jason Smythe")
(slot-set! p 'age 13)
(slot-set! p 'peers '("Wilbur" "Ralph" "Fred"))
(format #t "At age ~D, ~A's first friend is ~A.\n"
        (slot-ref p 'age) (slot-ref p 'name) (car (slot-ref p 'peers)))

;; For type-checking and field validation, define the setters
;; accordingly.
(define-class <person> ()
  (name #:accessor name)
  (age #:accessor age))

(define-method ((setter age) (p <person>) a)
  (cond ((not (number? a))
         (warn "age" a "isn't numeric"))
        ((> a 150)
         (warn "age" a "is unreasonable")))
  (slot-set! p 'age a))

(define-class <family> ()
  (head #:init-form (make <person>) #:accessor head)
  (address #:init-value "" #:accessor address)
  (members #:init-value '() #:accessor members))

(define folks (make <family>))

(define dad (head folks))
(set! (name dad) "John")
(set! (age dad) 34)

(format #t "~A's age is ~D\n" (name dad) (age dad))

;; Macros are the usual way to add syntactic sugar

;; For all fields of the same type, let's use _ to mean the slot name in
;; the options expansion.
(define-macro (define-uniform-class name supers slots . options)
  `(define-class ,name ,supers
     ,@(map (lambda (s) (cons s (map (lambda (o) (if (eq? o '_) s o)) options)))
            slots)))

(define-uniform-class <card> (name color cost type release text)
  #:accessor _ #:init-value "")

;; If you *really* wanted to enforce slot types you could use something
;; like the above with the custom setter.  To illustrate reversing
;; normal slot definition args, we'll reverse an init-value:
(define-macro (define-default-class name supers . default&slots)
  `(define-class ,name ,supers
     ,@(map (lambda (d&s) (list (cadr d&s)
                                #:init-value (car d&s)
                                #:accessor (cadr d&s)))
            default&slots)))

(define-default-class hostent ()
  ("" name)
  ('() aliases)
  ("" addrtype)
  (0  length)
  ('() addr-list))

;; Nothing special needed for Aliases - all names are equal
(define type addrtype)
(define-method (addr (h <hostent>))
  (car (addr-list h)))

;; @@PLEAC@@_13.6
;; A little more clear than the Perl, but not very useful.
(define obj1 (make <some-class>))
(define obj2 (make (class-of obj1)))

;; Use the shallow-clone or deep-clone methods to initialize from
;; another instance.
(define obj1 (make <widget>))
(define obj2 (deep-clone obj1))

;; @@PLEAC@@_13.7
;; Use eval or a variant to convert from a symbol or string to the
;; actual method.  As shown in 13.5 above, methods are first class and
;; you'd be more likely to store the actual method than the name in a
;; real Scheme program.
(define methname "flicker")
(apply-generic (eval-string methname) obj 10)

(for-each (lambda (m) (apply-generic obj (eval-string m)))
          '("start" "run" "stop"))

;; really, don't do this...
(define methods '("name" "rank" "serno"))
(define his-info
  (map (lambda (m) (cons m (apply-generic (eval-string m) obj)))
       methods))

;; same as this:
(define his-info (list (cons "name" (name obj))
                       (cons "rank" (rank obj))
                       (cons "serno" (serno obj))))

;; a closure works
(define fnref (lambda args (method obj args)))
(fnref 10 "fred")
(method obj 10 fred)

;; @@PLEAC@@_13.8
;; use is-a?
(is-a? obj <http-message>)
(is-a? <http-response> <http-message>)