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.
132 lines
3.7 KiB
Racket
132 lines
3.7 KiB
Racket
#lang racket/base
|
|
(require racket/match racket/port racket/dict racket/struct)
|
|
(provide (all-defined-out))
|
|
|
|
;; structs
|
|
(define verbose-pitfall-printing? (make-parameter #f))
|
|
|
|
(struct pdf (pages
|
|
refs
|
|
root
|
|
info
|
|
opacity-registry
|
|
current-fill-color
|
|
ctm
|
|
ctm-stack
|
|
font-families
|
|
current-font-features
|
|
current-font-size
|
|
current-font
|
|
registered-fonts
|
|
font-count
|
|
line-gap
|
|
x
|
|
y
|
|
image-registry
|
|
output-path) #:transparent #:mutable
|
|
#:methods gen:custom-write
|
|
[(define write-proc
|
|
(make-constructor-style-printer
|
|
(λ (obj) 'pitfall-pdf)
|
|
(λ (obj) (append
|
|
(list (pdf-output-path obj))
|
|
(if (verbose-pitfall-printing?)
|
|
(list 'other-pdf-fields)
|
|
null)))))])
|
|
|
|
(struct pdf-font (name
|
|
id
|
|
ascender
|
|
descender
|
|
underline-position
|
|
underline-thickness
|
|
line-gap
|
|
bbox
|
|
ref
|
|
embedded
|
|
embed
|
|
encode
|
|
measure-string) #:transparent #:mutable
|
|
#:methods gen:custom-write
|
|
[(define write-proc
|
|
(make-constructor-style-printer
|
|
(λ (obj) 'pitfall-font)
|
|
(λ (obj) (append
|
|
(list (pdf-font-name obj))
|
|
(if (verbose-pitfall-printing?)
|
|
(list 'other-pdf-font-fields)
|
|
null)))))])
|
|
|
|
;; for JPEG and PNG
|
|
(struct $img (data label width height ref embed-proc) #:transparent #:mutable)
|
|
|
|
;; for reference
|
|
(struct $ref (id payload offset port) #:transparent #:mutable
|
|
#:methods gen:dict
|
|
[(define (dict-ref ref key [thunk (λ () (error 'dict-ref-key-not-found))])
|
|
(hash-ref ($ref-payload ref) key))
|
|
(define (dict-ref! ref key thunk)
|
|
(hash-ref! ($ref-payload ref) key thunk))
|
|
(define (dict-set! ref key val) (hash-set! ($ref-payload ref) key val))
|
|
(define (dict-update! ref key updater [failure-result (λ () (error 'update-no-key))])
|
|
(hash-update! ($ref-payload ref) key updater failure-result))])
|
|
|
|
;; params
|
|
|
|
|
|
(define test-mode (make-parameter #f))
|
|
(define current-compress-streams (make-parameter #f))
|
|
|
|
(define current-pdf-version (make-parameter 1.3))
|
|
(define current-auto-first-page (make-parameter #t))
|
|
(define current-auto-helvetica (make-parameter #t))
|
|
|
|
(define current-font (make-parameter #f))
|
|
(define current-font-size (make-parameter 12))
|
|
|
|
;; helpers
|
|
|
|
(define (round-js-style n)
|
|
;; always round up on 0.5
|
|
;; contra racket, which rounds toward even on 0.5
|
|
(let* ([n (* n 1e6)]
|
|
[r (round n)])
|
|
(/ (if (= .5 (- n r))
|
|
(add1 r)
|
|
r)
|
|
1e6)))
|
|
|
|
(define (numberizer x #:round [round? #true])
|
|
(unless (and (number? x) (< -1e21 x 1e21))
|
|
(raise-argument-error 'number "valid number" x))
|
|
(let ([x (if round? (round-js-style x) x)])
|
|
(number->string (if (integer? x)
|
|
(inexact->exact x)
|
|
x))))
|
|
|
|
(define (to-bytes x)
|
|
(match x
|
|
[(? bytes?) x]
|
|
[(? input-port?) (port->bytes x)]
|
|
[_ (string->bytes/latin-1 (string-append x "\n"))]))
|
|
|
|
(define (write-bytes-out x)
|
|
(void (write-bytes (to-bytes x))))
|
|
|
|
(define (bounded low x high)
|
|
(if (high . < . low)
|
|
(bounded high x low)
|
|
(max low (min high x))))
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
(check-equal? (bounded 0 2 1) 1)
|
|
(check-equal? (bounded 1 2 0) 1)
|
|
(check-equal? (bounded 0 -2 1) 0)
|
|
(check-equal? (bounded 1 -2 0) 0)
|
|
(check-equal? (bounded 0 .5 1) 0.5)
|
|
(check-equal? (bounded 0 0 1) 0)
|
|
(check-equal? (bounded 0 1 1) 1))
|
|
|
|
|