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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
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)))
(when (null? (syntax-e rhses)) (hash-set! coord-to-content (car cells) pat)]))
(raise-syntax-error '2dmatch
(format "cell at ~a,~a should not be empty" ;; build up the coord-to-content mapping for the non-boundary cells
(list-ref (car cells) 0) ;; use the pattern-vars table to build up the let-bindings that
(list-ref (car cells) 1)) ;; bind identifiers to functions that end up getting called in the match clauses
stx)) (for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))]
;; this code will duplicate the rhses expressions [rhses (in-list (syntax->list #'((rhs ...) ...)))])
;; in the case that there are multiple cells in `cells' (define cells (syntax->datum cells-stx))
;; it would be better to analyze the corresponding (define rhses-lst (syntax->list rhses))
;; match patterns and then stick the code in a function (unless (on-boundary? cells)
;; whose arguments are the intersection of the bound variables (when (null? (syntax-e rhses))
;; (supplying the arguments in a call in the cell) (raise-syntax-error '2dmatch
(for ([cell (in-list cells)]) (format "cell at ~a,~a should not be empty"
(hash-set! coord-to-content (list-ref (car cells) 0)
cell (list-ref (car cells) 1))
(syntax->list rhses)))])) 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-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)])))]))