let me assq something

main
Matthew Butterick 3 years ago
parent f60e46f39f
commit ba872ac51f

@ -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))))

@ -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)))
(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"))
Loading…
Cancel
Save