| 1 |
(in-package :bos.m2) |
|---|
| 2 |
|
|---|
| 3 |
(defun draw-coordinate (x y coord) |
|---|
| 4 |
(let ((font (pdf:get-font "Helvetica"))) |
|---|
| 5 |
(dolist (part (nreverse (cl-ppcre:split ", " |
|---|
| 6 |
(with-output-to-string (s) |
|---|
| 7 |
(apply #'geometry:format-lon-lat s coord))))) |
|---|
| 8 |
(pdf:draw-left-text x y part font 8 300) |
|---|
| 9 |
(incf y 10)))) |
|---|
| 10 |
|
|---|
| 11 |
(defun make-m2-pdf (contract &key print template) |
|---|
| 12 |
(flet ((render-m2s () |
|---|
| 13 |
(pdf:in-text-mode |
|---|
| 14 |
(destructuring-bind (bb-x bb-y bb-width bb-height) (contract-bounding-box contract) |
|---|
| 15 |
(let* ((m2s (sort (copy-list (contract-m2s contract)) |
|---|
| 16 |
(lambda (a b) |
|---|
| 17 |
(if (= (m2-y a) (m2-y b)) |
|---|
| 18 |
(- (m2-x a) (m2-x b)) |
|---|
| 19 |
(- (m2-y b) (m2-y b)))))) |
|---|
| 20 |
(first-m2 (first m2s)) |
|---|
| 21 |
(last-m2 (first (last m2s))) |
|---|
| 22 |
(scale (/ 80 (max bb-width bb-height)))) |
|---|
| 23 |
|
|---|
| 24 |
(draw-coordinate 110 160 (m2-lon-lat first-m2)) |
|---|
| 25 |
|
|---|
| 26 |
(unless (eq first-m2 last-m2) |
|---|
| 27 |
(draw-coordinate 190 40 (m2-lon-lat last-m2))) |
|---|
| 28 |
|
|---|
| 29 |
(pdf:translate (+ 65.0 (if (>= bb-width bb-height) 0 |
|---|
| 30 |
(* 0.5 (abs (- bb-width bb-height)) scale))) |
|---|
| 31 |
(+ 65.0 (if (>= bb-height bb-width) 0 |
|---|
| 32 |
(* 0.5 (abs (- bb-width bb-height)) scale)))) |
|---|
| 33 |
|
|---|
| 34 |
(pdf:scale scale scale) |
|---|
| 35 |
|
|---|
| 36 |
(pdf:set-line-width 0.05) |
|---|
| 37 |
(pdf:set-gray-stroke 0.6) |
|---|
| 38 |
(pdf:move-to 0 0) |
|---|
| 39 |
(pdf:line-to 0 bb-height) |
|---|
| 40 |
(pdf:line-to bb-width bb-height) |
|---|
| 41 |
(pdf:line-to bb-width 0) |
|---|
| 42 |
(pdf:close-and-stroke) |
|---|
| 43 |
(pdf:stroke) |
|---|
| 44 |
|
|---|
| 45 |
(pdf:set-line-width 0.1) |
|---|
| 46 |
(pdf:set-gray-stroke 0) |
|---|
| 47 |
(pdf:set-gray-fill 0.6) |
|---|
| 48 |
(pdf:set-line-join 2) |
|---|
| 49 |
|
|---|
| 50 |
(dolist (m2 (contract-m2s contract)) |
|---|
| 51 |
(let ((x (- (m2-x m2) bb-x)) |
|---|
| 52 |
(y (- (m2-y m2) bb-y))) |
|---|
| 53 |
(pdf:move-to x y) |
|---|
| 54 |
(pdf:line-to x (1+ y)) |
|---|
| 55 |
(pdf:line-to (1+ x) (1+ y)) |
|---|
| 56 |
(pdf:line-to (1+ x) y) |
|---|
| 57 |
(pdf:line-to x y) |
|---|
| 58 |
(pdf:close-fill-and-stroke))))))) |
|---|
| 59 |
(save-pdf () |
|---|
| 60 |
(pdf:write-document (contract-m2-pdf-pathname contract :print print)))) |
|---|
| 61 |
(if template |
|---|
| 62 |
(if print |
|---|
| 63 |
(pdf:with-existing-document (template) |
|---|
| 64 |
(pdf:with-existing-page (0) |
|---|
| 65 |
(pdf:insert-original-page-content)) |
|---|
| 66 |
(pdf:with-existing-page (1) |
|---|
| 67 |
(pdf:insert-original-page-content) |
|---|
| 68 |
(render-m2s)) |
|---|
| 69 |
(save-pdf)) |
|---|
| 70 |
(pdf:with-existing-document (template) |
|---|
| 71 |
(pdf:with-existing-page (0) |
|---|
| 72 |
(pdf:insert-original-page-content) |
|---|
| 73 |
(render-m2s)) |
|---|
| 74 |
(save-pdf))) |
|---|
| 75 |
(pdf:with-document () |
|---|
| 76 |
(pdf:with-page () |
|---|
| 77 |
(render-m2s)) |
|---|
| 78 |
(save-pdf))) |
|---|
| 79 |
t)) |
|---|
| 80 |
|
|---|
| 81 |
#+(or) |
|---|
| 82 |
(make-m2-pdf (random-elt (class-instances 'contract))) |
|---|
