430 lines
9.0 KiB
Scheme
430 lines
9.0 KiB
Scheme
(define (zero? n)
|
|
(= n 0))
|
|
|
|
(define (positive? x)
|
|
(> x 0))
|
|
|
|
(define (negative? x)
|
|
(< x 0))
|
|
|
|
(define (odd? n)
|
|
(= 0 (floor-remainder n 2)))
|
|
|
|
(define (even? n)
|
|
(= 1 (floor-remainder n 2)))
|
|
|
|
(define (gcd n m)
|
|
(if (negative? n)
|
|
(set! n (- n)))
|
|
(if (negative? m)
|
|
(set! m (- m)))
|
|
(if (> n m)
|
|
((lambda (tmp)
|
|
(set! n m)
|
|
(set! m tmp))
|
|
n))
|
|
(if (zero? n)
|
|
m
|
|
(gcd (floor-remainder m n) n)))
|
|
|
|
(define (lcm n m)
|
|
(/ (* n m) (gcd n m)))
|
|
|
|
(define (caar p)
|
|
(car (car p)))
|
|
|
|
(define (cadr p)
|
|
(car (cdr p)))
|
|
|
|
(define (cdar p)
|
|
(cdr (car p)))
|
|
|
|
(define (cddr p)
|
|
(cdr (cdr p)))
|
|
|
|
(define (list . args)
|
|
args)
|
|
|
|
(define (list? obj)
|
|
(if (null? obj)
|
|
#t
|
|
(if (pair? obj)
|
|
(list? (cdr obj))
|
|
#f)))
|
|
|
|
(define (make-list k . args)
|
|
(if (null? args)
|
|
(make-list k #f)
|
|
(if (zero? k)
|
|
'()
|
|
(cons (car args)
|
|
(make-list (- k 1) (car args))))))
|
|
|
|
(define (length list)
|
|
(if (null? list)
|
|
0
|
|
(+ 1 (length (cdr list)))))
|
|
|
|
(define (append xs ys)
|
|
(if (null? xs)
|
|
ys
|
|
(cons (car xs)
|
|
(append (cdr xs) ys))))
|
|
|
|
(define (reverse list . args)
|
|
(if (null? args)
|
|
(reverse list '())
|
|
(if (null? list)
|
|
(car args)
|
|
(reverse (cdr list)
|
|
(cons (car list) (car args))))))
|
|
|
|
(define (list-tail list k)
|
|
(if (zero? k)
|
|
list
|
|
(list-tail (cdr list) (- k 1))))
|
|
|
|
(define (list-ref list k)
|
|
(car (list-tail list k)))
|
|
|
|
(define (list-set! list k obj)
|
|
(set-car! (list-tail list k) obj))
|
|
|
|
(define (memq obj list)
|
|
(if (null? list)
|
|
#f
|
|
(if (eq? obj (car list))
|
|
list
|
|
(memq obj (cdr list)))))
|
|
|
|
(define (memv obj list)
|
|
(if (null? list)
|
|
#f
|
|
(if (eqv? obj (car list))
|
|
list
|
|
(memq obj (cdr list)))))
|
|
|
|
(define (assq obj list)
|
|
(if (null? list)
|
|
#f
|
|
(if (eq? obj (caar list))
|
|
(car list)
|
|
(assq obj (cdr list)))))
|
|
|
|
(define (assv obj list)
|
|
(if (null? list)
|
|
#f
|
|
(if (eqv? obj (caar list))
|
|
(car list)
|
|
(assq obj (cdr list)))))
|
|
|
|
(define (list-copy obj)
|
|
(if (null? obj)
|
|
obj
|
|
(cons (car obj)
|
|
(list-copy (cdr obj)))))
|
|
|
|
(define (every pred list)
|
|
(if (null? list)
|
|
#t
|
|
(if (pred (car list))
|
|
(every pred (cdr list))
|
|
#f)))
|
|
|
|
(define (any pred list)
|
|
(if (null? list)
|
|
#f
|
|
((lambda (it)
|
|
(if it
|
|
it
|
|
(any pred (cdr list))))
|
|
(pred (car list)))))
|
|
|
|
(define (fold f s xs)
|
|
(if (null? xs)
|
|
s
|
|
(fold f (f (car xs) s) (cdr xs))))
|
|
|
|
(define (map f list . lists)
|
|
(define (single-map f list)
|
|
(if (null? list)
|
|
'()
|
|
(cons (f (car list))
|
|
(map f (cdr list)))))
|
|
(define (multiple-map f lists)
|
|
(if (any null? lists)
|
|
'()
|
|
(cons (apply f (single-map car lists))
|
|
(multiple-map f (single-map cdr lists)))))
|
|
(if (null? lists)
|
|
(single-map f list)
|
|
(multiple-map f (cons list lists))))
|
|
|
|
(define (for-each f list . lists)
|
|
(define (single-for-each f list)
|
|
(if (null? list)
|
|
#f
|
|
(begin
|
|
(f (car list))
|
|
(single-for-each f (cdr list)))))
|
|
(define (multiple-for-each f lists)
|
|
(if (any null? lists)
|
|
#f
|
|
(begin
|
|
(apply f (map car lists))
|
|
(multiple-for-each f (map cdr lists)))))
|
|
(if (null? lists)
|
|
(single-for-each f list)
|
|
(multiple-for-each f (cons list lists))))
|
|
|
|
(define-macro (let bindings . body)
|
|
(if (symbol? bindings)
|
|
(begin
|
|
(define name bindings)
|
|
(set! bindings (car body))
|
|
(set! body (cdr body))
|
|
;; expanded form should be like below:
|
|
;; `(let ()
|
|
;; (define ,loop
|
|
;; (lambda (,@vars)
|
|
;; ,@body))
|
|
;; (,loop ,@vals))
|
|
(list 'let '()
|
|
(list 'define name
|
|
(cons 'lambda (cons (map car bindings) body)))
|
|
(cons name (map cadr bindings))))
|
|
(cons (cons 'lambda (cons (map car bindings) body))
|
|
(map cadr bindings))))
|
|
|
|
(define-macro (cond . clauses)
|
|
(if (null? clauses)
|
|
#f
|
|
(let ((c (car clauses)))
|
|
(let ((test (car c))
|
|
(if-true (cons 'begin (cdr c)))
|
|
(if-false (cons 'cond (cdr clauses))))
|
|
(list 'if test if-true if-false)))))
|
|
|
|
(define else #t)
|
|
|
|
(define-macro (and . exprs)
|
|
(if (null? exprs)
|
|
#t
|
|
(let ((test (car exprs))
|
|
(if-true (cons 'and (cdr exprs))))
|
|
(list 'if test if-true #f))))
|
|
|
|
(define-macro (or . exprs)
|
|
(if (null? exprs)
|
|
#f
|
|
(let ((test (car exprs))
|
|
(if-false (cons 'or (cdr exprs))))
|
|
(list 'let (list (list 'it test))
|
|
(list 'if 'it 'it if-false)))))
|
|
|
|
(define-macro (quasiquote x)
|
|
(cond
|
|
((symbol? x) (list 'quote x))
|
|
((pair? x)
|
|
(cond
|
|
((eq? 'unquote (car x)) (cadr x))
|
|
((and (pair? (car x))
|
|
(eq? 'unquote-splicing (caar x)))
|
|
(list 'append (cadr (car x)) (list 'quasiquote (cdr x))))
|
|
(#t (list 'cons
|
|
(list 'quasiquote (car x))
|
|
(list 'quasiquote (cdr x))))))
|
|
(#t x)))
|
|
|
|
(define-macro (let* bindings . body)
|
|
(if (null? bindings)
|
|
`(let () ,@body)
|
|
`(let ((,(caar bindings)
|
|
,@(cdar bindings)))
|
|
(let* (,@(cdr bindings))
|
|
,@body))))
|
|
|
|
(define-macro (letrec bindings . body)
|
|
(let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))
|
|
(initials (map (lambda (v) `(set! ,@v)) bindings)))
|
|
`(let (,@vars)
|
|
(begin ,@initials)
|
|
,@body)))
|
|
|
|
(define-macro (letrec* . args)
|
|
`(letrec ,@args))
|
|
|
|
(define-macro (when test . exprs)
|
|
(list 'if test (cons 'begin exprs) #f))
|
|
|
|
(define-macro (unless test . exprs)
|
|
(list 'if test #f (cons 'begin exprs)))
|
|
|
|
(define (equal? x y)
|
|
(cond
|
|
((eqv? x y)
|
|
#t)
|
|
((and (pair? x) (pair? y))
|
|
(and (equal? (car x) (car y))
|
|
(equal? (cdr x) (cdr y))))
|
|
(else
|
|
#f)))
|
|
|
|
(define (member obj list . opts)
|
|
(let ((compare (if (null? opts) equal? (car opts))))
|
|
(if (null? list)
|
|
#f
|
|
(if (compare obj (car list))
|
|
list
|
|
(member obj (cdr list) compare)))))
|
|
|
|
(define (assoc obj list . opts)
|
|
(let ((compare (if (null? opts) equal? (car opts))))
|
|
(if (null? list)
|
|
#f
|
|
(if (compare obj (caar list))
|
|
(car list)
|
|
(assoc obj (cdr list) compare)))))
|
|
|
|
(define (values . args)
|
|
(if (and (pair? args)
|
|
(null? (cdr args)))
|
|
(car args)
|
|
(cons '*values-tag* args)))
|
|
|
|
(define (call-with-values producer consumer)
|
|
(let ((res (producer)))
|
|
(if (and (pair? res)
|
|
(eq? '*values-tag* (car res)))
|
|
(apply consumer (cdr res))
|
|
(consumer res))))
|
|
|
|
(define-macro (do bindings finish . body)
|
|
`(let loop ,(map (lambda (x)
|
|
(list (car x) (cadr x)))
|
|
bindings)
|
|
(if ,(car finish)
|
|
(begin ,@body
|
|
(loop ,@(map (lambda (x)
|
|
(if (null? (cddr x))
|
|
(car x)
|
|
(car (cddr x))))
|
|
bindings)))
|
|
(begin ,@(cdr finish)))))
|
|
|
|
;;; 6.2. Numbers
|
|
|
|
(define (+ . args)
|
|
(do ((acc 0)
|
|
(nums args (cdr nums)))
|
|
((pair? nums) acc)
|
|
(set! acc (+ acc (car nums)))))
|
|
|
|
(define (* . args)
|
|
(do ((acc 1)
|
|
(nums args (cdr nums)))
|
|
((pair? nums) acc)
|
|
(set! acc (* acc (car nums)))))
|
|
|
|
(define (min x . args)
|
|
(let loop ((pivot x) (rest args))
|
|
(if (null? rest)
|
|
pivot
|
|
(loop (if (< x (car rest)) x (car rest)) (cdr rest)))))
|
|
|
|
(define (max x . args)
|
|
(let loop ((pivot x) (rest args))
|
|
(if (null? rest)
|
|
pivot
|
|
(loop (if (> x (car rest)) x (car rest)) (cdr rest)))))
|
|
|
|
(define (floor/ n m)
|
|
(values (floor-quotient n m)
|
|
(floor-remainder n m)))
|
|
|
|
(define (truncate/ n m)
|
|
(values (truncate-quotient n m)
|
|
(truncate-remainder n m)))
|
|
|
|
(define (exact-integer-sqrt k)
|
|
(let ((n (exact (sqrt k))))
|
|
(values n (- k (square n)))))
|
|
|
|
;;; 6.3 Booleans
|
|
|
|
(define (boolean=? . objs)
|
|
(or (every (lambda (x) (eq? x #t)) objs)
|
|
(every (lambda (x) (eq? x #f)) objs)))
|
|
|
|
;;; 6.5. Symbols
|
|
|
|
(define (symbol=? . objs)
|
|
(let ((sym (car objs)))
|
|
(if (symbol? sym)
|
|
(every (lambda (x)
|
|
(and (symbol? x)
|
|
(eq? x sym)))
|
|
(cdr objs))
|
|
#f)))
|
|
|
|
;;; 6.6 Characters
|
|
|
|
(define-macro (define-char-transitive-predicate name op)
|
|
`(define (,name . cs)
|
|
(apply ,op (map char->integer cs))))
|
|
|
|
(define-char-transitive-predicate char=? =)
|
|
(define-char-transitive-predicate char<? <)
|
|
(define-char-transitive-predicate char>? >)
|
|
(define-char-transitive-predicate char<=? <=)
|
|
(define-char-transitive-predicate char>=? >=)
|
|
|
|
;;; 6.8. Vector
|
|
|
|
(define (vector . objs)
|
|
(let ((len (length objs)))
|
|
(let ((v (make-vector len)))
|
|
(do ((i 0 (+ i 1))
|
|
(l objs (cdr l)))
|
|
((< i len)
|
|
v)
|
|
(vector-set! v i (car l))))))
|
|
|
|
(define (vector-copy! to at from . opts)
|
|
(let ((start (if (pair? opts) (car opts) 0))
|
|
(end (if (>= (length opts) 2)
|
|
(cadr opts)
|
|
(vector-length from))))
|
|
(do ((i at (+ i 1))
|
|
(j start (+ j 1)))
|
|
((< j end))
|
|
(vector-set! to i (vector-ref from j)))))
|
|
|
|
(define (vector-copy v . opts)
|
|
(let ((start (if (pair? opts) (car opts) 0))
|
|
(end (if (>= (length opts) 2)
|
|
(cadr opts)
|
|
(vector-length v))))
|
|
(let ((res (make-vector (vector-length v))))
|
|
(vector-copy! res 0 v start end)
|
|
res)))
|
|
|
|
(define (vector-append . vs)
|
|
(define (vector-append-2-inv w v)
|
|
(let ((res (make-vector (+ (vector-length v) (vector-length w)))))
|
|
(vector-copy! res 0 v)
|
|
(vector-copy! res (vector-length v) w)
|
|
res))
|
|
(fold vector-append-2-inv #() vs))
|
|
|
|
;;; 6.9 bytevector
|
|
|
|
(define (bytevector . objs)
|
|
(let ((len (length objs)))
|
|
(let ((v (make-bytevector len)))
|
|
(do ((i 0 (+ i 1))
|
|
(l objs (cdr l)))
|
|
((< i len)
|
|
v)
|
|
(bytevector-u8-set! v i (car l))))))
|