; Andrew Tarr <arc@stuff.gen.nz> writes:
; > I'd like to have a look at a smallish application or two in scheme, as
; > I figure that seeing how other people do things is a good way to learn
; You have to understand the perfectionism of comp.lang.scheme. This is a
; newsgroup frequented by computer scientists who have written textbooks,
; and other various geniuses. It can be embarrassing to put forward code
; of the size you ask for, as such things are too large to hone to
; perfection, and too small to be anything someone has spent a lot of time
; on. They're likely to be afternoon hacks rife with bad style and
; possibly bugs. To post such code in this crowd, a person would
; basically have to have no shame.
; Below is code for a maze generator. It will run in most implementations
; with the addition of
; (define brl-random random)
; I.e. a function that when given a whole number n, returns a random
; number between 0 and n-1, inclusive.
; There is a web interface to this maze generator:
; http://www.webappcabaret.com/brl/p/brlewis/amaze.brl
(define (put-newline)
(newline))
(define (put-string s)
(display s))
(define (make-vector-and-init size val)
(let
((vec (make-vector size)))
(let loop ((x 0))
(if (< x size)
(begin
(vector-set! vec x val)
(loop (+ x 1)))))
vec))
(define random-number 17)
(define (random n)
(set! random-number (remainder (* random-number 4001) 8009))
(if (= n 0)
0
(remainder random-number n)))
; Characteristics of maze cells
(define open-top 1)
(define (open-top? cellval) (positive? (remainder cellval 2)))
(define open-left 2)
(define (open-left? cellval) (>= (remainder cellval 4) 2))
(define open-elsewhere 4)
(define black 8)
(define diggable? zero?)
(define (simplified-value cellval)
(if (>= (remainder cellval 8) 4)
(- cellval 4)
cellval))
(define (list-delete-subsequent! mylist target)
(if (pair? (cdr mylist))
(if (equal? (cadr mylist) target)
(set-cdr! mylist (cddr mylist))
(list-delete-subsequent! (cdr mylist) target))))
(define (list-delete! mylist target)
(if (equal? (car mylist) target)
(cdr mylist)
(begin
(list-delete-subsequent! mylist target)
mylist)))
(define (make-maze width height)
(let ((maze (make-vector height))
(diggable-cells (* width height)))
(let loop ((k 0))
(if (< k height)
(begin
(vector-set! maze k (make-vector-and-init width 0))
(loop (+ k 1)))))
(letrec ((my-set! (lambda (x y val)
(if (diggable? (my-get x y))
(set! diggable-cells (- diggable-cells 1)))
(vector-set! (vector-ref maze y) x val)))
(my-get (lambda (x y)
(vector-ref (vector-ref maze y) x)))
(my-dig! (lambda (x1 y1 x2 y2)
(cond ((< x1 x2)
(my-set! x2 y2 open-left))
((< y1 y2)
(my-set! x2 y2 open-top))
((> x1 x2)
(my-set! x2 y2 open-elsewhere)
(my-set! x1 y1 (+ open-left (my-get x1 y1))))
((> y1 y2)
(my-set! x2 y2 open-elsewhere)
(my-set! x1 y1 (+ open-top (my-get x1 y1)))))))
(my-dig-from!
(lambda (x y)
(let ((possible-targets
(if (and (> y 0)
(diggable? (my-get x (- y 1))))
(list (list x (- y 1)))
'())))
(if (and (< (+ y 1) height)
(diggable? (my-get x (+ y 1))))
(set! possible-targets
(cons (list x (+ y 1)) possible-targets)))
(if (and (> x 0)
(diggable? (my-get (- x 1) y)))
(set! possible-targets
(cons (list (- x 1) y) possible-targets)))
(if (and (< (+ x 1) width)
(diggable? (my-get (+ x 1) y)))
(set! possible-targets
(cons (list (+ x 1) y) possible-targets)))
(if (null? possible-targets)
#f
(let ((target
(list-ref possible-targets
(random (length possible-targets)))))
(my-dig! x y (car target) (cadr target))
target)))))
(my-random-diggable
(lambda ()
(let ((x (random width))
(y (random height)))
(if (diggable? (my-get x y))
(list x y)
(my-random-diggable)))))
(my-expand-cave1!
(lambda (xylist)
(let* ((target (list-ref xylist (random (length xylist))))
(result (my-dig-from! (car target) (cadr target))))
(if result
(cons result xylist)
(list-delete! xylist target)))))
(my-expand-cave2!
(lambda (xylist)
(let* ((target (car xylist))
(result (my-dig-from! (car target) (cadr target))))
(if result
(cons result xylist)
(if (pair? (cdr xylist))
(let ((new-target
(list-ref (cdr xylist)
(random (length (cdr xylist))))))
(cons new-target
(list-delete! (cdr xylist) new-target)))
'())))))
(my-expand-cave-completely!
(lambda (xylist)
(if (not (null? xylist))
(my-expand-cave-completely!
(my-expand-cave2! xylist)))))
(dispatch
(lambda (method . args)
(case method
((set!) (apply my-set! args))
((get) (apply my-get args))
((width) width)
((height) height)
((diggable-cells) diggable-cells)
((dig-randomly!)
(my-expand-cave-completely!
(list (list (random width)
(random height)))))
((dig!) (apply my-dig! args))
((dig-from!) (apply my-dig-from! args))
((expand-cave1!) (apply my-expand-cave1! args))
((expand-cave-completely!)
(apply my-expand-cave-completely! args))
(else "invalid method")))))
dispatch)))
(define (put-text cellval)
(put-string (case cellval
((0) "|~")
((1) "| ")
((2) "~~")
((3) "' ")
((8) "##")
(else "??"))))
(define (put-maze maze putproc)
(maze 'set! 0 0 open-top)
(let ((width (maze 'width))
(height (maze 'height)))
(let yloop ((y 0))
(if (< y height)
(begin
(let xloop ((x 0))
(if (< x width)
(begin
(putproc (simplified-value (maze 'get x y)))
(xloop (+ x 1)))
(begin
(putproc (if (= y (- height 1))
(+ open-left open-top)
open-top))
(put-newline))))
(yloop (+ y 1)))))
(let xloop ((x 0))
(if (< x width)
(begin
(putproc open-left)
(xloop (+ x 1)))))
(putproc (+ open-left open-top))
(put-newline)
""))
(define (test-maze width height)
(let ((m (make-maze width height)))
(m 'dig-randomly!)
(put-maze m put-text)))
(test-maze 15 15)