(require 'stdlib)

(define (make-account)
  (let ((balance 0))
    (define (get-balance)
      balance)
    (define (deposit amount)
      (setq balance (+ balance amount))
      balance)
    (define (withdraw amount)
      (deposit (- amount)))
     
    (lambda args                        ; no parens == #!rest ??
      (apply
       (case (car args)
         ((get-balance) get-balance)
         ((deposit) deposit)
         ((withdraw) withdraw)
         (else (error "Invalid method!")))
       (cdr args)))))

(define x (make-account))
;(x 'deposit 200)

;; ----------------------------------------------------------------------
;(defun bytes-to-int (bytearr start end)
;  "Convert the bits of a byte array to an integer"
;  (reduce (lambda (x y) (+ (* 256 x) y)) bytearr :start start :end end))

;; bytes are in lsb->msb order? (so #x1234 == #x34 #x12)
;;(defun bytes-to-int (bytes)
;;  "Convert the bits of a byte array to an integer"
;;  (reduce (lambda (x y) (+ (* 256 x) y)) 0 bytes))

; or:
(define null? null)

(define (fold kons knil list1 . rest)
  (if (null? rest)
      (let f ((knil knil) (list1 list1))
	(if (null? list1)
	    knil
	    (f (kons (car list1) knil) (cdr list1))))
      (let f ((knil knil) (lists (cons list1 rest)))
	(if (any null? lists)
	    knil
	    (let ((cars (map1 car lists))
		  (cdrs (map1 cdr lists)))
	      (f (apply kons (append! cars (list knil))) cdrs))))))

(define (reduce f ridentity lst)
  (fold f ridentity lst))

;;(define (bytes-to-i bytes)
;;  (fold (lambda (x y) (logior (ash x 8) y)) 0 bytes))

;;(define (bytes-to-int bytes)
;;  (cond ((null bytes) 0)
;;        (t (logior (ash (car bytes) 8) (bytes-to-int (cdr bytes))))))

;;(define (bytes-to-int bytes)
;;  (when (cdr bytes)
;;    (logior (ash (car bytes) 8) (bytes-to-int (cdr bytes)))))

;; iterative version
(define (bytes-to-int-iter bytes)
  (let ((result 0))
    (while bytes
      (setq result (logior (ash result 8) (car bytes)))
      (setq bytes (cdr bytes)))
    result))

;; tail-recursive version using accumulator
(define (bytes-to-int bytes)
  (define (bti bytes accum)
    (if bytes
        (bti (cdr bytes) (logior (ash accum 8) (car bytes)))
      accum))
  (bti bytes 0))

;;(dolist (b '(() (1) (0 1) (1 0) (#xff #xff) (1 0 0 0 0)))
;;  (puts (list (bytes-to-int-iter b) (bytes-to-int b))))

;; ----------------------------------------------------------------------
;; lambda calculus
;;(define true (lambda (x) (lambda (y) x)))
;;(define false (lambda (x) (lambda (y) y)))
;;(define if (lambda (condition
;;		(lambda (true-part)
;;			(lambda (false-part)
;;				<fill in the blank>)))))

;;--pair is cons, first is car, second is cdr
;;(define pair (lambda (f)
;;		(lambda (s)
;;		    (lambda (selector)
;;<write an expression here with no lambdas using the above
;;  definitions so that  pair f s true  is f  and pair f s false is
;;     s>))))

;;(define first <fill in the blank using only one lambda>)
;;(define second <fill in the blank using only one lambda>)

;; ----------------------------------------------------------------------
;; from HTDP
;; simple iota, non-tail-recursive (cons is last call)
(define (tabulate n f)
  (cond ((< n 0) nil)
        (t (cons (f n) (tabulate (1- n) f)))))

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

;;(tabulate 10 double)

;; same as fold
(define (reduce base f ls)
  (cond ((null ls) base)
        (t (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))
          (t (cond ((< an (car alon)) (cons an alon))
                   (t (cons (car alon) (insert an (cdr alon))))))))
  (reduce '() insert l))

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

;; ----------------------------------------------------------------------
;; tail-recursive make-range
(define (make-range a b)
  (define (make-range+ p q accum)
    (cond ((> p q) accum)
          (t (make-range+ (1+ p) q (cons p accum)))))
  (reverse (make-range+ a b '())))

;; without reverse, count b down, instead of a up
(define (make-range a b)
  (define (make-range+ p q accum)
    (cond ((< q p) accum)
          (t (make-range+ p (1- q) (cons q accum)))))
  (or (<= a b)
      (error "make-range: a > b"))
  (make-range+ a b '()))

;; non-recursive, using do
(define (make-range a b)
  (do ((count (- b a) (1- count))
       (value b (1- value))
       (result '() (cons value result)))
      ((< count 0) result)))

;; length using do, again without a body
(define (length sequence)
  (do ((result 0 (1+ result))
       (tail sequence (rest tail)))
      ((null tail) result)))

;; tail-recursive length
(define (length sequence)
  (define (length+ sequence accum)
    (cond ((null sequence) accum)
          (t (length+ (rest sequence) (1+ accum)))))
  (length+ sequence 0))

;; ----------------------------------------------------------------------
;; SRFI stuff
;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN.
(define (list-tabulate len proc)
  ;;(check-arg (lambda (n) (and (integer? n) (>= n 0))) len)
  ;;(check-arg procedure? proc)
  (do ((i (- len 1) (- i 1))
       (ans '() (cons (proc i) ans)))
      ((< i 0) ans)))

;; IOTA count [start step] (start start+step ... start+(count-1)*step)
(define (iota count . args)
  ;;(check-arg integer? count)
  (if (< count 0) (error "Negative step count" iota count))
  (let ((start (if (consp args) (car args) 0))
        (step  (if (and (consp args) (consp (cdr args))) (cadr args) 1)))
    ;;(check-arg number? start)
    ;;(check-arg number? step)
    (let ((last-val (+ start (* (- count 1) step))))
      (do ((count count (- count 1))
	   (val last-val (- val step))
	   (ans '() (cons val ans)))
	  ((<= count 0)  ans)))))

;; ----------------------------------------------------------------------
;; let is syntactic sugar for lambda
(let ((x 2) (y 3))
  (* x y))
;; is the same as
(lambda (x y)
  (* x y)
  2
  3)

;; ----------------------------------------------------------------------
(define (make-pairs ls)
  (define (pair? el)
    (and (car el) (cadr el)))
  (define (make-pairs+ ls accum)
    (cond ((null ls) accum)
          (t (make-pairs+ (cddr ls)
                          (cons (list (car ls) (cadr ls)) accum)))))
  (reverse (make-pairs+ ls nil)))

;; ----------------------------------------------------------------------
;; defining constants:
;;
;;         #define EOI     0       /* end of input         */
;;         #define SEMI    1       /* ;                    */
;;         #define PLUS    2       /* +                    */
;; 
;; I've translated this as
;; 
;;         (defconstant EOI        0       "End of input")
;;         (defconstant SEMI       1       ";")
;;         (defconstant PLUS       2       "+")
;;

;; CL
(defmacro define-constant-symbols (&rest forms)
  `(progn
     ,@(mapcar #'(lambda (form)
                   (etypecase form
                     (cons (let ((symbol (first form))
                                 (docstring (when (second form)
                                              (list (second form)))))
                             `(defconstant ,symbol ,symbol ,@docstring)))
                     (symbol `(defconstant ,symbol ,symbol))))
               forms)))

(define-constant-symbols
  (EOI "End of input")
  (SEMI ";")
  (PLUS "+")
  BLAH)

;; ----------------------------------------------------------------------
;; heavy consing
(define (cons-me-harder n)
  (do ((s (make-range 1 125))
       (i 0 (1+ i)))
      ((= i n))
    (setq s (reverse s))))

;; ----------------------------------------------------------------------
;; setf implementation
(defmacro setf (place value)
  (cond ((symbolp place)
         `(setq ,place ,value))
        ((memq (first place) '(car first))
         `(rplaca ,(second place) ,value))
        ((memq (first place) '(cadr second))
         `(rplaca (nthcdr 1 ,(second place)) ,value))
        ((memq (first place) '(caddr third))
         `(rplaca (nthcdr 2 ,(second place)) ,value))
        ((memq (first place) '(cdr rest))
         `(rplacd ,(second place) ,value))
        ((eq (first place) 'nth)
         `(rplaca (nthcdr ,(second place) ,(third place)) ,value))
        ((eq (first place) 'nthcdr)
         `(rplacd (nthcdr ,(second place) ,(third place)) ,value))
        ((eq (first place) 'last)
         `(rplaca (nthcdr (1- (length ,(second place))) ,(second place))
                  ,value))
        (t `(error "setf: flabbergasted by `%s'" ',(first place)))))

;; evaluates place twice, tricky...
(defmacro incf (place #!optional (amount 1))
  `(setf ,place (+ ,place ,amount)))

;; tests
(let ((x 0))
  (setf x 42)
  (expect 42 x))

(let ((x '(foo 2 3)))
  (setf (first x) 1)
  (expect '(1 2 3) x))

(let ((x '(1 foo 3)))
  (setf (second x) 2)
  (expect '(1 2 3) x))

(let ((x '(1 2 foo)))
  (setf (third x) 3)
  (expect '(1 2 3) x))

(let ((x '(1 foo)))
  (setf (rest x) '(2 3))
  (expect '(1 2 3) x))

(let ((x '(1 2 foo)))
  (setf (nth 2 x) 3)
  (expect '(1 2 3) x))

(let ((x '(1 2 foo)))
  (setf (nthcdr 1 x) '(3))
  (expect '(1 2 3) x))

(let ((x '(1 2 foo)))
  (setf (last x) 3)
  (expect '(1 2 3) x))