/usr/share/racket/pkgs/2d-lib/cond.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | #lang racket/base
(require (for-syntax racket/base))
(provide 2dcond)
(define-syntax (2dcond stx)
(syntax-case stx ()
[(_ widths heights
[(cell ...) rhs ...] ...)
(let ()
(define last-col (- (length (syntax->list #'widths)) 1))
(define last-row (- (length (syntax->list #'heights)) 1))
;; coord-to-content : hash[(list num num) -o> (listof syntax)]
(define coord-to-content (make-hash))
(define let-bindings '())
;; build up the coord-to-content mapping
;; side-effect: record need for let bindings to
;; cover the the situation where multiple cells
;; are joined together
(for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))]
[rhses (in-list (syntax->list #'((rhs ...) ...)))])
(define cells (syntax->datum cells-stx))
(cond
[(member (list 0 0) cells)
(unless (null? (syntax-e rhses))
(raise-syntax-error '2dcond
"cell at 0,0 must be empty"
stx))]
[else
(when (null? (syntax-e rhses))
(raise-syntax-error '2dcond
(format "cell at ~a,~a must not be empty"
(list-ref (car cells) 0)
(list-ref (car cells) 1))
stx))])
(cond
[(member (list 0 0) cells) (void)]
[(and (or (member (list 0 last-row) cells)
(member (list last-col 0) cells))
(syntax-case rhses (else)
[(else) #t]
[_ #f]))
;; found an 'else' (in a reasonable place)
;; => treat it like a #t in that cell
(hash-set! coord-to-content
(car cells)
(list #'#t))]
[(and
;; only one cell:
(null? (cdr cells))
;; not in the left-edge (questions)
(not (= 0 (car (car cells)))))
;; then we don't need a let binding
(hash-set! coord-to-content
(car cells)
(syntax->list rhses))]
[else
(for ([cell (in-list cells)])
(define x (list-ref cell 0))
(define y (list-ref cell 1))
(with-syntax ([(id) (generate-temporaries (list (format "2dcond~a-~a" x y)))]
[(rhs ...) rhses])
(set! let-bindings (cons #`[id (λ () rhs ...)]
let-bindings))
(hash-set! coord-to-content cell (list #'(id)))))]))
(define num-of-cols (length (syntax->list #'widths)))
(define num-of-rows (length (syntax->list #'heights)))
#`(let #,let-bindings
#,(for/fold ([else-branch #'(2dcond-runtime-error #f)])
([x-flip (in-range 1 num-of-cols)])
(define x (- num-of-cols x-flip))
#`(if (let () #,@(hash-ref coord-to-content (list x 0)))
(cond
#,@(for/list ([y (in-range 1 num-of-rows)])
#`[(let () #,@(hash-ref coord-to-content (list 0 y)))
#,@(hash-ref coord-to-content (list x y))])
[else (2dcond-runtime-error #,x)])
#,else-branch))))]))
(define (2dcond-runtime-error dir)
(define str
(if dir
(format "all of the y-direction questions were false (x coordinate ~a was true)"
dir)
"all of the x-direction questions were false"))
(error '2dcond str))
|