ikarus/benchmarks/new/r6rs-benchmarks/mazefun.ss

211 lines
6.2 KiB
Scheme
Raw Normal View History

Added many benchmarks. added: benchmarks/new/r6rs-benchmarks/BUGS benchmarks/new/r6rs-benchmarks/array1.ss benchmarks/new/r6rs-benchmarks/bib benchmarks/new/r6rs-benchmarks/boyer.ss benchmarks/new/r6rs-benchmarks/browse.ss benchmarks/new/r6rs-benchmarks/cat.ss benchmarks/new/r6rs-benchmarks/conform.ss benchmarks/new/r6rs-benchmarks/cpstak.ss benchmarks/new/r6rs-benchmarks/ctak.ss benchmarks/new/r6rs-benchmarks/dderiv.ss benchmarks/new/r6rs-benchmarks/deriv.ss benchmarks/new/r6rs-benchmarks/destruc.ss benchmarks/new/r6rs-benchmarks/diviter.ss benchmarks/new/r6rs-benchmarks/divrec.ss benchmarks/new/r6rs-benchmarks/dynamic.src.ss benchmarks/new/r6rs-benchmarks/dynamic.ss benchmarks/new/r6rs-benchmarks/earley.ss benchmarks/new/r6rs-benchmarks/fibc.ss benchmarks/new/r6rs-benchmarks/fibfp.ss benchmarks/new/r6rs-benchmarks/gcbench.ss benchmarks/new/r6rs-benchmarks/gcold.ss benchmarks/new/r6rs-benchmarks/graphs.ss benchmarks/new/r6rs-benchmarks/lattice.ss benchmarks/new/r6rs-benchmarks/matrix.ss benchmarks/new/r6rs-benchmarks/maze.ss benchmarks/new/r6rs-benchmarks/mazefun.ss benchmarks/new/r6rs-benchmarks/mbrot.ss benchmarks/new/r6rs-benchmarks/nboyer.ss benchmarks/new/r6rs-benchmarks/nqueens.ss benchmarks/new/r6rs-benchmarks/ntakl.ss benchmarks/new/r6rs-benchmarks/paraffins.ss benchmarks/new/r6rs-benchmarks/parsing-test.sch benchmarks/new/r6rs-benchmarks/parsing.ss benchmarks/new/r6rs-benchmarks/perm9.ss benchmarks/new/r6rs-benchmarks/peval.ss benchmarks/new/r6rs-benchmarks/pi.ss benchmarks/new/r6rs-benchmarks/pnpoly.ss benchmarks/new/r6rs-benchmarks/ray.ss benchmarks/new/r6rs-benchmarks/todo-src/ benchmarks/new/r6rs-benchmarks/todo-src/README.flonum-benchmarks benchmarks/new/r6rs-benchmarks/todo-src/compiler.scm benchmarks/new/r6rs-benchmarks/todo-src/fft.scm benchmarks/new/r6rs-benchmarks/todo-src/fpsum.scm benchmarks/new/r6rs-benchmarks/todo-src/nbody.scm benchmarks/new/r6rs-benchmarks/todo-src/nucleic.scm benchmarks/new/r6rs-benchmarks/todo-src/primes.scm benchmarks/new/r6rs-benchmarks/todo-src/puzzle.scm benchmarks/new/r6rs-benchmarks/todo-src/quicksort.scm benchmarks/new/r6rs-benchmarks/todo-src/rn100 benchmarks/new/r6rs-benchmarks/todo-src/sboyer.scm benchmarks/new/r6rs-benchmarks/todo-src/scheme.scm benchmarks/new/r6rs-benchmarks/todo-src/simplex.scm benchmarks/new/r6rs-benchmarks/todo-src/slatex.scm benchmarks/new/r6rs-benchmarks/todo-src/slatex.sty benchmarks/new/r6rs-benchmarks/todo-src/smlboyer.scm benchmarks/new/r6rs-benchmarks/todo-src/string.scm benchmarks/new/r6rs-benchmarks/todo-src/succeed.scm benchmarks/new/r6rs-benchmarks/todo-src/sum.scm benchmarks/new/r6rs-benchmarks/todo-src/sum1.scm benchmarks/new/r6rs-benchmarks/todo-src/sumfp.scm benchmarks/new/r6rs-benchmarks/todo-src/sumloop.scm benchmarks/new/r6rs-benchmarks/todo-src/tail.scm benchmarks/new/r6rs-benchmarks/todo-src/tak.scm benchmarks/new/r6rs-benchmarks/todo-src/takl.scm benchmarks/new/r6rs-benchmarks/todo-src/temp.scm benchmarks/new/r6rs-benchmarks/todo-src/temp2.scm benchmarks/new/r6rs-benchmarks/todo-src/test.scm benchmarks/new/r6rs-benchmarks/todo-src/test.tex benchmarks/new/r6rs-benchmarks/todo-src/tfib.scm benchmarks/new/r6rs-benchmarks/todo-src/trav1.scm benchmarks/new/r6rs-benchmarks/todo-src/trav2.scm benchmarks/new/r6rs-benchmarks/todo-src/triangl.scm benchmarks/new/r6rs-benchmarks/todo-src/wc.scm modified: benchmarks/new/r6rs-benchmarks.ss benchmarks/results.Larceny-r6rs benchmarks/src/ntakl.scm
2007-06-13 07:17:57 -04:00
;;; MAZEFUN -- Constructs a maze in a purely functional way,
;;; written by Marc Feeley.
(library (r6rs-benchmarks mazefun)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define foldr
(lambda (f base lst)
(define foldr-aux
(lambda (lst)
(if (null? lst)
base
(f (car lst) (foldr-aux (cdr lst))))))
(foldr-aux lst)))
(define foldl
(lambda (f base lst)
(define foldl-aux
(lambda (base lst)
(if (null? lst)
base
(foldl-aux (f base (car lst)) (cdr lst)))))
(foldl-aux base lst)))
(define for
(lambda (lo hi f)
(define for-aux
(lambda (lo)
(if (< lo hi)
(cons (f lo) (for-aux (+ lo 1)))
'())))
(for-aux lo)))
(define concat
(lambda (lists)
(foldr append '() lists)))
(define list-read
(lambda (lst i)
(if (= i 0)
(car lst)
(list-read (cdr lst) (- i 1)))))
(define list-write
(lambda (lst i val)
(if (= i 0)
(cons val (cdr lst))
(cons (car lst) (list-write (cdr lst) (- i 1) val)))))
(define list-remove-pos
(lambda (lst i)
(if (= i 0)
(cdr lst)
(cons (car lst) (list-remove-pos (cdr lst) (- i 1))))))
(define duplicates?
(lambda (lst)
(if (null? lst)
#f
(or (member (car lst) (cdr lst))
(duplicates? (cdr lst))))))
(define make-matrix
(lambda (n m init)
(for 0 n (lambda (i) (for 0 m (lambda (j) (init i j)))))))
(define matrix-read
(lambda (mat i j)
(list-read (list-read mat i) j)))
(define matrix-write
(lambda (mat i j val)
(list-write mat i (list-write (list-read mat i) j val))))
(define matrix-size
(lambda (mat)
(cons (length mat) (length (car mat)))))
(define matrix-map
(lambda (f mat)
(map (lambda (lst) (map f lst)) mat)))
(define initial-random 0)
(define next-random
(lambda (current-random)
(remainder (+ (* current-random 3581) 12751) 131072)))
(define shuffle
(lambda (lst)
(shuffle-aux lst initial-random)))
(define shuffle-aux
(lambda (lst current-random)
(if (null? lst)
'()
(let ((new-random (next-random current-random)))
(let ((i (modulo new-random (length lst))))
(cons (list-read lst i)
(shuffle-aux (list-remove-pos lst i)
new-random)))))))
(define make-maze
(lambda (n m) ; n and m must be odd
(if (not (and (odd? n) (odd? m)))
'error
(let ((cave
(make-matrix n m (lambda (i j)
(if (and (even? i) (even? j))
(cons i j)
#f))))
(possible-holes
(concat
(for 0 n (lambda (i)
(concat
(for 0 m (lambda (j)
(if (equal? (even? i) (even? j))
'()
(list (cons i j)))))))))))
(cave-to-maze (pierce-randomly (shuffle possible-holes) cave))))))
(define cave-to-maze
(lambda (cave)
(matrix-map (lambda (x) (if x '_ '*)) cave)))
(define pierce
(lambda (pos cave)
(let ((i (car pos)) (j (cdr pos)))
(matrix-write cave i j pos))))
(define pierce-randomly
(lambda (possible-holes cave)
(if (null? possible-holes)
cave
(let ((hole (car possible-holes)))
(pierce-randomly (cdr possible-holes)
(try-to-pierce hole cave))))))
(define try-to-pierce
(lambda (pos cave)
(let ((i (car pos)) (j (cdr pos)))
(let ((ncs (neighboring-cavities pos cave)))
(if (duplicates?
(map (lambda (nc) (matrix-read cave (car nc) (cdr nc))) ncs))
cave
(pierce pos
(foldl (lambda (c nc) (change-cavity c nc pos))
cave
ncs)))))))
(define change-cavity
(lambda (cave pos new-cavity-id)
(let ((i (car pos)) (j (cdr pos)))
(change-cavity-aux cave pos new-cavity-id (matrix-read cave i j)))))
(define change-cavity-aux
(lambda (cave pos new-cavity-id old-cavity-id)
(let ((i (car pos)) (j (cdr pos)))
(let ((cavity-id (matrix-read cave i j)))
(if (equal? cavity-id old-cavity-id)
(foldl (lambda (c nc)
(change-cavity-aux c nc new-cavity-id old-cavity-id))
(matrix-write cave i j new-cavity-id)
(neighboring-cavities pos cave))
cave)))))
(define neighboring-cavities
(lambda (pos cave)
(let ((size (matrix-size cave)))
(let ((n (car size)) (m (cdr size)))
(let ((i (car pos)) (j (cdr pos)))
(append (if (and (> i 0) (matrix-read cave (- i 1) j))
(list (cons (- i 1) j))
'())
(if (and (< i (- n 1)) (matrix-read cave (+ i 1) j))
(list (cons (+ i 1) j))
'())
(if (and (> j 0) (matrix-read cave i (- j 1)))
(list (cons i (- j 1)))
'())
(if (and (< j (- m 1)) (matrix-read cave i (+ j 1)))
(list (cons i (+ j 1)))
'())))))))
(define expected-result
'((_ * _ _ _ _ _ _ _ _ _)
(_ * * * * * * * _ * *)
(_ _ _ * _ _ _ * _ _ _)
(_ * _ * _ * _ * _ * _)
(_ * _ _ _ * _ * _ * _)
(* * _ * * * * * _ * _)
(_ * _ _ _ _ _ _ _ * _)
(_ * _ * _ * * * * * *)
(_ _ _ * _ _ _ _ _ _ _)
(_ * * * * * * * _ * *)
(_ * _ _ _ _ _ _ _ _ _)))
(define (main . args)
(run-benchmark
"mazefun"
mazefun-iters
(lambda (result)
(equal? result expected-result))
(lambda (n m) (lambda () (make-maze n m)))
11
11)))