typesetting/quad/quad/position.rkt

#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 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 #false))
  (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 #false))
  (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)
  (cond
    [(quad-ref q font-path-key #false)
     (* (/ (ascender q) (units-per-em q) 1.0) (fontsize q))]
    [else 0]))

(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) (vertical-baseline-offset q)]
                                   [_ 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 [ref-src #f])
  ;; recursively calculates coordinates for quad & subquads
  (define ref-pt (cond
                   [(quad? ref-src) (anchor->global-point ref-src (quad-from q))]
                   [ref-src] ; for passing explicit points in testing
                   [else (pt 0 0)]))
  (define this-origin (pt- ref-pt (to-point q)))
  (define shifted-origin (pt+ this-origin (quad-shift q)))
  ;; need to position before recurring, so subquads have accurate reference point
  (define positioned-q (struct-copy quad q
                                    [origin 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 (struct-copy quad positioned-q
                                 [origin (pt+ (quad-origin positioned-q) (quad-shift-elements positioned-q))]
                                 [shift-elements (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 this-q ref-q) prev-elems) rest)]
          [(cons x rest) (loop (cons x prev-elems) rest)]))))
  (struct-copy quad 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)))]))

(module+ test
  (require rackunit)
  (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)))