(define-structure stdlib
  (export first second third fourth rest
          puts printf
          inc dec
          push pop
          replace exit make-range
          for dotimes time with-open-file expect dolist
          ;; math
          factorial fibonacci
          ;; higher order
          map reduce
          ;; srfi-1
          list-tabulate iota
          zip unzip1 unzip2 unzip3 unzip4 unzip5
          ;; CL
          multiple-value-bind values)

  (open rep)

  (defmacro first (xs)
    `(car ,xs))
  (defmacro second (xs)
    `(cadr ,xs))
  (defmacro third (xs)
    `(caddr ,xs))
  (defmacro fourth (xs)
    `(cadddr ,xs))
  (defmacro rest (xs)
    `(cdr ,xs))

  (defmacro puts (x)
    `(format standard-output "%s\n" ,x))
  (defmacro printf (#!rest args)
    `(format standard-output ,@args))

  (defmacro inc (var)
    `(setq ,var (1+ ,var)))
  (defmacro dec (var)
    `(setq ,var (1- ,var)))

  (defmacro push (value lst)
    `(setq ,lst (cons ,value ,lst)))
  (defmacro pop (lst)
    `(prog1 (car ,lst)
       (setq ,lst (cdr ,lst))))

  (defmacro replace (seq pos val)
    "replace item in sequence SEQ at position POS with value VAL"
    `(rplaca (nthcdr ,pos ,seq) ,val))

  (define (exit #!optional (code 0))
    (throw 'quit code))

  (define (make-range a b)
    (cond ((> a b) nil)
          (t (cons a (make-range (1+ a) b)))))

  (defmacro for (var init final #!rest body)
    (let ((tempvar (make-symbol "max")))
      `(let ((,var ,init)
             (,tempvar ,final))
         (while (<= ,var ,tempvar)
           ,@body
           (inc ,var)))))

  (defmacro dotimes (var final #!rest body)
    (let ((tmp (make-symbol "max")))
      `(let ((,var 0)
             (,tmp ,final))
         (while (< ,var ,tmp)
           ,@body
           (inc ,var)))))

  (defmacro time (#!rest body)
    `(let ((start (current-utime)) end)
       ,@body
       (setq end (current-utime))
       (puts (/ (- end start) 1000000.0))))

  (defmacro with-open-file (var name #!rest body)
    `(let ((,var (open-file ,name 'read)))
       ,@body
       (close-file ,var)))

  (defmacro expect (expected actual)
    `(let ((result ,actual))
       (or (equal ,expected result)
           (printf "* expected %s, but got %s from %s\n"
                   ,expected result ',actual))))

  (defmacro dolist (spec #!rest body)
    "(dolist (VAR LIST) BODY...): loop over a list, each car bound to VAR"
    `(mapc (lambda (,(car spec)) ,@body)
           ,(cadr spec)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; math
  (define (factorial n)
    (define (factorial+ n accum)
      (if (<= n 1)
          accum
        (factorial+ (- n 1) (* accum n))))
    (factorial+ n 1))

  (define (fibonacci n)
    "from mupad: expose(numlib::fibonacci)"
    (cond ((= n 0) 0)
          ((= n 1) 1)
          (t (let ((x 1) (y 0) (z 1) (a 1) (b 1) (c 0) Z C)
               (while (> n 1)
                 (if (= (mod n 2) 1)
                     (setq Z (+ (* y b) (* z c))
                           y (+ (* x b) (* y c))
                           z Z
                           x (+ y z)))
                 (setq C (+ (* b b) (* c c))
                       b (* (+ a c) b)
                       c C
                       a (+ b c)
                       n (quotient n 2)))
               (+ (* x b) (* y c))))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; higher order
  (define (map fn first #!rest rest)
    (if rest
        (apply map2+ fn first rest)
      (apply map1 fn first rest)))

  (define (map1 fn xs)
    (cond ((null xs) nil)
          (t (cons (fn (first xs)) (map1 fn (rest xs))))))

  (define (map2+ fn #!rest lists)
    (cond ((memq nil lists) nil)
          (t (cons (apply fn (map1 car lists))
                   (apply map2+ fn (map1 cdr lists))))))

  ;; generalized reduce SICP 2.2.3 (calls this 'accumulate')
  ;; (reduce '+ 0 '(1 2 3 4 5)) => 15
  (define (reduce op initial sequence)
    (if (null sequence)
        initial
      (op (first sequence)
          (reduce op initial (rest sequence)))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; srfi-1 (from scheme48, gauche)
  ;;(define (xcons d a) (cons a d))

  ;; recursive tree-copy, built-in as `copy-sequence'
  ;;(define (tree-copy x)
  ;;  (let recur ((x x))
  ;;       (if (not (consp x)) x
  ;;         (cons (recur (car x)) (recur (cdr x))))))

  (define (list-tabulate len proc)
    "Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN."
    (do ((i (- len 1) (- i 1))
         (ans '() (cons (proc i) ans)))
        ((< i 0) ans)))

  (define (iota count . maybe-start+step)
    "IOTA count [start step] -> (start start+step ... start+(count-1)*step)"
    (if (< count 0) (error "Negative step count" iota count))
    (multiple-value-bind (start step)
        (case (length maybe-start+step)
          ((0) (values 0 1))
          ((2) (values (car maybe-start+step)
                       (cadr maybe-start+step)))
          (t
           (error "wrong number of arguments to IOTA"
                  (cons count maybe-start+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)))))

  (define (zip list1 . more-lists) (apply map list list1 more-lists))

  (define (unzip1 lis) (map car lis))

  (define (unzip2 lis)
    (let recur ((lis lis))
         (if (null lis) (values lis lis)
           (let ((elt (car lis)))
             (multiple-value-bind (a b) (recur (cdr lis))
               (values (cons (car  elt) a)
                       (cons (cadr elt) b)))))))

  (define (unzip3 lis)
    (let recur ((lis lis))
         (if (null lis) (values lis lis lis)
           (let ((elt (car lis)))
             (multiple-value-bind (a b c) (recur (cdr lis))
               (values (cons (car   elt) a)
                       (cons (cadr  elt) b)
                       (cons (caddr elt) c)))))))

  (define (unzip4 lis)
    (let recur ((lis lis))
         (if (null lis) (values lis lis lis lis)
           (let ((elt (car lis)))
             (multiple-value-bind (a b c d) (recur (cdr lis))
               (values (cons (car    elt) a)
                       (cons (cadr   elt) b)
                       (cons (caddr  elt) c)
                       (cons (cadddr elt) d)))))))

  (define (unzip5 lis)
    (let recur ((lis lis))
         (if (null lis) (values lis lis lis lis lis)
           (let ((elt (car lis)))
             (multiple-value-bind (a b c d e) (recur (cdr lis))
               (values (cons (car     elt) a)
                       (cons (cadr    elt) b)
                       (cons (caddr   elt) c)
                       (cons (cadddr  elt) d)
                       (cons (car (cddddr  elt)) e)))))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; CL
  ;; FIXME passing a lamda for form does not work
  ;;(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return
  ;;values.  FORM must return a list; the BODY is then executed with the
  ;;first N elements of this list bound (`let'-style) to each of the
  ;;symbols SYM in turn.  This is analogous to the Common Lisp
  ;;`multiple-value-bind' macro, using lists to simulate true multiple
  ;;return values.  For compatibility, (values A B C) is a synonym for
  ;;(list A B C).
  (defmacro multiple-value-bind (vars form #!rest body)
    "(multiple-value-bind (SYM SYM...) FORM BODY)"
    (let ((temp (gensym)) (n -1))
      (list* 'let* (cons (list temp form)
                         (mapcar (lambda (v)
                                   (list v (list 'nth (setq n (1+ n)) temp)))
                                 vars))
             body)))

  (define values list))