maze.scm

Scheme跨平台编译器

      (do ((c 0 (+ c 1))
           (i (* r ncols) (+ i 1)))
          ((= c ncols))
        (vector-set! v i (proc (* 3 c) (+ (* 2 r) (bitwise-and c 1))))))

    (make-harr nrows ncols v)))


(define (harr-for-each proc harr)
  (vector-for-each proc (harr:elts harr)))

;------------------------------------------------------------------------------
; Was file "hex.scm".

;;; Hexagonal hackery for maze generation.
;;; Copyright (c) 1995 by Olin Shivers.

;;; External dependencies:
;;; - cell and wall records
;;; - Functional Postscript for HEXES->PATH
;;; - logical functions for bit hacking
;;; - hex array code.

;;; To have the maze span (0,0) to (1,1):
;;; (scale (/ (+ 1 (* 3 ncols))) (/ (+ 1 (* 2 nrows)))
;;;        (translate (point 2 1) maze))

;;; Every elt of the hex array manages his SW, S, and SE wall.
;;; Terminology: - An even column is one whose column index is even. That
;;;                means the first, third, ... columns (indices 0, 2, ...).
;;;              - An odd column is one whose column index is odd. That
;;;                means the second, fourth... columns (indices 1, 3, ...).
;;;              The even/odd flip-flop is confusing; be careful to keep it
;;;              straight. The *even* columns are the low ones. The *odd*
;;;              columns are the high ones.
;;;    _   _
;;;  _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/
;;;  0 1 2 3

(define south-west 1)
(define south      2)
(define south-east 4)

(define (gen-maze-array r c)
  (harr-tabulate r c (lambda (x y) (make-cell (base-set 1) (cons x y)))))

