149 lines
5.4 KiB
Scheme
149 lines
5.4 KiB
Scheme
|
|
(module graph mzscheme
|
|
(require mzlib/class
|
|
"private/utils.ss")
|
|
(require-for-syntax "private/utils.ss")
|
|
|
|
(provide node% edge%
|
|
grid-graph)
|
|
|
|
(define node%
|
|
(class object%
|
|
(define edges null)
|
|
(define loc #f)
|
|
(define/public (set-location l)
|
|
(set! loc l))
|
|
(define/public (get-location)
|
|
loc)
|
|
(define/public (connect e)
|
|
(set! edges (cons e edges)))
|
|
(define/public (get-edges)
|
|
edges)
|
|
(define/public (edge-to n)
|
|
(ormap (lambda (e)
|
|
(and (memq n (send e get-nodes))
|
|
e))
|
|
edges))
|
|
(super-new)))
|
|
|
|
(define edge%
|
|
(class object%
|
|
(define nodes null)
|
|
(define loc #f)
|
|
(define/public (set-location l)
|
|
(set! loc l))
|
|
(define/public (get-location)
|
|
loc)
|
|
(define/public (connect n)
|
|
(set! nodes (cons n nodes)))
|
|
(define/public (get-nodes)
|
|
nodes)
|
|
(super-new)))
|
|
|
|
(define (check <%> v)
|
|
(unless (v . is-a? . <%>)
|
|
(error 'maze
|
|
"not an instance of ~a: ~e"
|
|
<%>
|
|
v))
|
|
v)
|
|
|
|
(define (connect-all! connect-key layout)
|
|
(define-member-name connect connect-key)
|
|
(let loop ([layout layout]
|
|
[j (sub1 (quotient (length layout) 2))])
|
|
(unless (null? (cdr layout))
|
|
(let loop ([edges (car layout)]
|
|
[nodes (cadr layout)]
|
|
[next-edges (caddr layout)]
|
|
[i 0])
|
|
(unless (null? (cdr nodes))
|
|
(let ([n (car edges)]
|
|
[s (car next-edges)]
|
|
[e (caddr nodes)]
|
|
[w (car nodes)]
|
|
[r (cadr nodes)])
|
|
(send r set-location (list i j))
|
|
(send n set-location (list i (+ j 0.5)))
|
|
(send s set-location (list i (- j 0.5)))
|
|
(send e set-location (list (+ i 0.5) j))
|
|
(send w set-location (list (- i 0.5) j))
|
|
(send r connect n)
|
|
(send r connect s)
|
|
(send r connect e)
|
|
(send r connect w)
|
|
(send n connect r)
|
|
(send s connect r)
|
|
(send e connect r)
|
|
(send w connect r))
|
|
(loop (cdr edges)
|
|
(cddr nodes)
|
|
(cdr next-edges)
|
|
(add1 i))))
|
|
(loop (cddr layout) (sub1 j)))))
|
|
|
|
(define-syntax grid-graph
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(maze edge<%> node<%> (items ...) ...)
|
|
(let ([itemss (syntax->list #'((items ...) ...))])
|
|
(unless (odd? (length itemss))
|
|
(raise-syntax-error
|
|
#f
|
|
"need an odd number of rows"
|
|
stx))
|
|
(let-values ([(edgess nodess) (alternates itemss)])
|
|
(when (null? nodess)
|
|
(raise-syntax-error
|
|
#f
|
|
"no nodes supplied"
|
|
stx))
|
|
(let ([first-edges-len
|
|
(length (syntax->list (car edgess)))])
|
|
(for-each (lambda (edges)
|
|
(let ([len (length (syntax->list edges))])
|
|
(unless (= len first-edges-len)
|
|
(raise-syntax-error
|
|
#f
|
|
"N/S edges sequence length doesn't match first edges sequence"
|
|
stx
|
|
edges))))
|
|
edgess)
|
|
(for-each (lambda (nodes)
|
|
(let ([len (length (syntax->list nodes))])
|
|
(unless (= len (add1 (* 2 first-edges-len)))
|
|
(raise-syntax-error
|
|
#f
|
|
"nodes with E/W edges sequence length doesn't match first edges sequence"
|
|
stx
|
|
nodes))))
|
|
nodess))
|
|
(with-syntax ([((items ...) ...)
|
|
(interleave
|
|
(map (lambda (edges)
|
|
(map (lambda (edge)
|
|
(quasisyntax/loc edge
|
|
(instance edge<%> #,edge)))
|
|
(syntax->list edges)))
|
|
edgess)
|
|
(map (lambda (nodes)
|
|
(let-values ([(edges nodes)
|
|
(alternates (syntax->list nodes))])
|
|
(interleave
|
|
(map (lambda (edge)
|
|
(quasisyntax/loc edge
|
|
(instance edge<%> #,edge)))
|
|
edges)
|
|
(map (lambda (node)
|
|
(quasisyntax/loc node
|
|
(instance node<%> #,node)))
|
|
nodes))))
|
|
nodess))])
|
|
(syntax/loc stx
|
|
(connect-all! (member-name-key connect) (list (list items ...) ...))))))])))
|
|
|
|
(define-syntax instance
|
|
(syntax-rules ()
|
|
[(instance <%> v)
|
|
(check <%> v)])))
|