Implement column reordering.
Fix ordering problems with non-linear or patterns. Use `nest' in a few places. Fix error message from match-expanders. svn: r9141
This commit is contained in:
Sam Tobin-Hochstadt
parent
d1ed1a1e52
commit
b5128a2874
|
|
@ -5,8 +5,10 @@
|
|||
syntax/stx
|
||||
"patterns.ss"
|
||||
"split-rows.ss"
|
||||
"reorder.ss"
|
||||
scheme/struct-info
|
||||
scheme/stxparam
|
||||
scheme/nest
|
||||
(only-in srfi/1 delete-duplicates))
|
||||
|
||||
(provide compile*)
|
||||
|
|
@ -77,35 +79,36 @@
|
|||
;; vectors are handled specially
|
||||
;; because each arity is like a different constructor
|
||||
[(eq? 'vector k)
|
||||
(let ()
|
||||
(define ht
|
||||
(hash-on (lambda (r) (length (Vector-ps (Row-first-pat r)))) rows))
|
||||
(with-syntax
|
||||
([(clauses ...)
|
||||
(hash-table-map
|
||||
ht
|
||||
(lambda (arity rows)
|
||||
(define ns (build-list arity values))
|
||||
(with-syntax ([(tmps ...) (generate-temporaries ns)])
|
||||
(with-syntax ([body
|
||||
(compile*
|
||||
(append (syntax->list #'(tmps ...)) xs)
|
||||
(map (lambda (row)
|
||||
(define-values (p1 ps)
|
||||
(Row-split-pats row))
|
||||
(make-Row (append (Vector-ps p1) ps)
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
rows)
|
||||
esc)]
|
||||
[(n ...) ns])
|
||||
#`[(#,arity)
|
||||
(let ([tmps (vector-ref #,x n)] ...)
|
||||
body)]))))])
|
||||
#`[(vector? #,x)
|
||||
(case (vector-length #,x)
|
||||
clauses ...)]))]
|
||||
(nest
|
||||
([let ()]
|
||||
[let ([ht (hash-on (lambda (r)
|
||||
(length (Vector-ps (Row-first-pat r)))) rows)])]
|
||||
[with-syntax
|
||||
([(clauses ...)
|
||||
(hash-table-map
|
||||
ht
|
||||
(lambda (arity rows)
|
||||
(define ns (build-list arity values))
|
||||
(with-syntax ([(tmps ...) (generate-temporaries ns)])
|
||||
(with-syntax ([body
|
||||
(compile*
|
||||
(append (syntax->list #'(tmps ...)) xs)
|
||||
(map (lambda (row)
|
||||
(define-values (p1 ps)
|
||||
(Row-split-pats row))
|
||||
(make-Row (append (Vector-ps p1) ps)
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row)))
|
||||
rows)
|
||||
esc)]
|
||||
[(n ...) ns])
|
||||
#`[(#,arity)
|
||||
(let ([tmps (vector-ref #,x n)] ...)
|
||||
body)]))))])])
|
||||
#`[(vector? #,x)
|
||||
(case (vector-length #,x)
|
||||
clauses ...)])]
|
||||
;; it's a structure
|
||||
[(box? k)
|
||||
;; all the rows are structures with the same predicate
|
||||
|
|
@ -192,23 +195,28 @@
|
|||
(error 'compile-one "Or block with multiple rows: ~a" block))
|
||||
(let* ([row (car block)]
|
||||
[pats (Row-pats row)]
|
||||
[seen (Row-vars-seen row)]
|
||||
;; all the pattern alternatives
|
||||
[qs (Or-ps (car pats))]
|
||||
;; the variables bound by this pattern - they're the same for the
|
||||
;; whole list
|
||||
[vars (bound-vars (car qs))])
|
||||
(with-syntax ([vars vars])
|
||||
[vars
|
||||
(for/list ([bv (bound-vars (car qs))]
|
||||
#:when (for/and ([seen-var seen])
|
||||
(not (free-identifier=? bv (car seen-var)))))
|
||||
bv)])
|
||||
(with-syntax ([(var ...) vars])
|
||||
;; do the or matching, and bind the results to the appropriate
|
||||
;; variables
|
||||
#`(let/ec exit
|
||||
(let ([esc* (lambda () (exit (#,esc)))])
|
||||
(let-values ([vars
|
||||
(let-values ([(var ...)
|
||||
#,(compile* (list x)
|
||||
(map (lambda (q)
|
||||
(make-Row (list q)
|
||||
#'(values . vars)
|
||||
#'(values var ...)
|
||||
#f
|
||||
(Row-vars-seen row)))
|
||||
seen))
|
||||
qs)
|
||||
#'esc*)])
|
||||
;; then compile the rest of the row
|
||||
|
|
@ -216,9 +224,7 @@
|
|||
(list (make-Row (cdr pats)
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(let ([vs (syntax->list #'vars)])
|
||||
(append (map cons vs vs)
|
||||
(Row-vars-seen row)))))
|
||||
(append (map cons vars vars) seen)))
|
||||
esc))))))]
|
||||
;; the App rule
|
||||
[(App? first)
|
||||
|
|
@ -295,99 +301,101 @@
|
|||
#`(cond [(pred? #,x) body] [else (#,esc)]))]
|
||||
;; Generalized sequences... slightly tested
|
||||
[(GSeq? first)
|
||||
(let* ([headss (GSeq-headss first)]
|
||||
[mins (GSeq-mins first)]
|
||||
[maxs (GSeq-maxs first)]
|
||||
[onces? (GSeq-onces? first)]
|
||||
[tail (GSeq-tail first)]
|
||||
[k (Row-rhs (car block))]
|
||||
[xvar (car (generate-temporaries (list #'x)))]
|
||||
[complete-heads-pattern
|
||||
(lambda (ps)
|
||||
(define (loop ps pat)
|
||||
(if (pair? ps)
|
||||
(make-Pair (car ps) (loop (cdr ps) pat))
|
||||
pat))
|
||||
(loop ps (make-Var xvar)))]
|
||||
[heads
|
||||
(for/list ([ps headss])
|
||||
(complete-heads-pattern ps))]
|
||||
[head-idss
|
||||
(for/list ([heads headss])
|
||||
(apply append (map bound-vars heads)))]
|
||||
[hid-argss (map generate-temporaries head-idss)]
|
||||
[head-idss* (map generate-temporaries head-idss)]
|
||||
[hid-args (apply append hid-argss)]
|
||||
[reps (generate-temporaries (for/list ([head heads]) 'rep))])
|
||||
(with-syntax ([x xvar]
|
||||
[var0 (car vars)]
|
||||
[((hid ...) ...) head-idss]
|
||||
[((hid* ...) ...) head-idss*]
|
||||
[((hid-arg ...) ...) hid-argss]
|
||||
[(rep ...) reps]
|
||||
[(maxrepconstraint ...)
|
||||
;; FIXME: move to side condition to appropriate pattern
|
||||
(for/list ([repvar reps] [maxrep maxs])
|
||||
(if maxrep #`(< #,repvar #,maxrep) #`#t))]
|
||||
[(minrepclause ...)
|
||||
(for/list ([repvar reps] [minrep mins] #:when minrep)
|
||||
#`[(< #,repvar #,minrep) (fail)])]
|
||||
[((hid-rhs ...) ...)
|
||||
(for/list ([hid-args hid-argss] [once? onces?])
|
||||
(for/list ([hid-arg hid-args])
|
||||
(if once?
|
||||
#`(car (reverse #,hid-arg))
|
||||
#`(reverse #,hid-arg))))]
|
||||
[(parse-loop failkv fail-tail)
|
||||
(generate-temporaries #'(parse-loop failkv fail-tail))])
|
||||
(with-syntax ([(rhs ...)
|
||||
#`[(let ([hid-arg (cons hid* hid-arg)] ...)
|
||||
(if maxrepconstraint
|
||||
(let ([rep (add1 rep)])
|
||||
(parse-loop x #,@hid-args #,@reps fail))
|
||||
(begin (fail))))
|
||||
...]]
|
||||
[tail-rhs
|
||||
#`(cond minrepclause ...
|
||||
[else
|
||||
(let ([hid hid-rhs] ... ...
|
||||
[fail-tail fail])
|
||||
#,(compile*
|
||||
(cdr vars)
|
||||
(list (make-Row rest-pats k
|
||||
(Row-unmatch (car block))
|
||||
(Row-vars-seen
|
||||
(car block))))
|
||||
#'fail-tail))])])
|
||||
(parameterize ([current-renaming
|
||||
(for/fold ([ht (copy-mapping (current-renaming))])
|
||||
([id (apply append head-idss)]
|
||||
[id* (apply append head-idss*)])
|
||||
(free-identifier-mapping-put! ht id id*)
|
||||
(free-identifier-mapping-for-each
|
||||
ht
|
||||
(lambda (k v)
|
||||
(when (free-identifier=? v id)
|
||||
(free-identifier-mapping-put! ht k id*))))
|
||||
ht)])
|
||||
#`(let parse-loop ([x var0]
|
||||
[hid-arg null] ... ...
|
||||
[rep 0] ...
|
||||
[failkv #,esc])
|
||||
#,(compile* (list #'x)
|
||||
(append
|
||||
(map (lambda (pats rhs)
|
||||
(make-Row pats
|
||||
rhs
|
||||
(Row-unmatch (car block))
|
||||
null))
|
||||
(map list heads)
|
||||
(syntax->list #'(rhs ...)))
|
||||
(list (make-Row (list tail)
|
||||
#`tail-rhs
|
||||
(Row-unmatch (car block))
|
||||
null)))
|
||||
#'failkv))))))]
|
||||
(nest
|
||||
([let* ([headss (GSeq-headss first)]
|
||||
[mins (GSeq-mins first)]
|
||||
[maxs (GSeq-maxs first)]
|
||||
[onces? (GSeq-onces? first)]
|
||||
[tail (GSeq-tail first)]
|
||||
[k (Row-rhs (car block))]
|
||||
[xvar (car (generate-temporaries (list #'x)))]
|
||||
[complete-heads-pattern
|
||||
(lambda (ps)
|
||||
(define (loop ps pat)
|
||||
(if (pair? ps)
|
||||
(make-Pair (car ps) (loop (cdr ps) pat))
|
||||
pat))
|
||||
(loop ps (make-Var xvar)))]
|
||||
[heads
|
||||
(for/list ([ps headss])
|
||||
(complete-heads-pattern ps))]
|
||||
[head-idss
|
||||
(for/list ([heads headss])
|
||||
(apply append (map bound-vars heads)))]
|
||||
[hid-argss (map generate-temporaries head-idss)]
|
||||
[head-idss* (map generate-temporaries head-idss)]
|
||||
[hid-args (apply append hid-argss)]
|
||||
[reps (generate-temporaries (for/list ([head heads]) 'rep))])]
|
||||
[with-syntax
|
||||
([x xvar]
|
||||
[var0 (car vars)]
|
||||
[((hid ...) ...) head-idss]
|
||||
[((hid* ...) ...) head-idss*]
|
||||
[((hid-arg ...) ...) hid-argss]
|
||||
[(rep ...) reps]
|
||||
[(maxrepconstraint ...)
|
||||
;; FIXME: move to side condition to appropriate pattern
|
||||
(for/list ([repvar reps] [maxrep maxs])
|
||||
(if maxrep #`(< #,repvar #,maxrep) #`#t))]
|
||||
[(minrepclause ...)
|
||||
(for/list ([repvar reps] [minrep mins] #:when minrep)
|
||||
#`[(< #,repvar #,minrep) (fail)])]
|
||||
[((hid-rhs ...) ...)
|
||||
(for/list ([hid-args hid-argss] [once? onces?])
|
||||
(for/list ([hid-arg hid-args])
|
||||
(if once?
|
||||
#`(car (reverse #,hid-arg))
|
||||
#`(reverse #,hid-arg))))]
|
||||
[(parse-loop failkv fail-tail)
|
||||
(generate-temporaries #'(parse-loop failkv fail-tail))])]
|
||||
[with-syntax ([(rhs ...)
|
||||
#`[(let ([hid-arg (cons hid* hid-arg)] ...)
|
||||
(if maxrepconstraint
|
||||
(let ([rep (add1 rep)])
|
||||
(parse-loop x #,@hid-args #,@reps fail))
|
||||
(begin (fail))))
|
||||
...]]
|
||||
[tail-rhs
|
||||
#`(cond minrepclause ...
|
||||
[else
|
||||
(let ([hid hid-rhs] ... ...
|
||||
[fail-tail fail])
|
||||
#,(compile*
|
||||
(cdr vars)
|
||||
(list (make-Row rest-pats k
|
||||
(Row-unmatch (car block))
|
||||
(Row-vars-seen
|
||||
(car block))))
|
||||
#'fail-tail))])])]
|
||||
[parameterize ([current-renaming
|
||||
(for/fold ([ht (copy-mapping (current-renaming))])
|
||||
([id (apply append head-idss)]
|
||||
[id* (apply append head-idss*)])
|
||||
(free-identifier-mapping-put! ht id id*)
|
||||
(free-identifier-mapping-for-each
|
||||
ht
|
||||
(lambda (k v)
|
||||
(when (free-identifier=? v id)
|
||||
(free-identifier-mapping-put! ht k id*))))
|
||||
ht)])])
|
||||
#`(let parse-loop ([x var0]
|
||||
[hid-arg null] ... ...
|
||||
[rep 0] ...
|
||||
[failkv #,esc])
|
||||
#,(compile* (list #'x)
|
||||
(append
|
||||
(map (lambda (pats rhs)
|
||||
(make-Row pats
|
||||
rhs
|
||||
(Row-unmatch (car block))
|
||||
null))
|
||||
(map list heads)
|
||||
(syntax->list #'(rhs ...)))
|
||||
(list (make-Row (list tail)
|
||||
#`tail-rhs
|
||||
(Row-unmatch (car block))
|
||||
null)))
|
||||
#'failkv)))]
|
||||
[else (error 'compile "unsupported pattern: ~a~n" first)]))
|
||||
|
||||
(define (compile* vars rows esc)
|
||||
|
|
@ -424,20 +432,22 @@
|
|||
|
||||
;; otherwise, we split the matrix into blocks
|
||||
;; and compile each block with a reference to its continuation
|
||||
(let ([fns
|
||||
(let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null])
|
||||
(if (null? blocks)
|
||||
;; if we're done, return the blocks
|
||||
(reverse acc)
|
||||
(with-syntax (;; f is the name this block will have
|
||||
[(f) (generate-temporaries #'(f))]
|
||||
;; compile the block, with jumps to the previous
|
||||
;; esc
|
||||
[c (compile-one vars (car blocks) esc)])
|
||||
;; then compile the rest, with our name as the esc
|
||||
(loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))])
|
||||
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
|
||||
(let/wrap #'(fns ...) #'body)))))
|
||||
(let*-values
|
||||
([(rows vars) (reorder-columns rows vars)]
|
||||
[(fns)
|
||||
(let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null])
|
||||
(if (null? blocks)
|
||||
;; if we're done, return the blocks
|
||||
(reverse acc)
|
||||
(with-syntax (;; f is the name this block will have
|
||||
[(f) (generate-temporaries #'(f))]
|
||||
;; compile the block, with jumps to the previous
|
||||
;; esc
|
||||
[c (compile-one vars (car blocks) esc)])
|
||||
;; then compile the rest, with our name as the esc
|
||||
(loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))])
|
||||
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
|
||||
(let/wrap #'(fns ...) #'body)))))
|
||||
|
||||
;; (require mzlib/trace)
|
||||
;; (trace compile* compile-one)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "patterns.ss" "compiler.ss"
|
||||
syntax/stx
|
||||
syntax/stx scheme/nest
|
||||
(for-template scheme/base (only-in "patterns.ss" match:error)))
|
||||
|
||||
(provide go)
|
||||
|
|
@ -9,52 +9,41 @@
|
|||
;; this parses the clauses using parse/cert, then compiles them
|
||||
;; go : syntax syntax syntax certifier -> syntax
|
||||
(define (go parse/cert stx exprs clauses cert)
|
||||
(parameterize ([orig-stx stx])
|
||||
(syntax-case clauses ()
|
||||
[([pats . rhs] ...)
|
||||
(let ([len (length (syntax->list exprs))])
|
||||
(with-syntax ([(xs ...) (generate-temporaries exprs)]
|
||||
[(exprs ...) exprs]
|
||||
[(fail) (generate-temporaries #'(fail))])
|
||||
(with-syntax ([body (compile*
|
||||
(syntax->list #'(xs ...))
|
||||
(map (lambda (pats rhs)
|
||||
(unless (= len
|
||||
(length (syntax->list pats)))
|
||||
(raise-syntax-error
|
||||
'match
|
||||
(format "~a, expected ~a and got ~a"
|
||||
"wrong number of match clauses"
|
||||
len
|
||||
(length (syntax->list pats)))
|
||||
pats))
|
||||
(syntax-case* rhs (=>)
|
||||
(lambda (x y)
|
||||
(eq? (syntax-e x)
|
||||
(syntax-e y)))
|
||||
[((=> unm) . rhs)
|
||||
(make-Row (map (lambda (s)
|
||||
(parse/cert s cert))
|
||||
(syntax->list pats))
|
||||
#`(begin . rhs)
|
||||
#'unm
|
||||
null)]
|
||||
[_
|
||||
(make-Row (map (lambda (s)
|
||||
(parse/cert s cert))
|
||||
(syntax->list pats))
|
||||
#`(begin . #,rhs)
|
||||
#f
|
||||
null)]))
|
||||
(syntax->list #'(pats ...))
|
||||
(syntax->list #'(rhs ...)))
|
||||
#'fail)]
|
||||
[orig-expr (if (= 1 len)
|
||||
(stx-car #'(xs ...))
|
||||
#'(list xs ...))])
|
||||
(quasisyntax/loc stx
|
||||
(let ([xs exprs]
|
||||
...)
|
||||
(let ([fail (lambda ()
|
||||
#,(syntax/loc stx (match:error orig-expr)))])
|
||||
body))))))])))
|
||||
(syntax-case clauses ()
|
||||
[([pats . rhs] ...)
|
||||
(nest
|
||||
([parameterize ([orig-stx stx])]
|
||||
[let ([len (length (syntax->list exprs))])]
|
||||
[with-syntax ([(xs ...) (generate-temporaries exprs)]
|
||||
[(exprs ...) exprs]
|
||||
[(fail) (generate-temporaries #'(fail))])]
|
||||
[with-syntax
|
||||
([body
|
||||
(compile*
|
||||
(syntax->list #'(xs ...))
|
||||
(for/list ([pats (syntax->list #'(pats ...))]
|
||||
[rhs (syntax->list #'(rhs ...))])
|
||||
(let ([lp (length (syntax->list pats))])
|
||||
(unless (= len lp)
|
||||
(raise-syntax-error
|
||||
'match
|
||||
(format
|
||||
"wrong number of match clauses, expected ~a and got ~a"
|
||||
len lp)
|
||||
pats))
|
||||
(let ([mk (lambda (unm rhs)
|
||||
(make-Row (for/list ([p (syntax->list pats)])
|
||||
(parse/cert p cert))
|
||||
#`(begin . #,rhs) unm null))])
|
||||
(syntax-case* rhs (=>)
|
||||
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
[((=> unm) . rhs) (mk #'unm #'rhs)]
|
||||
[_ (mk #f rhs)]))))
|
||||
#'fail)]
|
||||
[orig-expr
|
||||
(if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...))])])
|
||||
(quasisyntax/loc stx
|
||||
(let ([xs exprs] ...)
|
||||
(let ([fail (lambda ()
|
||||
#,(syntax/loc stx (match:error orig-expr)))])
|
||||
body))))]))
|
||||
|
|
|
|||
|
|
@ -119,7 +119,7 @@
|
|||
error-msg)
|
||||
(let* ([expander (syntax-local-value (cert expander))]
|
||||
[transformer (accessor expander)])
|
||||
(unless transformer (raise-syntax-error #f error-msg #'expander))
|
||||
(unless transformer (raise-syntax-error #f error-msg expander))
|
||||
(let* ([introducer (make-syntax-introducer)]
|
||||
[certifier (match-expander-certifier expander)]
|
||||
[mstx (introducer (syntax-local-introduce stx))]
|
||||
|
|
|
|||
|
|
@ -39,8 +39,6 @@
|
|||
;; start is what index to start at
|
||||
(define-struct (Vector CPat) (ps) #:transparent)
|
||||
|
||||
(define-struct (VectorSeq Pat) (p count start) #:transparent)
|
||||
|
||||
(define-struct (Pair CPat) (a d) #:transparent)
|
||||
(define-struct (MPair CPat) (a d) #:transparent)
|
||||
|
||||
|
|
|
|||
86
collects/scheme/match/reorder.ss
Normal file
86
collects/scheme/match/reorder.ss
Normal file
|
|
@ -0,0 +1,86 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "patterns.ss"
|
||||
scheme/list
|
||||
(only-in srfi/1/list take-while)
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(provide reorder-columns)
|
||||
|
||||
#|
|
||||
(define p-x (make-Var #'x))
|
||||
(define p-y (make-Var #'y))
|
||||
(define p-d (make-Dummy #'_))
|
||||
|
||||
(define p-cons (make-Pair p-x p-y))
|
||||
(define p-vec (make-Vector (list p-x p-y p-d)))
|
||||
|
||||
(define r1 (make-Row (list p-x) #'#f #f null))
|
||||
(define r2 (make-Row (list p-y) #'#f #f null))
|
||||
(define r3 (make-Row (list p-cons) #'#f #f null))
|
||||
(define r4 (make-Row (list p-vec p-d) #'#f #f null))
|
||||
|
||||
(define r5 (make-Row (list p-x p-y p-cons) #'1 #f null))
|
||||
(define r6 (make-Row (list p-cons p-y p-vec) #'1 #f null))
|
||||
|#
|
||||
|
||||
(define-sequence-syntax in-par
|
||||
(lambda () (raise-syntax-error 'in-par "bad"))
|
||||
(lambda (orig-stx stx)
|
||||
(syntax-case stx ()
|
||||
[((id) (_ lst-exprs))
|
||||
#'[(id)
|
||||
(:do-in
|
||||
;;outer bindings
|
||||
([(lst) lst-exprs])
|
||||
;; outer check
|
||||
(void) ; (unless (list? lst) (in-list lst))
|
||||
;; loop bindings
|
||||
([lst lst])
|
||||
;; pos check
|
||||
(not (ormap null? lst))
|
||||
;; inner bindings
|
||||
([(id) (map car lst)])
|
||||
;; pre guard
|
||||
#t
|
||||
;; post guard
|
||||
#t
|
||||
;; loop args
|
||||
((map cdr lst)))]]
|
||||
[_ (error 'no (syntax->datum stx))])))
|
||||
|
||||
(define (or-all? ps l)
|
||||
(ormap (lambda (p) (andmap p l)) ps))
|
||||
|
||||
(define (score col)
|
||||
(define n (length col))
|
||||
(define c (car col))
|
||||
(define preds (list Var? Pair? Null?))
|
||||
(cond [(or-all? preds col) (add1 n)]
|
||||
[(andmap CPat? col) n]
|
||||
[(Var? c) (length (take-while Var? col))]
|
||||
[(Pair? c) (length (take-while Pair? col))]
|
||||
[(Vector? c) (length (take-while Vector? col))]
|
||||
[(Box? c) (length (take-while Box? col))]
|
||||
[else 0]))
|
||||
|
||||
(define (reorder-by ps scores*)
|
||||
(for/fold
|
||||
([pats null])
|
||||
([score-ref scores*])
|
||||
(cons (list-ref ps score-ref) pats)))
|
||||
|
||||
|
||||
(define (reorder-columns rows vars)
|
||||
(define scores (for/list ([i (in-naturals)]
|
||||
[column (in-par (map (compose Row-pats) rows))])
|
||||
(cons i (score column))))
|
||||
(define scores* (reverse (map car (sort scores > #:key cdr))))
|
||||
(values
|
||||
(for/list ([row rows])
|
||||
(let ([ps (Row-pats row)])
|
||||
(make-Row (reorder-by ps scores*)
|
||||
(Row-rhs row)
|
||||
(Row-unmatch row)
|
||||
(Row-vars-seen row))))
|
||||
(reorder-by vars scores*)))
|
||||
Loading…
Reference in New Issue
Block a user