1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00

*** empty log message ***

This commit is contained in:
Keisuke Nishida 2001-04-01 04:57:52 +00:00
parent d43c690f40
commit c092937bd5
6 changed files with 0 additions and 162 deletions

View file

@ -1,4 +0,0 @@
.cvsignore
Makefile
Makefile.in
*.scc

View file

@ -1,16 +0,0 @@
SOURCE_FILES = control.scm procedure.scm queens.scm
COMPILED_FILES = control.scc procedure.scc queens.scc
EXTRA_DIST = test.scm $(SOURCE_FILES)
CLEANFILES = $(COMPILED_FILES)
MAINTAINERCLEANFILES = Makefile.in
GUILE = $(top_srcdir)/src/$(PACKAGE)
test: $(COMPILED_FILES)
@for file in $(COMPILED_FILES); do \
$(GUILE) -s test.scm $$file; \
done
SUFFIXES = .scm .scc
.scm.scc:
guile-compile $<

View file

@ -1,20 +0,0 @@
(define income-tax
(lambda (income)
(cond
((<= income 10000)
(* income .05))
((<= income 20000)
(+ (* (- income 10000) .08)
500.00))
((<= income 30000)
(+ (* (- income 20000) .13)
1300.00))
(else
(+ (* (- income 30000) .21)
2600.00)))))
(test (income-tax 5000) 250.0)
(test (income-tax 15000) 900.0)
(test (income-tax 25000) 1950.0)
(test (income-tax 50000) 6800.0)

View file

@ -1,60 +0,0 @@
(define length
(lambda (ls)
(if (null? ls)
0
(+ (length (cdr ls)) 1))))
(test (length '()) 0)
(test (length '(a)) 1)
(test (length '(a b)) 2)
(define remv
(lambda (x ls)
(cond
((null? ls) '())
((eqv? (car ls) x) (remv x (cdr ls)))
(else (cons (car ls) (remv x (cdr ls)))))))
(test (remv 'a '(a b b d)) '(b b d))
(test (remv 'b '(a b b d)) '(a d))
(test (remv 'c '(a b b d)) '(a b b d))
(test (remv 'd '(a b b d)) '(a b b))
(define tree-copy
(lambda (tr)
(if (not (pair? tr))
tr
(cons (tree-copy (car tr))
(tree-copy (cdr tr))))))
(test (tree-copy '((a . b) . c)) '((a . b) . c))
(define quadratic-formula
(lambda (a b c)
(let ((root1 0) (root2 0) (minusb 0) (radical 0) (divisor 0))
(set! minusb (- 0 b))
(set! radical (sqrt (- (* b b) (* 4 (* a c)))))
(set! divisor (* 2 a))
(set! root1 (/ (+ minusb radical) divisor))
(set! root2 (/ (- minusb radical) divisor))
(cons root1 root2))))
(test (quadratic-formula 2 -4 -6) '(3.0 . -1.0))
(define count
(let ((n 0))
(lambda ()
(set! n (1+ n))
n)))
(test (count) 1)
(test (count) 2)
(define (fibonacci i)
(cond ((= i 0) 0)
((= i 1) 1)
(else (+ (fibonacci (- i 1)) (fibonacci (- i 2))))))
(test (fibonacci 0) 0)
(test (fibonacci 5) 5)
(test (fibonacci 10) 55)

View file

@ -1,50 +0,0 @@
(define (filter predicate sequence)
(cond ((null? sequence) '())
((predicate (car sequence))
(cons (car sequence)
(filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (flatmap proc seq)
(accumulate append '() (map proc seq)))
(define (enumerate-interval low high)
(if (> low high)
'()
(cons low (enumerate-interval (+ low 1) high))))
(define empty-board '())
(define (rest bs k rest-of-queens)
(map (lambda (new-row)
(adjoin-position new-row k rest-of-queens))
(enumerate-interval 1 bs)))
(define (queen-cols board-size k)
(if (= k 0)
(list empty-board)
(filter (lambda (positions) (safe? k positions))
(flatmap (lambda (r) (rest board-size k r))
(queen-cols board-size (- k 1))))))
(define (queens board-size)
(queen-cols board-size board-size))
(define (adjoin-position new-row k rest-of-queens)
(append rest-of-queens (list new-row)))
(define (safe? k positions)
(let ((new (car (last-pair positions)))
(bottom (car positions)))
(cond ((= k 1) #t)
((= new bottom) #f)
((or (= new (- bottom (- k 1))) (= new (+ bottom (- k 1)))) #f)
(else (safe? (- k 1) (cdr positions))))))
(test (queens 4) '((2 4 1 3) (3 1 4 2)))

View file

@ -1,12 +0,0 @@
(set! %load-path (cons ".." %load-path))
(use-modules (vm vm))
(define (test a b)
(if (equal? a b)
(display "OK\n")
(display "failed\n")))
(let ((file (cadr (command-line))))
(format #t "Testing ~S...\n" file)
(load file))