start diagnosis

quad/quad/quad.rkt

@@ -7,7 +7,8 @@
          racket/promise
          racket/dict
          racket/match
-         "param.rkt")
+         "param.rkt"
+         "rebase.rkt")
 (provide (all-defined-out))
 (module+ test (require rackunit))
 
@@ -147,7 +148,7 @@
                         draw-start
                         draw
                         draw-end))
-          (define id (eq-hash-code args))
+          (define id (string->symbol (~r (eq-hash-code args) #:base 36)))
           (apply type (append args (list id)))]))
 
 (define-syntax (define-quad stx)

quad/quad/rebase.rkt

@@ -0,0 +1,54 @@
+#lang racket/base
+(require racket/list)
+(provide (all-defined-out))
+
+(define (base-base digit-str
+                   #:offset [offset 0]
+                   #:min-width [min-width #f])
+  (define digits (list->vector (string->list digit-str)))
+  (define len (vector-length digits))
+  (values
+   (λ (num)
+     (let loop ([num (+ num offset)] [acc null])
+       (if (zero? num)
+           (list->string
+            (if (and min-width (< (length acc) min-width))
+                (append (make-list (- min-width (length acc)) (vector-ref digits 0)) acc)
+                acc))
+           (let* ([r (modulo num len)]
+                  [q (quotient (- num r) len)]) 
+             (loop q (cons (vector-ref digits r) acc))))))
+   (λ (str)
+     (define digit-table (for/hash ([c (in-string digit-str)]
+                                    [i (in-naturals)])
+                                   (values c i)))
+     (- (for/sum ([c (in-list (reverse (string->list str)))]
+                  [i (in-naturals)])
+                 (* (hash-ref digit-table c) (expt len i))) offset))))
+
+(define-values (base62 unbase62)
+  (base-base "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))
+
+(define-values (base-readable unbase-readable)
+  (base-base "abcdefghjkmpqrtuvwxy2346789"))
+
+(define-values (zbase32 unzbase32)
+  (base-base "ybndrfg8ejkmcpqxot1uwisza345h769"))
+
+(define-values (rfc4648 unrfc4648)
+  (base-base "abcdefghijklmnopqrstuvwxyz234567"))
+
+(define-values (no-vowel un-no-vowel)
+  (base-base "bcdfghjklmnpqrstvwxz0123456789"))
+
+(define-values (base32-uc unbase32-uc)
+  (base-base "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
+
+(define-values (base-uc unbase-uc)
+  (base-base "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
+
+
+(module+ test
+  (require rackunit)
+  (check-equal? (base62 10234) "2F4")
+  (check-equal? (unbase62 "2F4") 10234))

quad/quadwriter/core.rkt

@@ -308,13 +308,16 @@
                              ;; just for debugging box
                              [size (pt 15 (pt-y (size line-q)))]))
                  (from-parent (list bq) 'sw)])
-              (cons (make-quad
+              (from-parent
-                     #:draw-end q:string-draw-end
+               (match (quad-ref elem 'inset-left 0)
-                     #:from-parent 'sw
+                 [0 elems]
-                     #:to 'sw
+                 [inset-val
-                     #:size (pt (quad-ref elem 'inset-left 0) 5)
+                  (cons (make-quad
-                     #:type offsetter)
+                         #:draw-end q:string-draw-end
-                    elems))]))]
+                         #:to 'sw
+                         #:size (pt inset-val 5)
+                         #:type offsetter)
+                        elems)]) 'sw))]))]
          [_ null])]))
   (append new-lines (cond
                       [ending-q null]
@@ -501,7 +504,7 @@
                                        (hash-set! h 'doc-title (string-titlecase (path->string name)))
                                        h)]))
   (list (struct-copy quad page-quad
-                     [elems (cons footer (from-parent (insert-blocks lns) 'nw))])))
+                     [elems (cons footer (from-parent #R (insert-blocks #R lns) 'nw))])))
 
 (define (page-wrap xs vertical-height [page-quad q:page])
   (unless (positive? vertical-height)
@@ -523,7 +526,8 @@
 (define (insert-blocks lines)
   (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x 'display)) lines))
   (append* (for/list ([line-group (in-list groups-of-lines)])
-             (if (quad-ref (car line-group) 'display)
+             #R (quad-attrs (car line-group))
+             (if #R (quad-ref #R (car line-group) 'display)
                  (list (block-wrap line-group))
                  line-group))))