;;; This could be made more efficient.
(define (make-wall-vec harr)
  (let* ((nrows (harr:nrows harr))
         (ncols (harr:ncols harr))
         (xmax (* 3 (- ncols 1)))

         ;; Accumulate walls.
         (walls '())
         (add-wall (lambda (o n b) ; owner neighbor bit
                     (set! walls (cons (make-wall o n b) walls)))))
        
    ;; Do everything but the bottom row.
    (do ((x (* (- ncols 1) 3) (- x 3)))
        ((< x 0))
      (do ((y (+ (* (- nrows 1) 2) (bitwise-and x 1))
              (- y 2)))
          ((<= y 1))    ; Don't do bottom row.
          (let ((hex (href harr x y)))
            (if (not (zero? x))
                (add-wall hex (href harr (- x 3) (- y 1)) south-west))
            (add-wall hex (href harr x (- y 2)) south)
            (if (< x xmax)
                (add-wall hex (href harr (+ x 3) (- y 1)) south-east)))))

    ;; Do the SE and SW walls of the odd columns on the bottom row.
    ;; If the rightmost bottom hex lies in an odd column, however,
    ;; don't add it's SE wall -- it's a corner hex, and has no SE neighbor.
    (if (> ncols 1)
        (let ((rmoc-x (+ 3 (* 6 (quotient (- ncols 2) 2)))))
          ;; Do rightmost odd col.
          (let ((rmoc-hex (href harr rmoc-x 1)))
            (if (< rmoc-x xmax) ; Not  a corner -- do E wall.
                (add-wall rmoc-hex (href harr xmax 0) south-east))
            (add-wall rmoc-hex (href harr (- rmoc-x 3) 0) south-west))

          (do ((x (- rmoc-x 6) ; Do the rest of the bottom row's odd cols.
                  (- x 6)))
              ((< x 3)) ; 3 is X coord of leftmost odd column.
            (add-wall (href harr x 1) (href harr (- x 3) 0) south-west)
            (add-wall (href harr x 1) (href harr (+ x 3) 0) south-east))))

    (list->vector walls)))


;;; Find the cell ctop from the top row, and the cell cbot from the bottom
;;; row such that cbot is furthest from ctop. 
;;; Return [ctop-x, ctop-y, cbot-x, cbot-y].

(define (pick-entrances harr)
  (dfs-maze harr (href/rc harr 0 0) for-each-hex-child)
  (let ((nrows (harr:nrows harr))
        (ncols (harr:ncols harr)))
    (let tp-lp ((max-len -1)
                (entrance #f)
                (exit #f)
                (tcol (- ncols 1)))
      (if (< tcol 0) (vector entrance exit)
          (let ((top-cell (href/rc harr (- nrows 1) tcol)))
            (reroot-maze top-cell)
            (let ((result
                    (let bt-lp ((max-len max-len)
                                (entrance entrance)
                                (exit exit)
                                (bcol (- ncols 1)))
;                     (format #t "~a ~a ~a ~a~%" max-len entrance exit bcol)
                      (if (< bcol 0) (vector max-len entrance exit)
                          (let ((this-len (path-length (href/rc harr 0 bcol))))
                            (if (> this-len max-len)
                                (bt-lp this-len tcol bcol (- bcol 1))
                                (bt-lp max-len  entrance exit (- bcol 1))))))))
              (let ((max-len (vector-ref result 0))
                    (entrance (vector-ref result 1))
                    (exit (vector-ref result 2)))
                (tp-lp max-len entrance exit (- tcol 1)))))))))
                


;;; Apply PROC to each node reachable from CELL.
(define (for-each-hex-child proc harr cell)
  (let* ((walls (cell:walls cell))
         (id (cell:id cell))
         (x (car id))
         (y (cdr id))
         (nr (harr:nrows harr))
         (nc (harr:ncols harr))
         (maxy (* 2 (- nr 1)))
         (maxx (* 3 (- nc 1))))
    (if (not (bit-test walls south-west)) (proc (href harr (- x 3) (- y 1))))
    (if (not (bit-test walls south))      (proc (href harr x       (- y 2))))
    (if (not (bit-test walls south-east)) (proc (href harr (+ x 3) (- y 1))))

    ;; NW neighbor, if there is one (we may be in col 1, or top row/odd col)
    (if (and (> x 0)    ; Not in first column.
             (or (<= y maxy)            ; Not on top row or
                 (zero? (modulo x 6)))) ; not in an odd column.
        (let ((nw (href harr (- x 3) (+ y 1))))
          (if (not (bit-test (cell:walls nw) south-east)) (proc nw))))

    ;; N neighbor, if there is one (we may be on top row).
    (if (< y maxy)              ; Not on top row
        (let ((n (href harr x (+ y 2))))
          (if (not (bit-test (cell:walls n) south)) (proc n))))

    ;; NE neighbor, if there is one (we may be in last col, or top row/odd col)
    (if (and (< x maxx) ; Not in last column.
             (or (<= y maxy)            ; Not on top row or
                 (zero? (modulo x 6)))) ; not in an odd column.
        (let ((ne (href harr (+ x 3) (+ y 1))))
          (if (not (bit-test (cell:walls ne) south-west)) (proc ne))))))



;;; The top-level
(define (make-maze nrows ncols)
  (let* ((cells (gen-maze-array nrows ncols))
         (walls (permute-vec! (make-wall-vec cells) (random-state 20))))
    (dig-maze walls (* nrows ncols))
    (let ((result (pick-entrances cells)))
      (let ((entrance (vector-ref result 0))
            (exit (vector-ref result 1)))
        (let* ((exit-cell (href/rc cells 0 exit))
               (walls (cell:walls exit-cell)))
          (reroot-maze (href/rc cells (- nrows 1) entrance))
          (mark-path exit-cell)
          (set-cell:walls exit-cell (bitwise-and walls (bitwise-not south)))
          (vector cells entrance exit))))))


(define (pmaze nrows ncols)
  (let ((result (make-maze nrows ncols)))
    (let ((cells (vector-ref result 0))
          (entrance (vector-ref result 1))
          (exit (vector-ref result 2)))
      (print-hexmaze cells entrance))))

;------------------------------------------------------------------------------
; Was file "hexprint.scm".

;;; Print out a hex array with characters.
;;; Copyright (c) 1995 by Olin Shivers.

;;; External dependencies:
;;; - hex array code
;;; - hex cell code

;;;    _   _
;;;  _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ 

;;; Top part of top row looks like this:
;;;    _   _  _   _
;;;  _/ \_/ \/ \_/ \
;;; /        

(define output #f) ; the list of all characters written out, in reverse order.

(define (write-ch c)
  (set! output (cons c output)))

(define (print-hexmaze harr entrance)
  (let* ((nrows  (harr:nrows harr))
         (ncols  (harr:ncols harr))
         (ncols2 (* 2 (quotient ncols 2))))

    ;; Print out the flat tops for the top row's odd cols.
    (do ((c 1 (+ c 2)))
        ((>= c ncols))
;     (display "   ")
      (write-ch #\space)
      (write-ch #\space)
      (write-ch #\space)
      (write-ch (if (= c entrance) #\space #\_)))
;   (newline)
    (write-ch #\newline)

    ;; Print out the slanted tops for the top row's odd cols
    ;; and the flat tops for the top row's even cols.
    (write-ch #\space)
    (do ((c 0 (+ c 2)))
        ((>= c ncols2))
;     (format #t "~a/~a\\"
;             (if (= c entrance) #\space #\_)
;             (dot/space harr (- nrows 1) (+ c 1)))
      (write-ch (if (= c entrance) #\space #\_))
      (write-ch #\/)
      (write-ch (dot/space harr (- nrows 1) (+ c 1)))
      (write-ch #\\))
    (if (odd? ncols)
        (write-ch (if (= entrance (- ncols 1)) #\space #\_)))
;   (newline)
    (write-ch #\newline)

    (do ((r (- nrows 1) (- r 1)))
        ((< r 0))

      ;; Do the bottoms for row r's odd cols.
      (write-ch #\/)
      (do ((c 1 (+ c 2)))
          ((>= c ncols2))
        ;; The dot/space for the even col just behind c.
        (write-ch (dot/space harr r (- c 1)))
        (display-hexbottom (cell:walls (href/rc harr r c))))    

      (cond ((odd? ncols)
             (write-ch (dot/space harr r (- ncols 1)))
             (write-ch #\\)))
;     (newline)
      (write-ch #\newline)

      ;; Do the bottoms for row r's even cols.
      (do ((c 0 (+ c 2)))
          ((>= c ncols2))
        (display-hexbottom (cell:walls (href/rc harr r c)))
        ;; The dot/space is for the odd col just after c, on row below.
        (write-ch (dot/space harr (- r 1) (+ c 1))))
      
      (cond ((odd? ncols)
             (display-hexbottom (cell:walls (href/rc harr r (- ncols 1)))))
            ((not (zero? r)) (write-ch #\\)))
;     (newline)
      (write-ch #\newline))))

(define (bit-test j bit)
  (not (zero? (bitwise-and j bit))))

;;; Return a . if harr[r,c] is marked, otherwise a space.
;;; We use the dot to mark the solution path.
(define (dot/space harr r c)
  (if (and (>= r 0) (cell:mark (href/rc harr r c))) #\. #\space))

;;; Print a \_/ hex bottom.
(define (display-hexbottom hexwalls)
  (write-ch (if (bit-test hexwalls south-west) #\\ #\space))
  (write-ch (if (bit-test hexwalls south     ) #\_ #\space))
  (write-ch (if (bit-test hexwalls south-east) #\/ #\space)))

;;;    _   _
;;;  _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \_/
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \_/

;------------------------------------------------------------------------------

(define (run)
  (do ((i 100 (- i 1)))
      ((zero? i) (reverse output))
    (set! output '())
    (pmaze 20 7) ) )

(let ((x (time (run))))
;  (for-each display x)
  (if (not (equal? x '
(#\  #\  #\  #\_ #\  #\  #\  #\_ #\  #\  #\  #\_ #\newline
 #\  #\_ #\/ #\  #\\ #\_ #\/ #\  #\\ #\_ #\/ #\. #\\ #\  #\newline
 #\/ #\  #\\ #\  #\  #\  #\\ #\_ #\  #\. #\  #\  #\/ #\. #\\ #\newline
 #\\ #\  #\  #\  #\\ #\  #\/ #\. #\  #\_ #\/ #\. #\\ #\  #\/ #\newline
 #\/ #\  #\\ #\_ #\/ #\. #\  #\_ #\/ #\  #\\ #\_ #\  #\. #\\ #\newline
 #\\ #\  #\/ #\  #\\ #\  #\/ #\  #\  #\_ #\/ #\  #\\ #\_ #\/ #\newline
 #\/ #\  #\  #\_ #\/ #\. #\\ #\  #\/ #\  #\\ #\  #\/ #\  #\\ #\newline
 #\\ #\  #\/ #\  #\\ #\  #\/ #\  #\  #\_ #\/ #\  #\  #\  #\/ #\newline
 #\/ #\  #\\ #\  #\/ #\. #\\ #\  #\/ #\. #\\ #\_ #\/ #\  #\\ #\newline
 #\\ #\_ #\/ #\  #\\ #\  #\/ #\. #\  #\_ #\  #\. #\\ #\  #\/ #\newline
 #\/ #\  #\\ #\_ #\  #\. #\  #\_ #\/ #\  #\\ #\  #\  #\  #\\ #\newline
 #\\ #\_ #\  #\  #\\ #\_ #\/ #\  #\  #\_ #\/ #\. #\\ #\  #\/ #\newline
 #\/ #\  #\  #\_ #\/ #\  #\  #\  #\/ #\  #\\ #\  #\/ #\  #\\ #\newline
 #\\ #\_ #\  #\  #\\ #\  #\/ #\  #\\ #\_ #\  #\. #\\ #\_ #\/ #\newline
 #\/ #\  #\\ #\_ #\  #\  #\\ #\_ #\  #\  #\\ #\_ #\  #\. #\\ #\newline
 #\\ #\_ #\  #\  #\\ #\_ #\/ #\  #\  #\_ #\/ #\. #\\ #\  #\/ #\newline
 #\/ #\  #\\ #\_ #\  #\  #\\ #\  #\/ #\. #\\ #\  #\  #\. #\\ #\newline
 #\\ #\  #\/ #\. #\\ #\_ #\  #\. #\  #\  #\/ #\. #\\ #\  #\/ #\newline
 #\/ #\  #\  #\  #\  #\. #\  #\_ #\/ #\. #\\ #\  #\/ #\  #\\ #\newline
 #\\ #\  #\/ #\. #\\ #\_ #\/ #\. #\\ #\_ #\  #\. #\\ #\  #\/ #\newline
 #\/ #\  #\\ #\_ #\  #\. #\  #\  #\/ #\  #\  #\_ #\/ #\  #\\ #\newline
 #\\ #\_ #\  #\  #\\ #\_ #\/ #\. #\\ #\_ #\  #\  #\\ #\_ #\/ #\newline
 #\/ #\  #\  #\_ #\/ #\  #\\ #\  #\/ #\  #\\ #\_ #\  #\  #\\ #\newline
 #\\ #\_ #\/ #\  #\  #\_ #\/ #\. #\\ #\_ #\  #\  #\\ #\_ #\/ #\newline
 #\/ #\  #\\ #\  #\/ #\  #\  #\_ #\  #\. #\  #\_ #\  #\  #\\ #\newline
 #\\ #\  #\/ #\  #\\ #\_ #\/ #\. #\  #\_ #\  #\  #\\ #\_ #\/ #\newline
 #\/ #\  #\  #\_ #\  #\  #\\ #\  #\  #\  #\\ #\_ #\/ #\  #\\ #\newline
 #\\ #\_ #\/ #\. #\\ #\_ #\  #\. #\\ #\_ #\/ #\  #\  #\_ #\/ #\newline
 #\/ #\  #\\ #\  #\  #\. #\  #\_ #\/ #\  #\  #\  #\/ #\  #\\ #\newline
 #\\ #\  #\/ #\. #\\ #\_ #\/ #\  #\\ #\_ #\/ #\. #\\ #\  #\/ #\newline
 #\/ #\  #\\ #\_ #\  #\. #\  #\_ #\/ #\. #\  #\  #\  #\  #\\ #\newline
 #\\ #\  #\  #\  #\  #\  #\  #\. #\  #\  #\/ #\. #\\ #\_ #\/ #\newline
 #\/ #\  #\\ #\_ #\/ #\  #\\ #\_ #\/ #\  #\\ #\_ #\  #\. #\\ #\newline
 #\\ #\_ #\/ #\  #\  #\  #\/ #\  #\\ #\_ #\/ #\. #\  #\  #\/ #\newline
 #\/ #\  #\  #\  #\/ #\  #\  #\_ #\  #\  #\\ #\  #\/ #\  #\\ #\newline
 #\\ #\_ #\/ #\  #\\ #\_ #\/ #\  #\\ #\_ #\/ #\. #\\ #\_ #\/ #\newline
 #\/ #\  #\\ #\_ #\/ #\  #\  #\_ #\/ #\  #\\ #\_ #\  #\. #\\ #\newline
 #\\ #\  #\  #\  #\  #\_ #\/ #\. #\  #\  #\/ #\. #\  #\_ #\/ #\newline
 #\/ #\  #\\ #\  #\/ #\. #\  #\  #\/ #\  #\\ #\_ #\  #\. #\\ #\newline
 #\\ #\_ #\/ #\. #\  #\_ #\/ #\. #\\ #\_ #\/ #\. #\\ #\  #\/ #\newline
 #\/ #\  #\  #\_ #\  #\. #\\ #\_ #\  #\. #\  #\_ #\  #\. #\\ #\newline
 #\\ #\_ #\/ #\  #\\ #\  #\/ #\  #\\ #\_ #\/ #\  #\\ #\_ #\/ #\newline)))
(error "wrong result") ) )