branch: externals/svg-lib commit 778ef64d80ba3a45e7fab69d43812f762fc479b0 Author: Nicolas P. Rougier <nicolas.roug...@inria.fr> Commit: Nicolas P. Rougier <nicolas.roug...@inria.fr>
Full rewrite --- screenshot.png | Bin 468252 -> 480935 bytes svg-lib-demo.el | 31 ++-- svg-lib.el | 508 +++++++++++++++++++++----------------------------------- 3 files changed, 202 insertions(+), 337 deletions(-) diff --git a/screenshot.png b/screenshot.png index 6276b76..4af2b44 100644 Binary files a/screenshot.png and b/screenshot.png differ diff --git a/svg-lib-demo.el b/svg-lib-demo.el index dae4d1d..8ace83d 100644 --- a/svg-lib-demo.el +++ b/svg-lib-demo.el @@ -1,38 +1,41 @@ - (dotimes (i 5) - (insert-image (svg-lib-tag "TODO" :padding 1 + (insert-image (svg-lib-tag "TODO" nil :family "Roboto Mono" :weight (* (+ i 2) 100)))) (dotimes (i 10) - (insert-image (svg-lib-tag "TODO" :padding 1 :stroke (/ i 4.0)))) + (insert-image (svg-lib-tag "TODO" nil :padding 1 :thickness (/ i 4.0)))) (dotimes (i 10) - (insert-image (svg-lib-tag "TODO" :padding 1 :stroke 2 :radius i))) + (insert-image (svg-lib-tag "TODO" nil :thickness 2 :radius i))) (dotimes (i 10) - (insert-image (svg-lib-progress-bar (/ (+ i 1) 10.0) - :width 5 :margin 1 :stroke 2 :padding 2))) + (insert-image (svg-lib-progress (/ (+ i 1) 10.0) nil + :width 5 :margin 1 :thickness 2 :padding 2))) -(insert-image (svg-lib-progress-bar .75 - :bar-color "#999999" :line-color "#999999" :margin 0 - :fill-color "#f0f0f0" :radius 0 :stroke .5 :padding 0)) +(insert-image (svg-lib-progress .75 nil + :foreground "#999999" :stroke "#999999" :margin 0 + :background "#f0f0f0" :radius 0 :thickness .5 :padding 0)) -(insert-image (svg-lib-progress-bar 0.75 :radius 8 :stroke 2 :padding 0)) +(insert-image (svg-lib-progress 0.75 nil :radius 8 :thickness 2 :padding 0)) +(dotimes (i 10) + (insert-image (svg-lib-icon "material" "star" nil + :scale (/ (+ i 1) 10.0)))) -(insert-image (svg-lib-icon "material" "star" :stroke 0)) -(insert-image (svg-lib-icon "material" "star" :stroke 1.5)) -(insert-image (svg-lib-icon "material" "star" :inverse t)) - + + +(insert-image (svg-lib-icon "material" "star" nil :radius 8 + :thickness 2 :scale 0.75 :padding 0)) + diff --git a/svg-lib.el b/svg-lib.el index 1c8a8f9..74a8237 100644 --- a/svg-lib.el +++ b/svg-lib.el @@ -30,13 +30,7 @@ ;; ;; (insert-image (svg-lib-tag "TODO")) ;; (insert-image (svg-lib-progress-bar 0.33)) -;; (insert-image (svg-lib-icon "material" "star" :stroke 0)) -;; -;; -;; (dotimes (i 10) -;; (insert-image (svg-lib-progress-bar (/ (+ i 1) 10.0) -;; :width 5 :margin 1 :stroke 2 :padding 2))) -;; +;; (insert-image (svg-lib-icon "material" "star")) ;; ;; Icons ares created by parsing remote collections whose license are ;; compatibles with GNU Emacs: @@ -80,61 +74,8 @@ :group 'convenience :prefix "svg-lib-") -(defcustom svg-lib-default-margin 1 - "Default margin in characters." - :type 'integer - :group 'svg-lib) - -(defcustom svg-lib-default-padding 1 - "Default padding in characters for tags, in pixels for bars & icons." - :type 'integer - :group 'svg-lib) - -(defcustom svg-lib-default-radius 3 - "Default radius in pixels." - :type 'integer - :group 'svg-lib) - -(defcustom svg-lib-default-zoom 1 - "Default zoom level for icons." - :type 'integer - :group 'svg-lib) - -(defcustom svg-lib-default-width 20 - "Default width of progress bar in characters." - :type 'integer - :group 'svg-lib) - -(defcustom svg-lib-default-stroke 1 - "Default stroke width in pixels." - :type 'integer - :group 'svg-lib) - -(defface svg-lib-default-face - `((t :foreground ,(face-attribute 'default :foreground) - :background ,(face-attribute 'default :background) - :box (:line-width ,svg-lib-default-stroke - :color ,(face-attribute 'default :foreground) - :style nil) - :family ,(face-attribute 'default :family) - :weight ,(face-attribute 'default :weight) - :height ,(if (display-graphic-p) - (- (face-attribute 'default :height) 20) - 1))) - "Default face used for all SVG objects" -:group 'svg-lib) - -;; SVG font weights translation -(defvar svg-lib--font-weights '((thin . 100) - (ultralight . 200) - (light . 300) - (regular . 400) - (medium . 500) - (semibold . 600) - (bold . 700) - (extrabold . 800) - (black . 900))) - +;; Default icon collections +;; --------------------------------------------------------------------- (defcustom svg-lib-icon-collections '(("bootstrap" . "https://icons.getbootstrap.com/icons/%s.svg") @@ -158,218 +99,169 @@ collection (there are way too many to store them)." :group 'svg-lib) +;; Default style for all objects +;; --------------------------------------------------------------------- +(defcustom svg-lib-style-default + '(:foreground "black" :background "white" :stroke "black" + :thickness 2 :radius 3 :padding 1 :margin 1 :width 20 :scale 1.0 + :family "Roboto Mono" :height 12 :weight regular) + "Default style" + :group 'svg-lib) +;; Convert Emacs color to SVG color +;; --------------------------------------------------------------------- (defun svg-lib-convert-color (color-name) "Convert Emacs COLOR-NAME to #rrggbb form. If COLOR-NAME is unknown to Emacs, then return COLOR-NAME as-is." + (let ((rgb-color (color-name-to-rgb color-name))) (if rgb-color (apply #'color-rgb-to-hex (append rgb-color '(2))) color-name))) -(defun svg-lib-foreground (face) - "Return the foreground color of FACE, ensuring it is specified." - (face-attribute face :foreground nil 'default)) - -(defun svg-lib-background (face) - "Return the background color of FACE, ensuring it is specified." - (face-attribute face :background nil 'default)) - - -;; --- Tags ------------------------------------------------------------ -(defun svg-lib-tag (label &rest args) - "Create an SVG image displaying LABEL in a rounded box. - -Visual aspect can be controlled using the ARGS parameters: - - :face FACE The face to use - :radius RADIUS The radius in pixels of the box - :margin MARGIN The (external) margin in characters - :padding PADDING The (internal) padding in characters - :text-color TEXT-COLOR The color of the label - :line-color LINE-COLOR The border color of the box - :fill-color FILL-COLOR The background color of the box - :inverse INVERSE Whether to swap text and fill colors - :stroke STROKE The width in pixels of the border of the box - :weight WEIGHT The font weight of the label - (takes precedence over face) - :family FAMILY The font family of the label - (takes precedence over face)" - - (let* ((face (or (plist-get args :face) - 'svg-lib-default-face)) - (padding (or (plist-get args :padding) - svg-lib-default-padding)) - (margin (or (plist-get args :margin) - svg-lib-default-margin)) - (radius (or (plist-get args :radius) - svg-lib-default-radius)) - (inverse (or (plist-get args :inverse) - nil)) - - (text-color (or (plist-get args :text-color) - (if inverse - (svg-lib-background face) - (svg-lib-foreground face)))) - - (fill-color (or (plist-get args :fill-color) - (if inverse - (svg-lib-foreground face) - (svg-lib-background face)))) - - (line-color (or (plist-get args :line-color) - (plist-get args :text-color) - (plist-get (face-attribute face :box) :color) - text-color)) - - (stroke (or (plist-get args :stroke) - (plist-get (face-attribute face :box) :line-width) - svg-lib-default-stroke)) - - (weight (or (plist-get args :weight) - (face-attribute face :weight nil 'default))) - (weight (or (cdr (assoc weight svg-lib--font-weights)) - weight)) - (family (or (plist-get args :family) - (face-attribute face :family))) +;; SVG Library style build from partial specification +;; --------------------------------------------------------------------- +(defun svg-lib-style (&optional base &rest args) + "Build a news style using BASE and style elements ARGS." + + (let* ((default svg-lib-style-default) + (base (or base default)) + (keys (cl-loop for (key value) on default by 'cddr + collect key)) + (style '())) + + (dolist (key keys) + (setq style (if (plist-member args key) + (plist-put style key (plist-get args key)) + (plist-put style key (plist-get base key))))) + + ;; Convert emacs colors to SVG colors + (plist-put style :foreground + (svg-lib-convert-color (plist-get style :foreground))) + (plist-put style :background + (svg-lib-convert-color (plist-get style :background))) + (plist-put style :stroke + (svg-lib-convert-color (plist-get style :stroke))) + + ;; Convert emacs font weights to SVG font weights + (let ((weights + '((thin . 100) (ultralight . 200) (light . 300) + (regular . 400) (medium . 500) (semibold . 600) + (bold . 700) (extrabold . 800) (black . 900)))) + (plist-put style :weight + (or (cdr (assoc (plist-get style :weight) weights)) + (plist-get style :weight)))) + style)) + + +;; Create an image displaying LABEL in a rounded box. +;; --------------------------------------------------------------------- +(defun svg-lib-tag (label &optional style &rest args) + "Create an image displaying LABEL in a rounded box using given STYLE +and style elements ARGS." + + (let* ((default svg-lib-style-default) + (style (if style (apply #'svg-lib-style nil style) default)) + (style (if args (apply #'svg-lib-style style args) style)) + + (foreground (plist-get style :foreground)) + (background (plist-get style :background)) + (stroke (plist-get style :stroke)) + (size (plist-get style :height)) + (family (plist-get style :family)) + (weight (plist-get style :weight)) + (radius (plist-get style :radius)) + (margin (plist-get style :margin)) + (padding (plist-get style :padding)) + (thickness (plist-get style :thickness)) - (size (/ (face-attribute face :height nil 'default) 10)) - (ascent (elt (font-info (format "%s:%d" family size)) 8)) - - (tag-char-width (window-font-width nil face)) - (tag-char-height (window-font-height nil face)) (txt-char-width (window-font-width)) (txt-char-height (window-font-height)) - - (tag-width (* (+ (length label) padding) txt-char-width)) - (tag-height (* txt-char-height 0.9)) + (ascent (aref (font-info (format "%s:%d" family size)) 8)) + (tag-char-width (aref (font-info (format "%s:%d" family size)) 11)) + (tag-char-height (aref (font-info (format "%s:%d" family size)) 3)) + (tag-width (* (+ (length label) padding) txt-char-width)) + (tag-height (* txt-char-height 0.9)) - (svg-width (+ tag-width (* margin txt-char-width))) - (svg-height tag-height) + (svg-width (+ tag-width (* margin txt-char-width))) + (svg-height tag-height) (tag-x (/ (- svg-width tag-width) 2)) (text-x (+ tag-x (/ (- tag-width (* (length label) tag-char-width)) 2))) (text-y ascent) + (svg (svg-create svg-width svg-height))) - (if (>= stroke 0.25) + (if (>= thickness 0.25) (svg-rectangle svg tag-x 0 tag-width tag-height - :fill (svg-lib-convert-color line-color) - :rx radius)) - (svg-rectangle svg (+ tag-x (/ stroke 2.0)) (/ stroke 2.0) - (- tag-width stroke) (- tag-height stroke) - :fill (svg-lib-convert-color fill-color) - :rx (- radius (/ stroke 2.0))) - (svg-text svg label - :font-family family - :font-weight weight - :font-size size - :fill (svg-lib-convert-color text-color) - :x text-x - :y text-y) + :fill stroke :rx radius)) + (svg-rectangle svg (+ tag-x (/ thickness 2.0)) (/ thickness 2.0) + (- tag-width thickness) (- tag-height thickness) + :fill background :rx (- radius (/ thickness 2.0))) + (svg-text svg label + :font-family family :font-weight weight :font-size size + :fill foreground :x text-x :y text-y) (svg-image svg :scale 1 :ascent 'center))) +;; Create a progress bar +;; --------------------------------------------------------------------- +(defun svg-lib-progress (value &optional style &rest args) + "Create a progress bar image with value VALUE using given STYLE +and style elements ARGS." + + (let* ((default svg-lib-style-default) + (style (if style (apply #'svg-lib-style nil style) default)) + (style (if args (apply #'svg-lib-style style args) style)) + + (width (plist-get style :width)) + (foreground (plist-get style :foreground)) + (background (plist-get style :background)) + (stroke (plist-get style :stroke)) + (size (plist-get style :height)) + (family (plist-get style :family)) + (weight (plist-get style :weight)) + (radius (plist-get style :radius)) + (margin (plist-get style :margin)) + (padding (plist-get style :padding)) + (thickness (plist-get style :thickness)) -;; --- Progress bars --------------------------------------------------- -(defun svg-lib-progress-bar (value &rest args) - "Create a SVG progress bar image with value VALUE. - -Visual aspect can be controlled using the ARGS parameters: - - :face FACE The face to use - :width WIDTH Total width in characters of the bar - :radius RADIUS The radius in pixels of the bar - :margin MARGIN The (external) margin in characters - :padding PADDING The (internal) padding in pixels - :bar-color TEXT-COLOR The color of the progress bar - :line-color LINE-COLOR The border color of the bar - :fill-color FILL-COLOR The background color of the bar - :inverse INVERSE Whether to swap bar and fill colors - :stroke STROKE The width in pixels of the border of the bar" - - (let* ((face (or (plist-get args :face) - 'svg-lib-default-face)) - (padding (or (plist-get args :padding) - svg-lib-default-padding)) - (margin (or (plist-get args :margin) - svg-lib-default-margin)) - (radius (or (plist-get args :radius) - svg-lib-default-radius)) - (inverse (or (plist-get args :inverse) - nil)) - - (bar-color (or (plist-get args :bar-color) - (if inverse - (svg-lib-background face) - (svg-lib-foreground face)))) - - (fill-color (or (plist-get args :fill-color) - (if inverse - (svg-lib-foreground face) - (svg-lib-background face)))) - - (line-color (or (plist-get args :line-color) - (plist-get args :text-color) - (plist-get (face-attribute face :box) :color) - bar-color)) - - (stroke (or (plist-get args :stroke) - (plist-get (face-attribute face :box) :line-width) - svg-lib-default-stroke)) - (width (or (plist-get args :width) - svg-lib-default-width)) - - (weight (or (plist-get args :weight) - (face-attribute face :weight))) - (weight (cdr (assoc weight svg-lib--font-weights))) - - (family (or (plist-get args :family) - (face-attribute face :family))) - - (size (face-attribute face :height)) - (size (if (eq size 'unspecified) - (face-attribute 'default :height) size)) - (size (/ size 10)) - (ascent (elt (font-info (format "%s:%d" family size)) 8)) - - (tag-char-width (window-font-width nil face)) - (tag-char-height (window-font-height nil face)) (txt-char-width (window-font-width)) (txt-char-height (window-font-height)) - - (tag-width (* width txt-char-width)) - (tag-height (* txt-char-height 0.9)) + + (ascent (aref (font-info (format "%s:%d" family size)) 8)) + (tag-char-width (aref (font-info (format "%s:%d" family size)) 11)) + (tag-char-height (aref (font-info (format "%s:%d" family size)) 3)) + (tag-width (* width txt-char-width)) + (tag-height (* txt-char-height 0.9)) - (svg-width (+ tag-width (* margin txt-char-width))) - (svg-height tag-height) + (svg-width (+ tag-width (* margin txt-char-width))) + (svg-height tag-height) (tag-x (/ (- svg-width tag-width) 2)) (svg (svg-create svg-width svg-height))) - (if (>= stroke 0.25) + (if (>= thickness 0.25) (svg-rectangle svg tag-x 0 tag-width tag-height - :fill (svg-lib-convert-color line-color) - :rx radius)) - (svg-rectangle svg (+ tag-x (/ stroke 2.0)) - (/ stroke 2.0) - (- tag-width stroke) - (- tag-height stroke) - :fill (svg-lib-convert-color fill-color) - :rx (- radius (/ stroke 2.0))) - - (svg-rectangle svg (+ tag-x (/ stroke 2.0) padding) - (+ (/ stroke 2.0) padding) - (- (* value tag-width) stroke (* 2 padding)) - (- tag-height stroke (* 2 padding)) - :fill (svg-lib-convert-color bar-color) - :rx (- radius (/ stroke 2.0))) + :fill stroke :rx radius)) + (svg-rectangle svg (+ tag-x (/ thickness 2.0)) + (/ thickness 2.0) + (- tag-width thickness) + (- tag-height thickness) + :fill background :rx (- radius (/ thickness 2.0))) + (svg-rectangle svg (+ tag-x (/ thickness 2.0) padding) + (+ (/ thickness 2.0) padding) + (- (* value tag-width) thickness (* 2 padding)) + (- tag-height thickness (* 2 padding)) + :fill foreground :rx (- radius (/ thickness 2.0))) + (svg-image svg :scale 1 :ascent 'center))) -;; --- Icons ----------------------------------------------------------- +;; Create a rounded box icon +;; --------------------------------------------------------------------- (defun svg-lib--icon-get-data (collection name &optional force-reload) "Retrieve icon NAME from COLLECTION. @@ -393,103 +285,73 @@ Cached version is returned if it exists unless FORCE-RELOAD is t." (url-insert-buffer-contents buffer url) (xml-parse-region (point-min) (point-max)))))) -(defun svg-lib-icon (collection name &rest args) - "Create a SVG image displaying icon NAME from COLLECTION. - -Default size is 2x1 characters. -Visual aspect can be controlled using the ARGS parameters: - - :face FACE The face to use - :zoom ZOOM Size of the icon (interger value) - :radius RADIUS The radius in pixels of the box - :margin MARGIN The (external) margin in characters - :padding PADDING The (internal) padding in characters - :icon-color TEXT-COLOR The color of the icon - :line-color LINE-COLOR The border color of the box - :fill-color FILL-COLOR The background color of the box - :inverse INVERSE Whether to swap text and fill colors - :stroke STROKE The width in pixels of the border of the box" + +(defun svg-lib-icon (collection name &optional style &rest args) + "Create a SVG image displaying icon NAME from COLLECTION using +given STYLE and style elements ARGS." (let* ((root (svg-lib--icon-get-data collection name)) - (face (or (plist-get args :face) - 'svg-lib-default-face)) - (padding (or (plist-get args :padding) - svg-lib-default-padding)) - (margin (or (plist-get args :margin) - svg-lib-default-margin)) - (radius (or (plist-get args :radius) - svg-lib-default-radius)) - (zoom (or (plist-get args :zoom) - svg-lib-default-zoom)) - (inverse (or (plist-get args :inverse) - nil)) - (icon-color (or (plist-get args :icon-color) - (if inverse - (svg-lib-background face) - (svg-lib-foreground face)))) - (fill-color (or (plist-get args :fill-color) - (if inverse - (svg-lib-foreground face) - (svg-lib-background face)))) - (line-color (or (plist-get args :line-color) - (plist-get args :text-color) - (plist-get (face-attribute face :box) :color) - icon-color)) - (stroke (or (plist-get args :stroke) - (plist-get (face-attribute face :box) :line-width) - svg-lib-default-stroke)) + (default svg-lib-style-default) + (style (if style (apply #'svg-lib-style nil style) default)) + (style (if args (apply #'svg-lib-style style args) style)) + + (foreground (plist-get style :foreground)) + (background (plist-get style :background)) + (stroke (plist-get style :stroke)) + (size (plist-get style :height)) + (family (plist-get style :family)) + (weight (plist-get style :weight)) + (radius (plist-get style :radius)) + (margin (plist-get style :margin)) + (padding (plist-get style :padding)) + (thickness (plist-get style :thickness)) + (scale (plist-get style :scale)) + (width (+ 2 padding)) + + (txt-char-width (window-font-width)) + (txt-char-height (window-font-height)) + (box-width (* width txt-char-width)) + (box-height (* 0.90 txt-char-height)) + (svg-width (+ box-width (* margin txt-char-width))) + (svg-height box-height) + (box-x (/ (- svg-width box-width) 2)) + (box-y 0) ;; Read original viewbox (viewbox (cdr (assq 'viewBox (xml-node-attributes (car root))))) (viewbox (mapcar 'string-to-number (split-string viewbox))) - (view-x (nth 0 viewbox)) - (view-y (nth 1 viewbox)) - (view-width (nth 2 viewbox)) - (view-height (nth 3 viewbox)) - - ;; Set icon size (in pixels) to 2x1 characters - (svg-width (* (window-font-width) 2)) - (svg-height (* (window-font-height) 1)) - - ;; Compute the new viewbox (adjust y origin and height) - (ratio (/ view-width svg-width)) - (delta-h (ceiling (/ (- view-height (* svg-height ratio) ) 2))) - (view-y (- view-y delta-h)) - (view-height (+ view-height (* delta-h 2))) - - ;; Zoom the icon by using integer factor only - (zoom (max 1 (truncate (or zoom 1)))) - (svg-width (* svg-width zoom)) - (svg-height (* svg-height zoom)) - - (svg-viewbox (format "%f %f %f %f" - view-x view-y view-width view-height)) - (f-ratio (/ (float view-width) (float svg-width))) - (transform (format "translate(%f,%f) scale(%f)" view-x view-y f-ratio)) - (svg (svg-create svg-width svg-height - :viewBox svg-viewbox - :stroke-width 0 - :fill (svg-lib-convert-color fill-color)))) - - (if (>= stroke 0.25) - (svg-rectangle svg 0 0 svg-width svg-height - :fill (svg-lib-convert-color icon-color) - :rx radius - :transform transform)) - (svg-rectangle svg (/ stroke 2.0) (/ stroke 2.0) - (- svg-width stroke) (- svg-height stroke) - :fill (svg-lib-convert-color fill-color) - :rx (- radius (/ stroke 2.0)) - :transform transform) + (icon-x (nth 0 viewbox)) + (icon-y (nth 1 viewbox)) + (icon-width (nth 2 viewbox)) + (icon-height (nth 3 viewbox)) + (scale (* scale (/ (float box-height) (float icon-height)))) + (icon-transform + (format "translate(%f,%f) scale(%f) translate(%f,%f)" + (- icon-x ) + (- icon-y ) + scale + (- (/ svg-width 2 scale) (/ icon-width 2)) + (- (/ svg-height 2 scale) (/ icon-height 2)))) + + (svg (svg-create svg-width svg-height))) + (if (>= thickness 0.25) + (svg-rectangle svg box-x box-y box-width box-height + :fill stroke :rx radius)) + (svg-rectangle svg (+ box-x (/ thickness 2.0)) + (+ box-y (/ thickness 2.0)) + (- box-width thickness) + (- box-height thickness) + :fill background :rx (- radius (/ thickness 2.0))) + (dolist (item (xml-get-children (car root) 'path)) (let* ((attrs (xml-node-attributes item)) (path (cdr (assoc 'd attrs))) - (fill (or (cdr (assoc 'fill attrs)) - (svg-lib-convert-color icon-color)))) - (message fill) - (svg-node svg 'path :d path :fill fill))) + (fill (or (cdr (assoc 'fill attrs)) foreground))) + (svg-node svg 'path :d path + :fill foreground + :transform icon-transform))) (svg-image svg :ascent 'center :scale 1)))