From 81f2bbc3949c113e2c9ff4691cdb44bc58958c03 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 14 Aug 2013 21:20:02 -0500 Subject: [PATCH] fix unstable/2d/match so that it doesn't duplicate the bodies of 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 --- pkgs/gui-pkgs/gui-lib/unstable/2d/match.rkt | 102 ++++++++++++++------ 1 file changed, 70 insertions(+), 32 deletions(-) diff --git a/pkgs/gui-pkgs/gui-lib/unstable/2d/match.rkt b/pkgs/gui-pkgs/gui-lib/unstable/2d/match.rkt index 3f2d7b5..e2bd199 100644 --- a/pkgs/gui-pkgs/gui-lib/unstable/2d/match.rkt +++ b/pkgs/gui-pkgs/gui-lib/unstable/2d/match.rkt @@ -1,5 +1,7 @@ #lang racket/base -(require (for-syntax racket/base) +(require (for-syntax racket/base + racket/match/parse + racket/match/patterns) racket/match) (provide 2dmatch) @@ -10,29 +12,38 @@ ;; coord-to-content : hash[(list num num) -o> (listof syntax)] (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 main-args #f) - ;; 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 - ;; (this code is similar to that in cond.rkt, but - ;; my attempt at abstracting between them was unsuccessful) + (define (on-boundary? cells) + (ormap (λ (lst) (or (= 0 (list-ref lst 0)) + (= 0 (list-ref lst 1)))) + cells)) + + ;; 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 ...) ...)))] [rhses (in-list (syntax->list #'((rhs ...) ...)))]) (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)) (cond [(member (list 0 0) cells) (unless (and rhses-lst (= 2 (length rhses-lst))) (raise-syntax-error '2dmatch "cell at 0,0 must contain two expressions")) - (set! main-args rhses)] - [on-boundary? + (with-syntax ([(left-x right-x) (generate-temporaries rhses)] + [(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))) (raise-syntax-error '2dmatch (format @@ -40,34 +51,61 @@ (list-ref (car cells) 0) (list-ref (car cells) 1) (length rhses-lst)) stx)) - (hash-set! coord-to-content (car cells) (car (syntax->list rhses)))] - [else - (when (null? (syntax-e rhses)) - (raise-syntax-error '2dmatch - (format "cell at ~a,~a should not be empty" - (list-ref (car cells) 0) - (list-ref (car cells) 1)) - stx)) - ;; this code will duplicate the rhses expressions - ;; in the case that there are multiple cells in `cells' - ;; it would be better to analyze the corresponding - ;; match patterns and then stick the code in a function - ;; whose arguments are the intersection of the bound variables - ;; (supplying the arguments in a call in the cell) - (for ([cell (in-list cells)]) - (hash-set! coord-to-content - cell - (syntax->list rhses)))])) + (define pat (car (syntax->list rhses))) + (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)) + (raise-syntax-error '2dmatch + (format "cell at ~a,~a should not be empty" + (list-ref (car cells) 0) + (list-ref (car cells) 1)) + stx)) + (define horizontal-vars (hash-ref pattern-vars (list (list-ref (car cells) 0) 0))) + (define vertical-vars (hash-ref pattern-vars (list 0 (list-ref (car cells) 1)))) + + (define (intersect vs1 vs2) + (for/list ([v1 (in-list vs1)] + #: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)]) + (hash-set! coord-to-content cell app)) + (set! let-bindings + (cons #`[id (λ (#,@horizontal-vars #,@vertical-vars) #,@rhses)] + let-bindings))))) (define num-of-cols (length (syntax->list #'widths))) (define num-of-rows (length (syntax->list #'heights))) - #`(let #,let-bindings + #`(let #,(reverse let-bindings) (match* #,main-args #,@(for*/list ([x (in-range 1 num-of-cols)] [y (in-range 1 num-of-rows)]) #`[(#,(hash-ref coord-to-content (list x 0)) #,(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)])))]))