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
(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)])))]))