commit f353f105973d0e0eb54f4e2defcf98afca461e09
parent 5aae1459db05186b24e89e80daabfc981989b4c6
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Tue, 27 Dec 2016 19:18:54 +0100
Fixed rendering issues with Scribble
Diffstat:
5 files changed, 358 insertions(+), 316 deletions(-)
diff --git a/flexible-with-utils.hl.rkt b/flexible-with-utils.hl.rkt
@@ -0,0 +1,116 @@
+#lang aful/unhygienic hyper-literate type-expander/lang
+
+@(require scribble-math)
+
+@title[#:style manual-doc-style]{Flexible functional modification and
+ extension of records (utility functions)}
+
+@(chunks-toc-prefix
+ '("(lib phc-graph/scribblings/phc-graph-implementation.scrbl)"
+ "phc-graph/flexible-with"))
+
+@defmodule[(lib "phc-graph/flexible-with-utils.hl.rkt")]
+
+@(unless-preexpanding
+ (require (for-label (submod ".."))))
+
+@chunk[<*>
+ (require (for-syntax racket/base))
+
+ (provide (for-syntax to-bits
+ from-bits
+ floor-log2
+ ceiling-log2))
+
+ <to-bits>
+ <from-bits>
+ <floor-log2>
+ <ceiling-log2>
+
+ (module* test racket/base
+ (require (for-template (submod "..")))
+ (require rackunit)
+ <test-to-bits>
+ <test-from-bits>)]
+
+@defproc[(to-bits [n exact-nonnegative-integer?]) (listof boolean?)]{}
+
+@CHUNK[<to-bits>
+ ; 1 => 1
+ ; 2 3 => 10 11
+ ;4 5 6 7 => 100 101 110 111
+ ;89 ab cd ef => 1000 1001 1010 1011 1100 1101 1110 1111
+
+ ; 1 => ""
+ ; 2 3 => 0 1
+ ;4 5 6 7 => 00 01 10 11
+ ;89 ab cd ef => 000 001 010 011 100 101 110 111
+
+ ; 0 => 0
+ ; 1 2 => 1 10
+ ;3 4 5 6 => 11 100 101 110
+ ;78 9a bc de => 111 1000 1001 1010 1011 1100 1101 1110
+
+
+ (define-for-syntax (to-bits n)
+ (reverse
+ (let loop ([n n])
+ (if (= n 0)
+ null
+ (let-values ([(q r) (quotient/remainder n 2)])
+ (cons (if (= r 1) #t #f) (loop q)))))))]
+
+@chunk[<test-to-bits>
+ (check-equal? (to-bits 0) '())
+ (check-equal? (to-bits 1) '(#t))
+ (check-equal? (to-bits 2) '(#t #f))
+ (check-equal? (to-bits 3) '(#t #t))
+ (check-equal? (to-bits 4) '(#t #f #f))
+ (check-equal? (to-bits 5) '(#t #f #t))
+ (check-equal? (to-bits 6) '(#t #t #f))
+ (check-equal? (to-bits 7) '(#t #t #t))
+ (check-equal? (to-bits 8) '(#t #f #f #f))
+ (check-equal? (to-bits 12) '(#t #t #f #f))
+ (check-equal? (to-bits 1024) '(#t #f #f #f #f #f #f #f #f #f #f))]
+
+@defproc[(from-bits [n (listof boolean?)]) exact-nonnegative-integer?]{}
+
+@CHUNK[<from-bits>
+ (define-for-syntax (from-bits b)
+ (foldl (λ (bᵢ acc)
+ (+ (* acc 2) (if bᵢ 1 0)))
+ 0
+ b))]
+
+@chunk[<test-from-bits>
+ (check-equal? (from-bits '()) 0)
+ (check-equal? (from-bits '(#t)) 1)
+ (check-equal? (from-bits '(#t #f)) 2)
+ (check-equal? (from-bits '(#t #t)) 3)
+ (check-equal? (from-bits '(#t #f #f)) 4)
+ (check-equal? (from-bits '(#t #f #t)) 5)
+ (check-equal? (from-bits '(#t #t #f)) 6)
+ (check-equal? (from-bits '(#t #t #t)) 7)
+ (check-equal? (from-bits '(#t #f #f #f)) 8)
+ (check-equal? (from-bits '(#t #t #f #f)) 12)
+ (check-equal? (from-bits '(#t #f #f #f #f #f #f #f #f #f #f)) 1024)]
+
+@defproc[(floor-log2 [n exact-positive-integer?])
+ exact-nonnegative-integer?]{
+ Exact computation of @${\lfloor\log_2(n)\rfloor}.
+}
+
+@chunk[<floor-log2>
+ (define-for-syntax (floor-log2 n)
+ (if (<= n 1)
+ 0
+ (add1 (floor-log2 (quotient n 2)))))]
+
+@defproc[(ceiling-log2 [n exact-positive-integer?])
+ exact-nonnegative-integer?]{
+ Exact computation of @${\lceil\log_2(n)\rceil}.
+}
+
+@chunk[<ceiling-log2>
+ (define-for-syntax (ceiling-log2 n)
+ (floor-log2 (sub1 (* n 2))))]
diff --git a/flexible-with-utils.rkt b/flexible-with-utils.rkt
@@ -1,88 +0,0 @@
-#lang aful/unhygienic hyper-literate type-expander/lang
-
-@chunk[<*>
- (require (for-syntax racket/base))
-
- (provide (for-syntax to-bits
- from-bits
- floor-log2
- ceiling-log2))
-
- <to-bits>
- <from-bits>
- <floor-log2>
- <ceiling-log2>
-
- (module* test racket/base
- (require (for-template (submod "..")))
- (require rackunit)
- <test-to-bits>
- <test-from-bits>)]
-
-@CHUNK[<to-bits>
- ; 1 => 1
- ; 2 3 => 10 11
- ;4 5 6 7 => 100 101 110 111
- ;89 ab cd ef => 1000 1001 1010 1011 1100 1101 1110 1111
-
- ; 1 => ""
- ; 2 3 => 0 1
- ;4 5 6 7 => 00 01 10 11
- ;89 ab cd ef => 000 001 010 011 100 101 110 111
-
- ; 0 => 0
- ; 1 2 => 1 10
- ;3 4 5 6 => 11 100 101 110
- ;78 9a bc de => 111 1000 1001 1010 1011 1100 1101 1110
-
-
- (define-for-syntax (to-bits n)
- (reverse
- (let loop ([n n])
- (if (= n 0)
- null
- (let-values ([(q r) (quotient/remainder n 2)])
- (cons (if (= r 1) #t #f) (loop q)))))))]
-
-@chunk[<test-to-bits>
- (check-equal? (to-bits 0) '())
- (check-equal? (to-bits 1) '(#t))
- (check-equal? (to-bits 2) '(#t #f))
- (check-equal? (to-bits 3) '(#t #t))
- (check-equal? (to-bits 4) '(#t #f #f))
- (check-equal? (to-bits 5) '(#t #f #t))
- (check-equal? (to-bits 6) '(#t #t #f))
- (check-equal? (to-bits 7) '(#t #t #t))
- (check-equal? (to-bits 8) '(#t #f #f #f))
- (check-equal? (to-bits 12) '(#t #t #f #f))
- (check-equal? (to-bits 1024) '(#t #f #f #f #f #f #f #f #f #f #f))]
-
-@CHUNK[<from-bits>
- (define-for-syntax (from-bits b)
- (foldl (λ (bᵢ acc)
- (+ (* acc 2) (if bᵢ 1 0)))
- 0
- b))]
-
-@chunk[<test-from-bits>
- (check-equal? (from-bits '()) 0)
- (check-equal? (from-bits '(#t)) 1)
- (check-equal? (from-bits '(#t #f)) 2)
- (check-equal? (from-bits '(#t #t)) 3)
- (check-equal? (from-bits '(#t #f #f)) 4)
- (check-equal? (from-bits '(#t #f #t)) 5)
- (check-equal? (from-bits '(#t #t #f)) 6)
- (check-equal? (from-bits '(#t #t #t)) 7)
- (check-equal? (from-bits '(#t #f #f #f)) 8)
- (check-equal? (from-bits '(#t #t #f #f)) 12)
- (check-equal? (from-bits '(#t #f #f #f #f #f #f #f #f #f #f)) 1024)]
-
-@chunk[<floor-log2>
- (define-for-syntax (floor-log2 n)
- (if (<= n 1)
- 0
- (add1 (floor-log2 (quotient n 2)))))]
-
-@chunk[<ceiling-log2>
- (define-for-syntax (ceiling-log2 n)
- (floor-log2 (sub1 (* n 2))))]
-\ No newline at end of file
diff --git a/flexible-with.hl.rkt b/flexible-with.hl.rkt
@@ -0,0 +1,238 @@
+#lang aful/unhygienic hyper-literate type-expander/lang
+
+@title[#;#:style #;(with-html5 manual-doc-style)
+ #:tag "flexible-with"
+ #:tag-prefix "phc-graph/flexible-with"]{Flexible functional
+ modification and extension of records}
+
+@(chunks-toc-prefix
+ '("(lib phc-graph/scribblings/phc-graph-implementation.scrbl)"
+ "phc-graph/flexible-with"))
+
+@chunk[<*>
+ (require (for-syntax (rename-in racket/base [... …])
+ syntax/stx
+ racket/syntax
+ racket/list
+ syntax/id-table
+ racket/sequence)
+ (for-meta 2 racket/base)
+ "flexible-with-utils.hl.rkt")
+
+ <tree-type-with-replacement>
+ <define-replace-in-tree>
+ <convert-fields>
+ <τ-tree-with-fields>
+ <define-struct→tree>
+ <define-trees>
+ <example>]
+
+@racketblock[
+ (a #,(+ 1 1) b)]
+
+@CHUNK[<tree-type-with-replacement>
+ (define-for-syntax (tree-type-with-replacement n last τ*)
+ (define-values (next mod) (quotient/remainder n 2))
+ (cond [(null? τ*) last]
+ [(= mod 0)
+ (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>
+ (if (= i 1)
+ #'(λ () replacement)
+ (let* ([bits (to-bits i)]
+ [next (from-bits (cons #t (cddr bits)))]
+ [mod (cadr bits)])
+ (define/with-syntax next-id (vector-ref names (sub1 next)))
+ (if mod
+ #`(λ ()
+ (let ([tree (tree-thunk)])
+ (let ([left-subtree (car tree)]
+ [right-subtree (cdr tree)])
+ (cons left-subtree
+ ((next-id (λ () right-subtree) replacement))))))
+ #`(λ ()
+ (let ([tree (tree-thunk)])
+ (let ([left-subtree (car tree)]
+ [right-subtree (cdr tree)])
+ (cons ((next-id (λ () left-subtree) replacement))
+ right-subtree)))))))]
+
+@CHUNK[<define-replace-in-tree>
+ (define-for-syntax (define-replace-in-tree names τ* i depth)
+ (define/with-syntax name (vector-ref names (sub1 i)))
+ (define τ*-limited (take τ* depth))
+ #`(begin
+ (provide name)
+ (: name
+ (∀ (#,@τ*-limited T)
+ (→ (→ #,(tree-type-with-replacement i #'Any τ*-limited))
+ T
+ (→ #,(tree-type-with-replacement i #'T τ*-limited)))))
+ (define (name tree-thunk replacement)
+ #,<make-replace-in-tree-body>)))]
+
+@CHUNK[<convert-fields>
+ (define-for-syntax (convert-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[<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>
+ (define-for-syntax (τ-tree-with-fields struct-fields fields)
+ (define/with-syntax (struct-field …) struct-fields)
+ (define/with-syntax (field …) fields)
+ <utils>
+ ;; Like in convert-from-struct
+ (define lookup
+ (make-free-id-table
+ (for/list ([n (in-syntax all-fields)]
+ [i (in-naturals)])
+ (cons n (+ i offset)))))
+ (define fields+indices
+ (sort (stx-map #λ(cons % (free-id-table-ref lookup %))
+ #'(struct-field …))
+ <
+ #:key cdr))
+
+ (define up (* offset 2))
+
+ ;; Like in convert-fields, but with Pairof
+ (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
+ `(Pairof ,(f (* i 2))
+ ,(f (add1 (* i 2))))))))
+ (f 1))]
+
+@CHUNK[<define-struct→tree>
+ (define-for-syntax (define-struct→tree
+ offset all-fields τ* struct-name fields)
+ (define/with-syntax (field …) fields)
+ (define/with-syntax fields→tree-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
+ (make-free-id-table
+ (for/list ([n (in-syntax all-fields)]
+ [i (in-naturals)])
+ (cons n (+ i offset)))))
+ (define fields+indices
+ (sort (stx-map #λ(cons % (free-id-table-ref lookup %))
+ fields)
+ <
+ #:key cdr))
+ #`(begin
+ (: fields→tree-name (∀ (field …)
+ (→ field …
+ (→ #,(τ-tree-with-fields #'(field …)
+ all-fields)))))
+ (define (fields→tree-name field …)
+ (λ ()
+ #,(convert-fields (* offset 2) fields+indices)))
+
+ (: tree→fields-name (∀ (field …)
+ (→ (→ #,(τ-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 ()
+ [(bt-fields-id (field …) [struct struct-field …] …)
+ (let ()
+ <utils>
+ (define ∀-types (map #λ(format-id #'here "τ~a" %)
+ (range (add1 depth-above))))
+ (define total-nb-functions (vector-length names))
+ #`(begin
+ (define-type-expander (bt-fields-id stx)
+ (syntax-case stx ()
+ [(_ . fs)
+ #`(∀ fs (→ #,(τ-tree-with-fields #'fs
+ #'(field …))))]))
+ #,@(map #λ(define-replace-in-tree names ∀-types % (floor-log2 %))
+ (range 1 (add1 total-nb-functions)))
+ #,@(map #λ(define-struct→tree
+ offset all-fields ∀-types %1 %2)
+ (syntax->list #'(struct …))
+ (syntax->list #'([struct-field …] …)))))]))]
+
+@CHUNK[<utils>
+ (define all-fields #'(field …))
+ (define depth-above (ceiling-log2 (length (syntax->list #'(field …)))))
+ (define offset (expt 2 depth-above))
+ (define i*-above (range 1 (expt 2 depth-above)))
+ (define names (list->vector
+ (append (map (λ (i) (format-id #'here "-with-~a" i))
+ i*-above)
+ (stx-map (λ (f) (format-id f "with-~a" f))
+ #'(field …)))))]
+@CHUNK[<example>
+ (define-syntax (gs stx)
+ (syntax-case stx ()
+ [(_ bt-fields-id nfields (f …) [struct struct-field …] …)
+ (let ()
+ (define/with-syntax (field …)
+ (append (syntax->list #'(f …))
+ (map (λ (_) (datum->syntax #'nfields (gensym 'g)))
+ (range (- (syntax-e #'nfields)
+ (length (syntax->list #'(f …))))))))
+ (define-trees #'(bt-fields-id (field …) [struct struct-field …] …)))]))
+
+ ;(gs 6)
+ (gs bt-fields
+ 16
+ (a b c)
+ [sab a b]
+ [sbc b c])
+
+ (ann (with-c (sab→tree 1 2) 'nine)
+ ((bt-fields a b c) One Positive-Byte 'nine))]
+
+@include-section[(submod "flexible-with-utils.hl.rkt" doc)]
+\ No newline at end of file
diff --git a/flexible-with.rkt b/flexible-with.rkt
@@ -1,224 +0,0 @@
-#lang aful/unhygienic hyper-literate type-expander/lang
-
-@chunk[<*>
- (require (for-syntax (rename-in racket/base [... …])
- syntax/stx
- racket/syntax
- racket/list
- syntax/id-table
- racket/sequence)
- (for-meta 2 racket/base)
- "flexible-with-utils.rkt")
-
- <tree-type-with-replacement>
- <define-replace-in-tree>
- <convert-fields>
- <τ-tree-with-fields>
- <define-struct→tree>
- <define-trees>
- <example>]
-
-@CHUNK[<tree-type-with-replacement>
- (define-for-syntax (tree-type-with-replacement n last τ*)
- (define-values (next mod) (quotient/remainder n 2))
- (cond [(null? τ*) last]
- [(= mod 0)
- (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>
- (if (= i 1)
- #'(λ () replacement)
- (let* ([bits (to-bits i)]
- [next (from-bits (cons #t (cddr bits)))]
- [mod (cadr bits)])
- (define/with-syntax next-id (vector-ref names (sub1 next)))
- (if mod
- #`(λ ()
- (let ([tree (tree-thunk)])
- (let ([left-subtree (car tree)]
- [right-subtree (cdr tree)])
- (cons left-subtree
- ((next-id (λ () right-subtree) replacement))))))
- #`(λ ()
- (let ([tree (tree-thunk)])
- (let ([left-subtree (car tree)]
- [right-subtree (cdr tree)])
- (cons ((next-id (λ () left-subtree) replacement))
- right-subtree)))))))]
-
-@CHUNK[<define-replace-in-tree>
- (define-for-syntax (define-replace-in-tree names τ* i depth)
- (define/with-syntax name (vector-ref names (sub1 i)))
- (define τ*-limited (take τ* depth))
- #`(begin
- (provide name)
- (: name
- (∀ (#,@τ*-limited T)
- (→ (→ #,(tree-type-with-replacement i #'Any τ*-limited))
- T
- (→ #,(tree-type-with-replacement i #'T τ*-limited)))))
- (define (name tree-thunk replacement)
- #,<make-replace-in-tree-body>)))]
-
-@CHUNK[<convert-fields>
- (define-for-syntax (convert-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[<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>
- (define-for-syntax (τ-tree-with-fields struct-fields fields)
- (define/with-syntax (struct-field …) struct-fields)
- (define/with-syntax (field …) fields)
- <utils>
- ;; Like in convert-from-struct
- (define lookup
- (make-free-id-table
- (for/list ([n (in-syntax all-fields)]
- [i (in-naturals)])
- (cons n (+ i offset)))))
- (define fields+indices
- (sort (stx-map #λ(cons % (free-id-table-ref lookup %))
- #'(struct-field …))
- <
- #:key cdr))
-
- (define up (* offset 2))
-
- ;; Like in convert-fields, but with Pairof
- (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
- `(Pairof ,(f (* i 2))
- ,(f (add1 (* i 2))))))))
- (f 1))]
-
-@CHUNK[<define-struct→tree>
- (define-for-syntax (define-struct→tree
- offset all-fields τ* struct-name fields)
- (define/with-syntax (field …) fields)
- (define/with-syntax fields→tree-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
- (make-free-id-table
- (for/list ([n (in-syntax all-fields)]
- [i (in-naturals)])
- (cons n (+ i offset)))))
- (define fields+indices
- (sort (stx-map #λ(cons % (free-id-table-ref lookup %))
- fields)
- <
- #:key cdr))
- #`(begin
- (: fields→tree-name (∀ (field …)
- (→ field …
- (→ #,(τ-tree-with-fields #'(field …)
- all-fields)))))
- (define (fields→tree-name field …)
- (λ ()
- #,(convert-fields (* offset 2) fields+indices)))
-
- (: tree→fields-name (∀ (field …)
- (→ (→ #,(τ-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 ()
- [(bt-fields-id (field …) [struct struct-field …] …)
- (let ()
- <utils>
- (define ∀-types (map #λ(format-id #'here "τ~a" %)
- (range (add1 depth-above))))
- (define total-nb-functions (vector-length names))
- #`(begin
- (define-type-expander (bt-fields-id stx)
- (syntax-case stx ()
- [(_ . fs)
- #`(∀ fs (→ #,(τ-tree-with-fields #'fs
- #'(field …))))]))
- #,@(map #λ(define-replace-in-tree names ∀-types % (floor-log2 %))
- (range 1 (add1 total-nb-functions)))
- #,@(map #λ(define-struct→tree
- offset all-fields ∀-types %1 %2)
- (syntax->list #'(struct …))
- (syntax->list #'([struct-field …] …)))))]))]
-
-@CHUNK[<utils>
- (define all-fields #'(field …))
- (define depth-above (ceiling-log2 (length (syntax->list #'(field …)))))
- (define offset (expt 2 depth-above))
- (define i*-above (range 1 (expt 2 depth-above)))
- (define names (list->vector
- (append (map (λ (i) (format-id #'here "-with-~a" i))
- i*-above)
- (stx-map (λ (f) (format-id f "with-~a" f))
- #'(field …)))))]
-@CHUNK[<example>
- (define-syntax (gs stx)
- (syntax-case stx ()
- [(_ bt-fields-id nfields (f …) [struct struct-field …] …)
- (let ()
- (define/with-syntax (field …)
- (append (syntax->list #'(f …))
- (map (λ (_) (datum->syntax #'nfields (gensym 'g)))
- (range (- (syntax-e #'nfields)
- (length (syntax->list #'(f …))))))))
- (define-trees #'(bt-fields-id (field …) [struct struct-field …] …)))]))
-
- ;(gs 6)
- (gs bt-fields
- 16
- (a b c)
- [sab a b]
- [sbc b c])
-
- (ann (with-c (sab→tree 1 2) 'nine)
- ((bt-fields a b c) One Positive-Byte 'nine))]
-\ No newline at end of file
diff --git a/scribblings/phc-graph-implementation.scrbl b/scribblings/phc-graph-implementation.scrbl
@@ -11,4 +11,5 @@ the @other-doc['(lib "phc-graph/scribblings/phc-graph.scrbl")] document.
@(table-of-contents)
-@include-section[(submod "../traversal.hl.rkt" doc)]
-\ No newline at end of file
+@include-section[(submod "../traversal.hl.rkt" doc)]
+@include-section[(submod "../flexible-with.hl.rkt" doc)]
+\ No newline at end of file
