From 8581321a90f1f1997ed3947528990940bb4e1a0e Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 14 Feb 2018 13:07:28 -0800 Subject: [PATCH] generic --- quad/quad/atomize.rkt | 6 +++--- quad/quad/break.rkt | 20 ++++++++++---------- quad/quad/generic.rkt | 12 ++++++++++++ quad/quad/qexpr.rkt | 7 +++---- quad/quad/quad.rkt | 28 +++++++++++++++------------- quad/quad/typewriter.rkt | 12 ++++++------ 6 files changed, 49 insertions(+), 36 deletions(-) create mode 100644 quad/quad/generic.rkt diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index f997cb80..46b1ec32 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -1,6 +1,6 @@ #lang debug racket/base (require racket/contract racket/match racket/list txexpr racket/dict sugar/list racket/function - "quad.rkt" "qexpr.rkt" "param.rkt") + "quad.rkt" "qexpr.rkt" "param.rkt" "generic.rkt") (provide (all-defined-out)) (module+ test (require rackunit)) @@ -13,7 +13,7 @@ ((hasheq 'foo "bar" 'zim "zam") . update-with . (hasheq 'zim "BANG") (hasheq 'toe "jam") (hasheq 'foo "zay")) '#hasheq((zim . "BANG") (foo . "zay") (toe . "jam")))) -(define (merge-whitespace aqs [white-aq? (λ (aq) (char-whitespace? (car (qe aq))))]) +(define (merge-whitespace aqs [white-aq? (λ (aq) (char-whitespace? (car (elems aq))))]) ;; collapse each sequence of whitespace aqs to the first one, and make it a space ;; also drop leading & trailing whitespaces ;; (same behavior as web browsers) @@ -25,7 +25,7 @@ (loop (list acc bs (if (and (pair? rest) ;; we precede bs (only #t if rest starts with bs, because we took the ws) (pair? bs) ;; we follow bs (pair? ws)) ;; we have ws - (quad (qa (car ws)) #\space) + (quad (attrs (car ws)) #\space) null)) rest))))) (module+ test diff --git a/quad/quad/break.rkt b/quad/quad/break.rkt index b8984f75..146a3815 100644 --- a/quad/quad/break.rkt +++ b/quad/quad/break.rkt @@ -1,6 +1,6 @@ #lang debug racket/base (require racket/contract racket/list racket/match txexpr sugar/debug sugar/define sugar/list racket/promise racket/function (only-in racket/control call/prompt) - "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt") + "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt" "generic.rkt") (define+provide/contract (insert-breaks xs [target-size (current-line-width)] @@ -65,15 +65,15 @@ (define d (q (hasheq 'size (delay (values 1 1 1))) #\d)) (define sp (q (hasheq 'size (delay (values 0 1 0))) #\space)) (define br (q (hasheq 'size (delay (values 0 0 0))) #\newline)) -(define optional-break? (λ (q) (and (quad? q) (memv (car (qe q)) '(#\space))))) +(define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space))))) (define (lbs xs size [debug #f]) (insert-breaks xs size debug #:break-val 'lb - #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (qe q)) '(#\newline)))) + #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline)))) #:optional-break-proc optional-break? - #:size-proc (λ (q) (let ([val (hash-ref (qa q) 'size (λ () - (if (memv (car (qe q)) '(#\space)) + #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ () + (if (memv (car (elems q)) '(#\space)) (delay (values 0 1 0)) (delay (values 1 1 1)))))]) (if (promise? val) (force val) (val)))))) @@ -141,7 +141,7 @@ (define (visual-breaks str int) (apply string (for/list ([b (in-list (lbs (atomize str) int))]) (cond - [(quad? b) (car (qe b))] + [(quad? b) (car (elems b))] [else #\|])))) (test-case @@ -167,7 +167,7 @@ (define (pbs xs size [debug #f]) (insert-breaks xs size debug #:break-val 'pb - #:mandatory-break-proc (λ (x) (and (quad? x) (memv (car (qe x)) '(#\page)))) + #:mandatory-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page)))) #:optional-break-proc (λ (x) (eq? x 'lb)) #:size-proc (λ (q) (case q [(lb) (values 0 0 0)] @@ -206,10 +206,10 @@ (define (lbs2 xs size [debug #f]) (insert-breaks xs size debug #:break-val 'lb - #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (qe q)) '(#\newline)))) + #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline)))) #:optional-break-proc optional-break? - #:size-proc (λ (q) (let ([val (hash-ref (qa q) 'size (λ () - (if (memv (car (qe q)) '(#\space)) + #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ () + (if (memv (car (elems q)) '(#\space)) (delay (values 0 1 0)) (delay (values 1 1 1)))))]) (if (promise? val) (force val) (val)))) diff --git a/quad/quad/generic.rkt b/quad/quad/generic.rkt new file mode 100644 index 00000000..c862247a --- /dev/null +++ b/quad/quad/generic.rkt @@ -0,0 +1,12 @@ +#lang debug racket/base +(require racket/generic) +(provide (all-defined-out)) + +(define-generics quad + (elems quad) + (attrs quad) + (entrance-point quad) + (exit-point quad) + (inner-point quad) + (size quad) + (draw quad)) \ No newline at end of file diff --git a/quad/quad/qexpr.rkt b/quad/quad/qexpr.rkt index 10298042..a2d7cad6 100644 --- a/quad/quad/qexpr.rkt +++ b/quad/quad/qexpr.rkt @@ -1,5 +1,5 @@ #lang debug racket/base -(require xml racket/contract racket/string racket/match racket/list txexpr "quad.rkt") +(require xml racket/contract racket/string racket/match racket/list txexpr "quad.rkt" "generic.rkt") (provide (all-defined-out)) (module+ test (require rackunit)) @@ -27,8 +27,7 @@ (check-true (qexpr? '(quad "Hello world"))) (check-false (qexpr? 'q))) -(define (quad-name q) - (string->symbol (string-trim (symbol->string (vector-ref (struct->vector q) 0)) "struct:$"))) +(define (quad-name q) (string->symbol (string-trim (symbol->string (object-name q)) "$"))) (define/contract (qexpr #:clean-attrs? [clean-attrs? #f] #:name [name 'q] @@ -50,7 +49,7 @@ (quad? . -> . qexpr?) (let loop ([x q]) (cond - [(quad? x) (apply qexpr #:name (quad-name x) #:clean-attrs? #t (hash->attrs (qa x)) (map loop (qe x)))] + [(quad? x) (apply qexpr #:name (quad-name x) #:clean-attrs? #t (hash->attrs (attrs x)) (map loop (elems x)))] [else x]))) (define/contract (qml->qexpr x) diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index 37249b26..5de18d84 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -1,10 +1,18 @@ -#lang sugar/debug racket/base -(require racket/match racket/function) +#lang debug racket/base +(require racket/match racket/function "generic.rkt") (provide (all-defined-out)) (module+ test (require rackunit)) -(struct $quad (attrs elems) #:transparent) -(define quad? $quad?) +(struct $quad (attrs elems) #:transparent + #:methods gen:quad + [(define (elems q) ($quad-elems q)) + (define (attrs q) ($quad-attrs q)) + (define (entrance-point q) (hash-ref (attrs q) 'entrance 'entrance)) + (define (exit-point q) (hash-ref (attrs q) 'exit 'exit)) + (define (inner-point q) (hash-ref (attrs q) 'inner 'inner)) + (define (size q) (length (elems q))) + (define (draw q) "<···>")]) + (define (quad-attrs? x) (and (hash? x) (hash-eq? x))) (define (quad-elem? x) (or (char? x) (string? x) ($quad? x))) (define (quad-elems? xs) (and (pair? xs) (andmap quad-elem? xs))) @@ -14,8 +22,9 @@ [(list (? quad-attrs? attrs) (? quad-elem? elems) ...) (type attrs elems)] [(list (? quad-elem? elems) ...) (apply quad #:type type #f elems)] [else (error 'bad-quad-input)])) +(define q quad) (define (quads? xs) (andmap quad? xs)) -(define (atomic-quad? x) (and (quad? x) (match (qe x) +(define (atomic-quad? x) (and (quad? x) (match (elems x) [(list (? char?)) #t] [else #f]))) (define (atomic-quads? xs) (andmap atomic-quad? xs)) @@ -23,15 +32,8 @@ (check-true (atomic-quad? ($quad '#hasheq() '(#\H)))) (check-true (atomic-quads? (list ($quad '#hasheq() '(#\H)))))) -(define quad-attrs $quad-attrs) -(define quad-elems $quad-elems) - -(define q quad) -(define q? quad?) -(define qs? quads?) -(define qa quad-attrs) -(define qe quad-elems) (struct $break $quad () #:transparent) (define (break . xs) (apply quad #:type $break xs)) (define b break) + diff --git a/quad/quad/typewriter.rkt b/quad/quad/typewriter.rkt index 64882775..e825cc59 100644 --- a/quad/quad/typewriter.rkt +++ b/quad/quad/typewriter.rkt @@ -1,11 +1,11 @@ #lang debug br/quicklang -(require racket/promise racket/list "quad.rkt" "atomize.rkt" "break.rkt" "qexpr.rkt") +(require racket/promise racket/list "quad.rkt" "atomize.rkt" "break.rkt" "qexpr.rkt" "generic.rkt") (provide (rename-out [mb #%module-begin])) -(define optional-break? (λ (q) (and (quad? q) (memv (car (qe q)) '(#\space))))) +(define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space))))) (struct $shim $quad () #:transparent) (struct $char $quad () #:transparent) -(define (charify q) ($char (qa q) (qe q))) +(define (charify q) ($char (attrs q) (elems q))) (define (shimify xs) (add-between (map charify xs) (list ($shim (hasheq) null)) #:splice? #t @@ -20,8 +20,8 @@ (insert-breaks xs size debug #:break-val (break #\newline) #:optional-break-proc optional-break? - #:size-proc (λ (q) (let ([val (hash-ref (qa q) 'size (λ () - (if (memv (car (qe q)) '(#\space)) + #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ () + (if (memv (car (elems q)) '(#\space)) (delay (values 0 1 0)) (delay (values 1 1 1)))))]) (if (promise? val) (force val) (val)))) @@ -31,7 +31,7 @@ (insert-breaks xs size debug #:break-val (break #\page) #:optional-break-proc $break? - #:size-proc (λ (q) (force (hash-ref (qa q) 'size (λ () (delay (values 1 1 1)))))) + #:size-proc (λ (q) (force (hash-ref (attrs q) 'size (λ () (delay (values 1 1 1)))))) #:finish-segment-proc (λ (pcs) (list ($page (hasheq) (filter-not $break? pcs)))))) (define (typeset args)