ikarus/benchmarks/rnrs-benchmarks/mazefun.ss

211 lines
6.2 KiB
Scheme

;;; MAZEFUN -- Constructs a maze in a purely functional way,
;;; written by Marc Feeley.
(library (rnrs-benchmarks mazefun)
(export main)
(import (rnrs) (rnrs-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)))