Making CL-PDF and CL-TYPESETTING work with images and URLs

pdf-img-url.lisp

(cl:in-package #:cl-pdf)

(defun draw-image (image x y dx dy rotation &optional keep-aspect-ratio)
  (when keep-aspect-ratio
    (unless (zerop dx)
      (let ((r1 (/ dy dx))
            (r2 (/ (height image) (width image))))
        (if (> r1 r2)
            (setf dy (* dx r2))
            (setf dx (/ dy r2))))))
  (with-saved-state (translate x y)
    (rotate rotation)
    (scale dx dy)
    (paint-image image)))


(in-package #:typeset)

(defclass uri-content (soft-box)
  ((uri :accessor uri :initarg :uri)
   (text :accessor uri-text :initarg :text)
   (text-style :accessor uri-text-style)))

(defun url (uri &optional text)
  (add-box (make-instance 'uri-content :uri uri :text (or text uri)
                          :dy *font-size*))
  (with-style (:color '(0 0 1))
    (put-string (or text uri))))

(defmethod stroke ((box uri-content) x y)
  (pdf:add-URI-link x y
                    (min (pdf::text-width (uri-text box)
                                          *font* *font-size*)
                         ;; only the first line will be clickable
                         (- (aref (pdf::bounds pdf:*page*) 2)
                            ;; arbitrary hard-coded value for right margin
                            60))
                    (dy box)
                    (uri box) :border nil))

(defun image (&rest args &key file inline center &allow-other-keys)
  (if inline
      (add-box (apply 'make-instance 'jpeg-box :allow-other-keys t args))
      (let* ((jpg (pdf:make-jpeg-image (pdf:read-jpeg-file file)))
             (jpg-box (apply 'make-instance 'jpeg-box
                             :allow-other-keys t args))
             (w (pdf:width jpg))
             (h (pdf:height jpg)))
        ;; scale large images to max 500px width
        (when (> w 500)
          (setf h (* h (/ 500 w))
                w 500))
        (setf (pdf-jpeg-obj jpg-box) jpg (offset jpg-box) 0
              (dx jpg-box) w
              (dy jpg-box) h)
        (add-box jpg-box))))

(defmethod stroke ((box jpeg-box) x y)
  (let ((jpg (pdf-jpeg-obj box)))
    (pdf:add-images-to-page jpg)
    (pdf:draw-image jpg
                    x (+ (- y (dy box)) (offset box))
                    (dx box) (dy box)
                    0 t)))