suzanne.soy/2d
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix unstable/2d/match so that it doesn't duplicate the bodies of

Browse Source 
the cells any more (but still gets the binding right)

The patterns are still being duplicated, so actual code might still
be being duplicated

original commit: 4efdfd6aa9ee435a31316fbd10f3c33c9a01f38f
This commit is contained in:
Robby Findler 2013-08-14 21:20:02 -05:00
parent 6721cf7f42
commit 81f2bbc394
1 changed files with 70 additions and 32 deletions

88
pkgs/gui-pkgs/gui-lib/unstable/2d/match.rkt
View File

@ -1,5 +1,7 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base) (require (for-syntax racket/base
racket/match/parse
racket/match/patterns)
racket/match) racket/match)
(provide 2dmatch) (provide 2dmatch)
@ -10,29 +12,38 @@
;; coord-to-content : hash[(list num num) -o> (listof syntax)] ;; coord-to-content : hash[(list num num) -o> (listof syntax)]
(define coord-to-content (make-hash)) (define coord-to-content (make-hash))
;; pattern-vars : hash[(list num num) -o> (listof identifier)]
;; for each cell on the boundary, tell us which vars are
;; bound in the corresponding pattern
(define pattern-vars (make-hash))
(define let-bindings '()) (define let-bindings '())
(define main-args #f) (define main-args #f)
;; build up the coord-to-content mapping (define (on-boundary? cells)
;; side-effect: record need for let bindings to (ormap (λ (lst) (or (= 0 (list-ref lst 0))
;; cover the the situation where multiple cells (= 0 (list-ref lst 1))))
;; are joined together cells))
;; (this code is similar to that in cond.rkt, but
;; my attempt at abstracting between them was unsuccessful) ;; build up the coord-to-content mapping for the
;; boundary cells and build up the pattern-vars table
(for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))] (for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))]
[rhses (in-list (syntax->list #'((rhs ...) ...)))]) [rhses (in-list (syntax->list #'((rhs ...) ...)))])
(define cells (syntax->datum cells-stx)) (define cells (syntax->datum cells-stx))
(define on-boundary? (ormap (λ (lst) (or (= 0 (list-ref lst 0))
(= 0 (list-ref lst 1))))
cells))
(define rhses-lst (syntax->list rhses)) (define rhses-lst (syntax->list rhses))
(cond (cond
[(member (list 0 0) cells) [(member (list 0 0) cells)
(unless (and rhses-lst (= 2 (length rhses-lst))) (unless (and rhses-lst (= 2 (length rhses-lst)))
(raise-syntax-error '2dmatch "cell at 0,0 must contain two expressions")) (raise-syntax-error '2dmatch "cell at 0,0 must contain two expressions"))
(set! main-args rhses)] (with-syntax ([(left-x right-x) (generate-temporaries rhses)]
[on-boundary? [(left-arg right-arg) rhses])
(set! let-bindings (list* #`[right-x right-arg]
#`[left-x left-arg]
let-bindings))
(set! main-args #'(left-x right-x)))]
[(on-boundary? cells)
(unless (and rhses-lst (= 1 (length rhses-lst))) (unless (and rhses-lst (= 1 (length rhses-lst)))
(raise-syntax-error '2dmatch (raise-syntax-error '2dmatch
(format (format
@ -40,34 +51,61 @@
(list-ref (car cells) 0) (list-ref (car cells) 1) (list-ref (car cells) 0) (list-ref (car cells) 1)
(length rhses-lst)) (length rhses-lst))
stx)) stx))
(hash-set! coord-to-content (car cells) (car (syntax->list rhses)))] (define pat (car (syntax->list rhses)))
[else (hash-set! pattern-vars (car cells) (bound-vars (parse pat)))
(hash-set! coord-to-content (car cells) pat)]))
;; build up the coord-to-content mapping for the non-boundary cells
;; use the pattern-vars table to build up the let-bindings that
;; bind identifiers to functions that end up getting called in the match clauses
(for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))]
[rhses (in-list (syntax->list #'((rhs ...) ...)))])
(define cells (syntax->datum cells-stx))
(define rhses-lst (syntax->list rhses))
(unless (on-boundary? cells)
(when (null? (syntax-e rhses)) (when (null? (syntax-e rhses))
(raise-syntax-error '2dmatch (raise-syntax-error '2dmatch
(format "cell at ~a,~a should not be empty" (format "cell at ~a,~a should not be empty"
(list-ref (car cells) 0) (list-ref (car cells) 0)
(list-ref (car cells) 1)) (list-ref (car cells) 1))
stx)) stx))
;; this code will duplicate the rhses expressions (define horizontal-vars (hash-ref pattern-vars (list (list-ref (car cells) 0) 0)))
;; in the case that there are multiple cells in `cells' (define vertical-vars (hash-ref pattern-vars (list 0 (list-ref (car cells) 1))))
;; it would be better to analyze the corresponding
;; match patterns and then stick the code in a function (define (intersect vs1 vs2)
;; whose arguments are the intersection of the bound variables (for/list ([v1 (in-list vs1)]
;; (supplying the arguments in a call in the cell) #:when (is-in? v1 vs2))
v1))
(define (is-in? v1 v2s)
(for/or ([v2 (in-list v2s)])
(free-identifier=? v1 v2)))
(for ([cell (in-list (cdr cells))])
(set! horizontal-vars (intersect horizontal-vars
(hash-ref pattern-vars (list (list-ref cell 0) 0))))
(set! vertical-vars (intersect vertical-vars
(hash-ref pattern-vars (list 0 (list-ref cell 1))))))
(with-syntax ([(id) (generate-temporaries (list (format "2d-~a-~a"
(list-ref (car cells) 0)
(list-ref (car cells) 1))))])
(define app #`(id #,@horizontal-vars #,@vertical-vars))
(for ([cell (in-list cells)]) (for ([cell (in-list cells)])
(hash-set! coord-to-content (hash-set! coord-to-content cell app))
cell (set! let-bindings
(syntax->list rhses)))])) (cons #`[id (λ (#,@horizontal-vars #,@vertical-vars) #,@rhses)]
let-bindings)))))
(define num-of-cols (length (syntax->list #'widths))) (define num-of-cols (length (syntax->list #'widths)))
(define num-of-rows (length (syntax->list #'heights))) (define num-of-rows (length (syntax->list #'heights)))
#`(let #,let-bindings #`(let #,(reverse let-bindings)
(match* #,main-args (match* #,main-args
#,@(for*/list ([x (in-range 1 num-of-cols)] #,@(for*/list ([x (in-range 1 num-of-cols)]
[y (in-range 1 num-of-rows)]) [y (in-range 1 num-of-rows)])
#`[(#,(hash-ref coord-to-content (list x 0)) #`[(#,(hash-ref coord-to-content (list x 0))
#,(hash-ref coord-to-content (list 0 y))) #,(hash-ref coord-to-content (list 0 y)))
(let () #,@(hash-ref coord-to-content (list x y)))]) #,(hash-ref coord-to-content (list x y))])
[(_ _) [(_ _)
(2dmatch-error #,@main-args)])))])) (2dmatch-error #,@main-args)])))]))