├── .gitignore ├── README.md ├── blackboard-lib ├── blackboard │ ├── info.rkt │ └── private │ │ ├── content.rkt │ │ ├── core.rkt │ │ ├── draw │ │ ├── font.rkt │ │ ├── text.rkt │ │ └── unsafe │ │ │ ├── cairo.rkt │ │ │ ├── harfbuzz.rkt │ │ │ └── pango.rkt │ │ ├── mpict.rkt │ │ ├── size.rkt │ │ ├── style-props.rkt │ │ ├── style.rkt │ │ ├── unicode.rkt │ │ └── util │ │ ├── case-kw.rkt │ │ ├── print.rkt │ │ └── struct.rkt └── info.rkt ├── example.svg └── fonts ├── eliminate-math-script.py └── fix-lm-metrics.py /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | *~ 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # blackboard 2 | 3 | This is a (very) unfinished implementation of an [OpenType Math][ot:math] layout and rendering engine in Racket. 4 | 5 | ![Some simple example output.](example.svg) 6 | 7 | It is almost certainly not directly useful to anyone at the moment, because it is essentially impossible for anyone other than its author to build and run it due to dependencies on upstream patches. In particular, it requires: 8 | 9 | * [HarfBuzz][harfbuzz] >=3.4.0, which includes [harfbuzz#3416](https://github.com/harfbuzz/harfbuzz/pull/3416) 10 | 11 | * some minor changes to `racket/draw` to expose some additional (unsafe) functionality, which are currently not publicly available anywhere (though I could push them if someone is really interested) 12 | 13 | * patched versions of OpenType math fonts to remove the dependency on the OpenType `math` script for proper shaping (see `fonts/eliminate-math-script.py` for more details) 14 | 15 | Even if one were to go to the hassle of setting up all the necessary dependencies, the system is currently too unfinished to be of any practical use. However, I have decided to make the source code publicly available on the off chance that someone might find it interesting. 16 | 17 | [harfbuzz]: https://github.com/harfbuzz/harfbuzz 18 | [ot:math]: https://docs.microsoft.com/en-us/typography/opentype/spec/math 19 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define compile-omit-paths 4 | ;; currently broken due to in-progress changes to the backend 5 | '("private/core.rkt")) 6 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/content.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/class 4 | racket/contract 5 | racket/hash 6 | racket/list 7 | racket/match 8 | threading 9 | 10 | "draw/font.rkt" 11 | "util/print.rkt" 12 | "mpict.rkt" 13 | "size.rkt" 14 | "style.rkt" 15 | (prefix-in s: "style-props.rkt")) 16 | 17 | ;; ----------------------------------------------------------------------------- 18 | 19 | (struct m:element (style) #:transparent) 20 | 21 | (struct m:text m:element (content) #:transparent) 22 | 23 | (struct m:space m:element (width ascent descent) #:transparent) 24 | (struct m:row m:element (content) #:transparent) 25 | (struct m:scripts m:element (nucleus-content sup-content sub-content) #:transparent) 26 | 27 | (struct m:table m:element (rows) #:transparent) 28 | (struct m:table-row (styles cells) #:transparent) 29 | (struct m:table-cell (styles row-span column-span content) #:transparent) 30 | 31 | ;; ----------------------------------------------------------------------------- 32 | 33 | (define s:explain? (make-style-property 'explain?)) 34 | (define s:explain-tokens? (make-inherited-style-property 'explain-tokens?)) 35 | 36 | (define (get-script-style which inherited) 37 | (combine-styles 38 | (style s:math-depth (add1 (computed-style-value inherited s:math-depth)) 39 | s:math-style 'compact) 40 | (match which 41 | ['sub (style s:math-shift 'compact)] 42 | ['sup (style)]))) 43 | 44 | (define (element->mpict e) 45 | (define (loop e #:style inherited-style) 46 | (match e 47 | [(? list?) 48 | (apply hbl-append (map (λ~> (loop #:style inherited-style)) e))] 49 | 50 | [(m:element element-style) 51 | (define style (compute-style inherited-style element-style)) 52 | 53 | (define (recur e #:style [extra-style plain]) 54 | (loop e #:style (compute-style style extra-style))) 55 | 56 | (define (resolve-math-font) 57 | (define base-font (~> (combine-font-descriptions (computed-style-value style s:font) 58 | (computed-style-value style s:math-font)) 59 | resolve-font-description)) 60 | 61 | (define depth (computed-style-value style s:math-depth)) 62 | (define depth-scale (~> (font-math-script-metrics base-font) 63 | (math-script-metrics-depth-scale depth))) 64 | 65 | (define base-desc (font-describe base-font)) 66 | (~> (copy-font-description base-desc 67 | #:size (* (font-description-size base-desc) depth-scale)) 68 | resolve-font-description)) 69 | 70 | (define (maybe-explain p #:token? [token? #f]) 71 | (if (or (computed-style-value style s:explain?) 72 | (and token? (computed-style-value style s:explain-tokens?))) 73 | (explain p) 74 | p)) 75 | 76 | (match e 77 | [(m:space _ width ascent descent) 78 | (define ppem (font-description-size (font-describe (resolve-math-font)))) 79 | (~> (blank #:w (make-size-absolute #:ppem ppem width) 80 | #:a (make-size-absolute #:ppem ppem ascent) 81 | #:d (make-size-absolute #:ppem ppem descent)) 82 | (maybe-explain #:token? #t))] 83 | 84 | [(m:row _ content) 85 | (maybe-explain (recur content))] 86 | 87 | [(m:text _ str) 88 | (~> (text str 89 | #:font (resolve-math-font) 90 | #:math-depth (computed-style-value style s:math-depth)) 91 | (maybe-explain #:token? #t))] 92 | 93 | [(m:scripts _ nucleus sup sub) 94 | (~> (scripts (recur nucleus) 95 | #:sup (and sup (recur sup #:style (get-script-style 'sup style))) 96 | #:sub (and sub (recur sub #:style (get-script-style 'sub style))) 97 | #:metrics (font-math-script-metrics (resolve-math-font)) 98 | #:cramped? (match (computed-style-value style s:math-shift) 99 | ['normal #f] 100 | ['compact #t])) 101 | maybe-explain)])])) 102 | 103 | (loop e #:style (compute-style #f plain))) 104 | 105 | ;; simple demo 106 | (module+ main 107 | (require racket/draw 108 | (prefix-in p: pict) 109 | "unicode.rkt") 110 | 111 | (define (add-white-bg p) 112 | (p:pin-over (p:filled-rectangle (p:pict-width p) (p:pict-height p) #:draw-border? #f #:color "white") 0 0 p)) 113 | 114 | (define (save-pict p where) 115 | (~> (add-white-bg p) 116 | p:pict->bitmap 117 | (send save-file where 'png))) 118 | 119 | (define (save-pict-svg p where) 120 | (define dc (new svg-dc% [width (p:pict-width p)] 121 | [height (p:pict-height p)] 122 | [output where] 123 | [exists 'truncate/replace])) 124 | (send dc start-doc "") 125 | (send dc start-page) 126 | (p:draw-pict (add-white-bg p) dc 0 0) 127 | (send dc end-page) 128 | (send dc end-doc)) 129 | 130 | (define thin-space (m:space plain (ems 3/18) 0 0)) 131 | (define med-space (m:space plain (ems 4/18) 0 0)) 132 | (define thick-space (m:space plain (ems 5/18) 0 0)) 133 | (define quad (m:space plain (ems 1) 0 0)) 134 | 135 | (define (italic-glyph c) 136 | (m:text plain (string (math-char c #:italic? #t)))) 137 | 138 | (define (demo-specimen #:family math-family) 139 | (m:scripts (style s:math-font (make-font-description #:family math-family)) 140 | (italic-glyph #\f) 141 | (m:text plain "1") 142 | (m:text plain "2"))) 143 | 144 | (define (demo-specimens #:explain? explain?) 145 | (~> (for/list ([family (in-list '("Blackboard Modern Math" 146 | "Blackboard Pagella Math" 147 | "Blackboard Cambria Math"))]) 148 | (demo-specimen #:family family)) 149 | (add-between (m:space (style s:explain-tokens? #f) (ems 1/2) 0 0)) 150 | (m:row (style s:font (make-font-description #:size 48) 151 | s:explain-tokens? explain?) 152 | _) 153 | element->mpict 154 | (inset 5))) 155 | 156 | (~> (p:vl-append (demo-specimens #:explain? #f) 157 | (demo-specimens #:explain? #t)) 158 | (~> (p:scale 3) 159 | (p:freeze #:scale 2)) 160 | #;(~> (p:scale 10) 161 | (save-pict-svg "/tmp/example.svg"))) 162 | 163 | #;(~> (m:group (style s:font (make-font-description #:size 72) 164 | s:math-font (make-partial-font-description #:family "Blackboard Modern Math")) 165 | (list (m:scripts plain 166 | (m:token plain (string (math-char #\x #:italic? #t))) 167 | (m:token plain "2") 168 | #f) 169 | med-space 170 | (m:token plain "+") 171 | med-space 172 | (m:scripts plain 173 | (m:token plain (string (math-char #\y #:italic? #t))) 174 | (m:token plain "2") 175 | #f) 176 | thick-space 177 | (m:token plain "=") 178 | thick-space 179 | (m:token plain "0"))) 180 | element->mpict 181 | (inset 5) 182 | (p:freeze #:scale 2)) 183 | 184 | #;(define (reduction-rule #:math math-family 185 | #:mathsf mathsf-family 186 | #:explain? explain?) 187 | (define (italic-glyph c) 188 | #;(m:token plain (string (math-char c #:italic? #t))) 189 | (m:token (style s:math-font (make-font-description #:family math-family #:style 'italic)) (string c))) 190 | #;(~> (m:group (style s:font (make-font-description #:size 48) 191 | s:math-font (make-font-description #:family math-family) 192 | s:explain-tokens? explain?) 193 | (list (italic-glyph #\E) 194 | (m:token plain "[") 195 | (m:token (style s:math-font (make-font-description #:family mathsf-family)) "fst") 196 | (m:space plain (ems 1/3) 0 0) 197 | (m:token plain "(") 198 | (m:scripts plain (italic-glyph #\v) #f (m:token plain "1")) 199 | (m:token plain ",") 200 | thin-space 201 | (m:scripts plain (italic-glyph #\v) #f (m:token plain "2")) 202 | (m:token plain ")") 203 | (m:token plain "]") 204 | (m:space plain (ems 2/3) 0 0) 205 | (m:token (style s:math-font (make-font-description #:family "Cambria")) "⟶") 206 | (m:space plain (ems 2/3) 0 0) 207 | (italic-glyph #\E) 208 | (m:token plain "[") 209 | (m:scripts plain (italic-glyph #\v) #f (m:token plain "1")) 210 | (m:token plain "]"))) 211 | element->mpict 212 | (inset 5))) 213 | 214 | #;(~> (p:vl-append (reduction-rule #:math "Blackboard Modern Math" #:mathsf "Latin Modern Sans" #:explain? #f) 215 | (reduction-rule #:math "Blackboard Cambria Math" #:mathsf "Calibri" #:explain? #f) 216 | (reduction-rule #:math "Blackboard Modern Math" #:mathsf "Latin Modern Sans" #:explain? #t) 217 | (reduction-rule #:math "Blackboard Cambria Math" #:mathsf "Calibri" #:explain? #t)) 218 | (p:scale 2) 219 | #;(p:freeze #:scale 2) 220 | (p:scale 4) 221 | (save-pict "/tmp/reduction-relation.png")) 222 | 223 | #;(~> (p:vl-append (reduction-rule #:math "Comic Sans MS" #:mathsf "Comic Sans MS" #:explain? #f) 224 | (reduction-rule #:math "Comic Sans MS" #:mathsf "Comic Sans MS" #:explain? #t)) 225 | (p:scale 2) 226 | #;(p:freeze #:scale 2) 227 | (p:scale 4) 228 | (save-pict "/tmp/reduction-relation.png"))) 229 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/core.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/list 4 | racket/match 5 | threading 6 | 7 | "content.rkt" 8 | "open-type.rkt" 9 | "size.rkt" 10 | "util/print.rkt" 11 | "util/struct.rkt") 12 | 13 | (define (sub a b) (error 'sub "fixme")) 14 | 15 | (define rdr:thin-space (rdr:spring (ems 3/18))) 16 | (define rdr:medium-space (rdr:spring (ems 4/18) #:stretch (ems 2/18) #:shrink (ems 4/18))) 17 | (define rdr:thick-space (rdr:spring (ems 5/18) #:stretch (ems 5/18))) 18 | 19 | (define absent-v (gensym 'absent)) 20 | 21 | ;; ----------------------------------------------------------------------------- 22 | ;; math fragments 23 | 24 | ;; A /math fragment/ is a fragment of renderable mathematics. The `content` 25 | ;; field contains the actual renderable structure. Each fragment also includes a 26 | ;; `name` field, which is used to `print` the fragment. 27 | ;; 28 | ;; Some math fragments also have additional information used by `term` to parse 29 | ;; mathematical expressions containing infix operators: 30 | ;; 31 | ;; * The `binop` function constructs an /infix fragment/, which has a 32 | ;; precedence and associativity stored in `op-info`. 33 | ;; 34 | ;; * When `term` parses an expression, it records information about the 35 | ;; operator used in the expression’s outermost spine in the `spine-op` 36 | ;; field. For example, the term 37 | ;; 38 | ;; (let ([<$> (binop 4 'left ....)]) 39 | ;; (term "a" <$> "b")) 40 | ;; 41 | ;; records that its spine was formed from an `infixl 4` binary operator. 42 | ;; This allows parentheses to be automatically inserted around the fragment 43 | ;; if it is later inserted into a larger expression immediately under an 44 | ;; operator with a tighter precedence. 45 | (struct math 46 | (name ; any/c 47 | props ; hash-equal? 48 | renderer ; renderable-content? 49 | #;op-fixity 50 | #;spine-op) 51 | #:name math-struct 52 | #:constructor-name make-math-struct 53 | #:property prop:object-name (struct-field-index name) 54 | #:property prop:custom-print-quotable 'never 55 | #:property prop:custom-write 56 | (λ (self out mode) 57 | (define (write-prefix) (write-string "#" out)) 59 | (define name (math-name self)) 60 | (match mode 61 | [(or #f #t) 62 | (write-prefix) 63 | (fprintf out "~.v" name) 64 | (write-suffix)] 65 | [0 66 | (print name out)] 67 | [1 68 | (write-prefix) 69 | (print name out) 70 | (write-suffix)]))) 71 | 72 | ;; A math fragment that is also a procedure. This is useful for defining math 73 | ;; fragments that behave as constructors when applied to arguments. 74 | (struct math:procedure math-struct (proc) 75 | ; We never construct instances of `math:procedure` directly, only subtypes of 76 | ; it; see the comment in `make-math`. 77 | #:constructor-name unused-make-math:procedure) 78 | 79 | (define (make-math renderer 80 | #:name name 81 | #:props [props (hash)] 82 | #:proc [proc #f]) 83 | (cond 84 | [proc 85 | ; Rather than attach a `prop:procedure` property to the `math:procedure` type 86 | ; directly, create a subtype with `proc` as its value. This allows the result 87 | ; to respond properly to `procedure-arity` while still receiving a `self` argument. 88 | (struct math:procedure* math:procedure () 89 | #:property prop:procedure proc) 90 | (math:procedure* name props renderer proc)] 91 | [else 92 | (make-math-struct name props renderer)])) 93 | 94 | ;; Like `struct-copy`, but uses `make-math` to preserve an attached procedure. 95 | (define (math-copy m 96 | #:name [name (math-name m)] 97 | #:props [props (math-props m)] 98 | #:renderer [renderer (math-renderer m)] 99 | #:proc [proc (and (math:procedure? m) (math:procedure-proc m))]) 100 | (make-math renderer #:name name #:props props #:proc proc)) 101 | 102 | (define (math-rename m name) 103 | (math-copy m #:name name)) 104 | 105 | (define (set-math-procedure m proc) 106 | (math-copy m #:proc proc)) 107 | 108 | (define math-property 109 | (case-lambda 110 | [(m k) 111 | (hash-ref (math-props m) k #f)] 112 | [(m k v) 113 | (math-copy m #:props (if v 114 | (hash-set (math-props m) k v) 115 | (hash-remove (math-props m) k)))])) 116 | 117 | (define empty-math (make-math (rdr:blank) #:name "")) 118 | 119 | (define (math->pict m) 120 | (render-pict (math-renderer m))) 121 | 122 | ;; ----------------------------------------------------------------------------- 123 | ;; decoding math 124 | 125 | (define (pre-math? v) 126 | (or (math? v) 127 | (string? v) 128 | (and (list? v) (andmap pre-math? v)))) 129 | 130 | (define (text str #:name [name absent-v]) 131 | (if (and (string=? str "") 132 | (eq? name absent-v)) 133 | empty-math 134 | (make-math (rdr:text str) 135 | #:name (if (eq? name absent-v) 136 | (quasiexpr (text ,str)) 137 | name)))) 138 | 139 | (require pict racket/function) 140 | (define (mathrm str) 141 | (make-math (rdr:math str) 142 | #:name (quasiexpr (mathrm ,str)))) 143 | (define (textsf str) 144 | (make-math (rdr:wrap (rdr:text str) 145 | (λ (go) 146 | (parameterize ([current-text-font 147 | (curry modern-text #:style 'sans-serif)]) 148 | (go)))) 149 | #:name (quasiexpr (textsf ,str)))) 150 | (define (textit str) 151 | (make-math (rdr:wrap (rdr:text str) 152 | (λ (go) 153 | (parameterize ([current-text-italic? #t]) 154 | (go)))) 155 | #:name (quasiexpr (textsf ,str)))) 156 | 157 | (define (var str) 158 | (cond 159 | [(string=? str "") 160 | empty-math] 161 | [(and (= (string-length str) 1) 162 | (let ([c (string-ref str 0)]) 163 | (and (or (char<=? #\A c #\Z) 164 | (char<=? #\a c #\z)) 165 | c))) 166 | => (λ (c) 167 | (make-math (rdr:math (string (math-char c #:italic? #t))) 168 | #:name (quasiexpr (var ,str))))] 169 | [else 170 | (make-math (rdr:wrap (rdr:text str) 171 | (λ (go) 172 | (parameterize ([current-text-italic? #t] 173 | [current-text-bold? #f]) 174 | (go)))) 175 | #:name (quasiexpr (var ,str)))])) 176 | 177 | (define (default-decode-math-string str) 178 | (match str 179 | ["" empty-math] 180 | [(regexp #px"^([^_]+)_([^_]+)$" (list _ a b)) 181 | (sub a b)] 182 | [_ (var str)])) 183 | 184 | (define current-decode-math-string (make-parameter default-decode-math-string)) 185 | (define (decode-math-string str) 186 | ((current-decode-math-string) str)) 187 | 188 | (struct math-app (names) 189 | #:property prop:custom-print-quotable 'never 190 | #:property prop:custom-write 191 | (λ (self out mode) (print (quasiexpr (math ,@(math-app-names self))) out))) 192 | 193 | ;; Like (map math-name ms), but removes empty names and splices uses of `math`. 194 | (define (math-sequence-names ms) 195 | (for/foldr ([names '()]) 196 | ([m (in-list ms)]) 197 | (match (math-name m) 198 | ["" names] 199 | [(math-app seq-names) (append seq-names names)] 200 | [name (cons name names)]))) 201 | 202 | (define (math #:name [name absent-v] . ms) 203 | (define outer-m 204 | (let loop ([m ms]) 205 | (match m 206 | [(? math?) m] 207 | [(? string?) (decode-math-string m)] 208 | ['() empty-math] 209 | [(list m) (loop m)] 210 | [(? list?) 211 | (define ms (map loop m)) 212 | (make-math (math-renderer ms) 213 | #:name (if (eq? name absent-v) 214 | (math-app (math-sequence-names ms)) 215 | #f))]))) 216 | (if (eq? name absent-v) 217 | outer-m 218 | (math-rename outer-m name))) 219 | 220 | ;; ----------------------------------------------------------------------------- 221 | 222 | (define (math-content? v) 223 | (or (string? v) 224 | (and (list? v) (andmap math-content? v)))) 225 | 226 | ;; ----------------------------------------------------------------------------- 227 | ;; binary operators 228 | 229 | (define (precedence? v) 230 | (and (rational? v) 231 | (exact? v))) 232 | 233 | (define (associativity? v) 234 | (and (memq v '(none left right)) #t)) 235 | 236 | (struct binop-fixity (prec assoc) #:transparent) 237 | (define-uniques math-prop:operator-fixity math-prop:spine-fixity) 238 | 239 | (define (math-binop? v) 240 | (and (math? v) 241 | (binop-fixity? (math-property v math-prop:operator-fixity)))) 242 | 243 | ;; Constructs a math fragment and assigns it the given fixity. `binop` supports 244 | ;; two different call patterns: 245 | ;; 1. (binop fixity m ...) 246 | ;; 2. (binop prec assoc m ...) 247 | ;; The second pattern is an abbreviation for (binop (binop-fixity prec assoc) m ...). 248 | (define (binop . args) 249 | (define-values [fixity ms] 250 | (match args 251 | [(cons (? binop-fixity? fixity) ms) (values fixity ms)] 252 | [(list* prec assoc ms) (values (binop-fixity prec assoc) ms)])) 253 | ; Note: we intentionally unset a math procedure here, as it doesn’t make sense 254 | ; to keep the procedure used by a prefix application if the operator is 255 | ; intended to be used infix. 256 | (set-math-procedure (math-property (math ms) math-prop:operator-fixity fixity) #f)) 257 | 258 | ;; ----------------------------------------------------------------------------- 259 | ;; math expressions 260 | 261 | (define current-application-fixity (make-parameter (binop-fixity 20 'left))) 262 | 263 | (define (pre-expr? v) 264 | (or (math? v) 265 | (string? v))) 266 | 267 | ;; Like `seq`, `term` constructs a math fragment that combines a sequence of 268 | ;; smaller math fragments. Unlike `seq`, `term` consults the fixity annotations 269 | ;; on its arguments to automatically insert parentheses around arguments that 270 | ;; need them to preserve the appropriate grouping structure. 271 | ;; 272 | ;; Note that this means that `term` is more restrictive than `seq`: not all 273 | ;; sequences of math fragments form valid expressions. In particular, `term` 274 | ;; requires that infix operators appear between two sequences that themselves 275 | ;; form valid expressions, and that if two operators appear in the sequence with 276 | ;; the same precedence, they both share the same non-`'none` associativity. 277 | ;; Additionally, to avoid confusion about whether lists should provide grouping 278 | ;; or if they should simply splice into the enclosing sequence, `term` does not 279 | ;; accept lists. 280 | (define (expr . pre-ms) 281 | (define fixity:app (current-application-fixity)) 282 | 283 | (match pre-ms 284 | ['() empty-math] 285 | [(list m) (math m)] 286 | [_ 287 | ;; Adds parentheses to an argument to an infix operator if necessary to 288 | ;; preserve grouping. The `left-or-right` argument specifies whether `m` 289 | ;; appears to the left or to the right of the operator. 290 | (define (maybe-parens m left-or-right op-info) 291 | (define rdr (math-renderer m)) 292 | (match (math-property m math-prop:spine-fixity) 293 | [#f rdr] 294 | [(binop-fixity spine-prec spine-assoc) 295 | (match-define (binop-fixity op-prec op-assoc) op-info) 296 | (if (or 297 | ; If the inner operator is looser, we definitely need parens. 298 | (< spine-prec op-prec) 299 | ; Otherwise, we might need parens if the precedence is the same. 300 | (and (= spine-prec op-prec) 301 | (or 302 | ; If either operator is nonfix, we need parens. 303 | (eq? 'none spine-assoc) 304 | (eq? 'none op-assoc) 305 | ; If they have different associativities, we need parens. 306 | (not (eq? spine-assoc op-assoc)) 307 | ; If they associate in the wrong direction, we need parens 308 | ; to maintain the right grouping. 309 | (not (eq? left-or-right spine-assoc))))) 310 | (rdr:list (rdr:math "(") rdr (rdr:math ")")) 311 | rdr)])) 312 | 313 | ;; Consumes one or more non-infix terms in `ms`. If multiple non-infix 314 | ;; terms appear in sequence, they are parsed as a function application. 315 | ;; The `op` argument is only used for error reporting. 316 | (define (consume-prefix-sequence op ms) 317 | (match ms 318 | ['() 319 | (raise-arguments-error 'term "missing second argument to binary operator" 320 | "operator" op)] 321 | [(cons (? math-binop? new-op) _) 322 | (raise-arguments-error 'term "unexpected infix operator" 323 | "operator" new-op)] 324 | [(cons m (and ms (or '() (cons (? math-binop?) _)))) 325 | (values m ms)] 326 | [(cons m ms) 327 | (let loop ([rdrs (list (maybe-parens m 'left fixity:app))] 328 | [ms ms]) 329 | (match ms 330 | [(or '() (cons (? math-binop?) _)) 331 | (values (make-math (apply rdr:list (add-between (reverse rdrs) rdr:thick-space)) 332 | #:name #f ; will be overridden later, anyway 333 | #:props (hash math-prop:spine-fixity fixity:app)) 334 | ms)] 335 | [(cons m ms) 336 | (loop (cons (maybe-parens m 'right fixity:app) rdrs) 337 | ms)]))])) 338 | 339 | ;; Extends the given `lhs` with a (possibly empty) series of infix 340 | ;; applications, stopping at either the end of the sequence or the first 341 | ;; operator that binds looser than `min-prec`. This implements the 342 | ;; “precedence climbing” method to operator precedence parsing. 343 | (define (consume-infix-sequence min-prec lhs ms) 344 | (match ms 345 | [(cons (? math? op1 (app (λ~> (math-property math-prop:operator-fixity)) 346 | (and op1-info (binop-fixity op1-prec op1-assoc)))) 347 | ms) 348 | #:when (>= op1-prec min-prec) 349 | (define-values [rhs ms*] (consume-prefix-sequence op1 ms)) 350 | (let loop ([rhs rhs] 351 | [ms ms*]) 352 | (match ms 353 | [(cons (? math? op2 (app (λ~> (math-property math-prop:operator-fixity)) 354 | (binop-fixity op2-prec op2-assoc))) 355 | _) 356 | (cond 357 | [(and (= op1-prec op2-prec) 358 | (or (eq? 'none op1-assoc) 359 | (eq? 'none op2-assoc) 360 | (not (eq? op1-assoc op2-assoc)))) 361 | (raise-arguments-error 'decode-term "associativity conflict between binary operators of same precedence" 362 | "first operator" op1 363 | "second operator" op2 364 | "first associativity" op1-assoc 365 | "second associativity" op2-assoc 366 | "precedence" op1-prec)] 367 | [(or (< op1-prec op2-prec) 368 | (and (= op1-prec op2-prec) 369 | (eq? 'right op1-assoc))) 370 | (define-values [rhs* ms*] (consume-infix-sequence op2-prec rhs ms)) 371 | (loop rhs* ms*)] 372 | [else 373 | (failure-cont)])] 374 | [_ 375 | (values (make-math (rdr:list (maybe-parens lhs 'left op1-info) 376 | rdr:thick-space 377 | (math-renderer op1) 378 | rdr:thick-space 379 | (maybe-parens rhs 'right op1-info)) 380 | #:name #f ; will be overridden later, anyway 381 | #:props (hash math-prop:spine-fixity op1-info)) 382 | ms)]))] 383 | [_ (values lhs ms)])) 384 | 385 | (define ms (for/list ([m (in-list pre-ms)]) 386 | (match m 387 | [(? string?) (decode-math-string m)] 388 | [(? math?) m]))) 389 | (define-values [lhs ms*] (consume-prefix-sequence #f ms)) 390 | (match-define-values [m '()] (consume-infix-sequence -inf.0 lhs ms*)) 391 | (math-rename m (quasiexpr (term ,@(map math-name ms))))])) 392 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/draw/font.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require ffi/cvector 4 | ffi/unsafe/atomic 5 | racket/contract 6 | racket/flonum 7 | racket/format 8 | racket/match 9 | (only-in racket/unsafe/ops unsafe-vector*->immutable-vector!) 10 | threading 11 | "../util/print.rkt" 12 | "unsafe/cairo.rkt" 13 | "unsafe/harfbuzz.rkt" 14 | "unsafe/pango.rkt") 15 | 16 | (provide (contract-out 17 | [font-family/c flat-contract?] 18 | [font-style/c flat-contract?] 19 | [font-weight/c flat-contract?] 20 | [font-size/c flat-contract?] 21 | 22 | [normalized-font-weight/c flat-contract?] 23 | [normalize-font-weight (-> font-weight/c normalized-font-weight/c)] 24 | [prettify-font-weight (-> normalized-font-weight/c font-weight/c)] 25 | 26 | [font-description? predicate/c] 27 | [font-description-family (-> font-description? (or/c font-family/c #f))] 28 | [font-description-style (-> font-description? (or/c font-style/c #f))] 29 | [font-description-weight (-> font-description? (or/c normalized-font-weight/c #f))] 30 | [font-description-size (-> font-description? (or/c font-size/c #f))] 31 | [make-font-description (->* [] [#:family (or/c font-family/c #f) 32 | #:style (or/c font-style/c #f) 33 | #:weight (or/c font-weight/c #f) 34 | #:size (or/c font-size/c #f) 35 | #:cache (or/c font-description-cache? #f)] 36 | font-description?)] 37 | [make-partial-font-description (->* [] [#:family (or/c font-family/c #f) 38 | #:style (or/c font-style/c #f) 39 | #:weight (or/c font-weight/c #f) 40 | #:size (or/c font-size/c #f) 41 | #:cache (or/c font-description-cache? #f)] 42 | font-description?)] 43 | [copy-font-description (->* [font-description?] 44 | [#:family (or/c font-family/c #f) 45 | #:style (or/c font-style/c #f) 46 | #:weight (or/c font-weight/c #f) 47 | #:size (or/c font-size/c #f) 48 | #:cache (or/c font-description-cache? #f)] 49 | font-description?)] 50 | [combine-font-descriptions (-> font-description? ... font-description?)] 51 | 52 | [font-description-cache? predicate/c] 53 | [make-font-description-cache (-> font-description-cache?)] 54 | [current-font-description-cache (parameter/c (or/c font-description-cache? #f))] 55 | 56 | [font-map? predicate/c] 57 | [make-font-map (-> font-map?)] 58 | [current-font-map (parameter/c font-map?)] 59 | [resolve-font-description (->* [font-description?] 60 | [#:font-map font-map? 61 | #:fail failure-result/c] 62 | any)] 63 | 64 | [font? predicate/c] 65 | [font-font-map (-> font? font-map?)] 66 | [font-describe (-> font? font-description?)] 67 | [math-font? predicate/c] 68 | [font-math-script-metrics (-> font? math-script-metrics?)] 69 | 70 | [missing-glyph-error (-> symbol? font? char? none/c)] 71 | [glyph-id? predicate/c] 72 | [font-nominal-glyph-id (->* [font? char?] [#:missing failure-result/c] glyph-id?)] 73 | [font-glyph-italic-correction (-> font? glyph-id? real?)] 74 | [font-glyph-math-script-kerns (-> font? glyph-id? math-script-kerns?)] 75 | 76 | (struct math-script-metrics 77 | ([depth-scales (vectorof (real-in 0 1) #:immutable #t)] 78 | [space-after real?] 79 | [sub-shift-down real?] 80 | [sub-top-max real?] 81 | [sub-baseline-drop-min real?] 82 | [sup-shift-up real?] 83 | [sup-shift-up-cramped real?] 84 | [sup-bottom-min real?] 85 | [sup-baseline-drop-max real?] 86 | [sub-sup-gap-min real?] 87 | [sup-bottom-max-with-sub real?])) 88 | [math-script-depth? predicate/c] 89 | [math-script-metrics-depth-scale (-> math-script-metrics? 90 | math-script-depth? 91 | (real-in 0 1))] 92 | 93 | (struct math-script-kerns 94 | ([top-left (or/c math-script-kern? #f)] 95 | [top-right (or/c math-script-kern? #f)] 96 | [bottom-left (or/c math-script-kern? #f)] 97 | [bottom-right (or/c math-script-kern? #f)])) 98 | [no-math-script-kerns math-script-kerns?] 99 | [any-math-script-kerns? (-> math-script-kerns? boolean?)] 100 | [make-math-script-kerns (->* [] [#:top-left (or/c math-script-kern? #f) 101 | #:top-right (or/c math-script-kern? #f) 102 | #:bottom-left (or/c math-script-kern? #f) 103 | #:bottom-right (or/c math-script-kern? #f)] 104 | math-script-kerns?)] 105 | [copy-math-script-kerns (->* [math-script-kerns?] 106 | [#:top-left (or/c math-script-kern? #f) 107 | #:top-right (or/c math-script-kern? #f) 108 | #:bottom-left (or/c math-script-kern? #f) 109 | #:bottom-right (or/c math-script-kern? #f)] 110 | math-script-kerns?)] 111 | [scale-math-script-kerns (-> math-script-kerns? real? real? math-script-kerns?)] 112 | [h-append-math-script-kerns (-> math-script-kerns? math-script-kerns? math-script-kerns?)] 113 | 114 | [math-script-kern? predicate/c] 115 | [math-script-kern-correction-heights (-> math-script-kern? (vectorof real? #:immutable #t))] 116 | [math-script-kern-kern-values (-> math-script-kern? (and/c (vectorof real? #:immutable #t) 117 | (property/c vector-length (>=/c 1))))] 118 | [math-script-kern-value (-> (or/c math-script-kern? #f) real? real?)] 119 | [scale-math-script-kern (-> math-script-kern? real? real? math-script-kern?)]) 120 | 121 | (protect-out 122 | make-pango-context 123 | font-map-pango-font-map 124 | 125 | font-pango-description 126 | font-hb-font)) 127 | 128 | ;; ----------------------------------------------------------------------------- 129 | ;; font maps and font descriptions 130 | 131 | (struct font-description-cache (hash)) 132 | 133 | ;; TODO: Cache eviction? 134 | (define (make-font-description-cache) 135 | (font-description-cache (make-hash))) 136 | 137 | (define current-font-description-cache (make-parameter (make-font-description-cache))) 138 | 139 | (define font-weight-sym-mapping 140 | (hasheq 'thin 100 141 | 'ultralight 200 142 | 'light 300 143 | 'semilight 350 144 | 'book 380 145 | 'normal 400 146 | 'medium 500 147 | 'semibold 600 148 | 'bold 700 149 | 'ultrabold 800 150 | 'heavy 900 151 | 'ultraheavy 1000)) 152 | (define font-weight-num-mapping 153 | (for/hasheq ([(sym num) (in-immutable-hash font-weight-sym-mapping)]) 154 | (values num sym))) 155 | 156 | (define font-family/c string?) 157 | (define font-style/c (or/c 'normal 'italic 'oblique)) 158 | (define normalized-font-weight/c (integer-in 100 1000)) 159 | (define font-weight/c (apply or/c normalized-font-weight/c (hash-keys font-weight-sym-mapping))) 160 | (define font-size/c (>=/c 0)) 161 | 162 | (struct font-description (family style weight size) 163 | #:transparent 164 | #:property prop:custom-print-quotable 'never 165 | #:property prop:custom-write 166 | (λ (self out mode) 167 | (match-define (font-description family style weight size) self) 168 | (cond 169 | [(eq? mode 0) 170 | (~> (quasiexpr (make-font-description 171 | {~seq #:family ,family} 172 | {~if (eq? style 'normal) {~seq #:style ,style}} 173 | {~if (eq? weight 400) {~seq #:weight ,(prettify-font-weight weight)}} 174 | {~if size {~seq #:size ,size}})) 175 | (print out))] 176 | [else 177 | (write-string "#> (list (~v family) 182 | (and (not (eq? style 'normal)) style) 183 | (and (not (eq? pretty-weight 'normal)) 184 | (if (symbol? pretty-weight) 185 | pretty-weight 186 | (~a "weight=" pretty-weight))) 187 | (and size 188 | (~a size "px"))) 189 | (filter values))) 190 | out) 191 | (write-string ">" out)]))) 192 | 193 | (define (make-font-description #:family [family #f] 194 | #:style [style 'normal] 195 | #:weight [weight 400] 196 | #:size [size #f] 197 | #:cache [cache (current-font-description-cache)]) 198 | (define new-desc (font-description family style (and~> weight normalize-font-weight) size)) 199 | (cond 200 | [cache 201 | (cond 202 | [(hash-ref-key (font-description-cache-hash cache) new-desc #f)] 203 | [else 204 | (hash-set! (font-description-cache-hash cache) new-desc #t) 205 | new-desc])] 206 | [else 207 | new-desc])) 208 | 209 | (define (make-partial-font-description #:family [family #f] 210 | #:style [style #f] 211 | #:weight [weight #f] 212 | #:size [size #f] 213 | #:cache [cache (current-font-description-cache)]) 214 | (make-font-description #:family family 215 | #:style style 216 | #:weight weight 217 | #:size size 218 | #:cache cache)) 219 | 220 | (define (copy-font-description desc 221 | #:family [family (font-description-family desc)] 222 | #:style [style (font-description-style desc)] 223 | #:weight [weight (font-description-weight desc)] 224 | #:size [size (font-description-size desc)] 225 | #:cache [cache (current-font-description-cache)]) 226 | (make-font-description #:family family 227 | #:style style 228 | #:weight weight 229 | #:size size 230 | #:cache cache)) 231 | 232 | (define combine-font-descriptions 233 | (case-lambda 234 | [() (make-partial-font-description)] 235 | [(desc) desc] 236 | [(desc . descs) 237 | (for/fold ([desc-a desc]) 238 | ([desc-b (in-list descs)]) 239 | (match-define (font-description family-a style-a weight-a size-a) desc-a) 240 | (match-define (font-description family-b style-b weight-b size-b) desc-b) 241 | (make-font-description #:family (or family-b family-a) 242 | #:style (or style-b style-b) 243 | #:weight (or weight-b weight-a) 244 | #:size (or size-b size-a)))])) 245 | 246 | (define (normalize-font-weight v) 247 | (if (symbol? v) 248 | (hash-ref font-weight-sym-mapping v) 249 | v)) 250 | 251 | (define (prettify-font-weight v) 252 | (hash-ref font-weight-num-mapping v v)) 253 | 254 | (define (font-description->PangoFontDescription desc) 255 | (match-define (font-description family style weight size) desc) 256 | 257 | (define pango-desc (pango_font_description_new)) 258 | (when family (pango_font_description_set_family pango-desc family)) 259 | (when style (pango_font_description_set_style pango-desc style)) 260 | (when weight (pango_font_description_set_weight pango-desc weight)) 261 | (when size (pango_font_description_set_absolute_size pango-desc (px->pango size))) 262 | 263 | pango-desc) 264 | 265 | (define (PangoFontDescription->font-description pango-desc) 266 | (define set-fields (pango_font_description_get_set_fields pango-desc)) 267 | (make-font-description 268 | #:family (and (memq 'family set-fields) 269 | (pango_font_description_get_family pango-desc)) 270 | #:style (and (memq 'style set-fields) 271 | (pango_font_description_get_style pango-desc)) 272 | #:weight (and (memq 'weight set-fields) 273 | (pango_font_description_get_weight pango-desc)) 274 | #:size (and (memq 'size set-fields) 275 | (pango->px (pango_font_description_get_size pango-desc))))) 276 | 277 | (struct font-map 278 | (pango-font-map 279 | pango-context 280 | font-description-mapping ; (ephemeron-hash/c font-description? font?) 281 | pango-font-mapping)) ; (ephemeron-hash/c PangoFont? font?) 282 | 283 | ;; FIXME: cache pango contexts 284 | (define (make-pango-context pango-fm) 285 | (define context (pango_font_map_create_context pango-fm)) 286 | 287 | (define options (cairo_font_options_create)) 288 | (cairo_font_options_set_antialias options 'gray) 289 | (cairo_font_options_set_hint_metrics options 'off) 290 | (pango_cairo_context_set_font_options context options) 291 | (cairo_font_options_destroy options) 292 | 293 | context) 294 | 295 | (define (make-font-map) 296 | (define pango-fm (pango_cairo_font_map_new)) 297 | (pango_cairo_font_map_set_resolution pango-fm 72.0) 298 | (font-map pango-fm 299 | (make-pango-context pango-fm) 300 | (make-ephemeron-hash) 301 | (make-ephemeron-hash))) 302 | 303 | (define current-font-map (make-parameter (make-font-map))) 304 | 305 | (define (resolve-font-description 306 | desc 307 | #:font-map [font-map (current-font-map)] 308 | #:fail [fail (λ () (raise-arguments-error 'resolve-font-description 309 | "no font matching description" 310 | "description" desc))]) 311 | (define desc-map (font-map-font-description-mapping font-map)) 312 | (cond 313 | [(hash-ref desc-map desc #f)] 314 | [else 315 | (define pango-desc (font-description->PangoFontDescription desc)) 316 | (cond 317 | [(begin0 318 | (pango_font_map_load_font (font-map-pango-font-map font-map) 319 | (font-map-pango-context font-map) 320 | pango-desc) 321 | (pango_font_description_free pango-desc)) 322 | => (λ (pango-font) 323 | (define font (PangoFont->font font-map pango-font)) 324 | (hash-set! desc-map desc font) 325 | font)] 326 | [else 327 | (if (procedure? fail) 328 | (fail) 329 | fail)])])) 330 | 331 | (define (resolve-font-description* desc 332 | #:font-map [font-map (current-font-map)] 333 | #:language [language #f]) 334 | (define pango-desc (font-description->PangoFontDescription desc)) 335 | (cond 336 | [(begin0 337 | (pango_font_map_load_fontset (font-map-pango-font-map font-map) 338 | (font-map-pango-context font-map) 339 | pango-desc 340 | (if language 341 | (pango_language_from_string language) 342 | (pango_language_get_default))) 343 | (pango_font_description_free pango-desc)) 344 | => (λ (pango-fontset) 345 | (define pango-fonts '()) 346 | (pango_fontset_foreach 347 | pango-fontset 348 | (λ (font) 349 | (set! pango-fonts (cons (g_object_ref font) pango-fonts)) 350 | #f)) 351 | (map (λ~> (PangoFont->font font-map _)) (reverse pango-fonts)))] 352 | [else 353 | '()])) 354 | 355 | (define (PangoFont->font font-map pango-font) 356 | (call-as-atomic 357 | (λ () 358 | (hash-ref! (font-map-pango-font-mapping font-map) 359 | pango-font 360 | (λ () (make-font font-map pango-font)))))) 361 | 362 | ;; ----------------------------------------------------------------------------- 363 | ;; fonts 364 | 365 | (struct font (font-map 366 | describe 367 | pango-font 368 | pango-description 369 | hb-font 370 | math-font? 371 | math-script-metrics) 372 | #:property prop:custom-write 373 | (λ (self out mode) 374 | (match-define (font-description family style weight size) (font-describe self)) 375 | (write-string 376 | (~a "#") 380 | out))) 381 | 382 | (define (make-font font-map pango-font) 383 | (define pango-desc (pango_font_describe_with_absolute_size pango-font)) 384 | (define desc (PangoFontDescription->font-description pango-desc)) 385 | (define hb-font (pango_font_get_hb_font pango-font)) 386 | (font font-map 387 | desc 388 | pango-font 389 | pango-desc 390 | hb-font 391 | (hb_ot_math_has_data (hb_font_get_face hb-font)) 392 | (load-math-script-metrics hb-font #:size (font-description-size desc)))) 393 | 394 | (define (missing-glyph-error who f c) 395 | (raise-arguments-error who "no glyph in font for char" 396 | "font" f 397 | "char" c)) 398 | 399 | (define (glyph-id? v) (exact-nonnegative-integer? v)) 400 | 401 | (define (font-nominal-glyph-id f c #:missing [missing (λ () (missing-glyph-error 'font-get-nominal-glyph f c))]) 402 | (or (hb_font_get_nominal_glyph (font-hb-font f) c) 403 | (if (procedure? missing) (missing) missing))) 404 | 405 | (define (font-glyph-italic-correction font glyph-id) 406 | (define hb-font (font-hb-font font)) 407 | (pango->px (hb_ot_math_get_glyph_italics_correction hb-font glyph-id))) 408 | 409 | (define (math-font? v) 410 | (and (font? v) (font-math-font? v))) 411 | 412 | ;; ----------------------------------------------------------------------------- 413 | ;; math metrics 414 | 415 | (struct math-script-metrics 416 | (depth-scales 417 | space-after 418 | 419 | sub-shift-down 420 | sub-top-max 421 | sub-baseline-drop-min 422 | 423 | sup-shift-up 424 | sup-shift-up-cramped 425 | sup-bottom-min 426 | sup-baseline-drop-max 427 | 428 | sub-sup-gap-min 429 | sup-bottom-max-with-sub) 430 | #:transparent) 431 | 432 | (define (load-math-script-metrics hb-font #:size em-size) 433 | (define (get which #:convert [convert values] #:fallback [fallback 0]) 434 | (define val (hb_ot_math_get_constant hb-font which)) 435 | (if (zero? val) 436 | (if (procedure? fallback) 437 | (fallback) 438 | fallback) 439 | (convert val))) 440 | 441 | (define (get/px which #:fallback [fallback 0]) 442 | (get which #:fallback fallback #:convert pango->px)) 443 | 444 | (define (get-mvar which) 445 | (pango->px (or (hb_ot_metrics_get_position hb-font which) 0))) 446 | 447 | (define (convert-percent v) 448 | (fl/ (->fl v) 100.0)) 449 | 450 | ;; Fallback values are computed as recommended by the MathML Core 2021-08-16 Working Draft: 451 | ;; 452 | (math-script-metrics 453 | (vector-immutable 454 | (get 'script-percent-scale-down #:convert convert-percent #:fallback 0.71) 455 | (get 'script-script-percent-scale-down #:convert convert-percent #:fallback 0.5041)) 456 | 457 | (get/px 'space-after-script #:fallback (λ () (fl* em-size (real->double-flonum 1/24)))) 458 | 459 | (get/px 'subscript-shift-down #:fallback (λ () (get-mvar 'subscript-em-y-offset))) 460 | (get/px 'subscript-top-max #:fallback (λ () (fl* (get-mvar 'x-height) 0.8))) 461 | (get/px 'subscript-baseline-drop-min) 462 | 463 | (get/px 'superscript-shift-up #:fallback (λ () (get-mvar 'superscript-em-y-offset))) 464 | (get/px 'superscript-shift-up-cramped #:fallback (λ () (get-mvar 'superscript-em-y-offset))) 465 | (get/px 'superscript-bottom-min #:fallback (λ () (fl* (get-mvar 'x-height) 0.25))) 466 | (get/px 'superscript-baseline-drop-max) 467 | 468 | (get/px 'sub-superscript-gap-min #:fallback (λ () (fl* (get-mvar 'underline-size) 4.0))) 469 | (get/px 'superscript-bottom-max-with-subscript #:fallback (λ () (fl* (get-mvar 'x-height) 0.8))))) 470 | 471 | (define (math-script-depth? v) 472 | (exact-nonnegative-integer? v)) 473 | 474 | (define (math-script-metrics-depth-scale sm depth) 475 | (define scales (math-script-metrics-depth-scales sm)) 476 | (if (or (zero? depth) 477 | (zero? (vector-length scales))) 478 | 1 479 | (vector-ref scales (sub1 (min depth (vector-length scales)))))) 480 | 481 | ;; 482 | (struct math-script-kerns 483 | (top-left 484 | top-right 485 | bottom-left 486 | bottom-right) 487 | #:transparent) 488 | 489 | (define no-math-script-kerns (math-script-kerns #f #f #f #f)) 490 | (define (any-math-script-kerns? cis) 491 | (and (or (math-script-kerns-top-left cis) 492 | (math-script-kerns-top-right cis) 493 | (math-script-kerns-bottom-left cis) 494 | (math-script-kerns-bottom-right cis)) 495 | #t)) 496 | 497 | (define (make-math-script-kerns #:top-left [tl #f] 498 | #:top-right [tr #f] 499 | #:bottom-left [bl #f] 500 | #:bottom-right [br #f]) 501 | (if (or tl tr bl br) 502 | (math-script-kerns tl tr bl br) 503 | no-math-script-kerns)) 504 | 505 | (define (copy-math-script-kerns cis 506 | #:top-left [tl (math-script-kerns-top-left cis)] 507 | #:top-right [tr (math-script-kerns-top-right cis)] 508 | #:bottom-left [bl (math-script-kerns-bottom-left cis)] 509 | #:bottom-right [br (math-script-kerns-bottom-right cis)]) 510 | (make-math-script-kerns #:top-left tl 511 | #:top-right tr 512 | #:bottom-left bl 513 | #:bottom-right br)) 514 | 515 | (define (scale-math-script-kerns ci x y) 516 | (match-define (math-script-kerns tl tr bl br) ci) 517 | (make-math-script-kerns #:top-left (and~> tl (scale-math-script-kern x y)) 518 | #:top-right (and~> tr (scale-math-script-kern x y)) 519 | #:bottom-left (and~> bl (scale-math-script-kern x y)) 520 | #:bottom-right (and~> br (scale-math-script-kern x y)))) 521 | 522 | (define (h-append-math-script-kerns a b) 523 | (make-math-script-kerns #:top-left (math-script-kerns-top-left a) 524 | #:bottom-left (math-script-kerns-bottom-left a) 525 | #:top-right (math-script-kerns-top-right b) 526 | #:bottom-right (math-script-kerns-bottom-right b))) 527 | 528 | ;; https://docs.microsoft.com/en-us/typography/opentype/spec/math#mathkern-table 529 | (struct math-script-kern (correction-heights kern-values) 530 | #:property prop:custom-write 531 | (λ (self out mode) 532 | (match-define (math-script-kern correction-heights kern-values) self) 533 | (write-string "#" out))) 541 | 542 | (define (math-script-kern-value ci height) 543 | (cond 544 | [ci 545 | (match-define (math-script-kern correction-heights kern-values) ci) 546 | (let loop ([i 0] 547 | [count (vector-length correction-heights)]) 548 | (cond 549 | [(> count 0) 550 | (define half (quotient count 2)) 551 | (define height* (vector-ref correction-heights (+ i half))) 552 | (if (< height* height) 553 | (loop (+ i half 1) (- count (+ half 1))) 554 | (loop i half))] 555 | [else 556 | (vector-ref kern-values i)]))] 557 | [else 0])) 558 | 559 | (define (unsafe-make-math-script-kern num-heights proc) 560 | (define correction-heights (make-vector num-heights)) 561 | (define kern-values (make-vector (add1 num-heights))) 562 | (proc correction-heights kern-values) 563 | (math-script-kern (unsafe-vector*->immutable-vector! correction-heights) 564 | (unsafe-vector*->immutable-vector! kern-values))) 565 | 566 | (define (scale-math-script-kern ci x y) 567 | (match-define (math-script-kern correction-heights kern-values) ci) 568 | (define num-heights (vector-length correction-heights)) 569 | (unsafe-make-math-script-kern 570 | num-heights 571 | (λ (correction-heights* kern-values*) 572 | (for ([i (in-range num-heights)]) 573 | (vector-set! correction-heights* i (* (vector-ref correction-heights i) y)) 574 | (vector-set! kern-values* i (* (vector-ref kern-values i) x))) 575 | (vector-set! kern-values* num-heights (* (vector-ref kern-values num-heights) x))))) 576 | 577 | ;; FIXME: cache? 578 | (define (font-glyph-math-script-kerns font glyph-id) 579 | (unless hb_ot_math_get_glyph_kernings 580 | (raise-arguments-error 581 | 'font-glyph-math-script-kerns 582 | "libharfbuzz is too old to load math script kerns" 583 | "current version" (unquoted-printing-string (hb_version_string)) 584 | "needed version" (unquoted-printing-string ">=3.4.0"))) 585 | 586 | (define hb-font (font-hb-font font)) 587 | 588 | (define (get-one which) 589 | (define kern-entries (hb_ot_math_get_glyph_kernings hb-font glyph-id which)) 590 | (cond 591 | [kern-entries 592 | (define num-heights (sub1 (cvector-length kern-entries))) 593 | (unsafe-make-math-script-kern 594 | num-heights 595 | (λ (correction-heights kern-values) 596 | (for ([i (in-range num-heights)]) 597 | (define entry (cvector-ref kern-entries i)) 598 | (vector-set! correction-heights i (pango->px (hb_ot_math_kern_entry_t-max-correction-height entry))) 599 | (vector-set! kern-values i (pango->px (hb_ot_math_kern_entry_t-kern-value entry)))) 600 | (define last-entry (cvector-ref kern-entries num-heights)) 601 | (vector-set! kern-values num-heights (pango->px (hb_ot_math_kern_entry_t-kern-value last-entry)))))] 602 | [else #f])) 603 | 604 | (make-math-script-kerns #:top-left (get-one 'top-left) 605 | #:top-right (get-one 'top-right) 606 | #:bottom-left (get-one 'bottom-left) 607 | #:bottom-right (get-one 'bottom-right))) 608 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/draw/text.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require ffi/cvector 4 | racket/class 5 | racket/contract 6 | (only-in racket/draw dc<%>) 7 | (only-in racket/draw/private/local 8 | flush-cr 9 | in-cairo-context 10 | install-color) 11 | racket/flonum 12 | racket/string 13 | "font.rkt" 14 | "unsafe/cairo.rkt" 15 | "unsafe/pango.rkt") 16 | 17 | (provide (contract-out 18 | (struct line-extents 19 | ([em-ascent (>=/c 0)] 20 | [em-descent (>=/c 0)] 21 | [advance-width real?] 22 | [bearing-left real?] 23 | [bearing-bottom real?] 24 | [ink-width (>=/c 0)] 25 | [ink-height (>=/c 0)] 26 | [italic-correction real?] 27 | [math-script-kerns math-script-kerns?])) 28 | [line-extents-em-height (-> line-extents? (>=/c 0))] 29 | [line-extents-bearing-right (-> line-extents? real?)] 30 | [line-extents-bearing-top (-> line-extents? real?)] 31 | [line-extents-ink-ascent (-> line-extents? real?)] 32 | [line-extents-ink-descent (-> line-extents? real?)] 33 | 34 | [font-feature-settings/c flat-contract?] 35 | [measure-text-line (->* [(is-a?/c dc<%>) font? string?] 36 | [#:features font-feature-settings/c 37 | #:fallback? any/c] 38 | line-extents?)] 39 | [draw-text-line (->* [(is-a?/c dc<%>) font? string?] 40 | [#:x real? #:y real? 41 | #:features font-feature-settings/c 42 | #:fallback? any/c] 43 | void?)])) 44 | 45 | ;; ----------------------------------------------------------------------------- 46 | ;; line-extents 47 | 48 | (struct line-extents 49 | (em-ascent ; logical ascent above the baseline, depends only on the font 50 | em-descent ; logical descent below the baseline, depends only on the font 51 | advance-width ; logical distance to advance to the right after drawing these glyphs 52 | 53 | bearing-left ; distance from the origin to the leftmost part of the glyphs as drawn 54 | bearing-bottom ; distance from the baseline to the bottommost part of the glyphs as drawn 55 | ; (negative if the glyph has a descender) 56 | ink-width ; width of the glyphs as drawn 57 | ink-height ; height of the glyphs as drawn 58 | 59 | italic-correction 60 | math-script-kerns) 61 | #:transparent) 62 | 63 | (define (line-extents-em-height le) 64 | (+ (line-extents-em-ascent le) 65 | (line-extents-em-descent le))) 66 | 67 | (define (line-extents-bearing-right le) 68 | (- (line-extents-advance-width le) 69 | (line-extents-bearing-left le) 70 | (line-extents-ink-width le))) 71 | 72 | (define (line-extents-bearing-top le) 73 | (- (line-extents-em-ascent le) 74 | (line-extents-bearing-bottom le) 75 | (line-extents-ink-height le))) 76 | 77 | (define (line-extents-ink-ascent le) 78 | (+ (line-extents-bearing-bottom le) 79 | (line-extents-ink-height le))) 80 | 81 | (define (line-extents-ink-descent le) 82 | (- (line-extents-bearing-bottom le))) 83 | 84 | ;; ----------------------------------------------------------------------------- 85 | ;; rendering 86 | 87 | (define font-feature-settings/c 88 | (and/c hash-equal? 89 | hash-strong? 90 | (hash/c (and/c string? #px"^[ !#-~]{4}$") 91 | exact-nonnegative-integer? 92 | #:immutable #t))) 93 | 94 | ;; FIXME: cache 95 | (define (make-pango-attrs #:fallback? fallback? 96 | #:features features) 97 | (define attrs (pango_attr_list_new)) 98 | (pango_attr_list_insert attrs (pango_attr_fallback_new fallback?)) 99 | (unless (hash-empty? features) 100 | (define css-features 101 | (for/list ([(tag val) (in-immutable-hash features)]) 102 | (format "\"~a\" ~a" tag val))) 103 | (pango_attr_list_insert attrs (pango_attr_font_features_new 104 | (string-join css-features ",")))) 105 | attrs) 106 | 107 | (define (with-pango-layout-line dc font str 108 | #:fallback? fallback? 109 | #:features features 110 | #:before [before-proc void] 111 | body-proc 112 | #:after [after-proc void]) 113 | (define ctx (make-pango-context (font-map-pango-font-map (font-font-map font)))) 114 | (define desc (font-pango-description font)) 115 | (define attrs (make-pango-attrs #:fallback? fallback? #:features features)) 116 | (send dc in-cairo-context 117 | (λ (cr) 118 | (before-proc cr) 119 | 120 | (pango_cairo_update_context cr ctx) 121 | (define layout (pango_layout_new ctx)) 122 | (pango_layout_set_single_paragraph_mode layout #t) 123 | (pango_layout_set_font_description layout desc) 124 | (pango_layout_set_attributes layout attrs) 125 | (pango_layout_set_text layout str) 126 | 127 | (begin0 128 | (body-proc cr (pango_layout_get_line_readonly layout 0)) 129 | 130 | (g_object_unref layout) 131 | (after-proc cr))))) 132 | 133 | (define (measure-text-line dc font str 134 | #:fallback? [fallback? #f] 135 | #:features [features (hash)]) 136 | (define-values [ink logical first-glyph last-glyph] 137 | (with-pango-layout-line dc font str #:fallback? fallback? #:features features 138 | (λ (cr line) 139 | (define-values [ink logical] (pango_layout_line_get_extents line)) 140 | (define-values [first-glyph last-glyph] 141 | (cond 142 | [(PangoLayoutLine-runs line) 143 | (define first-glyphs (PangoGlyphString-glyphs (PangoGlyphItem-glyphs (PangoLayoutLine-first-run line)))) 144 | (define last-glyphs (PangoGlyphString-glyphs (PangoGlyphItem-glyphs (PangoLayoutLine-last-run line)))) 145 | (values (PangoGlyphInfo-glyph (cvector-ref first-glyphs 0)) 146 | (PangoGlyphInfo-glyph (cvector-ref last-glyphs (sub1 (cvector-length last-glyphs)))))] 147 | [else 148 | (values #f #f)])) 149 | (values ink logical first-glyph last-glyph)))) 150 | 151 | (line-extents 152 | (fl- (pango->px (PangoRectangle-y logical))) 153 | (fl+ (pango->px (PangoRectangle-y logical)) 154 | (pango->px (PangoRectangle-height logical))) 155 | (pango->px (PangoRectangle-width logical)) 156 | (pango->px (PangoRectangle-x ink)) 157 | (fl- (fl+ (pango->px (PangoRectangle-y ink)) 158 | (pango->px (PangoRectangle-height ink)))) 159 | (pango->px (PangoRectangle-width ink)) 160 | (pango->px (PangoRectangle-height ink)) 161 | (if last-glyph (font-glyph-italic-correction font last-glyph) 0) 162 | (cond 163 | [(not first-glyph) 164 | no-math-script-kerns] 165 | [(eqv? first-glyph last-glyph) 166 | (font-glyph-math-script-kerns font first-glyph)] 167 | [else 168 | (h-append-math-script-kerns (font-glyph-math-script-kerns font first-glyph) 169 | (font-glyph-math-script-kerns font last-glyph))]))) 170 | 171 | (define (draw-text-line dc font str #:x [x 0] #:y [y 0] 172 | #:fallback? [fallback? #f] 173 | #:features [features (hash)]) 174 | (define text-color (send dc get-text-foreground)) 175 | (define alpha (send dc get-alpha)) 176 | (with-pango-layout-line dc font str #:fallback? fallback? #:features features 177 | #:before (λ (cr) 178 | (send dc install-color cr text-color alpha #f) 179 | (cairo_new_path cr) 180 | (cairo_move_to cr x y)) 181 | pango_cairo_show_layout_line 182 | #:after (λ (cr) (send dc flush-cr)))) 183 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/draw/unsafe/cairo.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require ffi/unsafe 4 | ffi/unsafe/alloc 5 | ffi/unsafe/cvector 6 | ffi/unsafe/define 7 | racket/draw/unsafe/cairo-lib 8 | racket/draw/unsafe/cairo) 9 | 10 | (provide _cairo_scaled_font_t 11 | (struct-out cairo_matrix_t) 12 | (struct-out cairo_glyph_t) 13 | (struct-out cairo_text_cluster_t) 14 | make-cairo-vector 15 | 16 | cairo_get_matrix 17 | cairo_set_matrix 18 | cairo_translate 19 | 20 | cairo_font_face_reference 21 | cairo_font_face_destroy 22 | 23 | cairo_font_options_create 24 | cairo_font_options_destroy 25 | cairo_font_options_set_antialias 26 | cairo_font_options_set_hint_style 27 | cairo_font_options_set_hint_metrics 28 | 29 | cairo_scaled_font_create 30 | cairo_scaled_font_destroy 31 | cairo_scaled_font_get_ctm 32 | cairo_scaled_font_get_font_face 33 | cairo_scaled_font_get_font_matrix 34 | cairo_scaled_font_get_font_options 35 | 36 | cairo_save 37 | cairo_restore 38 | cairo_move_to 39 | cairo_new_path 40 | cairo_get_scaled_font 41 | cairo_set_scaled_font 42 | cairo_show_text_glyph 43 | cairo_show_text_glyphs) 44 | 45 | ;; ----------------------------------------------------------------------------- 46 | ;; types 47 | 48 | (define-cpointer-type _cairo_font_face_t) 49 | (define-cpointer-type _cairo_font_options_t) 50 | (define-cpointer-type _cairo_scaled_font_t) 51 | 52 | (define _cairo_antialias_t (_enum '(default none gray subpixel fast good best))) 53 | (define _cairo_hint_style_t (_enum '(default none slight medium full))) 54 | (define _cairo_hint_metrics_t (_enum '(default off on))) 55 | 56 | (define-cstruct _cairo_matrix_t 57 | ([xx _double*] [yx _double*] 58 | [xy _double*] [yy _double*] 59 | [x0 _double*] [y0 _double*]) 60 | #:malloc-mode 'atomic-interior) 61 | 62 | (define-cstruct _cairo_glyph_t 63 | ([index _ulong] 64 | [x _double*] 65 | [y _double*]) 66 | #:malloc-mode 'atomic-interior) 67 | 68 | (define-cstruct _cairo_text_cluster_t 69 | ([num-bytes _int] 70 | [num-glyphs _int]) 71 | #:malloc-mode 'atomic-interior) 72 | 73 | (define (make-cairo-vector type length) 74 | (make-cvector* (malloc type length 'atomic-interior) 75 | type 76 | length)) 77 | 78 | ;; ----------------------------------------------------------------------------- 79 | 80 | (define-ffi-definer define-cairo cairo-lib) 81 | 82 | (define-cairo cairo_font_face_destroy (_fun _cairo_font_face_t -> _void) 83 | #:wrap (releaser)) 84 | (define-cairo cairo_font_face_reference (_fun [in : _cairo_font_face_t] -> _cairo_font_face_t -> in) 85 | #:wrap (retainer cairo_font_face_destroy)) 86 | 87 | #;(begin 88 | (define-cairo cairo_font_options_destroy (_fun _cairo_font_options_t -> _void) 89 | #:wrap (deallocator)) 90 | (define-cairo cairo_font_options_create (_fun -> _cairo_font_options_t) 91 | #:wrap (allocator cairo_font_options_destroy))) 92 | 93 | (define-cairo cairo_font_options_set_antialias (_fun _cairo_font_options_t _cairo_antialias_t -> _void)) 94 | (define-cairo cairo_font_options_set_hint_style (_fun _cairo_font_options_t _cairo_hint_style_t -> _void)) 95 | (define-cairo cairo_font_options_set_hint_metrics (_fun _cairo_font_options_t _cairo_hint_metrics_t -> _void)) 96 | 97 | (define-cairo cairo_scaled_font_destroy (_fun _cairo_scaled_font_t -> _void) 98 | #:wrap (releaser)) 99 | (define-cairo cairo_scaled_font_create 100 | (_fun _cairo_font_face_t 101 | _cairo_matrix_t-pointer 102 | _cairo_matrix_t-pointer 103 | _cairo_font_options_t 104 | -> _cairo_scaled_font_t) 105 | #:wrap (allocator cairo_scaled_font_destroy)) 106 | (define-cairo cairo_scaled_font_get_ctm (_fun _cairo_scaled_font_t _cairo_matrix_t-pointer -> _void)) 107 | (define-cairo cairo_scaled_font_get_font_face (_fun _cairo_scaled_font_t -> _cairo_font_face_t)) 108 | (define-cairo cairo_scaled_font_get_font_matrix (_fun _cairo_scaled_font_t _cairo_matrix_t-pointer -> _void)) 109 | (define-cairo cairo_scaled_font_get_font_options (_fun _cairo_scaled_font_t _cairo_font_options_t -> _void)) 110 | 111 | (define-cairo cairo_get_scaled_font (_fun _cairo_t -> _cairo_scaled_font_t)) 112 | (define-cairo cairo_set_scaled_font (_fun _cairo_t _cairo_scaled_font_t -> _void)) 113 | 114 | ;; simple case of only one glyph 115 | (define-cairo cairo_show_text_glyph 116 | (_fun _cairo_t 117 | [utf8 : _string/utf-8] 118 | [utf8_len : _int = (string-utf-8-length utf8)] 119 | _cairo_glyph_t-pointer 120 | [_int = 1] 121 | [_cairo_text_cluster_t-pointer = (make-cairo_text_cluster_t utf8_len 1)] 122 | [_int = 1] 123 | -> _void) 124 | #:c-id cairo_show_text_glyphs) 125 | 126 | (define-cairo cairo_show_text_glyphs 127 | (_fun _cairo_t 128 | [utf8 : _string/utf-8] 129 | [_int = (string-utf-8-length utf8)] 130 | [glyphs : (_cvector i)] 131 | [_int = (cvector-length glyphs)] 132 | [clusters : (_cvector i)] 133 | [_int = (cvector-length clusters)] 134 | -> _void)) 135 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/draw/unsafe/harfbuzz.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require ffi/cvector 4 | ffi/unsafe 5 | ffi/unsafe/alloc 6 | ffi/unsafe/define 7 | threading) 8 | 9 | (provide _hb_font_t 10 | (struct-out hb_ot_math_kern_entry_t) 11 | 12 | hb_version_string 13 | 14 | hb_font_destroy 15 | hb_font_create 16 | hb_font_reference 17 | hb_font_make_immutable 18 | hb_font_get_face 19 | 20 | hb_font_get_nominal_glyph 21 | hb_font_get_ppem 22 | hb_font_get_scale 23 | 24 | hb_ot_metrics_get_position 25 | 26 | hb_ot_math_has_data 27 | hb_ot_math_get_constant 28 | hb_ot_math_get_glyph_italics_correction 29 | hb_ot_math_get_glyph_kernings) 30 | 31 | ;; ----------------------------------------------------------------------------- 32 | ;; types 33 | 34 | (define _hb_codepoint_t _uint32) 35 | (define _hb_ot_name_id_t _uint) 36 | (define _hb_position_t _int32) 37 | 38 | (define _hb_codepoint_t/char 39 | (make-ctype _hb_codepoint_t 40 | char->integer 41 | integer->char)) 42 | 43 | (define _hb_tag_t 44 | (make-ctype _uint32 45 | (λ~> (integer-bytes->integer #f #t)) 46 | (λ~> (integer->integer-bytes 4 #f #t)))) 47 | 48 | (define-cpointer-type _hb_face_t) 49 | (define-cpointer-type _hb_font_t) 50 | (define-cpointer-type _hb_language_t) 51 | 52 | (define _hb_direction_t 53 | (_enum '(HB_DIRECTION_INVALID 54 | HB_DIRECTION_LTR 55 | HB_DIRECTION_RTL 56 | HB_DIRECTION_TTB 57 | HB_DIRECTION_BTT))) 58 | 59 | (define metrics-tag-sym-bytes-mapping 60 | (hasheq 'horizontal-ascender #"hasc" 61 | 'horizontal-descender #"hdsc" 62 | 'horizontal-line-gap #"hlgp" 63 | 'horizontal-clipping-ascent #"hcla" 64 | 'horizontal-clipping-descent #"hcld" 65 | 'vertical-ascender #"vasc" 66 | 'vertical-descender #"vdsc" 67 | 'vertical-line-gap #"vlgp" 68 | 'horizontal-caret-rise #"hcrs" 69 | 'horizontal-caret-run #"hcrn" 70 | 'horizontal-caret-offset #"hcof" 71 | 'vertical-caret-rise #"vcrs" 72 | 'vertical-caret-run #"vcrn" 73 | 'vertical-caret-offset #"vcof" 74 | 'x-height #"xhgt" 75 | 'cap-height #"cpht" 76 | 'subscript-em-x-size #"sbxs" 77 | 'subscript-em-y-size #"sbys" 78 | 'subscript-em-x-offset #"sbxo" 79 | 'subscript-em-y-offset #"sbyo" 80 | 'superscript-em-x-size #"spxs" 81 | 'superscript-em-y-size #"spys" 82 | 'superscript-em-x-offset #"spxo" 83 | 'superscript-em-y-offset #"spyo" 84 | 'strikeout-size #"strs" 85 | 'strikeout-offset #"stro" 86 | 'underline-size #"unds" 87 | 'underline-offset #"undo")) 88 | 89 | (define metrics-tag-sym-mapping 90 | (for/hasheq ([(sym str) (in-immutable-hash metrics-tag-sym-bytes-mapping)]) 91 | (values sym (cast str _hb_tag_t _uint32)))) 92 | 93 | (define metrics-tag-num-mapping 94 | (for/hasheqv ([(sym num) (in-immutable-hash metrics-tag-sym-mapping)]) 95 | (values num sym))) 96 | 97 | (define _hb_ot_metrics_tag_t 98 | (make-ctype 99 | _uint 100 | (λ (v) (hash-ref metrics-tag-sym-mapping v 101 | (λ () (raise-arguments-error '_hb_ot_metrics_tag_t "unknown Racket value" "value" v)))) 102 | (λ (v) (hash-ref metrics-tag-num-mapping v 103 | (λ () (raise-arguments-error '_hb_ot_metrics_tag_t "unknown C value" "value" v)))))) 104 | 105 | (define _hb_ot_math_constant_t 106 | (_enum '(script-percent-scale-down 107 | script-script-percent-scale-down 108 | delimited-sub-formula-min-height 109 | display-operator-min-height 110 | math-leading 111 | axis-height 112 | accent-base-height 113 | flattened-accent-base-height 114 | subscript-shift-down 115 | subscript-top-max 116 | subscript-baseline-drop-min 117 | superscript-shift-up 118 | superscript-shift-up-cramped 119 | superscript-bottom-min 120 | superscript-baseline-drop-max 121 | sub-superscript-gap-min 122 | superscript-bottom-max-with-subscript 123 | space-after-script 124 | upper-limit-gap-min 125 | upper-limit-baseline-rise-min 126 | lower-limit-gap-min 127 | lower-limit-baseline-drop-min 128 | stack-top-shift-up 129 | stack-top-display-style-shift-up 130 | stack-bottom-shift-down 131 | stack-bottom-display-style-shift-down 132 | stack-gap-min 133 | stack-display-style-gap-min 134 | stretch-stack-top-shift-up 135 | stretch-stack-bottom-shift-down 136 | stretch-stack-gap-above-min 137 | stretch-stack-gap-below-min 138 | fraction-numerator-shift-up 139 | fraction-numerator-display-style-shift-up 140 | fraction-denominator-shift-down 141 | fraction-denominator-display-style-shift-down 142 | fraction-numerator-gap-min 143 | fraction-num-display-style-gap-min 144 | fraction-rule-thickness 145 | fraction-denominator-gap-min 146 | fraction-denom-display-style-gap-min 147 | skewed-fraction-horizontal-gap 148 | skewed-fraction-vertical-gap 149 | overbar-vertical-gap 150 | overbar-rule-thickness 151 | overbar-extra-ascender 152 | underbar-vertical-gap 153 | underbar-rule-thickness 154 | underbar-extra-descender 155 | radical-vertical-gap 156 | radical-display-style-vertical-gap 157 | radical-rule-thickness 158 | radical-extra-ascender 159 | radical-kern-before-degree 160 | radical-kern-after-degree 161 | radical-degree-bottom-raise-percent))) 162 | 163 | (define _hb_ot_math_kern_t (_enum '(top-right 164 | top-left 165 | bottom-right 166 | bottom-left))) 167 | 168 | (define-cstruct _hb_feature_t 169 | ([tag* _hb_tag_t] 170 | [value _uint32] 171 | [start _uint] 172 | [end _uint])) 173 | 174 | (define-cstruct _hb_ot_math_kern_entry_t 175 | ([max-correction-height _hb_position_t] 176 | [kern-value _hb_position_t])) 177 | 178 | ;; ----------------------------------------------------------------------------- 179 | 180 | (define-ffi-definer define-harfbuzz (ffi-lib "libharfbuzz" '("0" #f))) 181 | 182 | (define-harfbuzz hb_version_string (_fun -> _string/utf-8)) 183 | 184 | ;; ----------------------------------------------------------------------------- 185 | ;; hb-font 186 | 187 | (define-harfbuzz hb_font_destroy (_fun _hb_font_t -> _void) 188 | #:wrap (releaser)) 189 | (define-harfbuzz hb_font_create (_fun _hb_face_t -> _hb_font_t) 190 | #:wrap (allocator hb_font_destroy)) 191 | (define-harfbuzz hb_font_reference (_fun [font : _hb_font_t] -> _hb_font_t -> font) 192 | #:wrap (retainer hb_font_destroy)) 193 | (define-harfbuzz hb_font_make_immutable (_fun _hb_font_t -> _void)) 194 | (define-harfbuzz hb_font_get_face (_fun _hb_font_t -> _hb_face_t)) 195 | 196 | (define-harfbuzz hb_font_get_nominal_glyph 197 | (_fun _hb_font_t 198 | _hb_codepoint_t/char 199 | [glyph : (_ptr o _hb_codepoint_t)] 200 | -> [found? : _bool] 201 | -> (and found? glyph))) 202 | 203 | (define-harfbuzz hb_font_get_ppem 204 | (_fun _hb_font_t 205 | [x : (_ptr o _uint)] 206 | [y : (_ptr o _uint)] 207 | -> _void 208 | -> (values x y))) 209 | 210 | (define-harfbuzz hb_font_get_scale 211 | (_fun _hb_font_t 212 | [x : (_ptr o _int)] 213 | [y : (_ptr o _int)] 214 | -> _void 215 | -> (values x y))) 216 | 217 | ;; ----------------------------------------------------------------------------- 218 | ;; hb-ot-metrics and hb-ot-math 219 | 220 | (define-harfbuzz hb_ot_metrics_get_position 221 | (_fun _hb_font_t 222 | _hb_ot_metrics_tag_t 223 | [pos : (_ptr o _hb_position_t)] 224 | -> [found? : _bool] 225 | -> (and found? pos))) 226 | 227 | (define-harfbuzz hb_ot_math_has_data (_fun _hb_face_t -> _bool)) 228 | (define-harfbuzz hb_ot_math_get_constant 229 | (_fun _hb_font_t _hb_ot_math_constant_t -> _hb_position_t)) 230 | (define-harfbuzz hb_ot_math_get_glyph_italics_correction 231 | (_fun _hb_font_t _hb_codepoint_t -> _hb_position_t)) 232 | 233 | (define-harfbuzz hb_ot_math_get_glyph_kernings 234 | (_fun #:retry (again [count 0]) 235 | _hb_font_t 236 | _hb_codepoint_t 237 | _hb_ot_math_kern_t 238 | [_uint = 0] 239 | [read-count : (_ptr io _uint) = count] 240 | [entries : (_cvector o _hb_ot_math_kern_entry_t count)] 241 | -> [kernings-count : _uint] 242 | -> (cond 243 | [(> kernings-count read-count) (again kernings-count)] 244 | [(zero? kernings-count) #f] 245 | [else entries])) 246 | #:fail (λ () #f)) 247 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/draw/unsafe/pango.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require ffi/unsafe 4 | ffi/unsafe/alloc 5 | ffi/unsafe/cvector 6 | ffi/unsafe/define 7 | racket/draw/unsafe/glib 8 | racket/draw/unsafe/pango 9 | racket/flonum 10 | (only-in "cairo.rkt" _cairo_scaled_font_t) 11 | (only-in "harfbuzz.rkt" _hb_font_t)) 12 | 13 | (provide (struct-out GSList) 14 | (struct-out PangoRectangle) 15 | (struct-out PangoGlyphInfo) 16 | (struct-out PangoGlyphString) PangoGlyphString-glyphs 17 | (struct-out PangoGlyphItem) 18 | (struct-out PangoLayoutLine) PangoLayoutLine-first-run PangoLayoutLine-last-run 19 | 20 | pango_version_string 21 | g_object_ref 22 | g_object_unref 23 | 24 | pango_language_from_string 25 | pango_language_get_default 26 | pango_language_to_string 27 | 28 | pango_font_description_new 29 | pango_font_description_free 30 | pango_font_description_get_family 31 | pango_font_description_get_set_fields 32 | pango_font_description_get_size 33 | pango_font_description_get_style 34 | pango_font_description_get_weight 35 | pango_font_description_set_absolute_size 36 | pango_font_description_set_family 37 | pango_font_description_set_style 38 | pango_font_description_set_weight 39 | 40 | pango_font_describe_with_absolute_size 41 | pango_font_get_hb_font 42 | pango_cairo_font_get_scaled_font 43 | 44 | pango_fontset_foreach 45 | 46 | pango_font_map_create_context 47 | pango_font_map_load_font 48 | pango_font_map_load_fontset 49 | pango_cairo_font_map_new 50 | pango_cairo_font_map_set_resolution 51 | 52 | pango_cairo_context_set_font_options 53 | pango_cairo_update_context 54 | 55 | pango_attr_fallback_new 56 | pango_attr_font_features_new 57 | 58 | pango_attr_list_new 59 | pango_attr_list_unref 60 | pango_attr_list_insert 61 | 62 | pango_layout_new 63 | pango_layout_get_line_readonly 64 | pango_layout_set_attributes 65 | pango_layout_set_font_description 66 | pango_layout_set_single_paragraph_mode 67 | pango_layout_set_text 68 | pango_cairo_show_layout 69 | 70 | pango_layout_line_get_extents 71 | pango_cairo_show_layout_line 72 | 73 | px->pango 74 | pango->px) 75 | 76 | ;; ----------------------------------------------------------------------------- 77 | ;; types 78 | 79 | (define _PangoGlyph _uint32) 80 | (define _PangoGlyphUnit _int32) 81 | 82 | (define-cpointer-type _PangoContext) 83 | (define-cpointer-type _PangoFont) 84 | (define-cpointer-type _PangoFontset) 85 | (define-cpointer-type _PangoFontDescription) 86 | (define-cpointer-type _PangoFontMap) 87 | (define-cpointer-type _PangoLanguage) 88 | (define-cpointer-type _PangoLayout) 89 | 90 | (define _PangoStyle 91 | (_enum '(normal 92 | oblique 93 | italic) 94 | #:unknown 'normal)) 95 | 96 | (define _PangoFontMask 97 | (_bitmask '(family 98 | style 99 | variant 100 | weight 101 | stretch 102 | size 103 | gravity 104 | variations))) 105 | 106 | (define-cstruct _GSList 107 | ([data _pointer] 108 | [next _GSList-pointer]) 109 | #:malloc-mode 'atomic-interior) 110 | 111 | (define-cstruct _PangoRectangle 112 | ([x _int] 113 | [y _int] 114 | [width _int] 115 | [height _int]) 116 | #:malloc-mode 'atomic-interior) 117 | 118 | (define-cstruct _PangoAnalysis 119 | ([shape-engine _pointer] 120 | [lang-engine _pointer] 121 | [font _PangoFont] 122 | [level _uint8] 123 | [gravity _uint8] 124 | [flags _uint8] 125 | [script _uint8] 126 | [language _PangoLanguage] 127 | [extra-attrs _GSList-pointer/null]) 128 | #:malloc-mode 'atomic-interior) 129 | 130 | (define-cstruct _PangoItem 131 | ([offset _int] 132 | [length _int] 133 | [num-chars _int] 134 | [analysis _PangoAnalysis]) 135 | #:malloc-mode 'atomic-interior) 136 | 137 | (define-cstruct _PangoGlyphGeometry 138 | ([width _PangoGlyphUnit] 139 | [x-offset _PangoGlyphUnit] 140 | [y-offset _PangoGlyphUnit]) 141 | #:malloc-mode 'atomic-interior) 142 | 143 | (define-cstruct _PangoGlyphVisAttr 144 | ([flags _uint]) 145 | #:malloc-mode 'atomic-interior) 146 | 147 | (define-cstruct _PangoGlyphInfo 148 | ([glyph _PangoGlyph] 149 | [geometry _PangoGlyphGeometry] 150 | [attr _PangoGlyphVisAttr]) 151 | #:malloc-mode 'atomic-interior) 152 | 153 | (define-cstruct _PangoGlyphString 154 | ([num-glyphs _int] 155 | [glyphs-pointer _PangoGlyphInfo-pointer] 156 | [log-clusters _pointer]) 157 | #:malloc-mode 'atomic-interior) 158 | 159 | (define (PangoGlyphString-glyphs pgs) 160 | (make-cvector* (PangoGlyphString-glyphs-pointer pgs) 161 | _PangoGlyphInfo 162 | (PangoGlyphString-num-glyphs pgs))) 163 | 164 | (define-cstruct _PangoGlyphItem 165 | ([item _PangoItem-pointer] 166 | [glyphs _PangoGlyphString-pointer] 167 | [y-offset _int] 168 | [start-x-offset _int] 169 | [end-x-offset _int]) 170 | #:malloc-mode 'atomic-interior) 171 | 172 | (define-cstruct _PangoLayoutLine 173 | ([layout _PangoLayout] 174 | [start-index _int] 175 | [length _int] 176 | [runs _GSList-pointer/null] 177 | [flags _uint]) 178 | #:malloc-mode 'atomic-interior) 179 | 180 | (define (PangoLayoutLine-first-run pll) 181 | (and (PangoLayoutLine-runs pll) 182 | (cast (GSList-data (PangoLayoutLine-runs pll)) 183 | _pointer 184 | _PangoGlyphItem-pointer))) 185 | 186 | (define (PangoLayoutLine-last-run pll) 187 | (and (PangoLayoutLine-runs pll) 188 | (cast (GSList-data (g_slist_last (PangoLayoutLine-runs pll))) 189 | _pointer 190 | _PangoGlyphItem-pointer))) 191 | 192 | ;; ----------------------------------------------------------------------------- 193 | 194 | (define-glib g_slist_last (_fun _GSList-pointer/null -> _GSList-pointer/null)) 195 | (define-gobj g_object_ref (_fun [object : _pointer] -> _pointer -> object) 196 | #:wrap (retainer g_object_unref)) 197 | 198 | ;; ----------------------------------------------------------------------------- 199 | 200 | (define-ffi-definer define-pango pango-lib) 201 | (define-ffi-definer define-pangocairo pangocairo-lib) 202 | 203 | (define-pango pango_version_string (_fun -> _string/utf-8)) 204 | 205 | (define-pango pango_language_from_string (_fun _string/utf-8 -> _PangoLanguage)) 206 | (define-pango pango_language_to_string (_fun _PangoLanguage -> _string/utf-8)) 207 | 208 | (define-pango pango_font_description_get_family (_fun _PangoFontDescription -> _string/utf-8)) 209 | (define-pango pango_font_description_get_set_fields (_fun _PangoFontDescription -> _PangoFontMask)) 210 | (define-pango pango_font_description_get_size (_fun _PangoFontDescription -> _int)) 211 | (define-pango pango_font_description_get_style (_fun _PangoFontDescription -> _PangoStyle)) 212 | (define-pango pango_font_description_get_weight (_fun _PangoFontDescription -> _int)) 213 | (define-pango pango_font_description_set_style (_fun _PangoFontDescription _PangoStyle -> _void)) 214 | 215 | (define-pango pango_font_describe_with_absolute_size (_fun _PangoFont -> _PangoFontDescription) 216 | #:wrap (allocator pango_font_description_free)) 217 | (define-pango pango_font_get_hb_font (_fun _PangoFont -> _hb_font_t)) 218 | (define-pangocairo pango_cairo_font_get_scaled_font (_fun _PangoFont -> _cairo_scaled_font_t)) 219 | 220 | (define-pango pango_fontset_foreach 221 | (_fun [fontset : _PangoFontset] 222 | (_cprocedure (list _PangoFontset _PangoFont _pointer) _bool 223 | #:keep #f 224 | #:atomic? #t 225 | #:wrapper (λ (proc) (λ (fontset font ptr) (proc font)))) 226 | [_pointer = #f] 227 | -> _void 228 | -> (void/reference-sink fontset))) 229 | 230 | (define-pango pango_font_map_load_fontset 231 | (_fun _PangoFontMap 232 | _PangoContext 233 | _PangoFontDescription 234 | _PangoLanguage 235 | -> _PangoFontset/null) 236 | #:wrap (allocator g_object_unref)) 237 | (define-pangocairo pango_cairo_font_map_set_resolution (_fun _PangoFontMap _double -> _void)) 238 | 239 | (define-pango pango_layout_set_single_paragraph_mode (_fun _PangoLayout _bool -> _void)) 240 | (define-pango pango_layout_line_get_extents 241 | (_fun _PangoLayoutLine-pointer 242 | [ink : (_ptr o _PangoRectangle atomic-interior)] 243 | [logical : (_ptr o _PangoRectangle atomic-interior)] 244 | -> _void 245 | -> (values ink logical))) 246 | 247 | (define PANGO_SCALE.0 (->fl PANGO_SCALE)) 248 | 249 | (define (px->pango v) 250 | (* v PANGO_SCALE.0)) 251 | (define (pango->px v) 252 | (fl/ (->fl v) PANGO_SCALE.0)) 253 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/mpict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base) 4 | (only-in pict 5 | current-expected-text-scale 6 | dc-for-text-size 7 | make-pict-drawer 8 | pict? 9 | pict-width 10 | pict-height 11 | pict-ascent 12 | pict-descent) 13 | (prefix-in p: pict) 14 | pict/convert 15 | racket/contract 16 | racket/class 17 | (only-in racket/draw 18 | dc-path% 19 | make-brush 20 | make-color 21 | make-pen) 22 | racket/match 23 | syntax/parse/define 24 | threading 25 | 26 | "draw/font.rkt" 27 | "draw/text.rkt" 28 | "util/case-kw.rkt") 29 | 30 | ;; ----------------------------------------------------------------------------- 31 | 32 | (provide (contract-out 33 | [mpict? predicate/c] 34 | [mpict-width (-> mpict? real?)] 35 | [mpict-height (-> mpict? real?)] 36 | [mpict-ascent (-> mpict? real?)] 37 | [mpict-descent (-> mpict? real?)] 38 | [mpict-italic-correction (-> mpict? real?)] 39 | [mpict-script-kerns (-> mpict? math-script-kerns?)] 40 | 41 | [pict->mpict (-> pict? mpict?)] 42 | 43 | [blank (case-kw-> 44 | (->* [] [real? real? real?] mpict?) 45 | (->* [#:h real?] [#:w real?] mpict?) 46 | (->* [] [#:w real? #:a real? #:d real?] mpict?))] 47 | [inset (case-kw-> 48 | (->* [mpict? real?] [real?] mpict?) 49 | (->* [mpict?] [#:h real? #:v real?] mpict?) 50 | (->* [mpict?] [#:l real? #:r real? #:t real? #:b real?] mpict?))] 51 | [apply-italic-correction (-> mpict? mpict?)] 52 | 53 | [scale (->* [mpict? real?] [real?] mpict?)] 54 | 55 | [hbl-append (-> mpict? ... mpict?)] 56 | [lbl-superimpose (-> mpict? ... mpict?)] 57 | [pin-over (->* [mpict? mpict?] [#:x real? #:y real?] mpict?)] 58 | [pin-under (->* [mpict? mpict?] [#:x real? #:y real?] mpict?)] 59 | 60 | [text (->* [string? 61 | #:font font?] 62 | [#:math-depth math-script-depth?] 63 | mpict?)] 64 | [scripts (->* [mpict? 65 | #:metrics math-script-metrics?] 66 | [#:sup (or/c mpict? #f) 67 | #:sub (or/c mpict? #f) 68 | #:cramped? any/c 69 | #:use-baseline-drop? any/c] 70 | mpict?)] 71 | [explain (-> mpict? mpict?)])) 72 | 73 | ;; ----------------------------------------------------------------------------- 74 | 75 | (struct mpict 76 | (draw 77 | width 78 | ascent 79 | descent 80 | italic-correction 81 | script-kerns) 82 | #:property prop:pict-convertible 83 | (λ (self) 84 | (p:dc (make-mpict-drawer self) 85 | (mpict-width self) 86 | (mpict-height self) 87 | (mpict-ascent self) 88 | (mpict-descent self)))) 89 | 90 | (define (mpict-height p) 91 | (+ (mpict-ascent p) 92 | (mpict-descent p))) 93 | 94 | (define (make-mpict #:draw draw 95 | #:width width 96 | #:ascent ascent 97 | #:descent [descent 0] 98 | #:italic-correction [italic-correction 0] 99 | #:script-kerns [script-kerns no-math-script-kerns]) 100 | (mpict draw width ascent descent italic-correction script-kerns)) 101 | 102 | (define (copy-mpict p 103 | #:draw [draw (mpict-draw p)] 104 | #:width [width (mpict-width p)] 105 | #:ascent [ascent (mpict-ascent p)] 106 | #:descent [descent (mpict-descent p)] 107 | #:italic-correction [italic-correction (mpict-italic-correction p)] 108 | #:script-kerns [script-kerns (mpict-script-kerns p)]) 109 | (mpict draw width ascent descent italic-correction script-kerns)) 110 | 111 | ;; ----------------------------------------------------------------------------- 112 | 113 | (define (pict->mpict p) 114 | (make-mpict #:draw (make-pict-drawer p) 115 | #:width (pict-width p) 116 | #:ascent (- (pict-height p) 117 | (pict-descent p)) 118 | #:descent (pict-descent p))) 119 | 120 | (define (draw-mpict p dc [x 0] [y 0]) 121 | ((mpict-draw p) dc x y)) 122 | 123 | (define (make-mpict-drawer p) 124 | (λ (dc [x 0] [y 0]) 125 | (draw-mpict p dc x y))) 126 | 127 | (define blank 128 | (case-kw-lambda 129 | [([w 0] [a w] [d 0]) (blank #:w w #:a a #:d d)] 130 | [(#:w [w 0] #:h h) (blank #:w w #:a h)] 131 | [(#:w [w 0] #:a [a 0] #:d [d 0]) 132 | (make-mpict #:width w 133 | #:ascent a 134 | #:descent d 135 | #:draw void)])) 136 | 137 | (define inset 138 | (case-kw-lambda 139 | [(p h [v h]) (inset p #:h h #:v v)] 140 | [(p #:h [h 0] #:v [v 0]) (inset p #:l h #:r h #:t v #:b v)] 141 | [(p #:l [l 0] #:r [r 0] #:t [t 0] #:b [b 0]) 142 | (define draw (make-mpict-drawer p)) 143 | (copy-mpict 144 | p 145 | #:width (+ (mpict-width p) l r) 146 | #:ascent (+ (mpict-ascent p) t) 147 | #:descent (+ (mpict-descent p) b) 148 | ;; TODO: is discarding the italic correction and script-kerns right? 149 | #:italic-correction 0 150 | #:script-kerns no-math-script-kerns 151 | #:draw (λ (dc x y) (draw dc (+ x l) (+ y t))))])) 152 | 153 | (define (translate p #:x [dx 0] #:y [dy 0] #:extend-bb? [extend-bb? #f]) 154 | (cond 155 | [(and (zero? dx) (zero? dy)) p] 156 | [else 157 | (define draw (make-mpict-drawer p)) 158 | (if extend-bb? 159 | (copy-mpict 160 | p 161 | #:width (+ (mpict-width p) (abs dx)) 162 | #:ascent (+ (mpict-ascent p) (if (negative? dy) (- dy) 0)) 163 | #:descent (+ (mpict-descent p) (if (positive? dy) dy 0)) 164 | ;; TODO: is discarding the italic correction and script-kerns right? 165 | #:italic-correction 0 166 | #:script-kerns no-math-script-kerns 167 | #:draw 168 | (let ([dx* (max 0 dx)] 169 | [dy* (max 0 dy)]) 170 | (λ (dc x y) (draw dc (+ x dx*) (+ y dy*))))) 171 | (copy-mpict 172 | p 173 | #:script-kerns (and (mpict-script-kerns p) 174 | (error 'translate "TODO script-kerns")) 175 | #:draw (λ (dc x y) (draw dc (+ x dx) (+ y dy)))))])) 176 | 177 | (define (set-italic-correction p ic) 178 | (copy-mpict p #:italic-correction ic)) 179 | 180 | (define (apply-italic-correction p) 181 | (copy-mpict p 182 | #:width (+ (mpict-width p) (mpict-italic-correction p)) 183 | #:italic-correction 0 184 | #:script-kerns (copy-math-script-kerns (mpict-script-kerns p) 185 | #:top-right #f 186 | #:bottom-right #f))) 187 | 188 | (define (scale p x-fac [y-fac x-fac]) 189 | (define draw (make-mpict-drawer p)) 190 | (make-mpict 191 | #:width (* (mpict-width p) x-fac) 192 | #:ascent (* (mpict-ascent p) y-fac) 193 | #:descent (* (mpict-descent p) y-fac) 194 | #:italic-correction (* (mpict-italic-correction p) x-fac) 195 | #:script-kerns (scale-math-script-kerns (mpict-script-kerns p) x-fac y-fac) 196 | #:draw 197 | (λ (dc x y) 198 | (define t (send dc get-transformation)) 199 | (send dc scale x-fac y-fac) 200 | (draw dc (/ x x-fac) (/ y y-fac)) 201 | (send dc set-transformation t)))) 202 | 203 | (define-simple-macro (scale/improve-new-text p {~or* fac-e {~seq x-fac-e y-fac-e}}) 204 | #:declare p (expr/c #'mpict? #:name "mpict argument") 205 | #:declare fac-e (expr/c #'real? #:name "scale argument") 206 | #:declare x-fac-e (expr/c #'real? #:name "x scale argument") 207 | #:declare y-fac-e (expr/c #'real? #:name "y scale argument") 208 | (let* ([x-fac {~? x-fac-e.c fac-e.c}] 209 | [y-fac {~? y-fac-e.c x-fac}] 210 | [old-scale (current-expected-text-scale)]) 211 | (parameterize ([current-expected-text-scale 212 | (list (* x-fac (car old-scale)) 213 | (* y-fac (cadr old-scale)))]) 214 | (scale p.c x-fac y-fac)))) 215 | 216 | (define (hbl-append . ps) 217 | (match ps 218 | ['() (blank)] 219 | [(cons p ps) 220 | (for/fold ([p1 p]) 221 | ([p2 (in-list ps)]) 222 | (define p1.w (mpict-width p1)) 223 | (define p1.a (mpict-ascent p1)) 224 | (define p1.d (mpict-descent p1)) 225 | (define p1.draw (make-mpict-drawer p1)) 226 | 227 | (define p2.w (mpict-width p2)) 228 | (define p2.a (mpict-ascent p2)) 229 | (define p2.d (mpict-descent p2)) 230 | (define p2.draw (make-mpict-drawer p2)) 231 | 232 | (define-values [p1.dy p2.dy] (if (< p1.a p2.a) 233 | (values (- p2.a p1.a) 0) 234 | (values 0 (- p1.a p2.a)))) 235 | (make-mpict 236 | #:width (+ p1.w p2.w) 237 | #:ascent (max p1.a p2.a) 238 | #:descent (max p1.d p2.d) 239 | #:italic-correction (mpict-italic-correction p2) 240 | #:script-kerns (h-append-math-script-kerns (mpict-script-kerns p1) (mpict-script-kerns p2)) 241 | #:draw 242 | (λ (dc x y) 243 | (p1.draw dc x (+ y p1.dy)) 244 | (p2.draw dc (+ x p1.w) (+ y p2.dy)))))])) 245 | 246 | (define (lbl-superimpose . ps) 247 | (match ps 248 | ['() (blank)] 249 | [(cons p ps) 250 | (for/fold ([p1 p]) 251 | ([p2 (in-list ps)]) 252 | (define p1.w (mpict-width p1)) 253 | (define p1.a (mpict-ascent p1)) 254 | (define p1.draw (make-mpict-drawer p1)) 255 | 256 | (define p2.w (mpict-width p2)) 257 | (define p2.a (mpict-ascent p2)) 258 | (define p2.draw (make-mpict-drawer p2)) 259 | 260 | (define w (max p1.w p2.w)) 261 | (define-values [p1.dy p2.dy] (if (< p1.a p2.a) 262 | (values (- p2.a p1.a) 0) 263 | (values 0 (- p1.a p2.a)))) 264 | (make-mpict 265 | #:width w 266 | #:ascent (max p1.a p2.a) 267 | #:descent (max (mpict-descent p1) (mpict-descent p2)) 268 | #:italic-correction (- (max (+ p1.w (mpict-italic-correction p1)) 269 | (+ p2.w (mpict-italic-correction p2))) 270 | w) 271 | ;; FIXME: Should use lub of script-kern values. 272 | #:script-kerns no-math-script-kerns 273 | #:draw 274 | (λ (dc x y) 275 | (p1.draw dc x (+ y p1.dy)) 276 | (p2.draw dc x (+ y p2.dy)))))])) 277 | 278 | (define (pin-over base p #:x [dx 0] #:y [dy 0]) 279 | (define base.draw (make-mpict-drawer base)) 280 | (define p.draw (make-mpict-drawer p)) 281 | (copy-mpict base 282 | #:draw (λ (dc x y) 283 | (base.draw dc x y) 284 | (p.draw dc x y)))) 285 | 286 | (define (pin-under base p #:x [dx 0] #:y [dy 0]) 287 | (define base.draw (make-mpict-drawer base)) 288 | (define p.draw (make-mpict-drawer p)) 289 | (copy-mpict base 290 | #:draw (λ (dc x y) 291 | (p.draw dc x y) 292 | (base.draw dc x y)))) 293 | 294 | (define (scripts nucleus #:sup [sup #f] #:sub [sub #f] 295 | #:metrics metrics 296 | #:cramped? [cramped? #f] 297 | #:use-baseline-drop? [use-baseline-drop? #t]) 298 | (cond 299 | [(and (not sup) (not sub)) nucleus] 300 | [else 301 | (define space-after (math-script-metrics-space-after metrics)) 302 | 303 | ; Computes a tentative amount to shift a superscript up, before resolving 304 | ; any superscript/subscript collisions. 305 | (define (get-base-shift-up) 306 | (max 307 | ; We start with a minimum shift specified by the font. 308 | (if cramped? 309 | (math-script-metrics-sup-shift-up-cramped metrics) 310 | (math-script-metrics-sup-shift-up metrics)) 311 | 312 | ; Next, we ensure that the bottom of the superscript’s descent is lifted 313 | ; above a font-specified minimum. That is, if a superscript descends far 314 | ; enough below its baseline, we may want to shift it up further. 315 | (+ (mpict-descent sup) 316 | (math-script-metrics-sup-bottom-min metrics)) 317 | 318 | ; Finally, we ensure the superscript’s baseline is not dropped further 319 | ; from the top of the nucleus than a font-specified maximum. This makes 320 | ; sure that if the nucleus is sufficiently tall, we shift the 321 | ; superscript up even more than usual so it’s attached to its upper 322 | ; right corner rather than somewhere in the middle. 323 | ; 324 | ; This rule should only be applied conditionally: in TeX, it only 325 | ; applies when the nucleus is a box rather than an individual character. 326 | ; We don’t distinguish between boxes and characters in the same way, so 327 | ; the choice of whether or not to apply this rule is deferred to higher- 328 | ; level logic. 329 | (if use-baseline-drop? 330 | (- (mpict-ascent nucleus) 331 | (math-script-metrics-sup-baseline-drop-max metrics)) 332 | 0))) 333 | 334 | ; Computes a tentative amount to shift a subscript down, before resolving 335 | ; any superscript/subscript collisions. 336 | (define (get-base-shift-down) 337 | (max 338 | ; As with a superscript, we start with a minimum drop specified by the 339 | ; font. However, we don’t make any distinction based on whether the 340 | ; context is “cramped” or not, because in TeX, subscripts are *always* 341 | ; considered cramped, and OpenType Math copied that decision. 342 | (math-script-metrics-sub-shift-down metrics) 343 | 344 | ; Next, we ensure that the top of the subscript’s ascent is dropped 345 | ; below a font-specified maximum, dual to the superscript case. 346 | (- (mpict-ascent sub) 347 | (math-script-metrics-sub-top-max metrics)) 348 | 349 | ; Finally, we ensure the subscript’s baseline is dropped sufficiently 350 | ; close to the bottom of the nucleus according to a font-specified 351 | ; minimum, also dual to the superscript case. 352 | (if use-baseline-drop? 353 | (- (mpict-descent nucleus) 354 | (math-script-metrics-sub-baseline-drop-min metrics)) 355 | 0))) 356 | 357 | (define (shifted-sup shift-up) 358 | (define nucleus-script-kern (math-script-kerns-top-right (mpict-script-kerns nucleus))) 359 | (define sup-script-kern (math-script-kerns-bottom-left (mpict-script-kerns sup))) 360 | (define kern (min (+ (math-script-kern-value nucleus-script-kern (mpict-ascent nucleus)) 361 | (math-script-kern-value sup-script-kern (- (mpict-ascent nucleus) shift-up))) 362 | (+ (math-script-kern-value nucleus-script-kern (- shift-up (mpict-descent sup))) 363 | (math-script-kern-value sup-script-kern (mpict-descent sup))))) 364 | (~> (set-italic-correction sup 0) 365 | (inset #:l (+ (mpict-italic-correction nucleus) kern) 366 | #:r space-after) 367 | (translate #:y (- shift-up) #:extend-bb? #t))) 368 | 369 | (define (shifted-sub shift-down) 370 | (define nucleus-script-kern (math-script-kerns-bottom-right (mpict-script-kerns nucleus))) 371 | (define sub-script-kern (math-script-kerns-top-left (mpict-script-kerns sub))) 372 | (define kern (min (+ (math-script-kern-value nucleus-script-kern (mpict-descent nucleus)) 373 | (math-script-kern-value sub-script-kern (- (mpict-descent nucleus) shift-down))) 374 | (+ (math-script-kern-value nucleus-script-kern (- shift-down (mpict-ascent sub))) 375 | (math-script-kern-value sub-script-kern (mpict-ascent sub))))) 376 | (~> (set-italic-correction sub 0) 377 | (inset #:l kern #:r space-after) 378 | (translate #:y shift-down #:extend-bb? #t))) 379 | 380 | (cond 381 | ; In the simplest case of a superscript but no subscript, just shift it 382 | ; up the needed amount and attach it. 383 | [(not sub) 384 | (hbl-append nucleus (shifted-sup (get-base-shift-up)))] 385 | 386 | ; If we have a subscript but no superscript, the situation is not much 387 | ; more complex, but we want to preserve any portion of the italic 388 | ; correction that extends beyond the placed subscript (unlikely as it is 389 | ; that there will ever be any at all). 390 | [(not sup) 391 | (~> (hbl-append nucleus (shifted-sub (get-base-shift-down))) 392 | (set-italic-correction (max 0 (- (mpict-italic-correction nucleus) 393 | (mpict-width sub)))))] 394 | 395 | ; If we have both a superscript and a subscript, we have significantly 396 | ; more work to do, as we must ensure they do not visually collide. 397 | [else 398 | (define gap-min (math-script-metrics-sub-sup-gap-min metrics)) 399 | (define base-shift-up (get-base-shift-up)) 400 | (define base-shift-down (get-base-shift-down)) 401 | 402 | ; When we have both a superscript and a subscript, we need to ensure 403 | ; they are placed sufficiently far apart so they don’t visually collide. 404 | ; To start, we compute the current gap between the bottom the 405 | ; superscript’s descent and top of the subscript’s ascent given our 406 | ; tentative placement locations. 407 | (define base-sup-bottom (- base-shift-up (mpict-descent sup))) 408 | (define base-sub-top (- (mpict-ascent sub) base-shift-down)) 409 | (define base-gap (- base-sup-bottom base-sub-top)) 410 | (define-values [shift-up shift-down] 411 | (cond 412 | ; Now we check whether the gap between them is larger than a 413 | ; font-specified minimum. 414 | [(>= base-gap gap-min) 415 | ; If it is, we’re fine, and we can just use the tentative locations. 416 | (values base-shift-up base-shift-down)] 417 | [else 418 | ; Otherwise, we have a collision. To resolve it, we start by trying 419 | ; to shift the superscript up. In the case of a collision, we’re 420 | ; allowed to move the bottom of the superscript up to a 421 | ; font-specified height. 422 | (define needed-extra-gap (- gap-min base-gap)) 423 | (define allowed-extra-shift-up (max 0 (- (math-script-metrics-sup-bottom-max-with-sub metrics) 424 | base-sup-bottom))) 425 | (cond 426 | ; If this extra allowed shift is enough to reach the minimum gap 427 | ; size, we just shift the superscript up the minimum amount we 428 | ; need. 429 | [(>= allowed-extra-shift-up needed-extra-gap) 430 | (values (+ base-shift-up needed-extra-gap) base-shift-down)] 431 | [else 432 | ; Otherwise, we shift the superscript up by the maximum allowed 433 | ; amount (if any) and shift the subscript down the rest of the 434 | ; needed amount. 435 | (values (+ base-shift-up allowed-extra-shift-up) 436 | (+ base-shift-down (- needed-extra-gap allowed-extra-shift-up)))])])) 437 | 438 | (hbl-append nucleus (lbl-superimpose (shifted-sup shift-up) 439 | (shifted-sub shift-down)))])])) 440 | 441 | (define (text str 442 | #:font font 443 | #:math-depth [math-depth 0]) 444 | (define dc (dc-for-text-size)) 445 | (unless dc 446 | (raise-arguments-error 'glyph "no dc<%> object installed for sizing")) 447 | 448 | (define features (if (zero? math-depth) 449 | (hash) 450 | (hash "ssty" (min math-depth 2)))) 451 | (define le (measure-text-line dc font str #:features features)) 452 | (define a (max 0 (line-extents-ink-ascent le))) 453 | (make-mpict 454 | #:width (line-extents-advance-width le) 455 | #:ascent a 456 | #:descent (max 0 (line-extents-ink-descent le)) 457 | #:italic-correction (line-extents-italic-correction le) 458 | #:script-kerns (line-extents-math-script-kerns le) 459 | #:draw 460 | (λ (dc x y) 461 | (draw-text-line dc font str #:x x #:y (+ y a) #:features features)))) 462 | 463 | (define (glyph c #:font font #:math-depth [math-depth 0]) 464 | (text (string c) #:font font #:math-depth math-depth)) 465 | 466 | (define (explain p) 467 | (define draw (make-mpict-drawer p)) 468 | (define w (mpict-width p)) 469 | (define a (mpict-ascent p)) 470 | (define d (mpict-descent p)) 471 | (define ic (mpict-italic-correction p)) 472 | 473 | (define (script-kern-path ci tb lr) 474 | (define correction-heights (math-script-kern-correction-heights ci)) 475 | (define kern-values (math-script-kern-kern-values ci)) 476 | 477 | (define num-heights (vector-length correction-heights)) 478 | (define first-kern (vector-ref kern-values 0)) 479 | (define last-kern (vector-ref kern-values num-heights)) 480 | 481 | (define-values [max-y min-y] 482 | (if (zero? num-heights) 483 | (values (+ a d) 0) 484 | (values (max (+ a d) (vector-ref correction-heights 0)) 485 | (min 0 (vector-ref correction-heights (sub1 num-heights)))))) 486 | 487 | (define (kern->x k) 488 | (match* {lr tb} 489 | [{'left _} (- k)] 490 | [{'right 'top} (+ w ic k)] 491 | [{'right 'bottom} (+ w k)])) 492 | (define (height->y h) 493 | (- a h)) 494 | 495 | (define path (new dc-path%)) 496 | (send path move-to (kern->x 0) max-y) 497 | (send path line-to (kern->x first-kern) max-y) 498 | 499 | (for ([h (in-vector correction-heights)] 500 | [k1 (in-vector kern-values)] 501 | [k2 (in-vector kern-values 1)]) 502 | (send path line-to (kern->x k1) (height->y h)) 503 | (send path line-to (kern->x k2) (height->y h))) 504 | 505 | (send path line-to (kern->x last-kern) min-y) 506 | (send path line-to (kern->x 0) min-y) 507 | (send path close) 508 | path) 509 | 510 | (define cis (mpict-script-kerns p)) 511 | (define-values [tl tr bl br] 512 | (values (and~> (math-script-kerns-top-left cis) (script-kern-path 'top 'left)) 513 | (and~> (math-script-kerns-top-right cis) (script-kern-path 'top 'right)) 514 | (and~> (math-script-kerns-bottom-left cis) (script-kern-path 'bottom 'left)) 515 | (and~> (math-script-kerns-bottom-right cis) (script-kern-path 'bottom 'right)))) 516 | 517 | (copy-mpict 518 | p 519 | #:draw 520 | (λ (dc x y) 521 | (draw dc x y) 522 | 523 | (define old-pen (send dc get-pen)) 524 | (define old-brush (send dc get-brush)) 525 | (define old-alpha (send dc get-alpha)) 526 | 527 | (send dc set-alpha 0.25) 528 | 529 | (when (any-math-script-kerns? cis) 530 | (send dc set-pen (make-pen #:style 'transparent)) 531 | (define (draw-script-kern path color) 532 | (send dc set-brush (make-brush #:color color)) 533 | (send dc draw-path path x y)) 534 | (when tl (draw-script-kern tl (make-color 255 255 0))) 535 | (when tr (draw-script-kern tr (make-color 255 0 0))) 536 | (when bl (draw-script-kern bl (make-color 0 255 0))) 537 | (when br (draw-script-kern br (make-color 0 0 255)))) 538 | 539 | (send dc set-alpha 0.7) 540 | 541 | (send dc set-brush (make-brush #:style 'transparent)) 542 | 543 | (send dc set-pen (make-pen #:color "light blue" 544 | #:width 1)) 545 | (send dc draw-rectangle x y w (+ a d)) 546 | 547 | (send dc set-pen (make-pen #:color "light blue" 548 | #:width 1 549 | #:style 'long-dash)) 550 | (send dc draw-line x (+ y a) (+ x w) (+ y a)) 551 | (send dc draw-line (+ x w ic) y (+ x w ic) (+ y a d)) 552 | 553 | (send dc set-pen old-pen) 554 | (send dc set-brush old-brush) 555 | (send dc set-alpha old-alpha)))) 556 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/size.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/match 4 | racket/contract 5 | racket/fixnum 6 | threading 7 | "util/print.rkt") 8 | 9 | (provide (contract-out 10 | ;; size 11 | [size? predicate/c] 12 | [absolute-size? predicate/c] 13 | [font-relative-size? predicate/c] 14 | [size-ems (-> size? rational?)] 15 | [size-pxs (-> size? absolute-size?)] 16 | [ems (-> rational? size?)] 17 | 18 | [size-zero? (-> size? boolean?)] 19 | [size= (-> size? size? boolean?)] 20 | [size+ (-> size? ... size?)] 21 | [size- (-> size? size? ... size?)] 22 | [size* (-> size? rational? ... size?)] 23 | [make-size-absolute (-> size? 24 | #:ppem absolute-size? 25 | absolute-size?)] 26 | 27 | ;; flexibility 28 | [flexibility? flat-contract?] 29 | [infinite-flexibility? predicate/c] 30 | [infinite-flexibility-cardinality? predicate/c] 31 | [infinite-flexibility-weight (-> infinite-flexibility? (and/c rational? positive?))] 32 | [infinite-flexibility-cardinality (-> infinite-flexibility? infinite-flexibility-cardinality?)] 33 | 34 | [fi (->* [] [(and/c rational? (not/c negative?))] flexibility?)] 35 | [fil (->* [] [(and/c rational? (not/c negative?))] flexibility?)] 36 | [fill (->* [] [(and/c rational? (not/c negative?)) infinite-flexibility-cardinality?] flexibility?)] 37 | [filll (->* [] [(and/c rational? (not/c negative?))] flexibility?)] 38 | 39 | [flexibility-zero? (-> flexibility? boolean?)] 40 | [flexibility= (-> flexibility? flexibility? boolean?)] 41 | [flexibility+ (-> flexibility? ... flexibility?)] 42 | [flexibility* (-> flexibility? (and/c rational? (not/c negative?)) ... flexibility?)] 43 | 44 | ;; flexible size 45 | [flexible-size? predicate/c] 46 | [flexible-size-basis (-> flexible-size? size?)] 47 | [flexible-size-grow (-> flexible-size? flexibility?)] 48 | [flexible-size-shrink (-> flexible-size? flexibility?)] 49 | [flex (->* [flexible-size?] 50 | [#:grow flexibility? 51 | #:shrink flexibility?] 52 | flexible-size?)] 53 | 54 | [flexible-size-zero? (-> flexible-size? boolean?)] 55 | [flexible-size= (-> flexible-size? flexible-size? boolean?)] 56 | [flexible-size+ (-> flexible-size? ... flexible-size?)] 57 | [flexible-size* (-> flexible-size? (and/c rational? (not/c negative?)) ... flexible-size?)] 58 | [make-flexible-size-absolute (-> flexible-size? 59 | #:ppem (and/c absolute-size? (not/c negative?)) 60 | absolute-size?)])) 61 | 62 | ;; ----------------------------------------------------------------------------- 63 | ;; rational arithmetic 64 | 65 | (define (check-overflow who n) 66 | (cond 67 | [(eqv? n +inf.0) (raise-arguments-error who "flonum positive overflow")] 68 | [(eqv? n -inf.0) (raise-arguments-error who "flonum negative overflow")] 69 | [else n])) 70 | 71 | (define (rational+ who a b) (check-overflow who (+ a b))) 72 | (define (rational* who a b) (check-overflow who (* a b))) 73 | 74 | ;; ----------------------------------------------------------------------------- 75 | ;; fixed size 76 | 77 | (define (size? v) 78 | (or (absolute-size? v) 79 | (font-relative-size? v))) 80 | 81 | (define (absolute-size? v) 82 | (rational? v)) 83 | 84 | (struct font-relative-size (ems pxs) 85 | #:property prop:equal+hash 86 | (let () 87 | (define (=? a b recur) 88 | (and (recur (font-relative-size-ems a) (font-relative-size-ems b)) 89 | (recur (font-relative-size-pxs a) (font-relative-size-pxs b)))) 90 | (define (hash self recur) 91 | (recur (cons (font-relative-size-ems self) 92 | (font-relative-size-pxs self)))) 93 | (list =? hash hash)) 94 | #:property prop:custom-write 95 | (λ (self out mode) 96 | (match self 97 | [(font-relative-size ems (? zero?)) 98 | #:when (eq? mode 0) 99 | (print (quasiexpr (ems ,ems)) out)] 100 | [_ 101 | (write-string "#" out)]))) 104 | 105 | (define (write-size-expression s out) 106 | (match s 107 | [(font-relative-size ems pxs) 108 | (if (zero? pxs) 109 | (fprintf out "~aem" ems) 110 | (fprintf out 111 | "~aem ~a ~apx" 112 | ems 113 | (if (positive? pxs) "+" "-") 114 | (abs pxs)))] 115 | [0 116 | (write-string "0" out)] 117 | [pxs 118 | (fprintf out "~apx" pxs)])) 119 | 120 | (define (make-size ems pxs) 121 | (if (zero? ems) 122 | pxs 123 | (font-relative-size ems pxs))) 124 | 125 | (define (size-pxs v) 126 | (if (font-relative-size? v) 127 | (font-relative-size-pxs v) 128 | v)) 129 | 130 | (define (size-ems v) 131 | (if (font-relative-size? v) 132 | (font-relative-size-ems v) 133 | 0)) 134 | 135 | (define (ems n) (make-size n 0)) 136 | 137 | (define (size-zero? s) 138 | (and (absolute-size? s) (zero? s))) 139 | 140 | (define (size= a b) 141 | (match* {a b} 142 | [{(? absolute-size?) (? absolute-size?)} 143 | (= a b)] 144 | [{(font-relative-size ems-a pxs-a) (font-relative-size ems-b pxs-b)} 145 | (and (= ems-a ems-b) (= pxs-a pxs-b))] 146 | [{_ _} 147 | #f])) 148 | 149 | (define (size+/who who a b) 150 | (match* {a b} 151 | [{(font-relative-size ems-a pxs-a) 152 | (font-relative-size ems-b pxs-b)} 153 | (make-size (rational+ who ems-a ems-b) (rational+ who pxs-a pxs-b))] 154 | [{(font-relative-size ems pxs-a) pxs-b} 155 | (font-relative-size ems (rational+ who pxs-a pxs-b))] 156 | [{pxs-a (font-relative-size ems pxs-b)} 157 | (font-relative-size ems (rational+ who pxs-a pxs-b))] 158 | [{pxs-a pxs-b} 159 | (rational+ who pxs-a pxs-b)])) 160 | 161 | (define size+ 162 | (case-lambda 163 | [() 0] 164 | [(s) s] 165 | [(a b) 166 | (size+/who 'size+ a b)] 167 | [(s . ss) 168 | (for/fold ([a s]) 169 | ([b (in-list ss)]) 170 | (size+ a b))])) 171 | 172 | (define size- 173 | (case-lambda 174 | [(s) 175 | (match s 176 | [(font-relative-size ems pxs) 177 | (font-relative-size (- ems) (- pxs))] 178 | [pxs (- pxs)])] 179 | [(a b) 180 | (size+/who 'size- a (size- b))] 181 | [(s . ss) 182 | (for/fold ([a s]) 183 | ([b (in-list ss)]) 184 | (size- a b))])) 185 | 186 | (define (size*/who who s n) 187 | (match s 188 | [(font-relative-size ems pxs) 189 | (make-size (rational* who ems n) (rational* who pxs n))] 190 | [pxs (rational* who pxs n)])) 191 | 192 | (define size* 193 | (case-lambda 194 | [(s) s] 195 | [(s n) 196 | (size*/who 'size* s n)] 197 | [(s . ns) 198 | (size* s (apply * ns))])) 199 | 200 | (define (make-size-absolute s #:ppem ppem #:who [who 'make-size-absolute]) 201 | (match s 202 | [(font-relative-size ems pxs) 203 | (check-overflow who (+ pxs (* ems ppem)))] 204 | [pxs pxs])) 205 | 206 | ;; ----------------------------------------------------------------------------- 207 | ;; flexibility 208 | 209 | (define (infinite-flexibility-cardinality? v) 210 | (and (fixnum? v) 211 | (fx<= 0 v 3))) 212 | 213 | (struct infinite-flexibility (weight cardinality) 214 | #:property prop:equal+hash 215 | (let () 216 | (define (=? a b recur) 217 | (and (recur (infinite-flexibility-weight a) (infinite-flexibility-weight b)) 218 | (fx= (infinite-flexibility-cardinality a) (infinite-flexibility-cardinality b)))) 219 | (define (hash self recur) 220 | (recur (cons (infinite-flexibility-weight self) 221 | (infinite-flexibility-cardinality self)))) 222 | (list =? hash hash)) 223 | #:property prop:custom-print-quotable 'never 224 | #:property prop:custom-write 225 | (λ (self out mode) 226 | (cond 227 | [(eq? mode 0) 228 | (match-define (infinite-flexibility weight cardinality) self) 229 | (~> (match cardinality 230 | [0 (quasiexpr (fi ,weight))] 231 | [1 (quasiexpr (fil ,weight))] 232 | [2 (quasiexpr (fill ,weight))] 233 | [3 (quasiexpr (filll ,weight))]) 234 | (print out))] 235 | [else 236 | (write-string "#" out)]))) 239 | 240 | (define (write-flexibility-expression s out) 241 | (match s 242 | [(infinite-flexibility weight cardinality) 243 | (display weight out) 244 | (write-string (match cardinality 245 | [0 "fi"] 246 | [1 "fil"] 247 | [2 "fill"] 248 | [3 "filll"]) 249 | out)] 250 | [_ 251 | (write-size-expression s out)])) 252 | 253 | (define (fill [weight 1] [cardinality 2]) 254 | (if (zero? weight) 255 | weight 256 | (infinite-flexibility weight cardinality))) 257 | 258 | (define (fi [weight 1]) 259 | (fill weight 0)) 260 | (define (fil [weight 1]) 261 | (fill weight 1)) 262 | (define (filll [weight 1]) 263 | (fill weight 3)) 264 | 265 | (define flexibility? 266 | (flat-contract-with-explanation 267 | #:name 'flexibility? 268 | (λ (v) 269 | (match v 270 | [(? absolute-size?) 271 | (or (>= v 0) 272 | (λ (blame) 273 | (raise-blame-error 274 | blame v 275 | '(expected "a flexibility, which must not be negative" 276 | given: "~e") 277 | v)))] 278 | 279 | [(font-relative-size ems pxs) 280 | (or (and (>= ems 0) (>= pxs 0)) 281 | (λ (blame) 282 | (define depends-on-ppem? (or (positive? ems) (positive? pxs))) 283 | (raise-blame-error 284 | blame v 285 | '(expected "a flexibility, which must not be negative" 286 | given: "~e~a") 287 | v (if depends-on-ppem? ",\n which could be negative (depending on the font size)" ""))))] 288 | 289 | [(? infinite-flexibility?) #t] 290 | [_ #f])))) 291 | 292 | (define (absolute-flexibility? v) 293 | (or (absolute-size? v) 294 | (infinite-flexibility? v))) 295 | 296 | (define (font-relative-flexibility? v) 297 | (font-relative-size? v)) 298 | 299 | (define (flexibility-zero? v) 300 | (and (absolute-size? v) (size-zero? v))) 301 | 302 | (define (flexibility= a b) 303 | (match* {a b} 304 | [{(? absolute-size?) (? absolute-size?)} 305 | (flexible-size= a b)] 306 | [{(infinite-flexibility weight-a cardinality-a) (infinite-flexibility weight-b cardinality-b)} 307 | (and (= weight-a weight-b) 308 | (fx= cardinality-a cardinality-b))])) 309 | 310 | (define (flexibility+/who who a b) 311 | (match* {a b} 312 | [{(infinite-flexibility weight-a cardinality-a) 313 | (infinite-flexibility weight-b cardinality-b)} 314 | (cond 315 | [(fx> cardinality-a cardinality-b) a] 316 | [(fx< cardinality-a cardinality-b) b] 317 | [else (fill (rational+ who weight-a weight-b) cardinality-a)])] 318 | [{(? infinite-flexibility?) _} a] 319 | [{_ (? infinite-flexibility?)} b] 320 | [{_ _} (size+/who who a b)])) 321 | 322 | (define flexibility+ 323 | (case-lambda 324 | [() 0] 325 | [(s) s] 326 | [(a b) 327 | (flexibility+/who 'flexibility+ a b)] 328 | [(s . ss) 329 | (for/fold ([a s]) 330 | ([b (in-list ss)]) 331 | (flexibility+ a b))])) 332 | 333 | (define (flexibility*/who who s n) 334 | (match s 335 | [(infinite-flexibility weight cardinality) 336 | (fill (rational* who weight n) cardinality)] 337 | [_ (size*/who who s n)])) 338 | 339 | (define flexibility* 340 | (case-lambda 341 | [(s) s] 342 | [(s n) 343 | (flexibility*/who 'flexibility* s n)] 344 | [(s . ns) 345 | (flexibility* s (apply * ns))])) 346 | 347 | (define (make-flexibility-absolute s #:ppem ppem #:who [who 'make-size-absolute]) 348 | (if (infinite-flexibility? s) 349 | s 350 | (make-size-absolute s #:ppem ppem #:who who))) 351 | 352 | ;; ----------------------------------------------------------------------------- 353 | ;; flexible size 354 | 355 | (struct flexible-size-struct (basis grow shrink) 356 | #:name flexible-size 357 | #:constructor-name flexible-size 358 | #:reflection-name 'flexible-size 359 | #:property prop:equal+hash 360 | (let () 361 | (define (=? a b recur) 362 | (and (recur (flexible-size-struct-basis a) (flexible-size-struct-basis b)) 363 | (recur (flexible-size-struct-grow a) (flexible-size-struct-grow b)) 364 | (recur (flexible-size-struct-shrink a) (flexible-size-struct-shrink b)))) 365 | (define (hash self recur) 366 | (recur (vector-immutable 367 | (flexible-size-struct-basis self) 368 | (flexible-size-struct-grow self) 369 | (flexible-size-struct-shrink self)))) 370 | (list =? hash hash)) 371 | #:property prop:custom-print-quotable 'never 372 | #:property prop:custom-write 373 | (λ (self out mode) 374 | (match-define (flexible-size basis grow shrink) self) 375 | (cond 376 | [(eq? mode 0) 377 | (print (quasiexpr 378 | (flex ,basis 379 | {~if (not (flexibility-zero? grow)) {~seq #:grow ,grow}} 380 | {~if (not (flexibility-zero? shrink)) {~seq #:shrink ,shrink}})) 381 | out)] 382 | [else 383 | (write-string "#" out)]))) 395 | 396 | (define (flex basis #:grow [grow 0] #:shrink [shrink 0]) 397 | (if (and (flexibility-zero? grow) 398 | (flexibility-zero? shrink)) 399 | basis 400 | (match basis 401 | [(flexible-size old-basis old-grow old-shrink) 402 | (flex old-basis 403 | #:grow (flexibility+ old-grow grow) 404 | #:shrink (flexibility+ old-shrink shrink))] 405 | [_ (flexible-size basis grow shrink)]))) 406 | 407 | (define (flexible-size? v) 408 | (or (size? v) 409 | (flexible-size-struct? v))) 410 | 411 | (define (flexible-size-basis v) 412 | (if (flexible-size-struct? v) 413 | (flexible-size-struct-basis v) 414 | v)) 415 | 416 | (define (flexible-size-grow v) 417 | (if (flexible-size-struct? v) 418 | (flexible-size-struct-grow v) 419 | 0)) 420 | 421 | (define (flexible-size-shrink v) 422 | (if (flexible-size-struct? v) 423 | (flexible-size-struct-shrink v) 424 | 0)) 425 | 426 | (define (flexible-size-zero? v) 427 | (and (size? v) (size-zero? v))) 428 | 429 | (define (flexible-size= a b) 430 | (match* {a b} 431 | [{(? size?) (? size?)} 432 | (size= a b)] 433 | [{(flexible-size basis-a grow-a shrink-a) (flexible-size basis-b grow-b shrink-b)} 434 | (and (flexible-size= basis-a basis-b) 435 | (flexibility= grow-a grow-b) 436 | (flexibility= shrink-a shrink-b))] 437 | [{_ _} 438 | #f])) 439 | 440 | (define flexible-size+ 441 | (case-lambda 442 | [() 0] 443 | [(s) s] 444 | [(a b) 445 | (match* {a b} 446 | [{(flexible-size basis-a grow-a shrink-a) 447 | (flexible-size basis-b grow-b shrink-b)} 448 | (flexible-size (size+/who 'flexible-size+ basis-a basis-b) 449 | (flexibility+/who 'flexible-size+ grow-a grow-b) 450 | (flexibility+/who 'flexible-size+ shrink-a shrink-b))] 451 | [{(flexible-size basis-a grow shrink) basis-b} 452 | (flexible-size (size+/who 'flexible-size+ basis-a basis-b) grow shrink)] 453 | [{basis-a (flexible-size basis-b grow shrink)} 454 | (flexible-size (size+/who 'flexible-size+ basis-a basis-b) grow shrink)] 455 | [{_ _} 456 | (size+/who 'flexible-size+ a b)])] 457 | [(s . ss) 458 | (for/fold ([a s]) 459 | ([b (in-list ss)]) 460 | (flexible-size+ a b))])) 461 | 462 | (define flexible-size* 463 | (case-lambda 464 | [(s) s] 465 | [(s n) 466 | (match s 467 | [(flexible-size basis grow shrink) 468 | (flex (size*/who 'flexible-size* basis n) 469 | #:grow (flexibility*/who 'flexible-size* grow n) 470 | #:shrink (flexibility*/who 'flexible-size* shrink n))] 471 | [_ (size*/who 'flexible-size* s n)])] 472 | [(s . ns) 473 | (flexible-size* s (apply * ns))])) 474 | 475 | (define (make-flexible-size-absolute s #:ppem ppem) 476 | (match s 477 | [(flexible-size basis grow shrink) 478 | (flex (make-size-absolute basis #:ppem ppem #:who 'make-flexible-size-absolute) 479 | #:grow (make-flexibility-absolute grow #:ppem ppem #:who 'make-flexible-size-absolute) 480 | #:shrink (make-flexibility-absolute shrink #:ppem ppem #:who 'make-flexible-size-absolute))] 481 | [_ 482 | (make-size-absolute s #:ppem ppem #:who 'make-flexible-size-absolute)])) 483 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/style-props.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract 4 | "draw/font.rkt" 5 | "style.rkt") 6 | 7 | (provide (contract-out 8 | [font (style-property/c font-description?)] 9 | [math-font (style-property/c font-description?)] 10 | [math-depth (style-property/c math-script-depth?)] 11 | [math-shift (style-property/c (or/c 'normal 'compact))] 12 | [math-style (style-property/c (or/c 'normal 'compact))] 13 | [visibility (style-property/c (or/c 'visible 'hidden))])) 14 | 15 | ;; ----------------------------------------------------------------------------- 16 | 17 | (define font (make-inherited-style-property 'font 18 | #:default (make-font-description #:size 16) 19 | #:combine combine-font-descriptions)) 20 | (define math-font (make-inherited-style-property 'math-font 21 | #:default (make-font-description #:family "math"))) 22 | 23 | (define math-depth (make-inherited-style-property 'math-depth #:default 0)) 24 | (define math-shift (make-inherited-style-property 'math-shift #:default 'normal)) 25 | (define math-style (make-inherited-style-property 'math-style #:default 'normal)) 26 | (define visibility (make-inherited-style-property 'visibility #:default 'visible)) 27 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/style.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; This module defines styles and style properties, which together implement 4 | ;; a limited form of CSS-like style inheritance and cascading. 5 | ;; 6 | ;; A `style` is essentially a dictionary that maps style properties to values. 7 | ;; Most of the magic lies in the style properties themselves, which are more 8 | ;; than just simple keys: 9 | ;; 10 | ;; * Style properties include a default value, which is returned by 11 | ;; `computed-style-value` if a value has not been explicitly specified. 12 | ;; 13 | ;; * Style properties can specify how multiple values for the same property 14 | ;; should be combined when styles are combined by `combine-styles`. 15 | ;; 16 | ;; * Style properties can be *inherited* or *uninherited*, which controls 17 | ;; whether or not their values are inherited from the parent set of styles 18 | ;; passed to `compute-style`. 19 | ;; 20 | ;; * Contracts can be attached to style properties to restrict the set of legal 21 | ;; values that a property may be associated with. 22 | ;; 23 | ;; The values of style properties cannot be queried from a style directly, since 24 | ;; the ultimate values may depend on inherited values. Instead, `compute-style` 25 | ;; must be used to explicitly resolve the style into a `computed-style`, which 26 | ;; may then be queried using `computed-style-value`. 27 | 28 | (require racket/contract 29 | racket/hash 30 | racket/list 31 | racket/match 32 | racket/string 33 | threading 34 | "util/print.rkt") 35 | 36 | (provide style-property? 37 | style-property/c 38 | (contract-out 39 | [make-style-property 40 | (->* [symbol?] 41 | [#:default any/c 42 | #:combine (or/c (-> any/c any/c any/c) #f)] 43 | style-property?)] 44 | [make-inherited-style-property 45 | (->* [symbol?] 46 | [#:default any/c 47 | #:combine (-> any/c any/c any/c)] 48 | style-property?)]) 49 | style? 50 | style 51 | plain 52 | computed-style? 53 | (contract-out 54 | [style-add (-> style? style-property? any/c style?)] 55 | [combine-styles (-> style? ... style?)] 56 | [compute-style (-> (or/c computed-style? #f) style? computed-style?)] 57 | [computed-style-value (-> computed-style? style-property? any/c)])) 58 | 59 | ;; ----------------------------------------------------------------------------- 60 | ;; styles and style properties 61 | 62 | (define-values [impersonator-prop:impersonator-of 63 | has-impersonator-target? 64 | impersonator-target] 65 | (make-impersonator-property 'impersonator-of)) 66 | 67 | ;; A style property key is essentially the “kernel” of a style property. It 68 | ;; contains all of the property’s metadata, and it is is the value used as a 69 | ;; hash key in a `style` or `computed-style`. The `style-property` structure 70 | ;; annotates a `style-property-key` with contract projections. 71 | (struct style-property-key (name default combine-proc) 72 | #:name info:style-property-key 73 | #:constructor-name unused-make-style-property-key) 74 | 75 | (struct uninherited-style-property-key info:style-property-key () 76 | #:constructor-name make-uninherited-style-property-key) 77 | (struct inherited-style-property-key info:style-property-key () 78 | #:constructor-name make-inherited-style-property-key) 79 | 80 | ;; For when we want to print something that references a style property, 81 | ;; but we actually only have a style property key. 82 | (define (wrap-key-for-print key) 83 | (unquoted-printing-string 84 | (format "#" (style-property-key-name key)))) 85 | 86 | ;; Annotates a style property key (which is, in a sense, the “real” style 87 | ;; property) with contract projections. When a contract is applied to a 88 | ;; `style-property` structure, the result is a chaperone or impersonator of the 89 | ;; uncontracted structure, but the `key`s of both structures are always `eq?`. 90 | (struct style-property (key guard-proc extract-proc) 91 | #:constructor-name internal-make-style-property 92 | #:property prop:impersonator-of (λ (self) (impersonator-target self #f)) 93 | #:property prop:object-name 94 | (λ (self) (style-property-key-name (style-property-key self))) 95 | #:property prop:custom-write 96 | (λ (self out mode) 97 | (fprintf out "#" (object-name self)))) 98 | 99 | (define (make-style-property-from-key key) 100 | (internal-make-style-property key (λ (val) val) (λ (val) val))) 101 | 102 | (define (make-style-property name 103 | #:default [default #f] 104 | #:combine [combine-proc #f]) 105 | (make-style-property-from-key 106 | (make-uninherited-style-property-key name default combine-proc))) 107 | 108 | (define (make-inherited-style-property name 109 | #:default [default #f] 110 | #:combine [combine-proc (λ (a b) b)]) 111 | (make-style-property-from-key 112 | (make-inherited-style-property-key name default combine-proc))) 113 | 114 | (define (print-style-mapping what mapping out mode #:as-expression? [try-as-expression? #f]) 115 | (define sorted-mapping (sort mapping symbol" what))] 125 | [else 126 | (~> (for/list ([key+vals (in-list sorted-mapping)]) 127 | (define entry (cons (unquoted-printing-string (format "~s" (car key+vals))) 128 | (match (cdr key+vals) 129 | [(list val) (list val)] 130 | [vals (reverse vals)]))) 131 | (if as-expression? 132 | (printing-sequence entry) 133 | (delimited-printing-sequence #:before "[" #:after "]" entry))) 134 | (cons (unquoted-printing-string what) _) 135 | (delimited-printing-sequence #:before (if as-expression? "(" "#<") 136 | #:after (if as-expression? ")" ">")) 137 | (custom-write/recur out mode))])) 138 | 139 | (struct style (mapping) 140 | #:name info:style 141 | #:constructor-name make-style 142 | #:property prop:custom-print-quotable 'never 143 | #:property prop:custom-write 144 | (λ (self out mode) 145 | (~> (for/list ([(key vals) (in-immutable-hash (style-mapping self))]) 146 | (cons (style-property-key-name key) vals)) 147 | (print-style-mapping "style" _ out mode #:as-expression? #t)))) 148 | 149 | (struct computed-style (inherited uninherited) 150 | #:constructor-name make-computed-style 151 | #:property prop:custom-write 152 | (λ (self out mode) 153 | (~> (append (for/list ([(key val) (in-immutable-hash (computed-style-inherited self))]) 154 | (cons (style-property-key-name key) (list val))) 155 | (for/list ([(key val) (in-immutable-hash (computed-style-uninherited self))]) 156 | (cons (style-property-key-name key) (list val)))) 157 | (print-style-mapping "computed-style" _ out mode)))) 158 | 159 | (define plain (make-style (hasheq))) 160 | 161 | (define (style . args) 162 | (unless (even? (length args)) 163 | (raise-arguments-error 164 | 'style 165 | "expected an even number of arguments, but received an odd number" 166 | "arguments" args)) 167 | 168 | (let loop ([s plain] 169 | [args args]) 170 | (match args 171 | ['() s] 172 | [(list* prop val args) 173 | (unless (style-property? prop) 174 | (raise-argument-error 'style "style-property?" prop)) 175 | (loop (style-add s prop val) args)]))) 176 | 177 | (define (style-add s prop val) 178 | (define key (style-property-key prop)) 179 | (define val* ((style-property-guard-proc prop) val)) 180 | (struct-copy info:style s 181 | [mapping (hash-update (style-mapping s) 182 | key 183 | (λ~>> (cons val*)) 184 | '())])) 185 | 186 | (define combine-styles 187 | (case-lambda 188 | [() plain] 189 | [(s) s] 190 | [ss (make-style (apply hash-union (map style-mapping ss) #:combine append))])) 191 | 192 | (define (compute-style old new) 193 | (for/fold ([inherited (if old (computed-style-inherited old) (hasheq))] 194 | [uninherited (hasheq)] 195 | #:result (make-computed-style inherited uninherited)) 196 | ([(key vals) (in-immutable-hash (style-mapping new))]) 197 | (define default (style-property-key-default key)) 198 | (define combine (style-property-key-combine-proc key)) 199 | 200 | (define (go h) 201 | (cond 202 | [combine 203 | (hash-update 204 | h 205 | key 206 | (λ (old) 207 | (for/fold ([old old]) 208 | ([new (in-list vals)]) 209 | (combine old new))) 210 | (λ () default))] 211 | [else 212 | (match vals 213 | [(list val) 214 | (hash-set h key val)] 215 | [_ 216 | (raise-arguments-error 'compute-style "multiple values provided for single-valued style property" 217 | "property" (wrap-key-for-print key) 218 | "values..." (unquoted-printing-string 219 | (string-append* 220 | (for/list ([val (in-list vals)]) 221 | (format "\n ~e" val)))))])])) 222 | 223 | (if (inherited-style-property-key? key) 224 | (values (go inherited) uninherited) 225 | (values inherited (go uninherited))))) 226 | 227 | (define (computed-style-value s prop) 228 | (define key (style-property-key prop)) 229 | (define val (hash-ref (if (inherited-style-property-key? key) 230 | (computed-style-inherited s) 231 | (computed-style-uninherited s)) 232 | key 233 | (λ () (style-property-key-default key)))) 234 | ((style-property-extract-proc prop) val)) 235 | 236 | ;; ----------------------------------------------------------------------------- 237 | ;; style-property/c 238 | 239 | (define (chaperone-style-property val 240 | #:guard wrap-guard 241 | #:extract wrap-extract 242 | . props) 243 | (apply chaperone-struct 244 | val 245 | style-property-guard-proc 246 | (λ (val guard-proc) (chaperone-procedure guard-proc wrap-guard)) 247 | style-property-extract-proc 248 | (λ (val extract-proc) (chaperone-procedure extract-proc wrap-extract)) 249 | props)) 250 | 251 | (define (impersonate-style-property val 252 | #:guard wrap-guard 253 | #:extract wrap-extract 254 | . props) 255 | (apply impersonate-struct 256 | (struct-copy style-property val 257 | [guard-proc (impersonate-procedure (style-property-guard-proc val) 258 | wrap-guard)] 259 | [extract-proc (impersonate-procedure (style-property-extract-proc val) 260 | wrap-extract)]) 261 | struct:style-property 262 | impersonator-prop:impersonator-of val 263 | props)) 264 | 265 | (define (make-style-property-contract-property build-contract-property wrap-style-property) 266 | (define ((relation * [char?] 11 | [#:bold? any/c 12 | #:italic? any/c 13 | #:style math-char-style/c] 14 | char?)] 15 | 16 | [superscript-char (-> char? char?)] 17 | [subscript-char (-> char? char?)] 18 | [integer->superscript-string (-> exact-integer? string?)] 19 | [integer->subscript-string (-> exact-integer? string?)])) 20 | 21 | ;; ----------------------------------------------------------------------------- 22 | 23 | (define char:minus #\u2212) 24 | 25 | (define (char+ c . ns) 26 | (integer->char (apply + (char->integer c) ns))) 27 | (define (char-diff c1 c2) 28 | (- (char->integer c1) (char->integer c2))) 29 | 30 | (define math-char-style/c 31 | (or/c 'serif 'sans-serif 'script 'fraktur 'monospace 'double-struck)) 32 | 33 | (define (math-char c 34 | #:bold? [bold? #f] 35 | #:italic? [italic? #f] 36 | #:style [style 'serif]) 37 | (define (bad-combo) 38 | (raise-arguments-error 'math-char "no character for style" 39 | "character" c 40 | "bold?" bold? 41 | "italic?" italic? 42 | "style" style)) 43 | 44 | (define (regular stride c) 45 | (match* {bold? italic?} 46 | [{#f #f} c] 47 | [{#t #f} (char+ c stride)] 48 | [{#f #t} (char+ c (* stride 2))] 49 | [{#t #t} (char+ c (* stride 3))])) 50 | 51 | (define (latin c c-offset) 52 | (match* {style bold? italic? c} 53 | [{'serif #f #t #\h} #\U210E] 54 | [{'serif _ _ _ } (regular 52 (char+ #\U1D3CC c-offset))] 55 | [{'sans-serif _ _ _ } (regular 52 (char+ #\U1D5A0 c-offset))] 56 | [{'script #f #f #\B} #\U212C] 57 | [{'script #f #f #\E} #\U2130] 58 | [{'script #f #f #\F} #\U2131] 59 | [{'script #f #f #\H} #\U210B] 60 | [{'script #f #f #\I} #\U2110] 61 | [{'script #f #f #\L} #\U2112] 62 | [{'script #f #f #\M} #\U2133] 63 | [{'script #f #f #\R} #\U211B] 64 | [{'script #f #f #\e} #\U212F] 65 | [{'script #f #f #\g} #\U210A] 66 | [{'script #f #f #\o} #\U2134] 67 | [{'script _ #f _ } (regular 52 (char+ #\U1D49C c-offset))] 68 | [{'fraktur #f #f #\C} #\U212D] 69 | [{'fraktur #f #f #\H} #\U210C] 70 | [{'fraktur #f #f #\I} #\U2111] 71 | [{'fraktur #f #f #\R} #\U211C] 72 | [{'fraktur #f #f #\Z} #\U2128] 73 | [{'fraktur _ #f _ } (regular 104 (char+ #\U1D504 c-offset))] 74 | [{'monospace #f #f _ } (char+ #\U1D670 c-offset)] 75 | [{'double-struck #f #f #\C} #\U2102] 76 | [{'double-struck #f #f #\H} #\U210D] 77 | [{'double-struck #f #f #\N} #\U2115] 78 | [{'double-struck #f #f #\P} #\U2119] 79 | [{'double-struck #f #f #\Q} #\U211A] 80 | [{'double-struck #f #f #\R} #\U211D] 81 | [{'double-struck #f #f #\Z} #\U2124] 82 | [{'double-struck #f #f _ } (char+ #\U1D538 c-offset)] 83 | [{_ _ _ _ } (bad-combo)])) 84 | 85 | (define (greek c-offset) 86 | (match* {style bold? italic?} 87 | [{'serif _ _ } (regular 58 (char+ #\U1D66E c-offset))] 88 | [{'sans-serif #t #f} (char+ #\U1D756 c-offset)] 89 | [{'sans-serif #t #t} (char+ #\U1D790 c-offset)] 90 | [{_ _ _ } (bad-combo)])) 91 | 92 | (define (digit c-offset) 93 | (match* {style bold? italic?} 94 | [{'serif #t #f} (char+ #\U1D7CE c-offset)] 95 | [{'sans-serif #f #f} (char+ #\U1D7E2 c-offset)] 96 | [{'sans-serif #t #f} (char+ #\U1D7EC c-offset)] 97 | [{'monospace #f #f} (char+ #\U1D7F6 c-offset)] 98 | [{'double-struck #f #f} (char+ #\U1D7D8 c-offset)] 99 | [{_ _ _ } (bad-combo)])) 100 | 101 | (cond 102 | [(and (not bold?) (not italic?) (eq? style 'serif)) c] 103 | [(char<=? #\A c #\Z) (latin c (char-diff c #\A))] 104 | [(char<=? #\a c #\z) (latin c (+ (char-diff c #\a) 26))] 105 | [(or (char<=? #\U391 c #\U3A1) 106 | (char<=? #\Σ c #\Ω) 107 | (char<=? #\α c #\ω)) 108 | (greek (char-diff c #\U391))] 109 | [(char=? c #\Θ) (greek 11)] 110 | [(char=? c #\∇) (greek 19)] 111 | [(char=? c #\U2202) (greek 39)] 112 | [(char=? c #\U03F5) (greek 40)] 113 | [(char=? c #\U03D1) (greek 41)] 114 | [(char=? c #\U03F0) (greek 42)] 115 | [(char=? c #\U03D5) (greek 43)] 116 | [(char=? c #\U03F1) (greek 44)] 117 | [(char=? c #\U03D6) (greek 45)] 118 | [(char<=? #\0 c #\9) (digit (char-diff c #\0))] 119 | [else (bad-combo)])) 120 | 121 | (define (superscript-char c) 122 | (match c 123 | [#\1 #\u00B9] 124 | [#\2 #\u00B2] 125 | [#\3 #\u00B3] 126 | [#\+ #\u207A] 127 | [(== char:minus) #\u207B] 128 | [#\= #\u207C] 129 | [#\( #\u207D] 130 | [#\) #\u207E] 131 | [#\n #\u207F] 132 | [_ 133 | (if (char<=? #\0 c #\9) 134 | (char+ #\u2070 (char-diff c #\0)) 135 | (raise-arguments-error 'superscript-char "no superscript variant for character" 136 | "character" c))])) 137 | 138 | (define (subscript-char c) 139 | (cond 140 | [(char<=? #\0 c #\9) 141 | (char+ #\u2080 (char-diff c #\0))] 142 | [else 143 | (match c 144 | [#\+ #\u208A] 145 | [(== char:minus) #\u208B] 146 | [#\= #\u208C] 147 | [#\( #\u208D] 148 | [#\) #\u208E] 149 | [#\a #\u2090] 150 | [#\e #\u2091] 151 | [#\o #\u2092] 152 | [#\x #\u2093] 153 | [#\ə #\u2094] 154 | [#\h #\u2095] 155 | [#\k #\u2096] 156 | [#\l #\u2097] 157 | [#\m #\u2098] 158 | [#\n #\u2099] 159 | [#\p #\u209A] 160 | [#\s #\u209B] 161 | [#\t #\u209C] 162 | [_ 163 | (raise-arguments-error 'subscript-char "no subscript variant for character" 164 | "character" c)])])) 165 | 166 | (define (integer->script-string n convert-char) 167 | (define num-str (number->string n)) 168 | (define len (string-length num-str)) 169 | (define str (if (immutable? num-str) (make-string len) num-str)) 170 | (for ([i (in-range len)]) 171 | (define c (string-ref num-str i)) 172 | (string-set! str i (convert-char (if (char=? c #\-) char:minus c)))) 173 | str) 174 | 175 | (define (integer->superscript-string n) 176 | (integer->script-string n superscript-char)) 177 | 178 | (define (integer->subscript-string n) 179 | (integer->script-string n subscript-char)) 180 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/util/print.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base) 4 | racket/contract 5 | racket/match 6 | racket/pretty 7 | (only-in syntax/parse ~seq) 8 | syntax/parse/define 9 | threading) 10 | 11 | (provide (contract-out 12 | [custom-write/recur (-> any/c output-port? custom-write-mode/c void?)] 13 | [make-custom-write/recur (-> output-port? custom-write-mode/c (->* [any/c] [output-port?] void?))] 14 | 15 | [empty-printing-value? predicate/c] 16 | [empty-printing-value empty-printing-value?] 17 | [custom-printing-value (->* [(-> output-port? custom-write-mode/c any)] 18 | [#:quotable (or/c 'self 'never 'always 'maybe)] 19 | any/c)] 20 | 21 | [with-printing-overflow-handler (->* [output-port? 22 | (-> output-port? any) 23 | (-> (->* [output-port?] void?) any)] 24 | [#:width exact-positive-integer? 25 | #:space-after exact-nonnegative-integer?] 26 | void?)] 27 | [printing-sequence (->* [list?] 28 | [#:space-after exact-nonnegative-integer? 29 | #:hang exact-nonnegative-integer?] 30 | any/c)] 31 | [delimited-printing-sequence (->* [list?] 32 | [#:before string? 33 | #:after string? 34 | #:hang exact-nonnegative-integer?] 35 | any/c)] 36 | [printing-append (-> any/c ... any/c)] 37 | [printing-add-separators (->* [list?] [#:trailing any/c #:leading any/c] list?)] 38 | [printing-hang (->* [any/c 39 | any/c] 40 | [#:indent exact-nonnegative-integer? 41 | #:space-after exact-nonnegative-integer?] 42 | any/c)] 43 | 44 | [constructor-style-printing-value (->* [(or/c symbol? string?) list?] [#:expression? any/c] any/c)] 45 | [make-constructor-style-printer (->* [(-> any/c (or/c symbol? string?)) 46 | (-> any/c list?)] 47 | [#:expression? any/c] 48 | (-> any/c output-port? custom-write-mode/c void?))]) 49 | 50 | quasiexpr ~@ ~seq ~if) 51 | 52 | ;; ----------------------------------------------------------------------------- 53 | 54 | (define custom-write-mode/c (or/c #f #t 0 1)) 55 | 56 | (define (custom-write/recur v out mode) 57 | ((make-custom-write/recur out mode) v)) 58 | 59 | (define (make-custom-write/recur out mode) 60 | (match mode 61 | [#f (λ (v [out out]) (display v out))] 62 | [#t (λ (v [out out]) (write v out))] 63 | [(or 0 1) (λ (v [out out]) (print v out mode))])) 64 | 65 | ;; A value that always prints nothing. 66 | (define-values [empty-printing-value empty-printing-value?] 67 | (let () 68 | (struct empty-printing-value () 69 | #:authentic 70 | #:property prop:custom-write (λ (self out mode) (void))) 71 | (values (empty-printing-value) empty-printing-value?))) 72 | 73 | ;; A helper to allow constructing “anonymous” custom printing values 74 | ;; of arbitrary quotability. 75 | (define (custom-printing-value proc #:quotable [quotable 'self]) 76 | (match quotable 77 | ['self (custom-printing-value:self-quotable proc)] 78 | ['never (custom-printing-value:never-quotable proc)] 79 | ['always (custom-printing-value:always-quotable proc)] 80 | ['maybe (custom-printing-value:maybe-quotable proc)])) 81 | 82 | (struct custom-printing-value (procedure) 83 | #:name info:custom-printing-value 84 | #:constructor-name custom-printing-value:self-quotable 85 | #:transparent 86 | #:property prop:custom-write 87 | (λ (self out mode) 88 | ((custom-printing-value-procedure self) out mode))) 89 | 90 | (struct custom-printing-value:never-quotable info:custom-printing-value () 91 | #:property prop:custom-print-quotable 'never) 92 | (struct custom-printing-value:always-quotable info:custom-printing-value () 93 | #:property prop:custom-print-quotable 'always) 94 | (struct custom-printing-value:maybe-quotable info:custom-printing-value () 95 | #:property prop:custom-print-quotable 'maybe) 96 | 97 | ;; ----------------------------------------------------------------------------- 98 | 99 | (define (write-spaces n out) 100 | (cond 101 | [(<= n 0) 102 | (void)] 103 | [else 104 | (let loop ([n n]) 105 | (cond 106 | [(> n 8) 107 | (write-string " " out) 108 | (loop (- n 8))] 109 | [else 110 | (write-string 111 | (vector-ref #(" " 112 | " " 113 | " " 114 | " " 115 | " " 116 | " " 117 | " " 118 | " ") 119 | (sub1 n)) 120 | out) 121 | (void)]))])) 122 | 123 | (define (with-printing-overflow-handler out 124 | #:width [width (pretty-print-columns)] 125 | #:space-after [space-after 0] 126 | single-line-proc 127 | multi-line-proc) 128 | (cond 129 | [(and (pretty-printing) 130 | (port-counts-lines? out)) 131 | (define-values [tentative-out overflowed?] 132 | (let/ec escape 133 | (define tentative-out 134 | (make-tentative-pretty-print-output-port 135 | out 136 | (max 0 (- width space-after)) 137 | (λ () (escape tentative-out #t)))) 138 | (single-line-proc tentative-out) 139 | (values tentative-out #f))) 140 | 141 | (cond 142 | [overflowed? 143 | (tentative-pretty-print-port-cancel tentative-out) 144 | (define-values [line col posn] (port-next-location out)) 145 | (multi-line-proc 146 | (λ ([out out]) 147 | (pretty-print-newline out width) 148 | (define-values [line* col* posn*] (port-next-location out)) 149 | (write-spaces (- col col*) out)))] 150 | [else 151 | (tentative-pretty-print-port-transfer tentative-out out)])] 152 | [else 153 | (single-line-proc out)]) 154 | (void)) 155 | 156 | ;; Prints like `vs`, but without any enclosing parentheses. When not pretty- 157 | ;; printing, this means each element of `vs` is just printed with one after the 158 | ;; other, with a single space between each one. When pretty-printing, however, 159 | ;; each element of `vs` will be printed on a separate line (with appropriate 160 | ;; indentation) if they do not fit within (- (pretty-print-colums) space-after). 161 | (define (printing-sequence vs 162 | #:space-after [space-after 0] 163 | #:hang [hang-indent 0]) 164 | (match vs 165 | ['() empty-printing-value] 166 | [(cons v vs) 167 | (custom-printing-value 168 | (λ (out mode) 169 | (define recur (make-custom-write/recur out mode)) 170 | (with-printing-overflow-handler out #:space-after space-after 171 | (λ (out) 172 | (recur v out) 173 | (for ([v (in-list vs)]) 174 | (write-char #\space out) 175 | (recur v out))) 176 | (λ (newline) 177 | (recur v) 178 | (for ([v (in-list vs)]) 179 | (newline) 180 | (write-spaces hang-indent out) 181 | (recur v))))))])) 182 | 183 | (define (delimited-printing-sequence vs 184 | #:before [before-str ""] 185 | #:after [after-str ""] 186 | #:hang [hang-indent 0]) 187 | (define printing-vs (printing-sequence vs 188 | #:space-after (string-length after-str) 189 | #:hang hang-indent)) 190 | (custom-printing-value 191 | (λ (out mode) 192 | (write-string before-str out) 193 | (custom-write/recur printing-vs out mode) 194 | (write-string after-str out)))) 195 | 196 | (define printing-append 197 | (case-lambda 198 | [() empty-printing-value] 199 | [(v) v] 200 | [vs (custom-printing-value 201 | (λ (out mode) (for-each (make-custom-write/recur out mode) vs)))])) 202 | 203 | (define (printing-add-separators vs 204 | #:trailing [trailing-v empty-printing-value] 205 | #:leading [leading-v empty-printing-value]) 206 | (match vs 207 | ['() '()] 208 | [(list v) (list v)] 209 | [(cons v vs) 210 | (cons (printing-append v trailing-v) 211 | (let loop ([vs vs]) 212 | (match vs 213 | [(list v) 214 | (list (printing-append leading-v v))] 215 | [(cons v vs) 216 | (cons (printing-append leading-v v trailing-v) (loop vs))])))])) 217 | 218 | (define (printing-hang herald body 219 | #:indent [indent-amount 1] 220 | #:space-after [space-after 0]) 221 | (custom-printing-value 222 | (λ (out mode) 223 | (define recur (make-custom-write/recur out mode)) 224 | (with-printing-overflow-handler out 225 | #:space-after space-after 226 | (λ (out) 227 | (recur herald out) 228 | (write-char #\space out) 229 | (recur body out)) 230 | (λ (newline) 231 | (recur herald) 232 | (newline) 233 | (write-spaces indent-amount out) 234 | (recur body)))))) 235 | 236 | ;; ----------------------------------------------------------------------------- 237 | 238 | (define (do-constructor-style-print out mode name args #:expression? expression?) 239 | (define as-expression? (and expression? (eq? mode 0))) 240 | (define name-str (if as-expression? 241 | (format "~a" name) 242 | (format "~a:" name))) 243 | (~> (delimited-printing-sequence 244 | #:before (if as-expression? "(" "#<") 245 | #:after (if as-expression? ")" ">") 246 | (cons (unquoted-printing-string name-str) args)) 247 | (custom-write/recur out mode))) 248 | 249 | (define (constructor-style-printing-value name args #:expression? [expression? #t]) 250 | (custom-printing-value 251 | #:quotable (if expression? 'never 'self) 252 | (λ (out mode) 253 | (do-constructor-style-print out mode name args #:expression? expression?)))) 254 | 255 | (define ((make-constructor-style-printer get-name get-args #:expression? [expression? #t]) 256 | self out mode) 257 | (do-constructor-style-print 258 | out 259 | mode 260 | (get-name self) 261 | (get-args self) 262 | #:expression? expression?)) 263 | 264 | ;; ----------------------------------------------------------------------------- 265 | 266 | (define (always-prints v [depth 0]) 267 | (custom-printing-value #:quotable 'never (λ (out mode) (print v out depth)))) 268 | 269 | (begin-for-syntax 270 | (define-syntax-class qe-term 271 | #:attributes [e] 272 | #:description #f 273 | #:commit 274 | #:literals [unquote unquote-splicing] 275 | (pattern {~and e {~or* _:boolean _:number _:id _:keyword _:string ()}}) 276 | (pattern (unquote ~! e*:expr) 277 | #:attr e #',(always-prints e*)) 278 | (pattern ({~literal ~seq} ~! t:qe-head-term ...) 279 | #:attr e #',(printing-sequence `(t.e ...))) 280 | (pattern ({~literal ~if} ~! cond:expr then:qe-term else:qe-term) 281 | #:attr e #',(if cond `then.e `else.e)) 282 | (pattern ({~and head-id {~or* unquote-splicing {~literal ~@}}} ~! . _) 283 | #:post {~fail #:when #'head-id "only allowed in a head context"} 284 | #:attr e #f) 285 | (pattern (t1:qe-head-term ...+ . t2:qe-term) 286 | #:attr e #'(t1.e ... . t2.e))) 287 | 288 | (define-syntax-class qe-head-term 289 | #:attributes [e] 290 | #:description #f 291 | #:commit 292 | #:literals [unquote-splicing] 293 | (pattern ({~literal ~@} ~! t1:qe-head-term ... . t2:qe-term) 294 | #:attr e #',@`(t1.e ... . t2.e)) 295 | (pattern ({~literal ~if} ~! cond:expr then:qe-head-term {~optional else:qe-head-term}) 296 | #:attr e #',@(if cond `(then.e) {~? `(else.e) '()})) 297 | (pattern (unquote-splicing ~! e*:expr) 298 | #:attr e #',@(map always-prints e*)) 299 | (pattern :qe-term))) 300 | 301 | ;; Constructs a value that prints like an unquoted expression. For example: 302 | ;; 303 | ;; > (quasiexpr (list (+ 1 2)) 304 | ;; (list (+ 1 2)) 305 | ;; 306 | ;; Uses of `unquote` or `unquote-splicing` escape as in `quasiquote`, and any 307 | ;; value inserted via an escape is printed normally: 308 | ;; 309 | ;; > (quasiexpr (list a ())) 310 | ;; (list a ()) 311 | ;; > (quasiexpr (list ,'a ,'())) 312 | ;; (list 'a '()) 313 | ;; 314 | ;; Additionally, `~seq` can be used to group subsequences, which is mostly 315 | ;; useful to suppress line breaks between keyword argument pairs. For example: 316 | ;; 317 | ;; > (quasiexpr (foo #:a 1 #:b 2 )) 318 | ;; (foo 319 | ;; #:a 320 | ;; 1 321 | ;; #:b 322 | ;; 2 323 | ;; ) 324 | ;; 325 | ;; > (quasiexpr (foo {~seq #:a 1} 326 | ;; {~seq #:b 2} 327 | ;; )) 328 | ;; (foo 329 | ;; #:a 1 330 | ;; #:b 2 331 | ;; ) 332 | (define-syntax-parse-rule (quasiexpr t:qe-term) 333 | (always-prints `t.e 1)) 334 | 335 | (define-syntax (~if stx) 336 | (raise-syntax-error #f "not allowed as an expression" stx)) 337 | -------------------------------------------------------------------------------- /blackboard-lib/blackboard/private/util/struct.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/syntax) 5 | racket/contract 6 | racket/list 7 | syntax/parse/define) 8 | 9 | (provide define-uniques 10 | define-struct-type-property 11 | (contract-out 12 | [make-unique (-> symbol? (values any/c predicate/c))] 13 | [make-standard-struct-type-property 14 | (->* [symbol?] 15 | [#:wrap-guard wrap-guard/c 16 | #:value-contract contract? 17 | #:allow-procedure? any/c 18 | #:allow-plain-value? any/c 19 | #:allow-field-index? any/c 20 | #:supers (listof (cons/c struct-type-property? (-> any/c any/c))) 21 | #:can-impersonate? any/c] 22 | (values struct-type-property? 23 | procedure? 24 | procedure?))])) 25 | 26 | ;; ----------------------------------------------------------------------------- 27 | 28 | (define (make-unique name) 29 | (struct unique () 30 | #:authentic 31 | #:reflection-name name) 32 | (values (unique) unique?)) 33 | 34 | (define-simple-macro (define-unique name:id) 35 | #:with name? (format-id #'name "~a?" #'name #:subs? #t) 36 | (define-values [name name?] (make-unique 'name))) 37 | 38 | (define-simple-macro (define-uniques name:id ...) 39 | (begin (define-unique name) ...)) 40 | 41 | ;; ----------------------------------------------------------------------------- 42 | 43 | (define struct-type-info-list/c 44 | (flat-named-contract 45 | 'struct-type-info-list/c 46 | (list/c symbol? 47 | exact-nonnegative-integer? 48 | exact-nonnegative-integer? 49 | struct-accessor-procedure? 50 | struct-mutator-procedure? 51 | (listof exact-nonnegative-integer?) 52 | (or/c struct-type? #f) 53 | boolean?))) 54 | 55 | (define wrap-guard/c 56 | (-> any/c 57 | struct-type-info-list/c 58 | (-> any/c struct-type-info-list/c (-> any/c any/c)) 59 | any/c)) 60 | 61 | (define (make-standard-struct-type-property 62 | name 63 | #:wrap-guard [wrap-guard (λ (v info guard) (guard v info))] 64 | #:value-contract [value/c any/c] 65 | #:allow-procedure? [allow-procedure? #t] 66 | #:allow-plain-value? [allow-plain-value? #t] 67 | #:allow-field-index? [allow-field-index? #t] 68 | #:supers [supers '()] 69 | #:can-impersonate? [can-impersonate? #f]) 70 | (define-values [prop:name name? name-ref] 71 | (make-struct-type-property 72 | name 73 | (λ (v info) 74 | (wrap-guard 75 | v info 76 | (λ (v info) 77 | (cond 78 | [(and allow-procedure? (procedure? v)) 79 | v] 80 | [(and allow-field-index? (exact-integer? v)) 81 | (define self-ref (fourth info)) 82 | (λ (self) (self-ref self v))] 83 | [else 84 | (λ (self) v)])))) 85 | supers 86 | can-impersonate?)) 87 | (values prop:name name? (procedure-rename (λ (self) ((name-ref self) self)) name))) 88 | 89 | (define-syntax-parser define-struct-type-property 90 | [(_ {~optional name:id} 91 | {~alt {~optional {~seq #:property-id property-id:id}} 92 | {~optional {~seq #:predicate-id predicate-id:id}} 93 | {~optional {~seq #:accessor-id accessor-id:id}} 94 | {~optional {~seq #:reflection-name reflection-name}} 95 | {~optional {~seq #:wrap-guard wrap-guard}} 96 | {~optional {~or* {~and #:disallow-procedure {~bind [allow-procedure? #'#f]}} 97 | {~seq #:allow-procedure? allow-procedure?:expr}}} 98 | {~optional {~or* {~and #:disallow-plain-value {~bind [allow-plain-value? #'#f]}} 99 | {~seq #:allow-plain-value? allow-plain-value?:expr}}} 100 | {~optional {~or* {~and #:disallow-field-index {~bind [allow-field-index? #'#f]}} 101 | {~seq #:allow-field-index? allow-field-index?:expr}}} 102 | {~seq #:super super-prop super-proc} 103 | {~optional {~or* {~and #:can-impersonate {~bind [can-impersonate? #'#t]}} 104 | {~seq #:can-impersonate? can-impersonate?:expr}}}} 105 | ...) 106 | #:declare reflection-name (expr/c #'symbol? #:name "#:reflection-name argument") 107 | #:declare wrap-guard (expr/c #'wrap-guard/c #:name "#:wrap-guard argument") 108 | #:declare super-prop (expr/c #'struct-type-property? #:name "#:super argument") 109 | #:declare super-proc (expr/c #'(-> any/c any/c) #:name "#:super argument") 110 | #:fail-unless (or (attribute name) 111 | (and (attribute property-id) 112 | (attribute predicate-id) 113 | (attribute accessor-id) 114 | (attribute reflection-name))) 115 | (string-append "either a name identifier must be specified, or the " 116 | "#:property-id, #:predicate-id, #:accessor-id, and " 117 | "#:reflection-name options must all be provided") 118 | #:with {~var prop:name} (or (attribute property-id) 119 | (format-id #'name "prop:~a" #'name #:subs? #t)) 120 | #:with name? (or (attribute predicate-id) 121 | (format-id #'name "~a?" #'name #:subs? #t)) 122 | #:with name-ref (or (attribute accessor-id) 123 | (format-id #'name "~a-ref" #'name #:subs? #t)) 124 | (syntax/loc this-syntax 125 | (define-values [prop:name name? name-ref] 126 | (make-standard-struct-type-property {~? reflection-name.c 'name} 127 | {~? {~@ #:wrap-guard wrap-guard.c}} 128 | {~? {~@ #:allow-procedure? allow-procedure?}} 129 | {~? {~@ #:allow-plain-value? allow-plain-value?}} 130 | {~? {~@ #:allow-field-index? allow-field-index?}} 131 | #:supers (list (cons super-prop.c super-proc.c) ...) 132 | {~? {~@ #:can-impersonate? can-impersonate?}})))]) 133 | -------------------------------------------------------------------------------- /blackboard-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define version "0.0") 4 | 5 | (define collection 'multi) 6 | 7 | (define deps 8 | '("base" 9 | "draw-lib" 10 | "pict-lib" 11 | "threading-lib")) 12 | (define build-deps '()) 13 | -------------------------------------------------------------------------------- /example.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | -------------------------------------------------------------------------------- /fonts/eliminate-math-script.py: -------------------------------------------------------------------------------- 1 | # This script patches an OpenType Math font to eliminate the requirement that 2 | # the OpenType `math` script be used to activate math shaping features. 3 | # Unfortunately, enabling the math script is currently difficult or impossible 4 | # in many systems, most notably when using HTML/CSS, so this workaround will 5 | # remain necessary unless that changes. 6 | 7 | import fontforge 8 | 9 | def alter_math_font(in_path, out_name, out_family): 10 | lm = fontforge.open(in_path) 11 | 12 | for lookup in lm.gsub_lookups: 13 | _, _, features = lm.getLookupInfo(lookup) 14 | new_features = tuple((feature, (('DFLT', ('dflt',)),)) for feature, _ in features) 15 | lm.lookupSetFeatureList(lookup, new_features) 16 | 17 | def update_sfnt_name(language, strid, string): 18 | if language == 'English (US)' and strid == 'Preferred Family': 19 | return (language, strid, out_family) 20 | else: 21 | return (language, strid, string) 22 | 23 | lm.fontname = out_name 24 | lm.fullname = out_name 25 | lm.familyname = out_family 26 | lm.sfnt_names = tuple(update_sfnt_name(*tup) for tup in lm.sfnt_names) 27 | lm.generate(f'{out_name}.otf') 28 | 29 | alter_math_font('/usr/share/texmf/fonts/opentype/public/lm-math/latinmodern-math.otf', 30 | 'BlackboardModernMath-Regular', 31 | 'Blackboard Modern Math') 32 | alter_math_font('/usr/share/texmf/fonts/opentype/public/tex-gyre-math/texgyrepagella-math.otf', 33 | 'BlackboardPagellaMath-Regular', 34 | 'Blackboard Pagella Math') 35 | alter_math_font('/usr/share/texmf/fonts/opentype/public/tex-gyre-math/texgyretermes-math.otf', 36 | 'BlackboardTermesMath-Regular', 37 | 'Blackboard Termes Math') 38 | alter_math_font('/usr/share/texmf/fonts/opentype/public/tex-gyre-math/texgyrebonum-math.otf', 39 | 'BlackboardBonumMath-Regular', 40 | 'Blackboard Bonum Math') 41 | alter_math_font('/home/alexis/Downloads/euler.otf', 42 | 'BlackboardNeoEuler-Regular', 43 | 'Blackboard Neo Euler') 44 | alter_math_font('/home/alexis/Downloads/gfsneohellenicmath/GFSNeohellenicMath.otf', 45 | 'BlackboardNeohellenicMath-Regular', 46 | 'Blackboard Neohellenic Math') 47 | alter_math_font('/home/alexis/Downloads/CambriaMath.otf', 48 | 'BlackboardCambriaMath-Regular', 49 | 'Blackboard Cambria Math') 50 | -------------------------------------------------------------------------------- /fonts/fix-lm-metrics.py: -------------------------------------------------------------------------------- 1 | # This FontForge script patches fonts in GUST’s Latin Modern family to fix two 2 | # issues with their metrics: 3 | # 4 | # 1. In the OS/2 table, the USE_TYPO_METRICS bit of the fsSelection field is 5 | # not set. 6 | # 7 | # 2. The metrics in the hhea table differ (significantly) from the metrics in 8 | # the OS/2 table. 9 | # 10 | # (These issues are only present in the Latin Modern *text* fonts. Latin Modern 11 | # Math does not have this issue, so it does not need to be patched.) 12 | # 13 | # These issues are unintentional, as the following discussion confirms: 14 | # 15 | # 16 | # 17 | # Unfortunately, fixes have not, as of this writing, been released to CTAN, so 18 | # this script is needed as a workaround in the meantime. 19 | 20 | import fontforge 21 | 22 | out_family = 'Blackboard Modern' 23 | 24 | def fix_lm(in_path, out_family_base, out_style): 25 | lm = fontforge.open(in_path) 26 | 27 | lm.hhea_ascent = lm.os2_typoascent 28 | lm.hhea_descent = lm.os2_typodescent 29 | lm.hhea_linegap = lm.os2_typolinegap 30 | lm.os2_use_typo_metrics = True 31 | 32 | out_name = f'BlackboardModern{out_family_base}-{out_style}' 33 | out_family = f'Blackboard Modern {out_family_base}' 34 | 35 | def update_sfnt_name(language, strid, in_str): 36 | out_str = in_str 37 | if language == 'English (US)': 38 | if strid in ['Family', 'Preferred Family']: 39 | out_str = out_family 40 | elif strid in ['Styles (SubFamily)', 'Preferred Styles']: 41 | out_str = out_style 42 | elif strid == 'Compatible Full': 43 | out_str = out_name 44 | elif strid == 'Version': 45 | out_str = '2.005.1' 46 | elif strid == 'UniqueID': 47 | out_str = f'2.005.1;{out_name}' 48 | return (language, strid, out_str) 49 | 50 | lm.fontname = out_name 51 | lm.fullname = out_name 52 | lm.familyname = out_family 53 | lm.sfnt_names = tuple(update_sfnt_name(*tup) for tup in lm.sfnt_names) 54 | lm.generate(f'{out_name}.otf') 55 | 56 | fix_lm('/usr/share/texmf/fonts/opentype/public/lm/lmroman10-regular.otf', 57 | 'Roman', 'Regular') 58 | fix_lm('/usr/share/texmf/fonts/opentype/public/lm/lmroman10-bold.otf', 59 | 'Roman', 'Bold') 60 | fix_lm('/usr/share/texmf/fonts/opentype/public/lm/lmroman10-italic.otf', 61 | 'Roman', 'Italic') 62 | fix_lm('/usr/share/texmf/fonts/opentype/public/lm/lmroman10-bolditalic.otf', 63 | 'Roman', 'BoldItalic') 64 | 65 | fix_lm('/usr/share/texmf/fonts/opentype/public/lm/lmsans10-regular.otf', 66 | 'Sans', 'Regular') 67 | fix_lm('/usr/share/texmf/fonts/opentype/public/lm/lmsans10-bold.otf', 68 | 'Sans', 'Bold') 69 | --------------------------------------------------------------------------------