<<>> <> <> <> <<>> (define (write-interpress filename thunk) "makes a one-page interpress master; thunk should draw a picture to *default-context*, in point units" (let ((m (open-interpress-output filename)) (save-c *default-context*)) (write-interpress-page m (lambda (c) (set! *default-context* c) (scale 127/360000) (thunk) ) ) (set! *default-context* save-c) (close-interpress-output m) ) ) (define (read-ais-as-res filename white-pixel black-pixel) "Reads an AIS file, making an res-description" (let ((pixel-array (pixel-array-from-ais filename)) ) `((color-image ,pixel-array) (color-operator ,(make-gray-linear-color-operator white-pixel black-pixel '()))) ) ) (define (read-interpress-page filename page-number) "makes a thunk that draws a picture to *default-context*, in point units" (define m (open-interpress-input filename)) (define (thunk) "a page from an interpress master" (do-save-all (lambda () (scale 360000/127) (interpret-interpress-page m page-number *default-context*) )) ) thunk ) (define (add-filename-extension filename ext) "strips directory, replaces or provides filename extension" (define end (string-length filename)) (define (find-dot k) (if (= k 0) end (case (string-ref filename (- k 1)) ((#\.) (- k 1)) ((#\/ #\> #\]) end) (else (find-dot (- k 1))) ) ) ) (define (find-base-start k) (if (= k 0) 0 (case (string-ref filename (- k 1)) ((#\/ #\> #\]) k) (else (find-base-start (- k 1))) ) ) ) (string-append (substring filename (find-base-start end) (find-dot end)) "." ext) ) (define res-bpi 300) (define (interpress->mumble filename portrait? page-bitmap-action pages) "converts an interpress master to bitmaps" (let ((master-in (open-interpress-input filename)) (s-size (if portrait? (* 11 res-bpi) (* #e8.5 res-bpi))) (f-size (if portrait? (* #e8.5 res-bpi) (* 11 res-bpi))) ) (define page-buffer (make-pixelmap s-size f-size)) (define (fill-buffer page-number) (define c (make-bitmap-context page-buffer)) (when (not portrait?) (translate (* 11 res-bpi #e.5) (* #e8.5 res-bpi #e.5) c) (rotate -90 c) (translate (* #e8.5 res-bpi -#e.5) (* 11 res-bpi -#e.5) c) ) (scale (/ res-bpi #e0.0254) c) (set-gray 0 c) (mask-box 0 0 1 1 c) (set-gray 1 c) (interpret-interpress-page master-in page-number c) ) (define (do-interpress-compressed-page-range first-page last-page) (if (> first-page last-page) #t (begin (if (or (null? pages) (memv first-page (car pages))) (begin (display "[") (fill-buffer first-page) (display first-page) (page-bitmap-action page-buffer first-page) (display "] ") )) (do-interpress-compressed-page-range (+ first-page 1) last-page) ) ) ) (do-interpress-compressed-page-range 1 (interpress-input-page-count master-in)) (newline) (close-interpress-input master-in) ) ) (define (interpress->compressed filename . pages) "converts an interpress master to one that consists of compressed bitmaps" (let ((outputname (add-filename-extension filename "cip")) ) (define master-out (open-interpress-output outputname)) (define (write-buffer page-buffer page-number) (write-interpress-page master-out (lambda (out-c) (scale (/ #e0.0254 res-bpi) out-c) (translate (* #e8.5 res-bpi #e.5) (* 11 res-bpi #e.5) out-c) (rotate 90 out-c) (translate (* 11 res-bpi -#e.5) (* #e8.5 res-bpi -#e.5) out-c) (mask-pixel-array (xerox-compress-pixel-array (pixelmap->pixel-array page-buffer #t)) out-c) )) ) (interpress->mumble filename #f write-buffer pages) (close-interpress-output master-out) outputname ) ) (define (interpress->res filename compress? . pages) "converts pages of an interpress master to RES format bitmap files" (define output-names '()) (define (write-buffer page-buffer page-number) (define outputname (add-filename-extension filename (format #f "~a.res" page-number))) (define pa (pixelmap->pixel-array page-buffer #t)) (write-restricted-res (open-output-file outputname) (if compress? (xerox-compress-pixel-array pa) pa) res-bpi compress? (format #f "from page ~a of ~a" page-number filename) ) (set! output-names (cons outputname output-names)) ) (interpress->mumble filename #t write-buffer pages) (reverse output-names) ) <<(define (debug-compress interpress-master-name output-port res-bpi)>> <<(define master-in (open-interpress-input interpress-master-name))>> <<(define page-buffer (make-pixelmap (* #e8.5 res-bpi) (* 11 res-bpi)))>> <<(define (fill-buffer page-number)>> <<(define c (make-bitmap-context page-buffer))>> <<(translate (* 11 res-bpi #e.5) (* #e8.5 res-bpi #e.5) c)>> <<(rotate -90 c)>> <<(translate (* #e8.5 res-bpi -#e.5) (* 11 res-bpi -#e.5) c)>> <<(scale (/ res-bpi #e0.0254) c)>> <<(set-gray 0 c)>> <<(mask-box 0 0 1 1 c)>> <<(set-gray 1 c)>> <<(interpret-interpress-page master-in page-number c)>> <<)>> <<(fill-buffer 1)>> <<(display "Compressed form of " output-port)>> <<(display interpress-master-name output-port)>> <<(display ":" output-port)>> <<(newline output-port)>> <<(debug-xerox-compress-pixel-array (pixelmap->pixel-array page-buffer #t) output-port)>> <<)>> <<>> <<(define (interpress-page-frame c)>> <<"for debugging coordinate systems; assumes interpress initial coordinate system; puts frame around 8.5 x 11 inch page">> <<(let>> << ((w (* 8.5 0.0254))>> <<(h (* 11 0.0254))>> <<)>> <<(set-stroke-width 0.05 c)>> <<(set-stroke-end 'square)>> <<(mask-vector 0 0 w 0 c)>> <<(mask-vector 0 0 0 h c)>> <<(mask-vector w 0 w h c)>> <<(mask-vector 0 h w h c)>> <<(set-stroke-width 0.02 c)>> <<(mask-vector 0 0 0 1e-6 c)>> <<)>> <<)>> <<>>