diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index ecc47d5d..65f5ef9d 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -3,21 +3,26 @@ (provide (all-defined-out)) (define (atomize x) - (apply vector-immutable + (define empty-attrs (make-attrs)) + (apply + vector-immutable (flatten - (let loop ([x x][loop-attrs default-attrs]) - (cond - [(symbol? x) ($shim (make-attrs) #f x)] - [(string? x) - (for/list ([c (in-string x)]) - (cons ($shim (make-attrs) #f 0) - (case c - [(#\space #\newline #\return) ($white loop-attrs #f c)] - [else ($black loop-attrs #f c)])))] - [else - (map (λ(xi) (loop xi ((quad-attrs x) . override-with . loop-attrs))) (quad-val x))]))))) + (let loop ([x x][loop-attrs default-attrs]) + (cond + [(symbol? x) ($hard empty-attrs x #f)] + [(string? x) + ;; consolidate consecutive whitespaces into single word space + (for/list ([c (in-string (regexp-replace* #px"\\s+" x " "))]) + (cons ($hard empty-attrs #f #f) + ;; todo: is it feasible to box or otherwise object-ize a char + ;; so that all the quads with that char share that object + ;; and thus the measurement can be shared too? + ;; (object would have to be packaged with other typographic specs) + ((if (or (char=? c #\space) (char=? c #\-)) $soft $black) loop-attrs #f c)))] + [else + (map (λ(xi) (loop xi ((quad-attrs x) . override-with . loop-attrs))) (quad-val x))]))))) (module+ test (require rackunit) (atomize (quad (make-attrs #:size 10 #:font "Eq") "ba" (line-break) "r" (quad (make-attrs #:size 8) "zam") "q\tux")) - (atomize (quad #f "Meg is " (line-break) "\nan ally."))) + (atomize (quad #f "Meg is-an ally."))) diff --git a/quad/quad/kafka.rkt b/quad/quad/kafka.rkt new file mode 100644 index 00000000..4527db86 --- /dev/null +++ b/quad/quad/kafka.rkt @@ -0,0 +1,28 @@ +#lang quad/text #:text +Produces a list of three-element lists, where each three-element list represents a set of consecutive code points for-which the Unicode standard specifies character properties. Each three-element list contains two integers and a boolean; the first integer is a starting code-point value (inclusive), the second integer is an ending code-point value (inclusive), and the boolean is #t when all characters in the code-point range have identical results for all of the character predicates above. The three-element lists are ordered in the overall result list such that later lists represent larger code-point values, and all three-element lists are separated from every other by at least one code-point value that is not specified by Unicode. + +One morning, when Gregor Samsa woke from troubled dreams, he found +himself transformed in his bed into a horrible vermin. He lay on +his armour-like back, and if he lifted his head a little he could +see his brown belly, slightly domed and divided by arches into stiff +sections. The bedding was hardly able to cover it and seemed ready +to slide off any moment. His many legs, pitifully thin compared +with the size of the rest of him, waved about helplessly as he +looked. + +"What's happened to me?" he thought. It wasn't a dream. His room, +a proper human room although a little too small, lay peacefully +between its four familiar walls. A collection of textile samples +lay spread out on the table - Samsa was a travelling salesman - and +above it there hung a picture that he had recently cut out of an +illustrated magazine and housed in a nice, gilded frame. It showed +a lady fitted out with a fur hat and fur boa who sat upright, +raising a heavy fur muff that covered the whole of her lower arm +towards the viewer. + +Gregor then turned to look out the window at the dull weather. +Drops of rain could be heard hitting the pane, which made him feel +quite sad. "How about if I sleep a little bit longer and forget all +this nonsense", he thought, but that was something he was unable to +do because he was used to sleeping on his right, and in his present +state couldn't get into that position. However hard he threw \ No newline at end of file diff --git a/quad/quad/main.rkt b/quad/quad/main.rkt index ffd9e922..99cbfae7 100644 --- a/quad/quad/main.rkt +++ b/quad/quad/main.rkt @@ -1,15 +1,16 @@ #lang racket/base -(require "quads.rkt" "typeset.rkt" "atomize.rkt" racket/list racket/string) +(require "quads.rkt" "typeset.rkt" "atomize.rkt" "render.rkt" racket/list racket/string) (provide (except-out (all-from-out racket/base "quads.rkt") #%module-begin) (rename-out [~module-begin #%module-begin])) (define-syntax-rule (~module-begin lang-line-config-arg . args) (#%module-begin - (define main-quad (quad #f . args)) + (define main-quad (apply quad #f (add-between (list . args) "\n"))) ; at-reader splits lines, but we want one contiguous run ;; branch on config-arg to allow debug / inspection options on #lang line (case (string-trim lang-line-config-arg) [("#:atoms") (atomize main-quad)] - [else (typeset (atomize main-quad))]))) + [("#:text") (time (debug-render (typeset-fit (atomize main-quad))))] + [else (typeset-fit (atomize main-quad))]))) (module reader syntax/module-reader "main.rkt") \ No newline at end of file diff --git a/quad/quad/measure-chars.rkt b/quad/quad/measure-chars.rkt deleted file mode 100644 index 8fe9935f..00000000 --- a/quad/quad/measure-chars.rkt +++ /dev/null @@ -1,30 +0,0 @@ -#lang quad/dev -(require "freetype-ffi.rkt") -(provide (all-defined-out)) - -(define measure-char - (let ([measure-cache (make-hash)] - [glyph-idx-cache (make-hash)] - [glyph-width-cache (make-hash)] - [em-size-cache (make-hash)] - [ft-library (FT_Init_FreeType)] - [ft-face-cache (make-hash)]) - (λ (font-pathstring char) - (define (do-measure) - (define ft-face (hash-ref! ft-face-cache font-pathstring (λ () (FT_New_Face ft-library font-pathstring 0)))) - (define width - (let ([glyph-idx (hash-ref! glyph-idx-cache (cons char font-pathstring) - (λ () (FT_Get_Char_Index ft-face (char->integer char))))]) - (hash-ref! glyph-width-cache (cons glyph-idx font-pathstring) - (λ () - (FT_Load_Glyph ft-face glyph-idx FT_LOAD_NO_RECURSE) ; loads into FTFace's 'glyph' slot - (define width (FT_Vector-x (FT_GlyphSlotRec-advance (FT_FaceRec-glyph ft-face)))) - (* width 1.0))))) ; store as inexact - (define em-size - (hash-ref! em-size-cache font-pathstring (λ () (FT_FaceRec-units_per_EM ft-face)))) - (/ width em-size)) - (hash-ref! measure-cache (cons font-pathstring char) do-measure)))) - -(module+ test - (require rackunit) - (check-equal? (measure-char "charter.ttf" #\f) .321)) \ No newline at end of file diff --git a/quad/quad/measure.rkt b/quad/quad/measure.rkt index e62a7713..37fe9bd0 100644 --- a/quad/quad/measure.rkt +++ b/quad/quad/measure.rkt @@ -1,15 +1,42 @@ #lang quad/dev -(require "measure-chars.rkt") +(require "freetype-ffi.rkt") (provide (all-defined-out)) (define (measure! q) (quad-dim-set! q (cond - [(or ($black? q) ($white? q)) + [(or ($black? q) ($soft? q)) (* (measure-char (quad-font q) (quad-val q)) (quad-font-size q))] [else 0]))) (module+ test (require rackunit) (define q ($black '#hasheq((size . 12) (font . "sc.otf")) 0 #\n)) - (check-equal? (measure-char (quad-font q) (quad-val q)) .6)) + (check-equal? (measure-char (quad-font q) (quad-val q)) .6)) + +(define measure-char + (let ([measure-cache (make-hash)] + [glyph-idx-cache (make-hash)] + [glyph-width-cache (make-hash)] + [em-size-cache (make-hash)] + [ft-library (FT_Init_FreeType)] + [ft-face-cache (make-hash)]) + (λ (font-pathstring char) + (define (do-measure) + (define ft-face (hash-ref! ft-face-cache font-pathstring (λ () (FT_New_Face ft-library font-pathstring 0)))) + (define width + (let ([glyph-idx (hash-ref! glyph-idx-cache (cons char font-pathstring) + (λ () (FT_Get_Char_Index ft-face (char->integer char))))]) + (hash-ref! glyph-width-cache (cons glyph-idx font-pathstring) + (λ () + (FT_Load_Glyph ft-face glyph-idx FT_LOAD_NO_RECURSE) ; loads into FTFace's 'glyph' slot + (define width (FT_Vector-x (FT_GlyphSlotRec-advance (FT_FaceRec-glyph ft-face)))) + (* width 1.0))))) ; store as inexact + (define em-size + (hash-ref! em-size-cache font-pathstring (λ () (FT_FaceRec-units_per_EM ft-face)))) + (/ width em-size)) + (hash-ref! measure-cache (cons font-pathstring char) do-measure)))) + +(module+ test + (require rackunit) + (check-equal? (measure-char "charter.ttf" #\f) .321)) diff --git a/quad/quad/quads.rkt b/quad/quad/quads.rkt index 70b1a25b..af05b220 100644 --- a/quad/quad/quads.rkt +++ b/quad/quad/quads.rkt @@ -4,9 +4,8 @@ (struct $quad (attrs dim val) #:transparent #:mutable) (struct $black $quad () #:transparent) -(struct $white $quad () #:transparent) -(struct $skip $quad () #:transparent) -(struct $shim $quad () #:transparent) +(struct $soft $quad () #:transparent) +(struct $hard $quad () #:transparent) (define quad? $quad?) @@ -54,17 +53,25 @@ measure (line width) (values k (or (hash-ref dest k) (hash-ref source k))))) (require (for-syntax sugar/debug)) -(define-syntax (define-break stx) - (syntax-case stx () - [(_ name) - (with-syntax ([BREAK-NAME (string->symbol (string-upcase (symbol->string (syntax->datum #'name))))]) - #'(define (name) (quad #f 'BREAK-NAME)))])) +(define-syntax-rule (define-break name) + (define (name) (quad #f 'name))) (define-break page-break) (define-break column-break) (define-break block-break) (define-break line-break) +(define-syntax (caseq stx) + ;; like case but strictly uses `eq?` comparison (as opposed to `equal?`) + (syntax-case stx () + [(_ test-val [(match-val ...) . result] ... [else . else-result]) + #'(cond + [(memq test-val '(match-val ...)) . result] ... + [else . else-result])] + [(_ test-val [(match-val ...) . result] ...) + #'(caseq test-val + [(match-val ...) . result] ... + [else (error 'caseq "no match")])])) (module+ test (require rackunit) diff --git a/quad/quad/render.rkt b/quad/quad/render.rkt new file mode 100644 index 00000000..96c11ddf --- /dev/null +++ b/quad/quad/render.rkt @@ -0,0 +1,30 @@ +#lang quad/dev +(require racket/format) +(provide (all-defined-out)) + +(define (debug-render qs) + (define line-counter #f) + (define (line-counter-increment!) (set! line-counter (add1 line-counter))) + (define (line-counter-reset!) (set! line-counter 1)) + (line-counter-reset!) + (printf " ") + (for ([i (in-range 1 71)]) + (printf (cond + [(zero? (modulo i 10)) "|"] + [(zero? (modulo i 5)) "'"] + [else "·"]))) + (define (print-line-counter) + (printf "\n~a "(~r line-counter #:min-width 2 #:pad-string " " #:base 10))) + (print-line-counter) + (for ([q (in-vector qs)]) + (define qd (quad-dim q)) + (cond + [(symbol? qd) + (case qd + [(line-break) (line-counter-increment!)] + [(column-break) (line-counter-reset!) (printf "\n--col--")] + [(page-break) (printf "\n\n==page==\n")]) + (print-line-counter)] + [(or ($black? q) ($soft? q)) (printf "~a" (quad-val q))] + [else (void)])) + (printf "\n\n")) \ No newline at end of file diff --git a/quad/quad/typeset.rkt b/quad/quad/typeset.rkt index caa2cbb0..0ddf9859 100644 --- a/quad/quad/typeset.rkt +++ b/quad/quad/typeset.rkt @@ -2,40 +2,59 @@ (provide (all-defined-out)) (require "measure.rkt") -(define last-bp-k #f) -(define line-measure 80) -(define col-measure 150) -(define page-measure 300) +(define last-breakpoint-k #f) +(define (set-breakpoint-k-here!) + (let/cc k (set! last-breakpoint-k k) #f)) -(struct tp (page col line) #:transparent) +(define char-width 6) +(define line-width (* 60 char-width)) ; 50 chars, each 6 pts wide +(define line-height 12) +(define col-height (* 6 line-height)) ; 3 rows, each 12 pts high +(define page-width (* 3 line-width)) ; meaning, two columns -(define (increment-tpos tpos page col line) - (tp (+ (tp-page tpos) page) (+ (tp-col tpos) col) (+ (tp-line tpos) line))) +(struct tp (page-horiz vert horiz)) -(define (typeset qs) - (for/fold ([tpos (tp 0 0 0)]) +(define page-start-position (tp 0 0 0)) + +(define (handle-break val [tpos #f]) + (caseq val ; test in order of frequency + [(line-break) (tp (tp-page-horiz tpos) (+ (tp-vert tpos) line-height) 0)] + [(column-break) (tp (+ (tp-page-horiz tpos) line-width) 0 0)] + [(page-break) page-start-position] + [else tpos])) + +(define (typeset-fit qs) + (for/fold ([tpos (handle-break 'page-break)]) ([q (in-vector qs)]) + (unless (quad-dim q) (measure! q)) (cond - [(not (quad-dim q)) ; fit pass - (measure! q) - (cond - [(> (tp-page tpos) page-measure) (last-bp-k 'break-page)] - [(> (tp-col tpos) col-measure) (last-bp-k 'break-col)] - [(> (tp-line tpos) line-measure) (last-bp-k 'break-line)] - [(and ($white? q) (let/cc bp-k (set! last-bp-k bp-k) #f)) - => - (λ(k-result) - (quad-dim-set! q k-result) - (case k-result - [(break-line) (tp (tp-page tpos) (tp-col tpos) 0)] - [(break-col) (tp (tp-page tpos) 0 0)] - [(break-page) (tp 0 0 0)]))] - [else (define qpos (quad-dim q)) - (increment-tpos tpos qpos qpos qpos)])] - [else ; fill pass - tpos])) + ;; hard may contain an imperative break. Test for this first because it makes the rest irrelevant. + ;; todo: how to suppress spaces adjacent to imperative breaks? + [($hard? q) (handle-break (quad-dim q) tpos)] + + ;; test for overset (before a new bp-k gets set). + ;; order is precedence: test bigger breaks first + ;; test page-horiz with >= because one column impliedly exists at the start + ;; (we could also make this explicit with page-start-position but it seems clearer to use zeroes there) + [(>= (tp-page-horiz tpos) page-width) (last-breakpoint-k 'page-break)] + + ;; test tp-vert with >= because one column impliedly exists at the start + [(>= (tp-vert tpos) col-height) (last-breakpoint-k 'column-break)] + + ;; but test tp-horiz with > because no characters exist in the line at the start + [(> (tp-horiz tpos) line-width) (last-breakpoint-k 'line-break)] + + ;; set a new bp-k, or resume after invoking a bp-k + [(and ($soft? q) (set-breakpoint-k-here!)) + => ; grabs the end value of the conditional, which is the arg passed when breakpoint-k was invoked + (λ (breakpoint-k-result) + ;; convert the white, thereby consuming it. todo: don't consume hyphens + (quad-dim-set! q breakpoint-k-result) + (handle-break breakpoint-k-result tpos))] + [else (tp (tp-page-horiz tpos) (tp-vert tpos) (+ (tp-horiz tpos) (quad-dim q)))])) qs) (module+ test - (require "atomize.rkt") - (time (typeset (atomize (quad #f "Meg is an ally. Meg is an ally. Meg is an ally. Meg is an ally. Meg is an ally. Meg is an ally."))))) \ No newline at end of file + (require "atomize.rkt" "render.rkt") + (define q (quad #f "One morning, when Gregor" (line-break) " and his old hizn himself")) + (time (debug-render (typeset-fit (atomize q))))) \ No newline at end of file