typesetting/quad/quad/position.rkt

#lang debug br
(require racket/contract "quad.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 point? (list/c number? number?))


(define valid-anchors '(nw n ne w c e sw s se bi bo))

(define (valid-anchor? anchor)
  (and (memq anchor valid-anchors) #t))

(define (random-anchor)
  (list-ref valid-anchors (random (length valid-anchors))))

(define (coerce-int x) (if (integer? x) (inexact->exact x) x))


(define (get-font p)
  (define fonts (make-hash))
  (hash-ref! fonts p (λ () (open-font p))))

(define ascender-cache (make-hash))
(define (ascender q)
  (define p (hash-ref (get-field attrs q) 'font "Courier"))
  (unless p
    (error 'ascender-no-font-key))
  (hash-ref! ascender-cache p (λ () (font-ascent (get-font p)))))

(define units-cache (make-hash))
(define (units-per-em q)
  (define p (hash-ref (get-field attrs q) 'font "Courier"))
  (unless p
    (error 'units-per-em-no-font-key))
  (hash-ref! units-cache p (λ () (font-units-per-em (get-font p)))))

(define (fontsize q)
  ;; this needs to not default to 0
  ;; needs parameter with default font size
  (define val (hash-ref (get-field attrs q) 'fontsize (λ () (error 'no-font-size))))
  ((if (number? val) values string->number) val))

(define (vertical-baseline-offset q)
  (* (/ (ascender q) (units-per-em q) 1.0) (fontsize q)))

(define (anchor->local-point q anchor)
  ;; calculate the location of the anchor on the bounding box relative to '(0 0) (aka "locally")
  (unless (valid-anchor? anchor)
    (raise-argument-error 'relative-anchor-pt "valid anchor" anchor))
  (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  )]
      [(bi) '(0 0  )]                  [(bo) '(1 0  )]))
  (match-define (list x y) (send q size))
  (pt (coerce-int (* x x-fac))
      (coerce-int (+ (* y y-fac) (if (memq anchor '(bi bo)) (vertical-baseline-offset q) 0)))))

(define (inner-point q)
  ;; calculate absolute location of inner-point
  ;; based on current origin and point type.
  ;; include offset, because it's intended to adjust inner 
  (pt+ (get-field origin q) (anchor->local-point q (or (get-field inner q) (get-field in q))) (get-field offset q)))

(define (in-point q)
  ;; calculate absolute location of in-point
  ;; based on current origin and point type.
  ;; don't include offset, so location is on bounding box
  (pt+ (get-field origin q) (anchor->local-point q (get-field in q))))

(define (out-point q)
  ;; calculate absolute location of out-point
  ;; based on current origin and point type.
  ;; don't include offset, so location is on bounding box
  (pt+ (get-field origin q) (anchor->local-point q (get-field out q))))

(define (position q [previous-end-pt #f])
  ;; recursively calculates coordinates for quad & subquads
  ;; based on starting origin point
  (set-field! origin q (if previous-end-pt
                           (pt- previous-end-pt (in-point q))
                           (in-point q)))
  (for/fold ([pt (inner-point q)])
            ([q (in-list (get-field elems q))]
             #:when (quad? q))
    (out-point (position q pt)))
  q)

(module+ test
  (require rackunit)
  #;(test-case
     "origins"
     (define size (pt 10 10))
     (define orig (pt 5 5))
     (check-equal? (get-field origin q (position (quad (hasheq 'in 'nw 'size size)) orig)) (pt 5 5))
     (check-equal? (get-field origin q (position (quad (hasheq 'in 'n 'size size)) orig)) (pt 0 5))
     (check-equal? (get-field origin q (position (quad (hasheq 'in 'ne 'size size)) orig)) (pt -5 5))
     (check-equal? (get-field origin q (position (quad (hasheq 'in 'e 'size size)) orig)) (pt -5 0))
     (check-equal? (get-field origin q (position (quad (hasheq 'in 'se 'size size)) orig)) (pt -5 -5))
     (check-equal? (get-field origin q (position (quad (hasheq 'in 's 'size size)) orig)) (pt 0 -5))
     (check-equal? (get-field origin q (position (quad (hasheq 'in 'sw 'size size)) orig)) (pt 5 -5))
     (check-equal? (get-field origin q (position (quad (hasheq 'in 'w 'size size)) orig)) (pt 5 0)))

  #;(test-case
     "in points"
     (check-equal? (in-point (quad (hasheq 'in 'nw 'size '(10 10) 'origin '(5 5)))) (pt 5 5))
     (check-equal? (in-point (quad (hasheq 'in 'n 'size '(10 10) 'origin '(5 5)))) (pt 10 5))
     (check-equal? (in-point (quad (hasheq 'in 'ne 'size '(10 10) 'origin '(5 5)))) (pt 15 5))
     (check-equal? (in-point (quad (hasheq 'in 'w 'size '(10 10) 'origin '(5 5)))) (pt 5 10))
     (check-equal? (in-point (quad (hasheq 'in 'c 'size '(10 10) 'origin '(5 5)))) (pt 10 10))
     (check-equal? (in-point (quad (hasheq 'in 'e 'size '(10 10) 'origin '(5 5)))) (pt 15 10))
     (check-equal? (in-point (quad (hasheq 'in 'sw 'size '(10 10) 'origin '(5 5)))) (pt 5 15))
     (check-equal? (in-point (quad (hasheq 'in 's 'size '(10 10) 'origin '(5 5)))) (pt 10 15))
     (check-equal? (in-point (quad (hasheq 'in 'se 'size '(10 10) 'origin '(5 5)))) (pt 15 15)))

  #;(test-case
     "out points"
     (check-equal? (out-point (quad (hasheq 'out 'nw 'size '(10 10) 'origin '(5 5)))) (pt 5 5))
     (check-equal? (out-point (quad (hasheq 'out 'n 'size '(10 10) 'origin '(5 5)))) (pt 10 5))
     (check-equal? (out-point (quad (hasheq 'out 'ne 'size '(10 10) 'origin '(5 5)))) (pt 15 5))
     (check-equal? (out-point (quad (hasheq 'out 'w 'size '(10 10) 'origin '(5 5)))) (pt 5 10))
     (check-equal? (out-point (quad (hasheq 'out 'c 'size '(10 10) 'origin '(5 5)))) (pt 10 10))
     (check-equal? (out-point (quad (hasheq 'out 'e 'size '(10 10) 'origin '(5 5)))) (pt 15 10))
     (check-equal? (out-point (quad (hasheq 'out 'sw 'size '(10 10) 'origin '(5 5)))) (pt 5 15))
     (check-equal? (out-point (quad (hasheq 'out 's 'size '(10 10) 'origin '(5 5)))) (pt 10 15))
     (check-equal? (out-point (quad (hasheq 'out 'se 'size '(10 10) 'origin '(5 5)))) (pt 15 15)))

  #;(test-case
     "inner points"
     (define size '(20 20))
     (define orig '(10 10))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'nw)) orig)) (pt 10 10))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'n)) orig)) (pt 20 10))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'ne)) orig)) (pt 30 10))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'e)) orig)) (pt 30 20))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'se)) orig)) (pt 30 30))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 's)) orig)) (pt 20 30))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'sw)) orig)) (pt 10 30))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'w)) orig)) (pt 10 20)))

  #;(test-case
     "inner points with offsets"
     (define size (pt 10 10))
     (define orig (pt 0 0))
     (define off (pt (random 100) (random 100)))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'nw 'offset off)) orig)) (pt+ '(0 0) off))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'n 'offset off)) orig)) (pt+ '(5 0) off))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'ne 'offset off)) orig)) (pt+ '(10 0) off))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'e 'offset off)) orig)) (pt+ '(10 5) off))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'se 'offset off)) orig)) (pt+ '(10 10) off))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 's 'offset off)) orig)) (pt+ '(5 10) off))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'sw 'offset off)) orig)) (pt+ '(0 10) off))
     (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'w 'offset off)) orig)) (pt+ '(0 5) off)))

  #;(test-case
     "folding positions"
     (define (unit [attrs null] . elems) (apply quad (append attrs '(size (1 1))) elems))
     (check-equal? (position (unit null (unit '(out se) (unit) (unit) (unit))
                                   (unit '(out se) (unit) (unit) (unit))
                                   (unit '(out se) (unit) (unit) (unit))))
                   (unit '(origin (0 0))
                         (unit '(origin (0 0) out se)
                               (unit '(origin (0 0))) (unit '(origin (1 0))) (unit '(origin (2 0))))
                         (unit '(origin (1 1) out se)
                               (unit '(origin (1 1))) (unit '(origin (2 1))) (unit '(origin (3 1))))
                         (unit '(origin (2 2) out se)
                               (unit '(origin (2 2))) (unit '(origin (3 2))) (unit '(origin (4 2))))))))


(require racket/runtime-path fontland/font)
(define-runtime-path fira "fira.ttf")

(define q1 (quad (list 'in 'bi 'out 'bo 'size '(10 10) 'font fira 'fontsize 12)))
(define q2 (quad (list 'in 'bi 'out 'bo 'size '(10 10) 'font fira 'fontsize 24)))
(define q3 (quad (list 'in 'bi 'out 'bo 'size '(10 10) 'font fira 'fontsize 6)))
#;(position (quad #f q1 q2 q3))


#;(module+ test
    (require rackunit)
    (define q (quad (list 'in 'bi 'out 'bo 'size '(10 10) 'font fira 'fontsize 12)))
    (check-equal? (ascender q) 935)
    (check-equal? (units-per-em q) 1000)
    (define ascender-scaled (* (/ (ascender q) (units-per-em q)) (hash-ref (get-field attrs q) 'fontsize) 1.0))
    (check-equal? (in-point q) (list 0 ascender-scaled))
    (check-equal? (out-point q) (list 10 ascender-scaled)))