.

flexible-with.rkt

@@ -10,20 +10,26 @@
                 (for-meta 2 racket/base)
                 "flexible-with-utils.rkt")
        
-       <→τ>
+       <tree-type-with-replacement>
        <define-replace-in-tree>
        <convert-fields>
        <τ-tree-with-fields>
-       <convert-from-struct>
-       <mk>
+       <define-struct→tree>
+       <define-trees>
        <example>]
 
-@CHUNK[<→τ>
-       (define-for-syntax (→τ n last τ*)
+@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) (→τ next #`(Pairof #,last #,(car τ*)) (cdr τ*))]
-               [else (→τ next #`(Pairof #,(car τ*) #,last) (cdr τ*))]))]
+               [(= 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)
@@ -54,9 +60,9 @@
              (provide name)
              (: name
                 (∀ (#,@τ*-limited T)
-                   (→ (→ #,(→τ i #'Any τ*-limited))
+                   (→ (→ #,(tree-type-with-replacement i #'Any τ*-limited))
                       T
-                      (→ #,(→τ i #'T τ*-limited)))))
+                      (→ #,(tree-type-with-replacement i #'T τ*-limited)))))
              (define (name tree-thunk replacement)
                #,<make-replace-in-tree-body>)))]
 
@@ -77,6 +83,23 @@
          ;(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)
@@ -110,12 +133,14 @@
                               ,(f (add1 (* i 2))))))))
          (f 1))]
 
-@CHUNK[<convert-from-struct>
-       (define-for-syntax (convert-from-struct
-                           offset all-fields τ* struct-name fields)
+@CHUNK[<define-struct→tree>
+       (define-for-syntax (define-struct→tree
+                            offset all-fields τ* struct-name fields)
          (define/with-syntax (field …) fields)
-         (define/with-syntax conv-name
-           (format-id struct-name "convert-~a" struct-name))
+         (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)]
@@ -127,20 +152,31 @@
                  <
                  #:key cdr))
          #`(begin
-             (: conv-name (∀ (field …)
-                             (→ field …
-                                (→ #,(τ-tree-with-fields #'(field …)
-                                                         all-fields)))))
-             (define (conv-name field …)
+             (: fields→tree-name (∀ (field …)
+                                    (→ field …
+                                       (→ #,(τ-tree-with-fields #'(field …)
+                                                                all-fields)))))
+             (define (fields→tree-name field …)
                (λ ()
-                 #,(convert-fields (* offset 2) fields+indices)))))]
+                 #,(convert-fields (* offset 2) fields+indices)))
 
-@CHUNK[<mk>
-       (define-for-syntax (mk stx)
+             (: 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)
@@ -148,10 +184,10 @@
                       [(_ . fs)
                        #`(∀ fs (→ #,(τ-tree-with-fields #'fs
                                                         #'(field …))))]))
-                  #,@(map #λ(define-replace-in-tree names τ* % (floor-log2 %))
+                  #,@(map #λ(define-replace-in-tree names ∀-types % (floor-log2 %))
                           (range 1 (add1 total-nb-functions)))
-                  #,@(map #λ(convert-from-struct
-                             offset all-fields τ* %1 %2)
+                  #,@(map #λ(define-struct→tree
+                              offset all-fields ∀-types %1 %2)
                           (syntax->list #'(struct …))
                           (syntax->list #'([struct-field …] …)))))]))]
 
@@ -160,12 +196,11 @@
        (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 τ* (map #λ(format-id #'here "τ~a" %) (range (add1 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 …)))))]
+                      (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 ()
@@ -176,7 +211,7 @@
                         (map (λ (_) (datum->syntax #'nfields (gensym 'g)))
                              (range (- (syntax-e #'nfields)
                                        (length (syntax->list #'(f …))))))))
-              (mk #'(bt-fields-id (field …) [struct struct-field …] …)))]))
+              (define-trees #'(bt-fields-id (field …) [struct struct-field …] …)))]))
 
        ;(gs 6)
        (gs bt-fields
@@ -185,5 +220,5 @@
            [sab a b]
            [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))]