suzanne.soy/phc-graph
1
0
Fork 0
Code Issues 24 Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source
This commit is contained in:
Georges Dupéron 2016-12-22 23:13:24 +01:00
parent d7c41fabe6
commit 5aae1459db
1 changed files with 67 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

99
flexible-with.rkt
View File

@ -10,20 +10,26 @@
(for-meta 2 racket/base) (for-meta 2 racket/base)
"flexible-with-utils.rkt") "flexible-with-utils.rkt")
<→τ> <tree-type-with-replacement>
<define-replace-in-tree> <define-replace-in-tree>
<convert-fields> <convert-fields>
<τ-tree-with-fields> <τ-tree-with-fields>
<convert-from-struct> <define-struct→tree>
<mk> <define-trees>
<example>] <example>]
@CHUNK[<→τ> @CHUNK[<tree-type-with-replacement>
(define-for-syntax (→τ n last τ*) (define-for-syntax (tree-type-with-replacement n last τ*)
(define-values (next mod) (quotient/remainder n 2)) (define-values (next mod) (quotient/remainder n 2))
(cond [(null? τ*) last] (cond [(null? τ*) last]
[(= mod 0) (→τ next #`(Pairof #,last #,(car τ*)) (cdr τ*))] [(= mod 0)
[else (→τ next #`(Pairof #,(car τ*) #,last) (cdr τ*))]))] (tree-type-with-replacement next
#`(Pairof #,last #,(car τ*))
(cdr τ*))]
[else
(tree-type-with-replacement next
#`(Pairof #,(car τ*) #,last)
(cdr τ*))]))]
@CHUNK[<make-replace-in-tree-body> @CHUNK[<make-replace-in-tree-body>
(if (= i 1) (if (= i 1)
@ -54,9 +60,9 @@
(provide name) (provide name)
(: name (: name
(∀ (#,@τ*-limited T) (∀ (#,@τ*-limited T)
(→ (→ #,(→τ i #'Any τ*-limited)) (→ (→ #,(tree-type-with-replacement i #'Any τ*-limited))
T T
(→ #,(→τ i #'T τ*-limited))))) (→ #,(tree-type-with-replacement i #'T τ*-limited)))))
(define (name tree-thunk replacement) (define (name tree-thunk replacement)
#,<make-replace-in-tree-body>)))] #,<make-replace-in-tree-body>)))]
@ -77,6 +83,23 @@
;(displayln (syntax->datum #`#,(f 1))) ;(displayln (syntax->datum #`#,(f 1)))
(f 1))] (f 1))]
@CHUNK[<convert-back-fields>
(define-for-syntax (convert-back-fields up fields+indices)
;(displayln fields+indices)
(define (f i)
;(displayln (list i '/ up (syntax->datum #`#,fields+indices)))
(if (and (pair? fields+indices) (= i (cdar fields+indices)))
(begin0
(caar fields+indices)
(set! fields+indices (cdr fields+indices)))
(if (>= (* i 2) up) ;; DEPTH
''MISSING
(begin
`(cons ,(f (* i 2))
,(f (add1 (* i 2))))))))
;(displayln (syntax->datum #`#,(f 1)))
(f 1))]
@CHUNK[<τ-tree-with-fields> @CHUNK[<τ-tree-with-fields>
(define-for-syntax (τ-tree-with-fields struct-fields fields) (define-for-syntax (τ-tree-with-fields struct-fields fields)
(define/with-syntax (struct-field …) struct-fields) (define/with-syntax (struct-field …) struct-fields)
@ -110,12 +133,14 @@
,(f (add1 (* i 2)))))))) ,(f (add1 (* i 2))))))))
(f 1))] (f 1))]
@CHUNK[<convert-from-struct> @CHUNK[<define-struct→tree>
(define-for-syntax (convert-from-struct (define-for-syntax (define-struct→tree
offset all-fields τ* struct-name fields) offset all-fields τ* struct-name fields)
(define/with-syntax (field …) fields) (define/with-syntax (field …) fields)
(define/with-syntax conv-name (define/with-syntax fields→tree-name
(format-id struct-name "convert-~a" struct-name)) (format-id struct-name "~a→tree" struct-name))
(define/with-syntax tree→fields-name
(format-id struct-name "tree→~a" struct-name))
(define lookup (define lookup
(make-free-id-table (make-free-id-table
(for/list ([n (in-syntax all-fields)] (for/list ([n (in-syntax all-fields)]
@ -127,20 +152,31 @@
< <
#:key cdr)) #:key cdr))
#`(begin #`(begin
(: conv-name (∀ (field …) (: fields→tree-name (∀ (field …)
(→ field … (→ field …
(→ #,(τ-tree-with-fields #'(field …) (→ #,(τ-tree-with-fields #'(field …)
all-fields))))) all-fields)))))
(define (conv-name field …) (define (fields→tree-name field …)
(λ () (λ ()
#,(convert-fields (* offset 2) fields+indices)))))] #,(convert-fields (* offset 2) fields+indices)))
@CHUNK[<mk> (: tree→fields-name (∀ (field …)
(define-for-syntax (mk stx) (→ (→ #,(τ-tree-with-fields #'(field …)
all-fields))
(Values field …))))
(define (tree→fields-name tree-thunk)
(define tree (tree-thunk))
(values (error "Not implmtd yet" 'field) …)
#;#,(convert-fields (* offset 2) fields+indices))))]
@CHUNK[<define-trees>
(define-for-syntax (define-trees stx)
(syntax-case stx () (syntax-case stx ()
[(bt-fields-id (field …) [struct struct-field …] …) [(bt-fields-id (field …) [struct struct-field …] …)
(let () (let ()
<utils> <utils>
(define ∀-types (map #λ(format-id #'here "τ~a" %)
(range (add1 depth-above))))
(define total-nb-functions (vector-length names)) (define total-nb-functions (vector-length names))
#`(begin #`(begin
(define-type-expander (bt-fields-id stx) (define-type-expander (bt-fields-id stx)
@ -148,10 +184,10 @@
[(_ . fs) [(_ . fs)
#`(∀ fs (→ #,(τ-tree-with-fields #'fs #`(∀ fs (→ #,(τ-tree-with-fields #'fs
#'(field …))))])) #'(field …))))]))
#,@(map #λ(define-replace-in-tree names τ* % (floor-log2 %)) #,@(map #λ(define-replace-in-tree names ∀-types % (floor-log2 %))
(range 1 (add1 total-nb-functions))) (range 1 (add1 total-nb-functions)))
#,@(map #λ(convert-from-struct #,@(map #λ(define-struct→tree
offset all-fields τ* %1 %2) offset all-fields ∀-types %1 %2)
(syntax->list #'(struct …)) (syntax->list #'(struct …))
(syntax->list #'([struct-field …] …)))))]))] (syntax->list #'([struct-field …] …)))))]))]
@ -160,12 +196,11 @@
(define depth-above (ceiling-log2 (length (syntax->list #'(field …))))) (define depth-above (ceiling-log2 (length (syntax->list #'(field …)))))
(define offset (expt 2 depth-above)) (define offset (expt 2 depth-above))
(define i*-above (range 1 (expt 2 depth-above))) (define i*-above (range 1 (expt 2 depth-above)))
(define τ* (map #λ(format-id #'here "τ~a" %) (range (add1 depth-above))))
(define names (list->vector (define names (list->vector
(append (map (λ (i) (format-id #'here "-with-~a" i)) (append (map (λ (i) (format-id #'here "-with-~a" i))
i*-above) i*-above)
(stx-map (λ (f) (format-id f "with-~a" f)) (stx-map (λ (f) (format-id f "with-~a" f))
#'(field …)))))] #'(field …)))))]
@CHUNK[<example> @CHUNK[<example>
(define-syntax (gs stx) (define-syntax (gs stx)
(syntax-case stx () (syntax-case stx ()
@ -176,7 +211,7 @@
(map (λ (_) (datum->syntax #'nfields (gensym 'g))) (map (λ (_) (datum->syntax #'nfields (gensym 'g)))
(range (- (syntax-e #'nfields) (range (- (syntax-e #'nfields)
(length (syntax->list #'(f …)))))))) (length (syntax->list #'(f …))))))))
(mk #'(bt-fields-id (field …) [struct struct-field …] …)))])) (define-trees #'(bt-fields-id (field …) [struct struct-field …] …)))]))
;(gs 6) ;(gs 6)
(gs bt-fields (gs bt-fields
@ -185,5 +220,5 @@
[sab a b] [sab a b]
[sbc b c]) [sbc b c])
(ann (with-c (convert-sab 1 2) 'nine) (ann (with-c (sab→tree 1 2) 'nine)
((bt-fields a b c) One Positive-Byte 'nine))] ((bt-fields a b c) One Positive-Byte 'nine))]