typesetting/quad/quad/position.rkt

#lang debug br
(require racket/contract "quad.rkt" "generic.rkt")
(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-anchor? anchor)
  (define valid-anchors '(nw n ne w c e sw s se bi bo))
  (and (memq anchor valid-anchors) #t))


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

(define fonts (make-hash))

(define/contract (ascender q)
  (quad? . -> . real?)
  (define p (hash-ref (attrs q) 'font "Courier"))
  (unless p
    (error 'ascender-no-font-key))
  (ascent (hash-ref! fonts p (λ () (openSync p)))))

(define/contract (units-per-em q)
  (quad? . -> . real?)
  (define p (hash-ref (attrs q) 'font "Courier"))
  (unless p
    (error 'units-per-em-no-font-key))
  (unitsPerEm (hash-ref! fonts p (λ () (openSync p)))))

(define (fontsize q)
  (define val (hash-ref (attrs q) 'fontsize 0))
  ((if (number? val) values string->number) val))


(define/contract (anchor->point q anchor)
  (quad? symbol? . -> . point?)
  (unless (valid-anchor? anchor)
    (raise-argument-error 'relative-anchor-pt "valid anchor" anchor))
  (cond
    [(eq? anchor 'bi) (pt 0 (* (/ (ascender q) (units-per-em q) 1.0) (fontsize q)))]
    [(eq? anchor 'bo) (pt (pt-x (size q)) (* (/ (ascender q) (units-per-em q) 1.0) (fontsize q)))]
    [else
     (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  )]))
     (match-define (list x y) (size q))
     (pt (coerce-int (* x x-fac)) (coerce-int (* y y-fac)))]))

(define point/c (quad? . -> . point?))

(define/contract (inner-point q)
  point/c
  (pt+ (origin q) (anchor->point q (inner q)) (offset q)))

(define/contract (in-point q)
  point/c
  (pt+ (origin q) (anchor->point q (in q))))

(define/contract (out-point q)
  point/c
  (pt+ (origin q) (anchor->point q (out q)))) ; no offset because end-point is calculated without padding


(define/contract (position q [previous-end-pt (origin q)])
  ((quad?) (point?) . ->* . quad?)
  (set-origin! q (pt- previous-end-pt (in-point q)))
  (for/fold ([pt (inner-point q)])
            ([q (in-list (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? (origin (position (quad (hasheq 'in 'nw 'size size)) orig)) (pt 5 5))
   (check-equal? (origin (position (quad (hasheq 'in 'n 'size size)) orig)) (pt 0 5))
   (check-equal? (origin (position (quad (hasheq 'in 'ne 'size size)) orig)) (pt -5 5))
   (check-equal? (origin (position (quad (hasheq 'in 'e 'size size)) orig)) (pt -5 0))
   (check-equal? (origin (position (quad (hasheq 'in 'se 'size size)) orig)) (pt -5 -5))
   (check-equal? (origin (position (quad (hasheq 'in 's 'size size)) orig)) (pt 0 -5))
   (check-equal? (origin (position (quad (hasheq 'in 'sw 'size size)) orig)) (pt 5 -5))
   (check-equal? (origin (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 fontkit/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 (attrs q) 'fontsize) 1.0))
  (check-equal? (in-point q) (list 0 ascender-scaled))
  (check-equal? (out-point q) (list 10 ascender-scaled)))