;; $Id: stdlib.jl,v 1.9 2002/11/05 09:08:48 michelv Exp $
;; gauche/scheme version of stdlib.jl

;; TODO look at srfi-0, which provides a way to handle different
;; scheme implementations

(define-module stdlib
  (export first second third fourth rest
          float
          puts printf
          inc dec
          push pop
          replace
          make-range
          fac fibonacci
          curry map filter reduce
          for dotimes time with-open-file dolist))

(select-module stdlib)

(define-macro (first xs) `(car ,xs))
(define-macro (second xs) `(cadr ,xs))
(define-macro (third xs) `(caddr ,xs))
(define-macro (fourth xs) `(cadddr ,xs))
(define-macro (rest xs) `(cdr ,xs))

(define-macro (inc var) `(set! ,var (+ ,var 1)))
(define-macro (dec var) `(set! ,var (- ,var 1)))

(define-macro (push value lst)
  `(set! ,lst (cons ,value ,lst)))
;; FIXME 'invalid binding form'
(define-macro (pop lst)
  `(let (result (car ,lst))
     (set! ,lst (cdr ,lst))
     result))

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

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

;; factorial using tail recursion
(define (fac n)
  (define (fac/internal n acc)
    (if (<= n 1)
        acc
        (fac/internal (- n 1) (* acc n))))
  (fac/internal n 1))

;; from mupad: 'expose(numlib::fibonacci)'
; (define (fibonacci n)
;   (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)
;                         (set! Z (+ (* y b) (* z c))
;                               y (+ (* x b) (* y c))
;                               z Z
;                               x (+ y z)))
;                     (set! C (+ (* b b) (* c c))
;                           b (* (+ a c) b)
;                           c C
;                           a (+ b c)
;                           n (quotient n 2)))
;              (+ (* x b) (* y c))))))

(define (curry function . args)
  (lambda more-args
    (apply function (append args more-args))))

(define (map fn first . lists)
  (if rest
      (apply map2+ fn first lists)
      (apply map1 fn first)))

(define (map1 fn xs)
  (cond ((null? xs) ())
        (else (cons (fn (first xs)) (map1 fn (rest xs))))))

(define (map2+ fn . lists)
  (cond ((memq () lists) ())
        (else (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)))))

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

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

; (define-macro (time #!rest body)
;   `(let ((start (current-utime)) end)
;      ,@body
;      (set! end (current-utime))
;      (puts (/ (- end start) 1000000.0))))

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

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

(provide "stdlib")