Add image scaling support

full/assets.lisp

@@ -8,99 +8,106 @@
                 #:xref
                 #:xref-locative
                 #:xref-symbol)
-  (:export #:defasset))
+  (:export #:defimage))
 (in-package #:40ants-doc-full/assets)
 
 
-(defclass asset ()
+(defclass image ()
   ((name :initarg :name
-         :reader asset-name)
+         :reader image-name)
    (source :initarg :source
-           :reader asset-source)
+           :reader image-source)
    (target-filename :initarg :target-filename
-                    :reader asset-target-filename)
+                    :reader image-target-filename)
    (description :initarg :description
-                :reader asset-description)
+                :reader image-description)
    (width :initarg :width
           :initform nil
-          :reader asset-width)
+          :type (or null (integer 1 *))
+          :reader image-width)
    (height :initarg :height
            :initform nil
-           :reader asset-height)))
+           :type (or null (integer 1 *))
+           :reader image-height)))
 
 
-(defun make-asset (name source target-filename description &rest restargs
+(defun make-image (name source target-filename description &rest restargs
                     &key width height)
   (declare (ignore width height))
-  (apply #'make-instance 'asset
+  (apply #'make-instance 'image
          :name name
          :source source
          :target-filename target-filename
          :description description
          restargs))
 
 
-(defvar *assets* (make-hash-table :test #'eq))
+(defvar *images* (make-hash-table :test #'eq))
 
 
-(defun asset-symbol-p (symbol)
-  (not (null (gethash symbol *assets*))))
+(defun image-symbol-p (symbol)
+  (not (null (gethash symbol *images*))))
 
 
 (defmethod 40ants-doc::transform-symbol-entry :around ((entry symbol))
-  (or (gethash entry *assets*)
+  (or (gethash entry *images*)
       (call-next-method)))
 
 
-(defmethod 40ants-doc/object-package::object-package ((asset asset))
-  (symbol-package (asset-name asset)))
+(defmethod 40ants-doc/object-package::object-package ((image image))
+  (symbol-package (image-name image)))
 
 
 (defun pathname-designator-string (pathname-designator)
   (namestring (pathname pathname-designator)))
 
 
-(defun register-asset (name source &key target-filename description width height)
+(defun register-image (name source &key target-filename description width height)
   (check-type name symbol)
   (check-type source (or string pathname))
+  (check-type width (or null (integer 1 *)))
+  (check-type height (or null (integer 1 *)))
 
   (let* ((source (pathname-designator-string source))
          (target-filename (pathname-designator-string
                            (or target-filename source)))
          (description (or description
                           (symbol-name name)))
-         (new-asset (make-asset name source target-filename description
+         (new-image (make-image name source target-filename description
                                 :width width
                                 :height height))
-         (old-asset (gethash name *assets*)))
-    (when (and old-asset
-               (not (and (string= (asset-source old-asset)
-                                  (asset-source new-asset))
-                         (string= (asset-target-filename old-asset)
-                                  (asset-target-filename new-asset))
-                         (string= (asset-description old-asset)
-                                  (asset-description new-asset))
-                         (equal (asset-width old-asset)
-                                (asset-width new-asset))
-                         (equal (asset-height old-asset)
-                                (asset-height new-asset)))))
-      (error "Asset ~S is already registered with different properties."
+         (old-image (gethash name *images*)))
+    (when (and old-image
+               (not (and (string= (image-source old-image)
+                                  (image-source new-image))
+                         (string= (image-target-filename old-image)
+                                  (image-target-filename new-image))
+                         (string= (image-description old-image)
+                                  (image-description new-image))
+                         (equal (image-width old-image)
+                                (image-width new-image))
+                         (equal (image-height old-image)
+                                (image-height new-image)))))
+      (error "Image ~S is already registered with different properties."
              name))
-    (setf (gethash name *assets*) new-asset)
-    new-asset))
+    (setf (gethash name *images*) new-image)
+    new-image))
 
 
-(defmacro defasset (name source &rest args)
+(defmacro defimage (name source &rest args)
   "Register NAME as a local image used in documentation.
 
 SOURCE is a pathname designator.  By default, the file is copied to the
 same relative pathname below the documentation output directory.  Use
 :TARGET-FILENAME to choose another relative output pathname.
 
+:WIDTH and :HEIGHT are positive pixel values. Only supplied dimensions are
+emitted, so browsers preserve the image's aspect ratio when one is omitted.
+
 Every unqualified occurrence of NAME in prose is rendered as an image."
   (check-type name symbol)
   `(eval-when (:compile-toplevel :load-toplevel :execute)
-     (register-asset ',name ,source ,@args)))
+     (register-image ',name ,source ,@args)))
 
 
 (defun safe-target-filename-p (target-filename)
@@ -109,48 +116,48 @@ Every unqualified occurrence of NAME in prose is rendered as an image."
          (not (member :up (pathname-directory pathname))))))
 
 
-(defun validate-asset (asset)
+(defun validate-image (image)
   (unless (probe-file
            (40ants-doc-full/commondoc/image::resolve-local-image-path
-            (asset-source asset)))
-    (error "Asset ~S source file does not exist: ~A"
-           (asset-name asset)
-           (asset-source asset)))
-
-  (unless (safe-target-filename-p (asset-target-filename asset))
-    (error "Asset ~S target filename is not below the output directory: ~A"
-           (asset-name asset)
-           (asset-target-filename asset)))
-
-  (maphash (lambda (name other-asset)
-             (when (and (not (eq name (asset-name asset)))
-                        (string= (asset-target-filename other-asset)
-                                 (asset-target-filename asset)))
-               (error "Assets ~S and ~S use the same target filename: ~A"
-                      (asset-name asset)
+            (image-source image)))
+    (error "Image ~S source file does not exist: ~A"
+           (image-name image)
+           (image-source image)))
+
+  (unless (safe-target-filename-p (image-target-filename image))
+    (error "Image ~S target filename is not below the output directory: ~A"
+           (image-name image)
+           (image-target-filename image)))
+
+  (maphash (lambda (name other-image)
+             (when (and (not (eq name (image-name image)))
+                        (string= (image-target-filename other-image)
+                                 (image-target-filename image)))
+               (error "Images ~S and ~S use the same target filename: ~A"
+                      (image-name image)
                       name
-                      (asset-target-filename asset))))
-           *assets*)
-  asset)
+                      (image-target-filename image))))
+           *images*)
+  image)
 
 
-(defun asset-to-local-image (asset)
-  (validate-asset asset)
-  (local-image (asset-source asset)
-               :target-filename (asset-target-filename asset)
-               :description (asset-description asset)
-               :width (asset-width asset)
-               :height (asset-height asset)))
+(defun image-to-local-image (image)
+  (validate-image image)
+  (local-image (image-source image)
+               :target-filename (image-target-filename image)
+               :description (image-description image)
+               :width (image-width image)
+               :height (image-height image)))
 
 
-(defun replace-assets (document)
-  "Replace XREF nodes naming registered assets with local image nodes."
+(defun replace-images (document)
+  "Replace XREF nodes naming registered images with local image nodes."
   (map-nodes document
              (lambda (node)
                (if (and (typep node 'xref)
                         (null (xref-locative node)))
-                   (let ((asset (gethash (xref-symbol node) *assets*)))
-                     (if asset
-                         (asset-to-local-image asset)
+                   (let ((image (gethash (xref-symbol node) *images*)))
+                     (if image
+                         (image-to-local-image image)
                          node))
                    node))))

full/builder.lisp

@@ -75,7 +75,8 @@
   (40ants-doc-full/world::@world section))
 
 
-(defsection @rendering-multiple-formats (:title "Multiple Formats")
+(defsection @rendering-multiple-formats (:title "Multiple Formats"
+                                         :ignore-words ("PAGE"))
   "With 40ANTS-DOC you can render HTML and Markdown documentation simultaneously.
    This way, you can cross-reference entities from the README.md or ChangeLog.md to HTML docs.
 
@@ -211,8 +212,8 @@
 
 
 (defmethod 40ants-doc-full/commondoc/builder:to-commondoc
-    ((asset 40ants-doc-full/assets::asset))
-  (40ants-doc-full/assets::asset-to-local-image asset))
+    ((image 40ants-doc-full/assets::image))
+  (40ants-doc-full/assets::image-to-local-image image))
 
 
 ;;; Generate with the default HTML look
@@ -227,9 +228,9 @@
                     document
                     :predicate (if 40ants-doc-full/builder/printer:*document-uppercase-is-code*
                                    (constantly t)
-                                   #'40ants-doc-full/assets::asset-symbol-p)))
+                                   #'40ants-doc-full/assets::image-symbol-p)))
          (document (40ants-doc-full/commondoc/xref:fill-locatives document))
-         (document (40ants-doc-full/assets::replace-assets document))
+         (document (40ants-doc-full/assets::replace-images document))
          (document (40ants-doc-full/commondoc/section::fill-html-fragments document))
          (document (40ants-doc-full/commondoc/page::warn-on-references-to-internals document))
          (document (if 40ants-doc-full/link:*document-link-code*

full/commondoc/image.lisp

@@ -263,6 +263,14 @@
 (defmethod common-doc.format:emit-document ((format commondoc-markdown:markdown)
                                             (obj local-image)
                                             stream)
-  (format stream "![~A](~A)"
-          (common-doc:description obj)
-          (image-source obj)))
+  (let ((width (width obj))
+        (height (height obj)))
+    (if (or width height)
+        (format stream "<img src=\"~A\" alt=\"~A\"~@[ width=\"~A\"~]~@[ height=\"~A\"~]>"
+                (image-source obj)
+                (common-doc:description obj)
+                width
+                height)
+        (format stream "![~A](~A)"
+                (common-doc:description obj)
+                (image-source obj)))))

full/doc.lisp

@@ -67,7 +67,7 @@
                 #:width
                 #:local-image)
   (:import-from #:40ants-doc-full/assets
-                #:defasset)
+                #:defimage)
   (:import-from #:40ants-doc/object-package
                 #:object-package)
   (:export #:@index
@@ -109,7 +109,9 @@
       "3BMD"
       "PYTHONIC-STRING-READER"
       "DOCS-BUILDER"
-      "COMMON-DOC:DOCUMENT-NODE"))
+      "COMMON-DOC:DOCUMENT-NODE"
+      "DEFASSET"
+      "DEFIMAGE"))
 
 
   (defparameter *badges*
@@ -129,8 +131,9 @@
 </table>
 "))
 
-(defasset @logo.png "static/logo.png"
-  :description "40ants-doc logo")
+(defimage @logo.png "static/logo.png"
+  :description "40ants-doc logo"
+  :width 256)
 
 (defsection @index (:title "40Ants Doc Manual"
                     :ignore-words *ignore-words*)
@@ -691,14 +694,15 @@ See full list of changes in the 40ANTS-DOC/CHANGELOG::@CHANGELOG section.
   (height (reader local-image)))
 
 
-(defsection @declaring-assets (:title "Declaring Assets")
-  "Use DEFASSET to declare a local image once and render it anywhere in
-   prose by writing its name. The asset is copied to the documentation
+(defsection @declaring-assets (:title "Declaring Images")
+  "Use DEFIMAGE to declare a local image once and render it anywhere in
+   prose by writing its name. The image is copied to the documentation
    output directory, and its name becomes an HTML or Markdown image
    depending on the target format.
 
    ```lisp
-   (defasset @demo.gif #\"static/demo.gif\")
+   (defimage @demo.gif #\"static/demo.gif\"
+     :width 240)
 
    (defsection @example ()
      \"Here is @DEMO.GIF.\"
@@ -709,8 +713,13 @@ See full list of changes in the 40ANTS-DOC/CHANGELOG::@CHANGELOG section.
    By default, the source's relative pathname is retained below the
    output directory. Use the :TARGET-FILENAME option when the output
    name should differ. The target must stay below the output directory
-   and must be unique among declared assets."
-  (defasset macro))
+   and must be unique among declared images.
+
+   :WIDTH and :HEIGHT are positive pixel values. When only one is given, the
+   browser preserves the image's proportions. Markdown keeps ordinary image
+   syntax when no size is requested; with a size it
+   emits an HTML `<img>` tag, because standard Markdown has no dimensions."
+  (defimage macro))
 
 
 (defsection @reference-based-extensions