On Fri, Jun 12, 2020 at 2:46 AM Catonano <caton...@gmail.com> wrote: > the original paper Andy Wingo refers to uses Haskell to express this > operator and I can't read Haskell and I'm not willing to learn >
I'm confused about what you mean: in the version of "Applications of Fold to XML Transformation", on Andy Wingo's blog <https://wingolog.org/pub/fold-and-xml-transformation.pdf>, all of the examples are in Scheme. Here is a version of the example from the paper that will run in Racket—most of the code is just copied and pasted from the figures: #lang racket ;; Source: https://wingolog.org/pub/fold-and-xml-transformation.pdf (module+ test (require rackunit) (check-equal? (cartouche->svg ;; figure 16 '(cartouche (@ (line-color "red") (text-height 56)) (para "Warning: Smoking Kills"))) ;; figure 17 '(g (rect (@ (fill "none") (stroke "red") (stroke-width "4") (width "660") (height "120.0") (x "0") (y "0") (ry "20"))) (text (@ (xml:space "preserve") (font-size "56") (font-family "Georgia") (x "32") (y "88")) (tspan (@ (x "32") (y "88")) "Warning: Smoking Kills"))))) ;; ----------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------- ;; for Racket compatibility (define (atom? v) (not (pair? v))) (struct layout (x y) #:constructor-name make-layout #:transparent) ;; p. 7 ;; "Figure 20 uses without definition the macro let-params, ;; which binds lexical variables from the parameters list." ;; p. 6 ;; "... representing parameters as a list of association lists. ;; At each descent into a new SXML node, we cons the new parameters ;; onto the list. Lookup proceeds left-to-right in the parameters list, ;; stopping at the first alist in which a parameter is found." (require syntax/parse/define) (define-simple-macro (let-params params:expr (name:id ...) body:expr ...+) (let ([the-params params]) (let ([name (params-ref the-params 'name)] ...) body ...))) (define (params-ref params name) (or (for*/first ([alist (in-list params)] [pr (in-list alist)] #:when (eq? name (car pr))) (cadr pr)) (raise-argument-error 'params-ref "no binding found for parameter" "name" name "params" params))) ;; ----------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------- ;; figure 7 (part) (define (assq-ref alist key default) (cond ((assq key alist) => cdr) (else default))) ;; figure 11 (define (fold-values proc list . seeds) (if (null? list) (apply values seeds) (call-with-values (lambda () (apply proc (car list) seeds)) (lambda seeds (apply fold-values proc (cdr list) seeds))))) ;; figure 12 (define (foldts*-values fdown fup fhere tree . seeds) (if (atom? tree) (apply fhere tree seeds) (call-with-values (lambda () (apply fdown tree seeds)) (lambda (tree . kseeds) (call-with-values (lambda () (apply fold-values (lambda (tree . seeds) (apply foldts*-values fdown fup fhere tree seeds)) tree kseeds)) (lambda kseeds (apply fup tree (append seeds kseeds)))))))) ;; figure 13, but with fdown replaced by figure 14 (define (post-order bindings tree) (define (err . args) (error "no binding available" args)) (define (fdown tree bindings pcont ret) (let ((tail (assq-ref bindings (car tree) #f))) (cond ((not tail) (let ((default (assq-ref bindings '*default* err))) (values tree bindings default '()))) ((pair? tail) (let ((cont (cdr tail))) (case (car tail) ((*preorder*) (values '() bindings (lambda x (reverse x)) (apply cont tree))) ((*macro*) (fdown (apply cont tree) bindings pcont ret)) (else (let ((new-bindings (append (car tail) bindings))) (values tree new-bindings cont '())))))) (else (values tree bindings tail '()))))) (define (fup tree bindings cont ret kbindings kcont kret) (values bindings cont (cons (apply kcont (reverse kret)) ret))) (define (fhere tree bindings cont ret) (define (tcont x) (if (symbol? x) x ; pass tags through ((or (assq-ref bindings '*text* #f) (assq-ref bindings '*default* err)) '*text* x))) (values bindings cont (cons (tcont tree) ret))) (call-with-values (lambda () (foldts*-values fdown fup fhere tree bindings #f '())) (lambda (bindings cont ret) (car ret)))) ;; figure 15, with fdown, fup, and fhere ;; filled in from figures 24, 15, and 26, respectively (define (fold-layout bindings params layout tree) (define (err . args) (error "no binding available" args)) (define (fdown tree bindings pcont params layout ret) (define (fdown-helper new-bindings new-layout cont) (let ((cont-with-tag (lambda args (apply cont (car tree) args))) (bindings (if new-bindings (append new-bindings bindings) bindings))) (cond ((null? (cdr tree)) (values '() bindings cont-with-tag (cons '() params) new-layout '())) ((and (pair? (cadr tree)) (eq? (caadr tree) '@)) (let ((params (cons (cdadr tree) params))) (values (cddr tree) bindings cont-with-tag params new-layout '()))) (else (values (cdr tree) bindings cont-with-tag (cons '() params) new-layout '()))))) (define (no-bindings) (fdown-helper #f layout (assq-ref bindings '*default* err))) (define (macro macro-handler) (fdown (apply macro-handler tree) bindings pcont params layout ret)) (define (pre pre-handler) (values '() bindings (lambda (params layout old-layout kids) (values layout (reverse kids))) params layout (apply pre-handler tree))) (define (have-bindings tag-bindings) (fdown-helper (assq-ref tag-bindings 'bindings #f) ((assq-ref tag-bindings 'pre-layout (lambda (tag params layout) layout)) tree params layout) (assq-ref tag-bindings 'post (assq-ref bindings '*default* err)))) (let ((tag-bindings (assq-ref bindings (car tree) #f))) (cond ((not tag-bindings) (no-bindings)) ((assq-ref tag-bindings 'macro #f) => macro) ((assq-ref tag-bindings 'pre #f) => pre) (else (have-bindings tag-bindings))))) (define (fup tree bindings cont params layout ret kbindings kcont kparams klayout kret) (call-with-values (lambda () (kcont kparams layout klayout (reverse kret))) (lambda (klayout kret) (values bindings cont params klayout (cons kret ret))))) (define (fhere tree bindings cont params layout ret) (call-with-values (lambda () ((assq-ref bindings '*text* err) tree params layout)) (lambda (tlayout tret) (values bindings cont params tlayout (cons tret ret))))) (call-with-values (lambda () (foldts*-values fdown fup fhere tree bindings #f params layout '())) (lambda (bindings cont params layout ret) (values (car ret) layout)))) ;; figure 20 (define (cartouche-pre-layout tree params layout) (let ((x (layout-x layout)) (y (layout-y layout))) (let-params params (margin-left margin-top) (make-layout (+ x margin-left) (+ y margin-top))))) ;; figure 21 (define (make-text-x params layout) (layout-x layout)) (define (make-text-y params layout) (let-params params (text-height) (+ text-height (layout-y layout)))) (define (layout-advance-text-line params layout) (let-params params (text-height line-spacing) (make-layout (layout-x layout) (+ (* text-height line-spacing) (layout-y layout))))) (define (text-handler text params layout) (values (layout-advance-text-line params layout) `(tspan (@ (x ,(number->string (make-text-x params layout))) (y ,(number->string (make-text-y params layout)))) ,text))) ;; figure 22 (define (p-post tag params old-layout layout kids) (values layout (let-params params (text-height font-family) `(text (@ (xml:space "preserve") (font-size ,(number->string text-height)) (font-family ,font-family) (x ,(number->string (make-text-x params old-layout))) (y ,(number->string (make-text-y params old-layout)))) ,@kids)))) ;; figure 23 (define (cartouche-post tag params old-layout layout kids) (let ((oldx (layout-x old-layout)) (oldy (layout-y old-layout)) (newy (layout-y layout))) (let-params params (margin-bottom stroke-width line-color page-width) (values (make-layout oldx (+ newy margin-bottom)) `(g (rect (@ (fill "none") (stroke ,line-color) (stroke-width ,(number->string stroke-width)) (width ,(number->string (- page-width (* 2 oldx)))) (height ,(number->string (+ newy margin-bottom))) ;; CORRECTION: was: (- newy oldy) (x ,(number->string oldx)) (y ,(number->string oldy)) (ry "20"))) ; rounded corners ,@kids))))) ;; figure 27 (define *cartouche-stylesheet* `((para (post . ,p-post)) (cartouche (pre-layout . ,cartouche-pre-layout) (post . ,cartouche-post)) (*text* . ,text-handler))) (define *default-params* ;; CORRECTION: was missing a layer of parentheses '(((margin-left 32) (margin-right 32) (margin-top 32) (margin-bottom 32) (line-spacing 1.0) (font-family "Georgia") (stroke-width 4) (line-color "blue") (text-height 64) (page-width 660)))) (define (cartouche->svg doc) ;; CORRECTION: was: ;; (fold-layout doc *cartouche-stylesheet* ;; *default-params* ;; (make-layout 0 0))) (define-values [svg layout] (fold-layout *cartouche-stylesheet* *default-params* (make-layout 0 0) doc)) svg) -- You received this message because you are subscribed to the Google Groups "Racket Users" group. To unsubscribe from this group and stop receiving emails from it, send an email to racket-users+unsubscr...@googlegroups.com. To view this discussion on the web visit https://groups.google.com/d/msgid/racket-users/CAH3z3gY01RKmwk8JJeQeLBgpz37iAogLcZUPjbfP-rqt%2BnwANw%40mail.gmail.com.
