(define (fac n)
  (if (< n 2)
      1
      (* n (fac (- n 1)))))

;;(do ((i 0 (1+ i)))
;;    ((= i 10))
;;  (display (fac i))
;;  (display "\n"))

;; from guile.info: shared variable
(define get-balance #f)
(define deposit #f)
(let ((balance 0))
  (set! get-balance
        (lambda ()
          balance))
  (set! deposit
        (lambda (amount)
          (set! balance (+ balance amount))
          balance)))

(define (withdraw amount)
  (deposit (- amount)))

;; TODO write a macro to expand this into equivalent code:
;;(define-closure
;;  (closure-variables balance)
;;  (closure-functions
;;   (get-balance () balance)
;;   (deposit (amount) (set! balance (+ balance amount)))
;;   (withdraw (amount) (deposit (- amount)))))


;; from guile.info: OO closure
(define (make-account)
  (let ((balance 0))
    (define (get-balance)
      balance)
    (define (deposit amount)
      (set! balance (+ balance amount))
      balance)
    (define (withdraw amount)
      (deposit (- amount)))
    
    (lambda args
      (apply
       (case (car args)
         ((get-balance) get-balance)
         ((deposit) deposit)
         ((withdraw) withdraw)
         (else (error "Invalid method!")))
       (cdr args)))))

;; ----------------------------------------------------------------------
;; from HTDP
;; simple iota, result is reversed
(define (tabulate n f)
  (cond ((< n 0) ())
        (else (cons (f n) (tabulate (- n 1) f)))))

(define (double x)
  (* 2 x))

;;(tabulate 10 double)

;; same as fold
(define (reduce base f ls)
  (cond ((null? ls) base)
        (else (reduce (f (car ls) base) f (cdr ls)))))

;; sort : (listof number) -> (listof number)
(define (sort. l)
  (define (insert an alon)
    (cond ((null? alon) (list an))
          (else (cond ((< an (car alon)) (cons an alon))
                      (else (cons (car alon) (insert an (cdr alon))))))))
  (reduce '() insert l))

;;(sort. '(6 4 7 8 3 5 5 6 7 2))

(define (make-range a b)
  (define (make-range+ p q accum)
    (cond ((< q p) accum)
          (else (make-range+ p (1- q) (cons q accum)))))
  (or (<= a b)
      (error "make-range: a > b"))
  (trace make-range+)
  (make-range+ a b '()))

;; ----------------------------------------------------------------------
;; guile/pipes
(use-modules (ice-9 popen))

(let ((p (open-input-pipe "date"))
      (line nil))
  (while (set! line (read-line p))
         (display line)))

(do ((p (open-input-pipe "ls"))
     (line nil (read-line p)))
    ((eof-object? line) 'done)
  (display line)
  (display ", "))

;; ----------------------------------------------------------------------
;; examples from TSPL

;; lazy evaluation
(define lazy
  (lambda (t)
    (let ((val #f) (flag #f))
      (lambda ()
        (if (not flag)
            (begin (set! val (t))
                   (set! flag #t)))
        val))))

(define p
  (lazy (lambda ()
          (display "Ouch!")
          (newline)
          "got me")))

;; call/cc
(define call/cc call-with-current-continuation) ; for scheme48

(define product
  (lambda (ls)
    (call/cc
     (lambda (break)
       (let f ((ls ls))
         (cond
          ((null? ls) 1)
          ((= (car ls) 0) (break 0))    ; invoke 'break' continuation
          (else (* (car ls) (f (cdr ls))))))))))

(product '(1 2 3 4 5))
(product '(7 3 8 0 1 9 5))

;; grok this one:
(((call/cc (lambda (k) k)) (lambda (x) x)) "hey!")

;; ----------------------------------------------------------------------
;; from Kent Pitman's PS: Lisp as a Vehicle for Rapid Prototyping

;; Higher Order Functions

;; Another feature of Lisp which supports delayed decision-making is
;; procedural abstraction--the ability to pass functions as arguments to
;; other functions. Through this technique, a certain decision may be delayed
;; until a later time in development. For example, a simple but
;; general-purpose data browsing tool might look like:

;; (DEFUN BROWSE-LOOP (ITEMS DISPLAYER COMMAND-READER PROCESSOR)
;;   (LOOP (DOLIST (ITEM ITEMS) (FUNCALL DISPLAYER ITEM))
;;         (SETQ ITEMS (FUNCALL PROCESSOR (FUNCALL COMMAND-READER) ITEMS))))

;; This program acknowledges a general theory of browsing; that is, that a
;; set of items is presented, then an opportunity is offered to operate on
;; that set, and then the process begins anew (perhaps with the same items,
;; perhaps with some new set of items). This can be done in advance of
;; knowing the details of how items will be displayed or how commands will be
;; read and processed.

;; The flexibility provided by this paradigm means that programs don't have
;; to change as often because assumptions are not built into every part of
;; the code. Or if they do have to change, they might do so in localized
;; places; for example, only in BROWSE-LOOP and not its callers, or vice
;; versa.

;; scheme version:
(define (browse-loop items displayer command-reader processor)
  (do () (#f)                           ; forever
    (map (lambda (item) (displayer item)) items)
    (set! items (processor (command-reader) items))))

(define items '(aap noot mies))

(define (displayer item)
  (display (list "item" item))
  (newline))

(define (command-reader)
  (display "command > ")
  (read))

(define (processor command items)
  (display (list "apply" command "to" items))
  (newline)
  (case (car command)
    ((add) (append items (list (cadr command))))
    (else items)))

(browse-loop items displayer command-reader processor)

;; ----------------------------------------------------------------------
;; examples from Petite Chez Scheme

;;; fatfib.ss
;;; this is "fat" because it uses only increments and decrements
;;; for addition and subtraction (i.e., peano arithmetic).
;;; note that fat+ is tail-recursive; this is how all looping is
;;; performed in Scheme.

(define fat+
   (lambda (x y)
      (if (zero? y)
          x
          (fat+ (1+ x) (1- y)))))

(define fatfib
   (lambda (x)
      (if (< x 2)
          1
          (fat+ (fatfib (1- x)) (fatfib (1- (1- x)))))))

;; fft.ss
(define (dft x)
  (define (w-powers n)
    (let ((pi (* (acos 0.0) 2)))
      (let ((delta (/ (* -2.0i pi) n)))
        (let f ((n n) (x 0.0))
          (if (= n 0)
              '()
              (cons (exp x) (f (- n 2) (+ x delta))))))))
  (define (evens w)
    (if (null? w)
        '()
        (cons (car w) (evens (cddr w)))))
  (define (interlace x y)
    (if (null? x)
        '()
        (cons (car x) (cons (car y) (interlace (cdr x) (cdr y))))))
  (define (split ls)
    (let split ((fast ls) (slow ls))
      (if (null? fast)
          (values '() slow)
          (call-with-values
            (lambda () (split (cddr fast) (cdr slow)))
            (lambda (front back)
              (values (cons (car slow) front) back))))))
  (define (butterfly x w)
    (call-with-values
      (lambda () (split x))
      (lambda (front back)
        (values
          (map + front back)
          (map * (map - front back) w)))))
  (define (rfft x w)
    (if (null? (cddr x))
      (let ((x0 (car x)) (x1 (cadr x)))
        (list (+ x0 x1) (- x0 x1)))
      (call-with-values
        (lambda () (butterfly x w))
        (lambda (front back)
          (let ((w (evens w)))
            (interlace (rfft front w) (rfft back w)))))))
  (rfft x (w-powers (length x))))

;; object.ss
;;; define-object creates an object constructor that uses let* to bind
;;; local fields and letrec to define the exported procedures.  An
;;; object is itself a procedure that accepts messages corresponding
;;; to the names of the exported procedures.  The second pattern is
;;; used to allow the set of local fields to be omitted.
(define-syntax define-object
  (syntax-rules ()
    ((_ (name . varlist)
        ((var1 val1) ...)
        ((var2 val2) ...))
     (define name
       (lambda varlist
         (let* ((var1 val1) ...)
           (letrec ((var2 val2) ...)
             (lambda (msg . args)
               (case msg
                 ((var2) (apply var2 args)) ...
                 (else
                  (error 'name "invalid message ~s"
                     (cons msg args))))))))))
    ((_ (name . varlist)
        ((var2 val2) ...))
     (define-object (name . varlist)
       ()
       ((var2 val2) ...)))))

;;; send-message abstracts the act of sending a message from the act
;;; of applying a procedure and allows the message to be unquoted.
(define-syntax send-message
  (syntax-rules ()
    ((_ obj msg arg ...)
     (obj 'msg arg ...))))

;; power.ss
;;; doubly recursive power (expt) function
(define power
   (lambda (x n)
      (cond
         [(= n 0) 1]
         [(= n 1) x]
         [else
          (let ([q (quotient n 2)])
             (* (power x q) (power x (- n q))))])))

;;; queue
;;; an abstract datatype

;;; operations:
;;;    (queue)           ;create a queue object

;;;    if 'q' is a queue object:

;;;    (q 'type?)        ;return the type (queue), useful if there are other
;;;                      ;abstract datatypes floating around.
;;;    (q 'empty?)       ;returns true iff q is empty
;;;    (q 'put val)      ;adds val to end of q; returns val
;;;    (q 'get)          ;removes first element of q and returns it

;;; Examples

;;;    (define! q (queue))
;;;    (q 'type?)             => queue
;;;    (q 'empty?)            => #!true
;;;    (q 'put 3)
;;;    (q 'put 4)
;;;    (q 'put 5)
;;;    (q 'empty?)            => ()
;;;    (q 'get)               => 3
;;;    (q 'get)               => 4
;;;    (q 'put 7)
;;;    (q 'get)               => 5
;;;    (q 'get)               => 7
;;;    (q 'empty?)            => #!true

(define queue
   (lambda ()
      (let ([head '()] [tail '()])
         (lambda (request . args)
            (case request
               [type? 'queue]
               [empty? (null? head)]
               [put
                (let ([v (car args)])
                   (if (null? head)
                       (let ([p (cons v '())])
                          (set! tail p)
                          (set! head p))
                       (let ([quebit (cons v '())])
                          (set-cdr! tail quebit)
                          (set! tail quebit)))
                   v)]
               [get
                (if (null? head)
                    (error 'queue "queue is empty")
                    (let ([v (car head)])
                       (set! head (cdr head))
                       (when (null? head) (set! tail '()))
                       v))]
               [else
                (error 'queue "~s is not a valid request" request)])))))

;;; scons.ss (see also: SICP 3.5)
;;; a stream-construction facility

;;; The scons special form performs a cons, suspending the cdr field
;;; by enclosing it in a procedure of no arguments.  scdr tests to see
;;; if the cdr is a procedure, and if so, invokes it.  scar is provided
;;; for symmetry; it is just car.

;;; The function stream-ref is simply list-ref defined in terms of
;;; scdr and scar.

;;; factlist and fiblist are two infinite streams.
;;; Try (stream-ref factlist 10) or (stream-ref fiblist 20).

;;; scons could easily suspend the car field as well.  This would
;;; implement the lazy cons of Friedman & Wise.

(define-syntax scons
  (syntax-rules ()
    ((_ car cdr) (cons car (lambda () cdr)))))

(define scar car)

(define scdr
   (lambda (x)
      (when (procedure? (cdr x)) (set-cdr! x ((cdr x))))
      (cdr x)))

(define stream-ref
   (lambda (x n)
      (if (zero? n)
          (scar x)
          (stream-ref (scdr x) (- n 1)))))

(define factlist
   (let fact ((a 1) (n 1))
      (scons a (fact (* a n) (+ n 1)))))

(define fiblist
   (let fib ((fib-2 0) (fib-1 1))
      (scons fib-1 (fib fib-1 (+ fib-2 fib-1)))))

(print (stream-ref factlist 10))
(print (stream-ref fiblist 10))

;; ----------------------------------------------------------------------
;; iterative procedures for common operations
(define (length. sequence)
  (do ((result 0 (+ result 1))
       (tail sequence (cdr tail)))
      ((null? tail) result)))

(define factorial
  (lambda (n)
    (do ((i n (- i 1)) (a 1 (* a i)))
        ((zero? i) a))))

;; implicit tail recursive factorial
(define (factorial n)
  (let loop ((n n) (acc 1))
    (cond
     ((< n 2) acc)
     (else (loop (- n 1) (* n acc))))))

(define fibonacci
  (lambda (n)
    (if (= n 0)
        0
        (do ((i n (- i 1)) (a1 1 (+ a1 a2)) (a2 0 a1))
            ((= i 1) a1)))))

;; -----------------------------------------------------------------
;; embedded state
(define counter
  (let1 i 0
    (lambda ()
      (inc! i)
      i)))

(print (list (counter) (counter) (counter)))

;; -----------------------------------------------------------------
;; peek
(use gauche.macroutil)                  ; xmac

(define (peek/f . form)
  "print the form, and return its result"
  (format #t ";; ~s\n" form)
  (car (last-pair form)))

(define-macro (peek forms)
  (format #t ";; ~s\n" forms)
  forms)

(format #t "~s\n" (peek (* 2 3)))
(peek 'lala (+ 1 2))

;; -----------------------------------------------------------------
;; number crunching example
(let* ((a (vector (vector 1.0 0.0) (vector 0.0 1.0)))
       (b (vector (vector 1.0 0.0) (vector 0.0 1.0)))
       (c (vector (make-vector 2) (make-vector 2)))
       (rows-a (vector-length a))
       (cols-b (vector-length (vector-ref b 0)))
       (cols-a (vector-length (vector-ref a 0))))
  (do ((i 0 (+ i 1))) ((>= i rows-a))
    (do ((j 0 (+ j 1))) ((>= j cols-b))
      (vector-set! (vector-ref c i) j 0.0)
      (do ((k 0 (+ k 1))) ((>= k cols-a))
        (vector-set! (vector-ref c i) j
                     (+ (vector-ref (vector-ref c i) j)
                        (* (vector-ref (vector-ref a i) k)
                           (vector-ref (vector-ref b k) j))))))))

;; -----------------------------------------------------------------
;; simple reader
(call-with-input-file "z.scm"
  (lambda (port)
    (do ((expr (read port) (read port)))
        ((eof-object? expr))
      (format #t "~s\n" expr))))

;; alternate with tail recursion
(call-with-input-file "z.scm"
  (lambda (port)
    (let loop ((expr (read port)))
      (unless (eof-object? expr)
        (print expr)
        (loop (read port))))))

;; generalised
(define (read-with-reader reader file proc)
  "call proc for each sexp in file"
  (call-with-input-file file
    (lambda (port)
      (let loop ((expr (reader port)))
      (unless (eof-object? expr)
        (proc expr)
        (loop (reader port)))))))

(define (read-sexps file proc)
  (read-with-reader read file proc))
(define (read-lines file proc)
  (read-with-reader read-line file proc))

(define (file-transformer proc file)
  (call-with-input-file file
    (lambda (port)
      (proc port))))

(define (file->string file)
  (file-transformer port->string file))
(define (file->string-list file)
  (file-transformer port->string-list file))
(define (file->sexp-list file)
  (file-transformer port->sexp-list file))

;; or simply:
(call-with-input-file "test.out" port->string)

;; from portutil.scm:

;; port->something
;;   TODO: allow caller to specify reading units
(define (port->string port)
  (let ((out (open-output-string)))
    (%with-port-locking port
      (lambda ()
        (%with-port-locking out
          (lambda ()
            (let loop ((ch (%read-char-unsafe port)))
              (unless (eof-object? ch)
                (%write-char-unsafe ch out)
                (loop (%read-char-unsafe port))))
            (get-output-string out)))))))

(define (port->list reader port)
  (let loop ((obj (reader port))
             (result '()))
    (if (eof-object? obj)
        (reverse! result)
        (loop (reader port) (cons obj result)))))

(define (port->string-list port)
  (port->list read-line port))

(define (port->sexp-list port)
  (port->list read port))

;; file->string, file->list, file->string-list, file->sexp-list
;; shortcuts of port->string, port->list, port->string-list adn port->sexp-list

;; NB: this doesn't work well with gauche.charconv.  Redefinition of
;; call-with-input-file isn't reflected to these definitions.

;(define (file->string file . opts)
;  (apply call-with-input-file file port->string opts))

;(define (file->list reader file . opts)
;  (apply call-with-input-file file (pa$ port->list reader) opts))

;(define (file->string-list file . opts)
;  (apply call-with-input-file file (pa$ port->list read-line) opts))

;(define (file->sexp-list file . opts)
;  (apply call-with-input-file file (pa$ port->list read) opts))

;; -----------------------------------------------------------------
;; translate a symbol to an instruction
(define (ins1 x)
  (* x x))

(define (ins2 x)
  (+ x x))

(define (make-instruction name)
  (lambda (value)
    (apply
     (case name
       ((ins1) ins1)
       ((ins2) ins2))
     value)))

(define (symbol->function name)
  (case name
    ((ins1) ins1)
    ((ins2) ins2)))

;; alternate approach
(define (a) (print "a"))
(define (b) (print "b"))

;; type I: quote the program, needs a helper function with 'eval'...
(define program '(a a b))

(define (symbol-value . args)
  (let-optionals* args (name (module (current-module)))
      (eval name module)))

(define (execute p)
  (for-each (lambda (ins)
              (apply (symbol-value ins) '()))
            p))

;; type II: evaluate inline directly
(define program (list a a b))

(define (execute p)
  (for-each (lambda (ins)
              (apply ins '()))
            p))

;; -----------------------------------------------------------------
;; f1, f2 and f3 all disassemble into the same bytecode
(use gauche.vm.disasm)

(define (f1 x)
  (define (f1-aux x)
    (* x x))
  (f1-aux (+ x 1)))

(define (f2 x)
  (let ((f1-aux (lambda (x)
                  (* x x))))
    (f1-aux (+ x 1))))

(define f3 (lambda (x)
             (let ((f1-aux (lambda (x)
                             (* x x))))
               (f1-aux (+ x 1)))))

;; -----------------------------------------------------------------
;; continuations

;; If you really want to see some strangeness, Alan Bawden, a person
;; generally known as Al* Petrofsky, and others have done some very
;; interesting work on the interactions between call/cc and letrec.
;; For example, try figuring out what this does and why (courtesy of
;; Al):

(letrec ((x (call/cc list)) (y (call/cc list)))
  (if (procedure? x) (x (pair? y)))
  (if (procedure? y) (y (pair? x)))
  (let ((x-cont (car x)) (y-cont (car y)))
    (and (call/cc x-cont) (call/cc y-cont) (call/cc x-cont))))