diff --git a/quad/quad2/compile.rkt b/quad/quad2/compile.rkt index 5063b284..8301eaab 100644 --- a/quad/quad2/compile.rkt +++ b/quad/quad2/compile.rkt @@ -16,17 +16,17 @@ ($point (+ ($point-x p0) ($size-width p1)) (+ ($point-y p0) ($size-height p1)))) (define/contract (size char) - ($quad? . -> . $size?) + (quad? . -> . $size?) ($size 1 1)) (define/contract (advance char) - ($quad? . -> . $size?) + (quad? . -> . $size?) ($size 1 0)) (define/contract (quadify str) - (string? . -> . (listof $quad?)) + (string? . -> . (listof quad?)) (for/list ([c (in-string str)]) - ($quad #f c))) + (make-quad #f (list (cons 'char c))))) (define (make-compiler . passes) (apply compose1 (reverse (cons quadify passes)))) @@ -48,7 +48,7 @@ (and (rect-contains-point? outer ($rect-origin inner)) (rect-contains-point? outer ($point (max-x inner) (max-y inner))))) -(define (has-position? q) (not (eq? ($quad-posn q) #false))) +(define (has-position? q) (not (eq? (quad-posn q) #false))) (define-pass (layout qs) #:precondition (λ (qs) (and (list? qs) (andmap (λ (q) (not (has-position? q))) qs))) #:postcondition (λ (qs) (and (list? qs) (andmap has-position? qs))) @@ -62,7 +62,7 @@ ([q (in-list qs)]) (define first-posn-on-next-line ($point 0 (add1 ($point-y posn)))) (define winning-posn (or (ormap (λ (posn) (quad-fits? q posn)) (list posn first-posn-on-next-line)) (error 'no-posn-that-fits))) - (set-$quad-posn! q winning-posn) + (set-quad-posn! q winning-posn) (posn-add winning-posn (advance q)))) (define-pass (make-drawing-insts qs) @@ -72,8 +72,8 @@ (list ($doc 'start) ($page 'start) (for/list ([q (in-list qs)]) (cond - [($quad? q) - (list ($move ($quad-posn q)) ($text (char->integer ($quad-char q))))] + [(quad? q) + (list ($move (quad-posn q)) ($text (char->integer (quad-char q))))] [else (error 'render-unknown-thing)])) ($page 'end) ($doc 'end)))) diff --git a/quad/quad2/quad.rkt b/quad/quad2/quad.rkt index ed0cc8cb..14b3cc29 100644 --- a/quad/quad2/quad.rkt +++ b/quad/quad2/quad.rkt @@ -1,11 +1,57 @@ -#lang racket/base +#lang debug racket/base +(require racket/contract racket/match (for-syntax racket/base racket/syntax)) (provide (all-defined-out)) (struct $point (x y) #:transparent #:mutable) (struct $size (width height) #:transparent #:mutable) (struct $rect (origin size) #:transparent #:mutable) -(struct $quad (posn char) #:transparent #:mutable) - (define current-wrap-width (make-parameter 5)) -(define current-page-size (make-parameter ($size 10 10))) \ No newline at end of file +(define current-page-size (make-parameter ($size 10 10))) + +(define (quad? x) + (match x + [($quad (? quad-tag?) + (list (cons symbol? _) ...) + (list _ ...)) #true] + [_ #false])) + +(struct $quad (tag attrs elems) #:transparent #:mutable) + +(define quad-tag $quad-tag) +(define (quad-tag? x) (match x + [(or (? symbol?) #false) #true] + [_ #false])) +(define set-quad-tag! set-$quad-tag!) +(define quad-attrs $quad-attrs) +(define (quad-attrs? x) (match x + [(list (cons symbol? _) ...) #true] + [_ #false])) +(define set-quad-attrs! set-$quad-attrs!) +(define quad-elems $quad-elems) +(define (quad-elems? x) (list? x)) +(define set-quad-elems! set-$quad-elems!) + +(define/contract (make-quad tag attrs . elems) + ((quad-tag? quad-attrs?) #:rest quad-elems? . ->* . quad?) + ($quad tag attrs elems)) + +(define (quad-ref q key [default-val #false]) (match (assq key (quad-attrs q)) + [#false default-val] + [(cons _ val) val])) +(define (quad-set! q key val) + (set-quad-attrs! q (cons (cons key val) (quad-attrs q)))) + +(define-syntax (define-quad-field stx) + (syntax-case stx () + [(_ FIELD) + (with-syntax ([GETTER (format-id stx "quad-~a" #'FIELD)] + [SETTER (format-id stx "set-quad-~a!" #'FIELD)]) + #'(begin + (define (GETTER q) (quad-ref q 'FIELD)) + (define (SETTER q val) (quad-set! q 'FIELD val))))])) + +(define-quad-field posn) +(define-quad-field char) + +(define q (make-quad 'div '((hello . "world")) "fine")) \ No newline at end of file