From cb798129f28c777a2bd18d50851aa0baa4c91b58 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 7 May 2019 21:45:06 -0700 Subject: [PATCH] start diagnosis --- quad/quad/quad.rkt | 5 ++-- quad/quad/rebase.rkt | 54 ++++++++++++++++++++++++++++++++++++++++ quad/quadwriter/core.rkt | 22 +++++++++------- 3 files changed, 70 insertions(+), 11 deletions(-) create mode 100644 quad/quad/rebase.rkt diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index 2df773d2..7dc987c9 100644 --- a/quad/quad/quad.rkt +++ b/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) diff --git a/quad/quad/rebase.rkt b/quad/quad/rebase.rkt new file mode 100644 index 00000000..ded2bf27 --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/quad/quadwriter/core.rkt b/quad/quadwriter/core.rkt index f79e18ac..e282802b 100644 --- a/quad/quadwriter/core.rkt +++ b/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 - #:draw-end q:string-draw-end - #:from-parent 'sw - #:to 'sw - #:size (pt (quad-ref elem 'inset-left 0) 5) - #:type offsetter) - elems))]))] + (from-parent + (match (quad-ref elem 'inset-left 0) + [0 elems] + [inset-val + (cons (make-quad + #:draw-end q:string-draw-end + #: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))))