From ba872ac51f8f5426527e47c6ff536e6247f359e7 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Thu, 24 Feb 2022 16:39:04 -0800
Subject: [PATCH] let me assq something

---
 quad/quad2/compile.rkt | 16 ++++++-------
 quad/quad2/quad.rkt    | 54 ++++++++++++++++++++++++++++++++++++++----
 2 files changed, 58 insertions(+), 12 deletions(-)

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