From d0c73c12ab93dddd503951ad0942c86a727c7037 Mon Sep 17 00:00:00 2001 From: Max New Date: Sun, 13 Oct 2013 18:53:21 -0500 Subject: [PATCH] Smarter production sort in redex nts --- .../redex/private/build-nt-property.rkt | 25 ++++- .../redex/private/preprocess-lang.rkt | 95 +++++++++++++------ 2 files changed, 89 insertions(+), 31 deletions(-) diff --git a/pkgs/redex-pkgs/redex-lib/redex/private/build-nt-property.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/build-nt-property.rkt index 3a5aefc8ba..bcf1d252b5 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/build-nt-property.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/build-nt-property.rkt @@ -9,16 +9,33 @@ (-> any/c (hash/c symbol? any/c) any/c) any/c (-> any/c any/c any/c) - (hash/c symbol? any/c))])) + (hash/c symbol? any/c))] + [build-nt-property/name (-> (listof nt?) + (-> any/c symbol? (hash/c symbol? any/c) any/c) + any/c + (-> any/c any/c any/c) + (hash/c symbol? any/c))])) ;; build-nt-property : lang -;; (pattern hash[nt -o> ans] -> ans) +;; (pattern hash[symbol -o> ans] -> ans) ;; init-ans -;; (ans ans ans) +;; (ans ans -> ans) ;; -> hash[nt -o> ans] ;; builds a property table using a fixed point computation, ;; using base-answer and lub as the lattice (define (build-nt-property lang test-rhs base-answer lub) + (build-nt-property/name lang + (λ (pat n ht) + (test-rhs pat ht)) + base-answer + lub)) + +;; build-nt-property : lang +;; (pattern symbol hash[symbol -o> ans] -> ans) +;; init-ans +;; (ans ans -> ans) +;; -> hash[nt -o> ans] +(define (build-nt-property/name lang test-rhs/name base-answer lub) (define ht (make-hash)) (for ([nt (in-list lang)]) (hash-set! ht (nt-name nt) base-answer)) @@ -28,7 +45,7 @@ (define next-val (for/fold ([acc base-answer]) ([rhs (in-list (nt-rhs nt))]) - (lub acc (test-rhs (rhs-pattern rhs) ht)))) + (lub acc (test-rhs/name (rhs-pattern rhs) (nt-name nt) ht)))) (unless (equal? next-val (hash-ref ht (nt-name nt))) (hash-set! ht (nt-name nt) next-val) (set! something-changed? #t))) diff --git a/pkgs/redex-pkgs/redex-lib/redex/private/preprocess-lang.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/preprocess-lang.rkt index 715ef16902..9e90e33958 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/preprocess-lang.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/preprocess-lang.rkt @@ -1,8 +1,12 @@ #lang racket/base -(require racket/contract +(require (for-syntax racket/base) + racket/bool + racket/contract racket/list + racket/math racket/match racket/set + "build-nt-property.rkt" "lang-struct.rkt" "match-a-pattern.rkt") @@ -38,7 +42,7 @@ (filter-edges edges non-cyclic))) ;; rhs sort (define sorted-right - (sort-nt-terms cyclic + (sort-productions cyclic cyclic-nts)) (values sorted-left sorted-right)) @@ -136,18 +140,6 @@ sub-pats)] [(? (compose not pair?)) #f]))) -;; recursive-rhss : lang (hash[symbol] -o> symbol) -;; -> (hash[symbol] -o> (assoclist rhs bool)) -(define (recursive-rhss cyclic recs) - (for/hash ([cur-nt (in-list cyclic)]) - (match-define (nt cur-name cur-rhss) cur-nt) - (define rhss - (for/list ([cur-rhs (in-list cur-rhss)]) - (cons cur-rhs - (calls-rec? (rhs-pattern cur-rhs) - recs)))) - (values cur-name rhss))) - ;; topo-sort : lang (hash[symbol] -o> (setof symbol)) -> lang (define (topo-sort lang edges) (define (find-top rem edges) @@ -178,23 +170,55 @@ lang)) -;; sort-nt-terms : lang, (hash[symbol] -o> (setof symbol)) -> lang -(define (sort-nt-terms cyclic nts) - (define recs (recursive-rhss cyclic nts)) - (for/list ([cur-nt (in-list cyclic)]) - (match cur-nt - [(nt name rhs) - (define rec-nts (hash-ref recs name)) - (nt name - (sort rhs - (λ (r1 r2) - (and (not (cdr (assoc r1 rec-nts))) - (cdr (assoc r2 rec-nts))))))]))) +;; sort-productions : lang, (hash[symbol] -o> (setof symbol)) -> lang +(define (sort-productions cyclic nts) + (define table (terminal-distance-table cyclic nts)) + (define resp + (for/list ([cur-nt (in-list cyclic)]) + (match cur-nt + [(nt name productions) + (define (max-terminal-distance pat) + (define referenced-nts (directly-used-nts pat)) + (define maximum + (for/max ([cur-name (in-set referenced-nts)]) + (if (symbol=? cur-name name) + +inf.0 + (hash-ref table cur-name 0)))) + (if (and (negative? maximum) + (infinite? maximum)) + 0 + maximum)) + (nt name + (sort productions + < + #:key (compose max-terminal-distance rhs-pattern) + #:cache-keys? #t))]))) + resp) + +;; terminal-distance-table : lang (hash[symbol] -o> symbol) +;; -> (hash[symbol] -o> (U natural +inf) +(define (terminal-distance-table cyclic recs) + (define (terminal-distance pat this-nt-name table) + (define referenced-nts (directly-used-nts pat)) + (define maximum + (for/max ([cur-name (in-set referenced-nts)]) + (cond [(symbol=? cur-name this-nt-name) + +inf.0] + [else + (hash-ref table cur-name 0)]))) + (or (and (infinite? maximum) + (negative? maximum) + 0) + (add1 maximum))) + (build-nt-property/name cyclic + terminal-distance + +inf.0 + min)) ;; directly-used-nts : pat -> (setof symbol) (define (directly-used-nts pat) (match pat - [`(nt id) (set nt)] + [`(nt ,id) (set id)] [(or `(name ,n ,p) `(mismatch-name ,n ,p)) (directly-used-nts p)] @@ -268,3 +292,20 @@ (set-union (f x) s)) (set) l)) + +;; Short circuits for +inf +(define-syntax (for/max stx) + (syntax-case stx () + [(_ clauses . defs+exprs) + (with-syntax ([original stx]) + #'(for/fold/derived original + ([current-max -inf.0]) + clauses + #:break (and (infinite? current-max) + (positive? current-max)) + (define maybe-new-max + (let () . defs+exprs)) + (if (> maybe-new-max current-max) + maybe-new-max + current-max)))])) +