maze.scm

Scheme跨平台编译器

;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers.

; 18/07/01 (felix): 100 iterations

;------------------------------------------------------------------------------
; Was file "rand.scm".

; Minimal Standard Random Number Generator
; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version.
; better constants, as proposed by Park.
; By Ozan Yigit

;;; Rehacked by Olin 4/1995.

(define (random-state n)
  (cons n #f))

(define (rand state)
  (let ((seed (car state))
        (A 2813) ; 48271
        (M 8388607) ; 2147483647
        (Q 2787) ; 44488
        (R 2699)) ; 3399
    (let* ((hi (quotient seed Q))
           (lo (modulo seed Q))
           (test (- (* A lo) (* R hi)))
           (val (if (> test 0) test (+ test M))))
      (set-car! state val)
      val)))

(define (random-int n state)
  (modulo (rand state) n))

; poker test
; seed 1
; cards 0-9 inclusive (random 10)
; five cards per hand
; 10000 hands
;
; Poker Hand     Example    Probability  Calculated
; 5 of a kind    (aaaaa)      0.0001      0
; 4 of a kind    (aaaab)      0.0045      0.0053
; Full house     (aaabb)      0.009       0.0093
; 3 of a kind    (aaabc)      0.072       0.0682
; two pairs      (aabbc)      0.108       0.1104
; Pair           (aabcd)      0.504       0.501
; Bust           (abcde)      0.3024      0.3058

; (define (random n)
;   (let* ((M 2147483647)
;        (slop (modulo M n)))
;     (let loop ((r (rand)))
;       (if (> r slop)
;         (modulo r n)  
;         (loop (rand))))))
; 
; (define (rngtest)
;   (display "implementation ")
;   (srand 1)
;   (let loop ((n 0))
;     (if (< n 10000)
;         (begin
;          (rand)
;          (loop (1+ n)))))
;   (if (= *seed* 399268537)
;       (display "looks correct.")
;       (begin
;        (display "failed.")
;        (newline)
;        (display "   current seed ") (display *seed*)
;        (newline)
;        (display "   correct seed 399268537")))
;   (newline))

;------------------------------------------------------------------------------
; Was file "uf.scm".

;;; Tarjan's amortised union-find data structure.
;;; Copyright (c) 1995 by Olin Shivers.

;;; This data structure implements disjoint sets of elements.
;;; Four operations are supported. The implementation is extremely
;;; fast -- any sequence of N operations can be performed in time
;;; so close to linear it's laughable how close it is. See your
;;; intro data structures book for more. The operations are:
;;;
;;; - (base-set nelts) -> set
;;;   Returns a new set, of size NELTS.
;;;
;;; - (set-size s) -> integer
;;;   Returns the number of elements in set S.
;;;
;;; - (union! set1 set2)
;;;   Unions the two sets -- SET1 and SET2 are now considered the same set
;;;   by SET-EQUAL?.
;;;
;;; - (set-equal? set1 set2)
;;;   Returns true <==> the two sets are the same.

;;; Representation: a set is a cons cell. Every set has a "representative"
;;; cons cell, reached by chasing cdr links until we find the cons with
;;; cdr = (). Set equality is determined by comparing representatives using
;;; EQ?. A representative's car contains the number of elements in the set.

;;; The speed of the algorithm comes because when we chase links to find 
;;; representatives, we collapse links by changing all the cells in the path
;;; we followed to point directly to the representative, so that next time
;;; we walk the cdr-chain, we'll go directly to the representative in one hop.


(define (base-set nelts) (cons nelts '()))

;;; Sets are chained together through cdr links. Last guy in the chain
;;; is the root of the set.

(define (get-set-root s)
  (let lp ((r s))                       ; Find the last pair
    (let ((next (cdr r)))               ; in the list. That's
      (cond ((pair? next) (lp next))    ; the root r.

            (else
             (if (not (eq? r s))        ; Now zip down the list again,
                 (let lp ((x s))        ; changing everyone's cdr to r.
                   (let ((next (cdr x)))        
                     (cond ((not (eq? r next))
                            (set-cdr! x r)
                            (lp next))))))
             r)))))                     ; Then return r.

(define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2)))

(define (set-size s) (car (get-set-root s)))

(define (union! s1 s2)
  (let* ((r1 (get-set-root s1))
         (r2 (get-set-root s2))
         (n1 (set-size r1))
         (n2 (set-size r2))
         (n  (+ n1 n2)))

    (cond ((> n1 n2)
           (set-cdr! r2 r1)
           (set-car! r1 n))
          (else
           (set-cdr! r1 r2)
           (set-car! r2 n)))))

;------------------------------------------------------------------------------
; Was file "maze.scm".

;;; Building mazes with union/find disjoint sets.
;;; Copyright (c) 1995 by Olin Shivers.

;;; This is the algorithmic core of the maze constructor.
;;; External dependencies:
;;; - RANDOM-INT
;;; - Union/find code
;;; - bitwise logical functions

; (define-record wall
;   owner         ; Cell that owns this wall.
;   neighbor      ; The other cell bordering this wall.
;   bit)          ; Integer -- a bit identifying this wall in OWNER's cell.

; (define-record cell
;   reachable     ; Union/find set -- all reachable cells.
;   id            ; Identifying info (e.g., the coords of the cell).
;   (walls -1)    ; A bitset telling which walls are still standing.
;   (parent #f)   ; For DFS spanning tree construction.
;   (mark #f))    ; For marking the solution path.

(define (make-wall owner neighbor bit)
  (vector 'wall owner neighbor bit))

(define (wall:owner o)          (vector-ref o 1))
(define (set-wall:owner o v)    (vector-set! o 1 v))
(define (wall:neighbor o)       (vector-ref o 2))
(define (set-wall:neighbor o v) (vector-set! o 2 v))
(define (wall:bit o)            (vector-ref o 3))
(define (set-wall:bit o v)      (vector-set! o 3 v))

(define (make-cell reachable id)
  (vector 'cell reachable id -1 #f #f))

(define (cell:reachable o)       (vector-ref o 1))
(define (set-cell:reachable o v) (vector-set! o 1 v))
(define (cell:id o)              (vector-ref o 2))
(define (set-cell:id o v)        (vector-set! o 2 v))
(define (cell:walls o)           (vector-ref o 3))
(define (set-cell:walls o v)     (vector-set! o 3 v))
(define (cell:parent o)          (vector-ref o 4))
(define (set-cell:parent o v)    (vector-set! o 4 v))
(define (cell:mark o)            (vector-ref o 5))
(define (set-cell:mark o v)      (vector-set! o 5 v))

;;; Iterates in reverse order.

(define (vector-for-each proc v)
  (let lp ((i (- (vector-length v) 1)))
    (cond ((>= i 0)
           (proc (vector-ref v i))
           (lp (- i 1))))))


;;; Randomly permute a vector.

(define (permute-vec! v random-state)
  (let lp ((i (- (vector-length v) 1)))
    (cond ((> i 1)
           (let ((elt-i (vector-ref v i))
                 (j (random-int i random-state)))       ; j in [0,i)
             (vector-set! v i (vector-ref v j))
             (vector-set! v j elt-i))
           (lp (- i 1)))))
  v)


;;; This is the core of the algorithm.

(define (dig-maze walls ncells)
  (call-with-current-continuation
    (lambda (quit)
      (vector-for-each
       (lambda (wall)                   ; For each wall,
         (let* ((c1   (wall:owner wall)) ; find the cells on
                (set1 (cell:reachable c1))

                (c2   (wall:neighbor wall)) ; each side of the wall
                (set2 (cell:reachable c2)))

           ;; If there is no path from c1 to c2, knock down the
           ;; wall and union the two sets of reachable cells.
           ;; If the new set of reachable cells is the whole set
           ;; of cells, quit.
           (if (not (set-equal? set1 set2))
               (let ((walls (cell:walls c1))    
                     (wall-mask (bitwise-not (wall:bit wall))))
                 (union! set1 set2)
                 (set-cell:walls c1 (bitwise-and walls wall-mask))
                 (if (= (set-size set1) ncells) (quit #f))))))
       walls))))


;;; Some simple DFS routines useful for determining path length 
;;; through the maze.

;;; Build a DFS tree from ROOT. 
;;; (DO-CHILDREN proc maze node) applies PROC to each of NODE's children.
;;; We assume there are no loops in the maze; if this is incorrect, the
;;; algorithm will diverge.

(define (dfs-maze maze root do-children)
  (let search ((node root) (parent #f))
    (set-cell:parent node parent)
    (do-children (lambda (child)
                   (if (not (eq? child parent))
                       (search child node)))
                 maze node)))

;;; Move the root to NEW-ROOT.

(define (reroot-maze new-root)
  (let lp ((node new-root) (new-parent #f))
    (let ((old-parent (cell:parent node)))
      (set-cell:parent node new-parent)
      (if old-parent (lp old-parent node)))))

;;; How far from CELL to the root?

(define (path-length cell)
  (do ((len 0 (+ len 1))
       (node (cell:parent cell) (cell:parent node)))
      ((not node) len)))

;;; Mark the nodes from NODE back to root. Used to mark the winning path.

(define (mark-path node)
  (let lp ((node node))
    (set-cell:mark node #t)
    (cond ((cell:parent node) => lp))))

;------------------------------------------------------------------------------
; Was file "harr.scm".

;;; Hex arrays
;;; Copyright (c) 1995 by Olin Shivers.

;;; External dependencies:
;;; - define-record

;;;        ___       ___       ___
;;;       /   \     /   \     /   \
;;;   ___/  A  \___/  A  \___/  A  \___
;;;  /   \     /   \     /   \     /   \
;;; /  A  \___/  A  \___/  A  \___/  A  \
;;; \     /   \     /   \     /   \     /
;;;  \___/     \___/     \___/     \___/
;;;  /   \     /   \     /   \     /   \
;;; /     \___/     \___/     \___/     \
;;; \     /   \     /   \     /   \     /
;;;  \___/     \___/     \___/     \___/
;;;  /   \     /   \     /   \     /   \
;;; /     \___/     \___/     \___/     \
;;; \     /   \     /   \     /   \     /
;;;  \___/     \___/     \___/     \___/

;;; Hex arrays are indexed by the (x,y) coord of the center of the hexagonal
;;; element. Hexes are three wide and two high; e.g., to get from the center
;;; of an elt to its {NW, N, NE} neighbors, add {(-3,1), (0,2), (3,1)}
;;; respectively.
;;;
;;; Hex arrays are represented with a matrix, essentially made by shoving the
;;; odd columns down a half-cell so things line up. The mapping is as follows:
;;;     Center coord      row/column
;;;     ------------      ----------
;;;     (x,  y)        -> (y/2, x/3)
;;;     (3c, 2r + c&1) <- (r,   c)


; (define-record harr
;   nrows
;   ncols
;   elts)

(define (make-harr nrows ncols elts)
  (vector 'harr nrows ncols elts))

(define (harr:nrows o)       (vector-ref o 1))
(define (set-harr:nrows o v) (vector-set! o 1 v))
(define (harr:ncols o)       (vector-ref o 2))
(define (set-harr:ncols o v) (vector-set! o 2 v))
(define (harr:elts o)        (vector-ref o 3))
(define (set-harr:elts o v)  (vector-set! o 3 v))

(define (harr r c)
  (make-harr r c (make-vector (* r c))))



(define (href ha x y)
  (let ((r (quotient y 2))
        (c (quotient x 3)))
    (vector-ref (harr:elts ha)
                (+ (* (harr:ncols ha) r) c))))

(define (hset! ha x y val)
  (let ((r (quotient y 2))
        (c (quotient x 3)))
    (vector-set! (harr:elts ha)
                 (+ (* (harr:ncols ha) r) c)
                 val)))

(define (href/rc ha r c)
    (vector-ref (harr:elts ha)
                (+ (* (harr:ncols ha) r) c)))

;;; Create a nrows x ncols hex array. The elt centered on coord (x, y)
;;; is the value returned by (PROC x y).

(define (harr-tabulate nrows ncols proc)
  (let ((v (make-vector (* nrows ncols))))

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