You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
239 lines
11 KiB
Racket
239 lines
11 KiB
Racket
#lang debug br
|
|
(require "quad.rkt" "param.rkt" fontland)
|
|
(provide (all-defined-out))
|
|
|
|
(define pt-x first)
|
|
(define pt-y second)
|
|
(define (pt x y) (list x y))
|
|
(define (pt+ . pts) (apply map + pts))
|
|
(define (pt- . pts) (apply map - pts))
|
|
|
|
(define (sum-base qs which)
|
|
(for/sum ([q (in-list qs)])
|
|
(which (size q))))
|
|
(define (sum-y qs) (sum-base qs pt-y))
|
|
(define (sum-x qs) (sum-base qs pt-x))
|
|
|
|
(define valid-anchors '(nw n ne w c e sw s se bi bo))
|
|
|
|
(define (coerce-int x) (if (integer? x) (inexact->exact x) x))
|
|
|
|
(define font-cache (make-hash))
|
|
(define (get-font font-name)
|
|
(hash-ref! font-cache font-name (λ () (open-font font-name))))
|
|
|
|
(define font-path-key 'font-path)
|
|
|
|
(define ascender-cache (make-hash))
|
|
(define (ascender q)
|
|
(define font-key-val (quad-ref q font-path-key))
|
|
(unless font-key-val
|
|
(error 'ascender-no-font-key))
|
|
(hash-ref! ascender-cache font-key-val (λ () (font-ascent (get-font font-key-val)))))
|
|
|
|
(define units-cache (make-hash))
|
|
(define (units-per-em q)
|
|
(define font-key-val (quad-ref q font-path-key))
|
|
(unless font-key-val
|
|
(error 'units-per-em-no-font-key))
|
|
(hash-ref! units-cache font-key-val (λ () (font-units-per-em (get-font font-key-val)))))
|
|
|
|
(define (fontsize q)
|
|
(define val (quad-ref q 'font-size current-default-font-size))
|
|
((if (number? val) values string->number) val))
|
|
|
|
(define (vertical-baseline-offset q [fallback-val 0])
|
|
(cond
|
|
[(quad-ref q font-path-key)
|
|
(* (/ (ascender q) (units-per-em q) 1.0) (fontsize q))]
|
|
[else fallback-val]))
|
|
|
|
(define (anchor->local-point q anchor)
|
|
;; calculate the location of the anchor on the bounding box relative to '(0 0) (aka "locally")
|
|
(match-define (list x-fac y-fac)
|
|
(case anchor
|
|
[(nw) '(0 0 )] [(n) '(0.5 0 )] [(ne) '(1 0 )]
|
|
[( w) '(0 0.5)] [(c) '(0.5 0.5)] [( e) '(1 0.5)]
|
|
[(sw) '(0 1 )] [(s) '(0.5 1 )] [(se) '(1 1 )]
|
|
[(baseline-in bi) '(0 0 )] [(baseline-out bo) '(1 0 )]
|
|
[else (raise-argument-error 'anchor->local-point (format "anchor value in ~v" valid-anchors) anchor)]))
|
|
(match-define (list x y) (size q))
|
|
(pt (coerce-int (* x x-fac))
|
|
(coerce-int (+ (* y y-fac) (match anchor
|
|
[(or 'bi 'bo 'baseline-in 'baseline-out)
|
|
;; if no font available, match baseline to south edge by passing y as fallback value
|
|
(vertical-baseline-offset q y)]
|
|
[_ 0])))))
|
|
|
|
(define (to-point q)
|
|
;; calculate absolute location
|
|
;; based on current origin and point type.
|
|
;; don't include offset, so location is on bounding box
|
|
(anchor->global-point q (quad-to q)))
|
|
|
|
(define (from-point q)
|
|
;; calculate absolute location
|
|
;; based on current origin and point type.
|
|
;; don't include offset, so location is on bounding box
|
|
(anchor->global-point q (quad-from q)))
|
|
|
|
(define (anchor->global-point q anchor)
|
|
;; don't include shift here: it should be baked into origin calculation
|
|
(pt+ (anchor->local-point q anchor) (quad-origin q)))
|
|
|
|
(define (position q-or-qs [ref-src #f])
|
|
(define-values (arg post-proc)
|
|
(match q-or-qs
|
|
[(? quad? q) (values q values)]
|
|
[(list (? quad? qs) ...) (values (make-quad #:elems qs) quad-elems)]))
|
|
(post-proc (position-one arg ref-src)))
|
|
|
|
(define (position-one q ref-src)
|
|
;; recursively calculates coordinates for quad & subquads
|
|
;; need to position before recurring, so subquads have accurate reference point
|
|
(define positioned-q
|
|
(quad-copy quad q
|
|
[origin (let* ([ref-pt (cond
|
|
[(quad? ref-src)
|
|
(anchor->global-point ref-src (or (quad-from-parent q) (quad-from q)))]
|
|
[ref-src] ; for passing explicit points in testing
|
|
[else (pt 0 0)])]
|
|
[this-origin (pt- ref-pt (to-point q))]
|
|
[shifted-origin (pt+ this-origin (quad-shift q))])
|
|
shifted-origin)]
|
|
;; set shift to zero because it's baked into new origin value
|
|
[shift (pt 0 0)]))
|
|
(define positioned-elems
|
|
;; for purposes of positioning the elements, we want to also bake in the `shift-elements` value
|
|
;; but we don't want this origin to be permanent on the parent.
|
|
;; akin to `push` a graphics state and then `pop` afterwards.
|
|
(let ([parent-q (quad-copy quad positioned-q
|
|
[origin (pt+ (quad-origin positioned-q) (quad-shift-elems positioned-q))]
|
|
[shift-elems (pt 0 0)])])
|
|
;; can't use for/list here because previous quads provide context for later ones
|
|
(let loop ([prev-elems null] [elems (quad-elems parent-q)])
|
|
(match elems
|
|
[(? null?) (reverse prev-elems)]
|
|
[(cons (? quad? this-q) rest)
|
|
(define ref-q (if (or (quad-from-parent this-q) (null? prev-elems))
|
|
parent-q
|
|
(car prev-elems)))
|
|
(loop (cons (position-one this-q ref-q) prev-elems) rest)]
|
|
[(cons x rest) (loop (cons x prev-elems) rest)]))))
|
|
(quad-update! positioned-q [elems positioned-elems]))
|
|
|
|
(define (distance q)
|
|
(match (pt- (from-point q) (to-point q))
|
|
[(list-no-order 0 val) val]
|
|
[(list ∆x ∆y) (sqrt (+ (expt ∆x 2) (expt ∆y 2)))]))
|
|
|
|
(define (flatten-quad q)
|
|
(cons (struct-copy quad q [elems null])
|
|
(apply append (map flatten-quad (quad-elems q)))))
|
|
|
|
(define (bounding-box . qs-in)
|
|
;; size of box that holds q and all subqs, based on reported origin and size
|
|
;; does not know anything about drawing (which may go outside the box)
|
|
(define qs (flatten-quad (make-quad #:elems qs-in)))
|
|
(define (outer-pt q) (pt+ (quad-origin q) (quad-size q)))
|
|
(define max-outer-pt (apply map max (cons '(0 0) (map outer-pt qs))))
|
|
(define min-origin (apply map min (cons '(0 0) (map quad-origin qs))))
|
|
(append min-origin max-outer-pt))
|
|
|
|
(define (attach-to from-q from-pt to-q to-pt)
|
|
(struct-copy quad from-q
|
|
[elems (cons (struct-copy quad to-q
|
|
[from-parent from-pt]
|
|
[to to-pt])
|
|
(quad-elems from-q))]))
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
|
|
(test-case
|
|
"bounding boxes"
|
|
(define q10 (make-quad #:size '(10 10)))
|
|
(define q20 (make-quad #:size '(20 20)))
|
|
(check-equal? (bounding-box q10) '(0 0 10 10))
|
|
(check-equal? (bounding-box (position (make-quad #:elems (list q10 q10)))) '(0 0 20 10))
|
|
(check-equal? (bounding-box q20) '(0 0 20 20))
|
|
(check-equal? (bounding-box (position (make-quad #:elems (list q10 q20)))) '(0 0 30 20))
|
|
(check-equal? (bounding-box (position (make-quad #:elems (list q10 q20 q20)))) '(0 0 50 20)))
|
|
|
|
(test-case
|
|
"origins"
|
|
(define size (pt 10 10))
|
|
(define orig (pt 5 5))
|
|
(check-equal? (quad-origin (position (q #:to 'nw #:size size) orig)) (pt 5 5))
|
|
(check-equal? (quad-origin (position (q #:to 'n #:size size) orig)) (pt 0 5))
|
|
(check-equal? (quad-origin (position (q #:to 'ne #:size size) orig)) (pt -5 5))
|
|
(check-equal? (quad-origin (position (q #:to 'e #:size size) orig)) (pt -5 0))
|
|
(check-equal? (quad-origin (position (q #:to 'se #:size size) orig)) (pt -5 -5))
|
|
(check-equal? (quad-origin (position (q #:to 's #:size size) orig)) (pt 0 -5))
|
|
(check-equal? (quad-origin (position (q #:to 'sw #:size size) orig)) (pt 5 -5))
|
|
(check-equal? (quad-origin (position (q #:to 'w #:size size) orig)) (pt 5 0)))
|
|
|
|
|
|
(test-case
|
|
"origins with shifts"
|
|
(define size (pt 10 10))
|
|
(define orig (pt 5 5))
|
|
(define shift (pt 3 3))
|
|
(check-equal? (quad-origin (position (q #:to 'nw #:size size #:shift shift) orig)) (pt+ (pt 5 5) shift))
|
|
(check-equal? (quad-origin (position (q #:to 'n #:size size #:shift shift) orig)) (pt+ (pt 0 5) shift))
|
|
(check-equal? (quad-origin (position (q #:to 'ne #:size size #:shift shift) orig)) (pt+ (pt -5 5) shift))
|
|
(check-equal? (quad-origin (position (q #:to 'e #:size size #:shift shift) orig)) (pt+ (pt -5 0) shift))
|
|
(check-equal? (quad-origin (position (q #:to 'se #:size size #:shift shift) orig)) (pt+ (pt -5 -5) shift))
|
|
(check-equal? (quad-origin (position (q #:to 's #:size size #:shift shift) orig)) (pt+ (pt 0 -5) shift))
|
|
(check-equal? (quad-origin (position (q #:to 'sw #:size size #:shift shift) orig)) (pt+ (pt 5 -5) shift))
|
|
(check-equal? (quad-origin (position (q #:to 'w #:size size #:shift shift) orig)) (pt+ (pt 5 0) shift)))
|
|
|
|
(test-case
|
|
"in points"
|
|
(define size '(10 10))
|
|
(define pos '(5 5))
|
|
(check-equal? (to-point (q #:to 'nw #:size size #:origin pos)) (pt 5 5))
|
|
(check-equal? (to-point (q #:to 'n #:size size #:origin pos)) (pt 10 5))
|
|
(check-equal? (to-point (q #:to 'ne #:size size #:origin pos)) (pt 15 5))
|
|
(check-equal? (to-point (q #:to 'w #:size size #:origin pos)) (pt 5 10))
|
|
(check-equal? (to-point (q #:to 'c #:size size #:origin pos)) (pt 10 10))
|
|
(check-equal? (to-point (q #:to 'e #:size size #:origin pos)) (pt 15 10))
|
|
(check-equal? (to-point (q #:to 'sw #:size size #:origin pos)) (pt 5 15))
|
|
(check-equal? (to-point (q #:to 's #:size size #:origin pos)) (pt 10 15))
|
|
(check-equal? (to-point (q #:to 'se #:size size #:origin pos)) (pt 15 15)))
|
|
|
|
|
|
(test-case
|
|
"out points"
|
|
(define size (pt 10 10))
|
|
(define pos (pt 5 5))
|
|
(check-equal? (from-point (q #:from 'nw #:size size #:origin pos)) (pt 5 5))
|
|
(check-equal? (from-point (q #:from 'n #:size size #:origin pos)) (pt 10 5))
|
|
(check-equal? (from-point (q #:from 'ne #:size size #:origin pos)) (pt 15 5))
|
|
(check-equal? (from-point (q #:from 'w #:size size #:origin pos)) (pt 5 10))
|
|
(check-equal? (from-point (q #:from 'c #:size size #:origin pos)) (pt 10 10))
|
|
(check-equal? (from-point (q #:from 'e #:size size #:origin pos)) (pt 15 10))
|
|
(check-equal? (from-point (q #:from 'sw #:size size #:origin pos)) (pt 5 15))
|
|
(check-equal? (from-point (q #:from 's #:size size #:origin pos)) (pt 10 15))
|
|
(check-equal? (from-point (q #:from 'se #:size size #:origin pos)) (pt 15 15)))
|
|
|
|
)
|
|
|
|
#;(module+ test
|
|
(require racket/runtime-path fontland/font)
|
|
(define-runtime-path fira "fira.ttf")
|
|
|
|
(define q1 (q (list 'in 'bi 'out 'bo 'size '(10 10) font-path-key fira 'fontsize 12)))
|
|
(define q2 (q (list 'in 'bi 'out 'bo 'size '(10 10) font-path-key fira 'fontsize 24)))
|
|
(define q3 (q (list 'in 'bi 'out 'bo 'size '(10 10) font-path-key fira 'fontsize 6)))
|
|
#;(position (q #f q1 q2 q3)))
|
|
|
|
|
|
#;(module+ test
|
|
(require rackunit)
|
|
(define q (q (list 'in 'bi 'out 'bo 'size '(10 10) font-path-key fira 'fontsize 12)))
|
|
(check-equal? (ascender q) 935)
|
|
(check-equal? (units-per-em q) 1000)
|
|
(define ascender-scaled (* (/ (ascender q) (units-per-em q)) (quad-ref q 'fontsize) 1.0))
|
|
(check-equal? (in-point q) (list 0 ascender-scaled))
|
|
(check-equal? (out-point q) (list 10 ascender-scaled))) |