;;;
;;; Copyright 2009-2014 Yuichiro Moriguchi
;;; 
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;; 
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;; 
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

; syntax
(define-syntax and
  (syntax-rules ()
    ((_) #t)
    ((_ e1) e1)
    ((_ e1 e2 ...) (if e1 (and e2 ...) #f))))

(define-syntax or
  (syntax-rules ()
    ((_) #f)
    ((_ e1) e1)
    ((_ e1 e2 ...)
       (let ((x e1))
         (if x x (or e2 ...))))))

(define-syntax cond
  (syntax-rules (else =>)
    ((_ (else r1 r2 ...)) (begin r1 r2 ...))
    ((_ (cd => r1))
      (let ((tm cd)) (if tm (r1 tm))))
    ((_ (cd => r1) c1 c2 ...)
      (let ((tm cd))
        (if tm
            (r1 tm)
            (cond c1 c2 ...))))
    ((_ (cd)) test)
    ((_ (cd) c1 c2 ...)
      (let ((tm cd))
        (if tm tm (cond c1 c2 ...))))
    ((_ (cd r1 r2 ...))
      (if cd (begin r1 r2 ...)))
    ((_ (cd r1 r2 ...) c1 c2 ...)
      (if cd
          (begin r1 r2 ...)
          (cond c1 c2 ...)))))

(define-syntax case
  (syntax-rules (else)
    ((case (key ...) cs ...)
      (let ((ak (key ...)))
        (case ak cs ...)))
    ((case key (else r1 ...)) (begin r1 ...))
    ((case key ((atoms ...) r1 ...))
      (if (memv key '(atoms ...))
          (begin r1 ...)))
    ((case key ((atoms ...) r1 ...) cl ...)
      (if (memv key '(atoms ...))
          (begin r1 ...)
          (case key cl ...)))))

(define-syntax let
  (syntax-rules ()
    ((let ((name val) ...)) (if #f #f))
    ((let ((name val) ...) body1 body2 ...)
      ((lambda (name ...) body1 body2 ...)
         val ...))
    ((let tag ((name val) ...) body1 body2 ...)
      ((letrec ((tag (lambda (name ...) body1 body2 ...))) tag)
          val ...))))

(define-syntax let*
  (syntax-rules ()
    ((_ () e1 ...)
     (let () e1 ...))
    ((_ ((x1 v1) (x2 v2) ...) e1 ...)
     (let ((x1 v1))
       (let* ((x2 v2) ...) e1 ...)))))

(define-syntax do
  (syntax-rules ()
    ((_ ((var init step ...) ...) (test expr ...) command ...)
      (letrec ((loop (lambda (var ...)
                       (if test
                           (begin
                             (if #f #f)
                             expr ...)
                           (begin
                             command ...
                             (loop (do "step" var step ...) ...))))))
        (loop init ...)))
    ((_ "step" x) x)
    ((_ "step" x y) y)))

; lib
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (caar x)))
(define (caadr x) (car (cadr x)))
(define (cadar x) (car (cdar x)))
(define (caddr x) (car (cddr x)))
(define (cdaar x) (cdr (caar x)))
(define (cdadr x) (cdr (cadr x)))
(define (cddar x) (cdr (cdar x)))
(define (cdddr x) (cdr (cddr x)))
(define (caaaar x) (car (caaar x)))
(define (caaadr x) (car (caadr x)))
(define (caadar x) (car (cadar x)))
(define (caaddr x) (car (caddr x)))
(define (cadaar x) (car (cdaar x)))
(define (cadadr x) (car (cdadr x)))
(define (caddar x) (car (cddar x)))
(define (cadddr x) (car (cdddr x)))
(define (cdaaar x) (cdr (caaar x)))
(define (cdaadr x) (cdr (caadr x)))
(define (cdadar x) (cdr (cadar x)))
(define (cdaddr x) (cdr (caddr x)))
(define (cddaar x) (cdr (cdaar x)))
(define (cddadr x) (cdr (cdadr x)))
(define (cdddar x) (cdr (cddar x)))
(define (cddddr x) (cdr (cdddr x)))

(define (not x) (if x #f #t))
(define (boolean? x) (or (eq? x #t) (eq? x #f)))

(define (call-with-input-file fname f)
  (let ((prt (open-input-file fname)))
    (let ((res (f prt)))
      (close-input-port prt)
      res)))

(define (call-with-output-file fname f)
  (let ((prt (open-output-file fname)))
    (let ((res (f prt)))
      (close-output-port prt)
      res)))

(define (port? x)
  (or (input-port? x) (output-port? x)))

(define (equal? x y)
  (define (vector-equal? x y i)
    (cond ((= (vector-length x) i) #t)
          ((not (equal? (vector-ref x i) (vector-ref y i))) #f)
          (else (vector-equal? x y (+ i 1)))))
  (cond ((eqv? x y) #t)
        ((pair? x)
          (and (pair? y)
               (equal? (car x) (car y))
               (equal? (cdr x) (cdr y))))
        ((string? x) (and (string? y) (string=? x y)))
        ((vector? x)
          (and (vector? y)
               (= (vector-length x) (vector-length y))
               (vector-equal? x y 0)))
        (else #f)))

(define (member x lis)
  (cond ((null? lis) #f)
        ((equal? x (car lis)) lis)
        (else (member x (cdr lis)))))

(define (assq x lis)
  (cond ((null? lis) #f)
        ((not (pair? (car lis)))
          (error (get-default-message 'err.require.pair)))
        ((eq? (caar lis) x) (car lis))
        (else (assq x (cdr lis)))))

(define (assv x lis)
  (cond ((null? lis) #f)
        ((not (pair? (car lis)))
          (error (get-default-message 'err.require.pair)))
        ((eqv? (caar lis) x) (car lis))
        (else (assv x (cdr lis)))))

(define (assoc x lis)
  (cond ((null? lis) #f)
        ((not (pair? (car lis)))
          (error (get-default-message 'err.require.pair)))
        ((equal? (caar lis) x) (car lis))
        (else (assoc x (cdr lis)))))

(define dynamic-wind #f)
(let ((wind-list '()))
  (define (dw bef tnk aft)
    (bef)
    (set! wind-list (cons (list bef tnk aft) wind-list))
    (let ((res (tnk)))
      (set! wind-list (cdr wind-list))
      (aft)
      res))
  (define (ex ext lst)
    (let loop ((l (reverse lst)))
      (cond ((null? l) #t)
            (else
              ((ext (car l)))
              (loop (cdr l))))))
  (define (ez ext lst oldwl)
    (let loop ((l oldwl))
      (cond ((null? l) #t)
            ((eq? l lst) #t)
            (else
              ((ext (car l)))
              (loop (cdr l))))))
  (define (f? wx lst)
    (let loop ((l lst))
      (cond ((null? l) #f)
            ((eq? wx l) #t)
            (else (loop (cdr l))))))
  (set! dynamic-wind dw)
  (set! call/cc
    (let ((ccorg call/cc))
      (lambda (pr)
        (letrec ((l1 (lambda (k)
                       (let ((wl wind-list))
                         (lambda (m)
                           (cond ((and (null? wl) (null? wind-list)) #f)
                                 ((or (null? wl) (f? wl wind-list))
                                   (let ((oldwl wind-list))
                                     (set! wind-list wl)
                                     (ez caddr wl oldwl)))
                                 (else
                                   (ex car wl)
                                   (set! wind-list wl)))
                           (k m))))))
          (ccorg (lambda (k) (pr (l1 k)))))))))

; list
(define (list . l)
  (let lp ((l l))
    (if (null? l)
        '()
        (cons (car l) (lp (cdr l))))))

(define (length l)
  (let lp ((l l) (r 0))
    (if (null? l)
        r
        (lp (cdr l) (+ r 1)))))      

(define (list-ref l n)
  (if (< n 0) (error "list-ref"))
  (cond ((not (pair? l)) (error "list-ref"))
        ((<= n 0) (car l))
        (else (list-ref (cdr l) (- n 1)))))

(define (list-tail l n)
  (if (< n 0) (error "list-tail"))
  (cond ((<= n 0) l)
        ((not (pair? l)) (error "list-tail"))
        (else (list-tail (cdr l) (- n 1)))))

(define (list->string l)
  (cond ((null? l) x)
        (else (string-append (->string (car l))
                             (list->string (cdr l))))))

(define (append . l)
  (let lp1 ((l l))
    (cond ((null? l) '())
          ((null? (cdr l)) (car l))
          (else
            (let lp2 ((m (car l)))
              (if (null? m)
                  (lp1 (cdr l))
                  (cons (car m) (lp2 (cdr m)))))))))

(define (reverse l)
  (if (pair? l)
      (let lp ((l l) (r '()))
        (if (null? l)
            r
            (lp (cdr l) (cons (car l) r))))
      l))

(define (memq o l)
  (cond ((null? l) #f)
        ((eq? o (car l)) l)
        (else (memq o (cdr l)))))

(define (memv o l)
  (cond ((null? l) #f)
        ((eqv? o (car l)) l)
        (else (memq o (cdr l)))))

(define (list? l)
  (let lp ((l l) (c '()))
    (cond ((null? l) #t)
          ((memq l c) #f)
          ((pair? l) (lp (cdr l) (cons l c)))
          (else #f))))

; map
(define (map p . l1)
  (define (cx p l2)
    (let l1 ((l l2))
      (if (null? l)
          '()
          (cons (p (car l)) (l1 (cdr l))))))
  (define (n? l2)
    (let l1 ((l l2))
      (cond ((null? l) #f)
            ((null? (car l)) #t)
            (else (l1 (cdr l))))))
  (let l0 ((l l1))
    (if (n? l)
        '()
        (cons (apply p (cx car l)) (l0 (cx cdr l))))))

(define (for-each p . l1)
  (define (cx p l2)
    (let l1 ((l l2))
      (if (null? l)
          '()
          (cons (p (car l)) (l1 (cdr l))))))
  (define (n? l2)
    (let l1 ((l l2))
      (cond ((null? l) #f)
            ((null? (car l)) #t)
            (else (l1 (cdr l))))))
  (let l0 ((l l1))
    (if (n? l)
        '()
        (begin
           (apply p (cx car l))
           (l0 (cx cdr l))))))
; vector
(define (list->vector l)
  (let* ((m (length l)) (v (make-vector m)))
    (let lp ((k 0) (l l))
      (if (= k m)
          v
          (begin
            (vector-set! v k (car l))
            (lp (+ k 1) (cdr l)))))))
(define (vector . l) (list->vector l))

(define (vector->list v)
  (let lp ((k 0) (l (vector-length v)))
    (if (= k l)
        '()
        (cons (vector-ref v k) (lp (+ k 1) l)))))

(define (vector-fill! v x)
  (let lp ((k 0) (l (vector-length v)))
    (if (< k l)
        (begin
          (vector-set! v k x)
          (lp (+ k 1) l)))))

; string
(define (make-string n . a)
  (define (ms n x)
    (let lp ((s "") (k 0) (t (->string x)))
      (if (< k n)
          (lp (string-append s t) (+ k 1) t)
          s)))
  (cond ((null? a) (ms n " "))
        ((null? (cdr a)) (ms n (car a)))
        (else (get-default-message 'err.argument))))

(define (string->list v)
  (let lp ((k 0) (l (string-length v)))
    (if (= k l)
        '()
        (cons (string-ref v k) (lp (+ k 1) l)))))

(define (string-fill! v x)
  (let lp ((k 0) (l (string-length v)))
    (if (< k l)
        (begin
          (string-set! v k x)
          (lp (+ k 1) l)))))

; math
(define (even? x) (and (integer? x) (= (abs (remainder x 2)) 0)))
(define (odd?  x) (and (integer? x) (= (abs (remainder x 2)) 1)))
(define (inexact? x) (not (exact? x)))
(define (negative? x) (< x 0))
(define (positive? x) (> x 0))
(define (zero? x) (= x 0))

(define (max . l)
  (let lp ((x #f) (l l))
    (cond ((null? l) x)
          ((not x) (lp (car l) (cdr l)))
          ((and (inexact? x) (exact? (car l)))
            (lp (if (> x (car l)) x (exact->inexact (car l))) (cdr l)))
          ((and (exact? x) (inexact? (car l)))
            (lp (if (> x (car l)) (exact->inexact x) (car l)) (cdr l)))
          (else
            (lp (if (> x (car l)) x (car l)) (cdr l))))))

(define (min . l)
  (let lp ((x #f) (l l))
    (cond ((null? l) x)
          ((not x) (lp (car l) (cdr l)))
          ((and (inexact? x) (exact? (car l)))
            (lp (if (< x (car l)) x (exact->inexact (car l))) (cdr l)))
          ((and (exact? x) (inexact? (car l)))
            (lp (if (< x (car l)) (exact->inexact x) (car l)) (cdr l)))
          (else
            (lp (if (< x (car l)) x (car l)) (cdr l))))))

(define (gcd . l)
  (define (gcdn a b) (if (= b 0) a (gcdn b (remainder a b))))
  (define (gcd2 a b)
    (cond ((= a 0) b)
          ((= b 0) a)
          ((< a 0) (- (gcd2 (- a) b)))
          ((< b 0) (gcd2 a (- b)))
          ((< a b) (gcd2 b a))
          (else (gcdn a b))))
  (cond ((null? l) 0)
        ((null? (cdr l)) (car l))
        (else
          (let lp ((x (car l)) (y (cdr l)))
            (if (null? y)
                x
                (lp (gcd2 x (car y)) (cdr y)))))))

(define (lcm . l)
  (define (gcdn a b) (if (= b 0) a (gcdn b (remainder a b))))
  (define (lcm2 a b)
    (cond ((= a 0) b)
          ((= b 0) a)
          ((< a 0) (- (lcm2 (- a) b)))
          ((< b 0) (lcm2 a (- b)))
          ((< a b) (lcm2 b a))
          (else (/ (* a b) (gcdn a b)))))
  (cond ((null? l) 1)
        ((null? (cdr l)) (car l))
        (else
          (let lp ((x (car l)) (y (cdr l)))
            (if (null? y)
                x
                (lp (lcm2 x (car y)) (cdr y)))))))

(define (sqrt x)
  (define N 10)
  (define M 100)
  (define (dv l a)
    (if (< a M)
        (cons a l)
        (dv (cons (remainder a M) l) (quotient a M))))
  (define (fr r d k)
    (if (= d 0)
        0
        (let ((a (* (+ (* r N) k) k)))
          (cond ((< a d) (fr r d (+ k 1)))
                ((= a d) k)
                (else (- k 1))))))
  (define (si l r s d)
    (let* ((f (fr s d 1))
          (r2 (+ (* r N) f))
          (s2 (+ (* s N) f))
          (d2 (- d (* s2 f))))
      (if (null? l)
          (if (= d2 0) r2 (expt x 0.5))
          (si (cdr l) r2 (+ s2 f) (+ (* d2 M) (car l))))))
  (cond ((not (real? x)) (expt x 0.5))
        ((inexact? x) (expt x 0.5))
        ((= x 0) 0)
        ((< x 0) (- (sqrt (- x))))
        (else
          (let ((l (dv '() x)))
            (si (cdr l) 0 0 (car l))))))

(define (magnitude z)
  (sqrt (+ (* (real-part z) (real-part z))
           (* (imag-part z) (imag-part z)))))
(define (abs z) (magnitude z))
(define (angle z) (atan (/ (real-part z) (imag-part z))))

(define (make-polar r i)
  (if (and (>= r 0) (real? i))
      (make-rectangular (* r (cos i)) (* r (sin i)))
      (get-default-message 'err.require.real)))

; etc
(define (atom? x) (not (or (null? x) (pair? x))))

; end