diff --git a/quad/quad/quad-class.rkt b/quad/quad/quad-class.rkt new file mode 100644 index 00000000..7038b62a --- /dev/null +++ b/quad/quad/quad-class.rkt @@ -0,0 +1,91 @@ +#lang debug racket/base +(require racket/match racket/promise racket/dict racket/class) +(provide (all-defined-out)) +(module+ test (require rackunit)) + +(define quad% + (class object% + (super-new) + (init-field [@attrs null] [@elems null]) + ;; why 'nw and 'ne as defaults for in and out points: + ;; if size is '(0 0), 'nw and 'ne are the same point, + ;; and everything piles up at the origin + ;; if size is otherwise, the items don't pile up (but rather lay out in a row) + (field [@in 'nw] + [@out 'ne] + [@inner #f] + [@printable #f] + [@size '(0 0)] + [@offset '(0 0)] + [@origin '(0 0)]) + + (define/public-final (elems) @elems) + (define/public-final (attrs) @attrs) + (define/public-final (in) @in) + (define/public-final (out) @out) + (define/public-final (inner) (or @inner (in))) + (define/public-final (origin) @origin) + (define/public-final (set-origin! val) (set! @origin val)) + (define/public (offset [signal #f]) @offset) + + (define/public (printable? [signal #f]) + (match (or @printable + (match @elems + [(list (and (? char?) (? char-whitespace?))) + #:when (memq signal '(start end)) #false] + [else #true])) + [(? procedure? proc) (proc signal)] + [(? promise? prom) (force prom)] + [val val])) + + (define/public (size) + (match @size + [(? procedure? proc) (proc)] + [(? promise? prom) (force prom)] + [val val])) + + (define/public (draw [surface #f]) + (for-each (λ (e) (draw e surface)) @elems)))) + +(define (quad? x) (is-a? x quad%)) +(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))) +(define (quad #:type [type quad%] . xs) + (match xs + [(list #f xs ...) (apply quad #:type type (hasheq) xs)] + [(list (list (? symbol? sym) rest ...) (? quad-elem? elems) ...) + (make-object type (apply hasheq (cons sym rest)) elems)] + [(list (? dict? attrs) (? quad-elem? elems) ...) + (make-object type (for/hasheq ([(k v) (in-dict attrs)]) + (values k v)) elems)] + [(list (? quad-attrs? attrs) (? quad-elem? elems) ...) (make-object 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 (send x elems) + [(list (? char?)) #t] + [else #f]))) +(define (atomic-quads? xs) (andmap atomic-quad? xs)) + +(module+ test + (check-true (atomic-quad? (make-object quad% '#hasheq() '(#\H)))) + (check-true (atomic-quads? (list (make-object quad% '#hasheq() '(#\H)))))) + + + + +(define break% (class quad% (super-new))) +(define (break . xs) (apply quad #:type break% xs)) +(define b break) + + + +(module+ test + (define x (make-object + (class quad% + (super-new) + (define/override (draw [surface #f]) + (println "foo"))) '(#\H #\e #\l #\o))) + (send x draw))