;;; svg-lib.el --- SVG tags, progress bars & icons -*- lexical-binding: t -*-

;; Copyright (C) 2021-2023 Free Software Foundation, Inc.

;; Maintainer: Nicolas P. Rougier <Nicolas.Rougier@inria.fr>
;; URL: https://github.com/rougier/svg-lib
;; Version: 0.3
;; Package-Requires: ((emacs "27.1"))
;; Keywords: svg, icons, tags, convenience

;; This file is not part of GNU Emacs.

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; For a full copy of the GNU General Public License
;; see <https://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Usage example:
;;
;; (insert-image (svg-lib-tag "TODO"))
;; (insert-image (svg-lib-progress-bar 0.33))
;; (insert-image (svg-lib-icon "star"))
;;
;; Icons are created by parsing remote collections, whose license are
;; compatibles with GNU Emacs:
;;
;; - Boxicons (https://github.com/atisawd/boxicons), available under a
;;   Creative Commons 4.0 license. As of version 2.07 (December 2020),
;;   this collection offers 1500 icons in two styles (regular & solid).
;;   Gallery is available at https://boxicons.com/
;;
;; - Octicons (https://github.com/primer/octicons), available under a
;;   MIT License with some usage restriction for the GitHub logo. As of
;;   version 11.2.0 (December 2020), this collection offers 201 icons.
;;   Gallery available at https://primer.style/octicons/
;;
;; - Material (https://github.com/google/material-design-icons),
;;   available under an Apache 2.0 license. As of version 4.0.0
;;   (December 2020), this collection offers 500+ icons in 4 styles
;;   (filled, outlined, rounded, sharp). Gallery available at
;;   https://material.io/resources/icons/?style=baseline
;;
;; - Bootstrap (https://github.com/twbs/icons), available under a MIT
;;   license.  As of version 1.2.1 (December 2020), this collection
;;   offers 1200+ icons in 2 styles (regular & filled).  Gallery
;;   available at https://icons.getbootstrap.com/
;;
;; The default size of an icon is exactly 2x1 characters such that it
;; can be inserted inside a text without disturbing alignment.
;;
;; Note: Each icon is cached locally to speed-up loading the next time
;;       you use it. If for some reason the cache is corrupted you can
;;       force reload using the svg-icon-get-data function.
;;
;; If you want to add new collections (i.e. URL), make sure the icons
;; are monochrome and that their size is consistent.

;;; NEWS:

;; Version 0.3.1
;; - Added icon only button
;; - Added face-or-style option to creation functions
;; - Make svg-lib-tag more generic (can now create tag, icon or icon+tag)
;; - Various bug fixes

;; Version 0.3
;; - Renamed 'svg-lib-button' to 'svg-lib-icon+tag'
;; - Added interactive 'svg-lib-button' with associtated 'svg-lib-button-mode'
;; - Added proper documentation in the README

;; Version 0.2.8
;; - No background for icon when background color is nil
;; - Refactored date icons

;; Version 0.2.7
;; - Added a dynamic date icon

;; Version 0.2.6
;; - Bug fix with bootstrap icon directory

;; Version 0.2.5
;; - Bug fix in text size computation

;; Version 0.2.4
;; - Better error handling if SVG support is missing

;; Version 0.2.2
;; - Added a left/right crop style argument to allow for tags collage.

;; Version 0.2.1
;; - Added an alignment parameter for moving tags inside margins.

;; Version 0.2
;; - Fix most of the warnings.

;; Version 0.1:
;; - Submission to ELPA


;;; Code:
(require 'svg)
(require 'xml)
(require 'cl-lib)
(require 'color)

;; Check if Emacs has been compiled with svg support
(defun svg-lib--image (&rest args)
  ;; FIXME: Should `svg-image' perform this check instead?
  (unless (image-type-available-p 'svg)
     (error "svg-lib.el requires Emacs to be compiled with svg support.\n"))
  (apply #'svg-image args))

(defgroup svg-lib nil
  "SVG tags, bars & icons."
  :group 'convenience
  :prefix "svg-lib-")

(defface svg-lib-button-active-face
  `((t :foreground ,(face-foreground 'default)
       :background ,(face-background 'default)
       :family "RobotoMono Nerd Font"
       :weight regular
       :box (:line-width 2 :style nil)))
  "Default face for active button"
  :group 'svg-lib)

(defface svg-lib-button-hover-face
  `((t :foreground ,(face-background 'font-lock-comment-face nil 'default)
       :background ,(face-foreground 'font-lock-comment-face nil 'default)
       :family "RobotoMono Nerd Font"
       :weight semibold
       :box nil))
  "default face for when mouse is over the button"
  :group 'svg-lib)

(defface svg-lib-button-press-face
  `((t :foreground ,(face-background 'default)
       :background ,(face-foreground 'default)
       :family "RobotoMono Nerd Font"
       :weight semibold
       :box nil))
  "Default face for when button is prssed (mouse click or keyboard)"
  :group 'svg-lib)

;; Default icon collections
;; ---------------------------------------------------------------------
(defcustom  svg-lib-icon-collections
  '(("bootstrap" .
     "https://icons.getbootstrap.com/assets/icons/%s.svg")
    ("simple" .
     "https://raw.githubusercontent.com/simple-icons/simple-icons/develop/icons/%s.svg")
    ("material" .
     "https://raw.githubusercontent.com/Templarian/MaterialDesign/master/svg/%s.svg")
    ("octicons" .
     "https://raw.githubusercontent.com/primer/octicons/main/icons/%s-24.svg")
    ("boxicons" .
     "https://boxicons.com/static/img/svg/regular/bx-%s.svg")
    ("vscode" .
     "https://raw.githubusercontent.com/microsoft/vscode-icons/main/icons/light/%s.svg"))

  "Various icons collections stored as (name . base-url).

The name of the collection is used as a pointer for the various
icon creation methods.  The base-url is a string containing a %s
such that is can be replaced with the name of a specific icon.
User is responsible for finding/giving proper names for a given
collection (there are way too many to store them)."

  :type '(alist :key-type (string :tag "Name")
                :value-type (string :tag "URL"))
  :group 'svg-lib)

(defcustom svg-lib-icons-dir
  (expand-file-name (concat user-emacs-directory ".cache/svg-lib/"))
  "svg-lib icons directory."
  :group 'svg-lib
  :type 'directory)


;; Default style for all objects
(defun svg-lib-style-compute-default (&optional face)
  "Compute the default style according to face (which defaults
to the default face)."

  (let* ((face        (or face 'default))
         (font-family (face-attribute face :family nil 'default))
         (font-weight (face-attribute face :weight nil 'default))
         (font-size   (face-attribute face :height nil 'default))
         (font-size   (round (* font-size 0.085)))
         (foreground  (face-attribute face :foreground nil 'default))
         (background  (face-attribute face :background nil 'default)))

    `(:background    ,background
      :foreground    ,foreground

      :padding       1      ;; In characters (tag and icons) or pixels (progress)
      :margin        0      ;; In characters
      :stroke        2      ;; In pixels
      :radius        3      ;; In pixels
      :alignment     0.5    ;; Horizontal alignment (in fraction of margin)
      :width         20     ;; In characters
      :height        0.90   ;; Ratio of text line height
      :scale         0.75   ;; Icon scaling
      :ascent        center ;; Position / baseline
      :crop-left     nil    ;; Whether to crop on left (for collage with other tags)
      :crop-right    nil    ;; Whether to crop on right (for collage with other tags)

      :collection    "material" ;; Icon collection

      :font-family   ,font-family
      :font-size     ,font-size
      :font-weight   ,font-weight)))

(defcustom svg-lib-style-default
  nil
  "Default style"
  :type '(plist :key-type (choice (const :tag "Background" :background)
                                  (const :tag "Foreground" :foreground)
                                  (const :tag "Padding" :padding)
                                  (const :tag "Margin" :margin)
                                  (const :tag "Stroke" :stroke)
                                  (const :tag "Radius" :radius)
                                  (const :tag "Ascent" :ascent)
                                  (const :tag "Alignment" :alignment)
                                  (const :tag "Width" :width)
                                  (const :tag "Height" :height)
                                  (const :tag "Scale" :scale)
                                  (const :tag "Crop Left" :crop-left)
                                  (const :tag "Crop Right" :crop-right)
                                  (const :tag "Collection" :collection)
                                  (const :tag "Font Family" :font-family)
                                  (const :tag "Font Size" :font-size)
                                  (const :tag "Font Weight" :font-weight))
                :value-type (choice (const :tag "None" nil)
                                    (number)
                                    (string)
                                    (boolean)
                                    (symbol)))
  :group 'svg-lib)

(defun svg-lib-style-default--get ()
  "Get default style.

Should be considered the main way to get default style.
Will compute default style if not set. This is neccessary
in order to delay evaluation of default style until
everything is loaded."
  (or svg-lib-style-default (setq svg-lib-style-default
                                  (svg-lib-style-compute-default))))

(defvar-local svg-lib-button--press-id nil
  "Id of the currently pressed button (buffer local)")

(defvar-local svg-lib-button--hover-id nil
  "Id of the currently hovered button (buffer local)")

;; 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."
  (when color-name
    (let ((rgb-color (color-name-to-rgb color-name)))
      (if rgb-color
          (apply #'color-rgb-to-hex (append rgb-color '(2)))
        color-name))))

;; 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--get))
         (base (or base default))
         (keys (cl-loop for (key _value) on default by 'cddr
                        collect key))
         (style '()))

    (dolist (key keys)
      (setq style (cond ((plist-member args key)
                         (plist-put style key (plist-get args key)))
                         ((plist-member base key)
                          (plist-put style key (plist-get base key)))
                         (t
                          (plist-put style key (plist-get default 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)))

    ;; 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 :font-weight
                 (or (cdr (assoc (plist-get style :font-weight) weights))
                     (plist-get style :font-weight))))
    style))

(defun svg-lib-style-from-face (face &rest args)
  "Return a style from FACE and style element ARGS"

  (let* ((font-family (face-attribute face :family nil 'default))
         (font-weight (face-attribute face :weight nil 'default))
         (font-size   (face-attribute face :height nil 'default))
         (font-size   (round (* font-size 0.085)))
         (foreground  (face-attribute face :foreground nil 'default))
         (background  (face-attribute face :background nil 'default))
         (stroke      (or (plist-get (face-attribute face :box) ':line-width) nil))
         (style       `(:background ,background
                        :foreground ,foreground
                        ,@(when stroke `(:stroke ,stroke))
                        :font-family ,font-family
                        :font-size ,font-size
                        :font-weight ,font-weight))
         (base (svg-lib-style-default--get))
         (keys (cl-loop for (key _value) on base by 'cddr collect key)))
    (dolist (key keys)
      (cond ((plist-member args key)
             (plist-put style key (plist-get args key)))
            ((not (plist-member style key))
             (plist-put style key (plist-get base key)))))
    (svg-lib-style style)))


(defun svg-lib-tag (label &optional face-or-style &rest args)
  "Create an image displaying LABEL in a rounded box using given FACE-OR-STYLE
and additional style elements ARGS."

  (save-match-data
    (let* ((style (cond ((facep face-or-style)
                         (apply #'svg-lib-style-from-face face-or-style args))
                        (face-or-style
                         (apply #'svg-lib-style face-or-style args))
                      (t
                       (apply #'svg-lib-style (svg-lib-style-default--get) args))))
           (label-regex "\\[\\([a-zA-Z0-9]+:\\)?\\([a-zA-Z0-9 _-]+\\)\\] *\\(.+\\)?"))
      (if (string-match label-regex label)
          (let* ((collection (match-string 1 label))
                 (collection (if (stringp collection)
                                 (substring collection 0 -1)
                               (plist-get (svg-lib-style-default--get) ':collection)))
                 (icon       (match-string 2 label))
                 (label      (match-string 3 label)))
            (if (and (stringp label) (> (length label) 0))
                (svg-lib-icon+tag icon label style :collection collection)
              (svg-lib-icon icon style :collection collection)))
        (svg-lib-text-tag label style)))))


;; Create an image displaying LABEL in a rounded box.
(defun svg-lib-text-tag (label &optional face-or-style &rest args)
  "Create an image displaying LABEL in a rounded box using given FACE-OR-STYLE
and additional style elements ARGS."

  (let* ((style (cond ((facep face-or-style)
                       (apply #'svg-lib-style-from-face face-or-style args))
                      (face-or-style
                       (apply #'svg-lib-style face-or-style args))
                      (t
                       (apply #'svg-lib-style (svg-lib-style-default--get) args))))
         (foreground  (plist-get style :foreground))
         (background  (plist-get style :background))
         (crop-left   (plist-get style :crop-left))
         (crop-right  (plist-get style :crop-right))
         (alignment   (plist-get style :alignment))
         (stroke      (plist-get style :stroke))
         (height      (plist-get style :height))
         (radius      (plist-get style :radius))
         (margin      (plist-get style :margin))
         (padding     (plist-get style :padding))
         (font-size   (plist-get style :font-size))
         (font-family (plist-get style :font-family))
         (font-weight (plist-get style :font-weight))
         (txt-char-width  (window-font-width))
         (txt-char-height (window-font-height))
         (txt-char-height (if line-spacing
                              (+ txt-char-height line-spacing)
                            txt-char-height))
         (font-info       (font-info (format "%s-%d" font-family font-size)))
         (font-size       (aref font-info 2)) ;; redefine font-size
         (ascent          (aref font-info 8))
         (tag-char-width  (aref font-info 11))
         (tag-width       (* (+ (length label) padding) txt-char-width))
         (tag-height      (* txt-char-height height))
         (svg-width       (+ tag-width (* margin txt-char-width)))
         (svg-height      tag-height)
         (svg-ascent      (plist-get style :ascent))
         (tag-x  (* (- svg-width tag-width)  alignment))
         (text-x (+ tag-x (/ (- tag-width (* (length label) tag-char-width)) 2)))
         (text-y ascent)
         (tag-x      (if crop-left  (- tag-x     txt-char-width) tag-x))
         (tag-width  (if crop-left  (+ tag-width txt-char-width) tag-width))
         (text-x     (if crop-left  (- text-x (/ stroke 2)) text-x))
         (tag-width  (if crop-right (+ tag-width txt-char-width) tag-width))
         (text-x     (if crop-right (+ text-x (/ stroke 2)) text-x))

         (svg (svg-create svg-width svg-height)))

    (when (>= stroke 0.25)
      (svg-rectangle svg tag-x 0 tag-width tag-height
                     :fill foreground :rx radius))
    (svg-rectangle svg (+ tag-x (/ stroke 2.0)) (/ stroke 2.0)
                       (- tag-width stroke) (- tag-height stroke)
                       :fill background :rx (- radius (/ stroke 2.0)))
    (svg-text svg label
              :font-family font-family :font-weight font-weight  :font-size font-size
              :fill foreground :x text-x :y  text-y)
    (svg-lib--image svg :ascent svg-ascent)))


(defun svg-lib-progress-pie (value &optional face-or-style &rest args)
  "Create a progress pie image with value VALUE using given FACE-OR-STYLE
and additional style elements ARGS."

  (let* ((style (cond ((facep face-or-style)
                       (apply #'svg-lib-style-from-face face-or-style args))
                      (face-or-style
                       (apply #'svg-lib-style face-or-style args))
                      (t
                       (apply #'svg-lib-style (svg-lib-style-default--get) args))))
         (foreground  (plist-get style :foreground))
         (background  (plist-get style :background))
         (stroke      (plist-get style :stroke))
         (height      (plist-get style :height))
         (margin      (plist-get style :margin))
         (padding     (plist-get style :padding))
         (txt-char-width  (window-font-width))
         (txt-char-height (window-font-height))
         (tag-width       (* 2 txt-char-width))
         (tag-height      (* txt-char-height height))
         (svg-width       (+ tag-width (* margin txt-char-width)))
         (svg-height      tag-height)
         (svg-ascent      (plist-get style :ascent))
         (cx              (/ svg-width  2))
         (cy              (/ svg-height 2))
         (radius          (- (/ tag-height 2) (/ stroke 2)))
         (iradius         (- radius stroke (/ padding 2)))
         (angle0          (- (/ float-pi 2)))
         (x0              (+ cx (* iradius (cos angle0))))
         (y0              (+ cy (* iradius (sin angle0))))
         (angle1          (+ angle0 (* value 2 float-pi)))
         (x1              (+ cx (* iradius (cos angle1))))
         (y1              (+ cy (* iradius (sin angle1))))
         (large-arc       (>= (- angle1 angle0) float-pi))
         (svg (svg-create svg-width svg-height)))

    (when (>= stroke 0.25)
      (svg-circle svg cx cy radius :fill foreground))

    (svg-circle svg cx cy (- radius (/ stroke 2.0)) :fill background)

    (if (>= (- angle1 angle0) (* float-pi 2))
        (svg-circle svg cx cy iradius :fill foreground)
      (svg-path svg `((moveto ((,cx . ,cy)))
                    (lineto ((,x0 . ,y0)))
                    (elliptical-arc ((,iradius ,iradius ,x1 ,y1
                                      :sweep t :large-arc ,large-arc))))
              :fill foreground))
    (svg-lib--image svg :ascent svg-ascent)))



;; Create a progress bar
(defun svg-lib-progress-bar (value &optional face-or-style &rest args)
  "Create a progress bar image with value VALUE using given FACE-OR-STYLE
and additional style elements ARGS."

  (let* ((style (cond ((facep face-or-style)
                       (apply #'svg-lib-style-from-face face-or-style args))
                      (face-or-style
                       (apply #'svg-lib-style face-or-style args))
                      (t
                       (apply #'svg-lib-style (svg-lib-style-default--get) args))))
         (foreground  (plist-get style :foreground))
         (background  (plist-get style :background))
         (stroke      (plist-get style :stroke))
         (width       (plist-get style :width))
         (height      (plist-get style :height))
         (radius      (plist-get style :radius))
         (margin      (plist-get style :margin))
         (padding     (plist-get style :padding))
         (txt-char-width  (window-font-width))
         (txt-char-height (window-font-height))
         (tag-width       (* width txt-char-width))
         (tag-height      (* txt-char-height height))
         (svg-width       (+ tag-width (* margin txt-char-width)))
         (svg-height      tag-height)
         (svg-ascent      (plist-get style :ascent))
         (tag-x (/ (- svg-width tag-width) 2))
         (svg (svg-create svg-width svg-height)))

    (when (>= stroke 0.25)
      (svg-rectangle svg tag-x 0 tag-width tag-height
                     :fill foreground :rx radius))
    (svg-rectangle svg (+ tag-x (/ stroke 2.0))
                       (/ stroke 2.0)
                       (- tag-width stroke)
                       (- tag-height stroke)
                       :fill background :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 foreground :rx (- radius (/ stroke 2.0)))

    (svg-lib--image svg :ascent svg-ascent)))

;; Create a rounded box icon
(defun svg-lib--icon-get-data (collection name &optional force-reload)
  "Retrieve icon NAME from COLLECTION.

Cached version is returned if it exists unless FORCE-RELOAD is t."

  ;; Build url from collection and name without checking for error
  (let ((url (format (cdr (assoc collection svg-lib-icon-collections)) name)))
    ;; create the svg-lib-icons-dir if not exists
    (unless (file-exists-p svg-lib-icons-dir)
      (make-directory svg-lib-icons-dir t))
    (let* ((filename (expand-file-name (format "%s_%s.svg" collection name) svg-lib-icons-dir))
           (buffer (if (or force-reload (not (file-exists-p filename)))
                       (with-current-buffer (url-retrieve-synchronously url)
                         (goto-char (point-min))
                         (search-forward "\n\n")
                         (write-region (point) (point-max) filename)
                         (current-buffer))
                     (with-current-buffer (generate-new-buffer " *temp*")
                       (insert-file-contents filename)
                       (current-buffer)))))
      (with-current-buffer buffer
        (xml-parse-region (point-min) (point-max))))))


(defun svg-lib-icon (icon &optional face-or-style &rest args)
  "Create a SVG image displaying icon NAME from COLLECTION using
given FACE-OR-STYLE and additional style elements ARGS."

  (let* ((style (cond ((facep face-or-style)
                       (apply #'svg-lib-style-from-face face-or-style args))
                      (face-or-style
                       (apply #'svg-lib-style face-or-style args))
                      (t
                       (apply #'svg-lib-style (svg-lib-style-default--get) args))))
         (collection  (plist-get style :collection))
         (root (svg-lib--icon-get-data collection icon))
         (foreground  (plist-get style :foreground))
         (background  (plist-get style :background))
         (stroke      (plist-get style :stroke))
         (height      (plist-get style :height))
         (radius      (plist-get style :radius))
         (scale       (plist-get style :scale))
         (margin      (plist-get style :margin))
         (padding     (plist-get style :padding))
         (width      (+ 2 padding))
         (txt-char-width  (window-font-width))
         (txt-char-height (window-font-height))
         (box-width       (* width txt-char-width))
         (box-height      (* height txt-char-height))
         (svg-width       (+ box-width (* margin txt-char-width)))
         (svg-height      box-height)
         (svg-ascent      (plist-get style :ascent))
         (box-x           (/ (- svg-width box-width) 2))
         (box-y           0)
         (viewbox (cdr (assq 'viewBox (xml-node-attributes (car root)))))
         (viewbox (mapcar #'string-to-number (split-string viewbox)))
         (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)))

    (when (>= stroke 0.25)
      (svg-rectangle svg box-x box-y box-width box-height
                     :fill foreground :rx radius))
    (when background
      (svg-rectangle svg (+ box-x (/ stroke 2.0))
                     (+ box-y (/ stroke 2.0))
                     (- box-width stroke)
                     (- box-height stroke)
                     :fill background :rx (- radius (/ stroke 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)) foreground))
             )
        (svg-node svg 'path :d path
                            :fill foreground
                            :transform icon-transform)))
    (svg-lib--image svg :ascent svg-ascent)))



;; Create an image displaying LABEL in a rounded box.
(defun svg-lib-icon+tag (icon label &optional face-or-style &rest args)
  "Create an image displaying LABEL in a rounded box using given FACE-OR-STYLE
and additional style elements ARGS."

  (let* ((style (cond ((facep face-or-style)
                       (apply #'svg-lib-style-from-face face-or-style args))
                      (face-or-style
                       (apply #'svg-lib-style face-or-style args))
                      (t
                       (apply #'svg-lib-style (svg-lib-style-default--get) args))))
         (collection (plist-get style :collection))
         (root (svg-lib--icon-get-data collection icon))
         (foreground  (plist-get style :foreground))
         (background  (plist-get style :background))
         (stroke      (plist-get style :stroke))
         (height      (plist-get style :height))
         (radius      (plist-get style :radius))
         (scale       (plist-get style :scale))
         (margin      (plist-get style :margin))
         (padding     (plist-get style :padding))
         (font-size   (plist-get style :font-size))
         (font-family (plist-get style :font-family))
         (font-weight (plist-get style :font-weight))
         (label-length    (+ (length label) 2))
         (txt-char-width  (window-font-width))
         (txt-char-height (window-font-height))
         (font-info       (font-info (format "%s-%d" font-family font-size)))
         (ascent          (aref font-info 8))
         (tag-char-width  (aref font-info 11))
         (tag-width       (* (+ label-length padding) txt-char-width))
         (tag-height      (* txt-char-height height))
         (svg-width       (+ tag-width (* margin txt-char-width)))
         (svg-height      tag-height)
         (svg-ascent      (plist-get style :ascent))
         (tag-x (/ (- svg-width tag-width) 2))
         (text-x (+ tag-x (/ (- tag-width (* (length label) tag-char-width)) 2)))
         (text-x (+ text-x tag-char-width))
         (text-y ascent)
         (viewbox (cdr (assq 'viewBox (xml-node-attributes (car root)))))
         (viewbox (mapcar 'string-to-number (split-string viewbox)))
         (icon-x      (nth 0 viewbox))
         (icon-y      (nth 1 viewbox))
         (icon-width  (nth 2 viewbox))
         (icon-height (nth 3 viewbox))
         (scale       (* scale (/ (float tag-height) (float icon-height))))
         (icon-transform
          (format "translate(%f,%f) scale(%f) translate(%f,%f)"
                  (- icon-x )
                  (- icon-y )
                  scale
                  (- (/ (- text-x (* tag-char-width 1.25)) scale) (/ icon-width 2))
                  (- (/ svg-height 2 scale) (/ icon-height 2))))
         (svg (svg-create svg-width svg-height)))

    (when (>= stroke 0.25)
      (svg-rectangle svg tag-x 0 tag-width tag-height
                     :fill foreground :rx radius))
    (svg-rectangle svg (+ tag-x (/ stroke 2.0)) (/ stroke 2.0)
                       (- tag-width stroke) (- tag-height stroke)
                       :fill background :rx (- radius (/ stroke 2.0)))
    (svg-text svg label
              :font-family font-family :font-weight font-weight  :font-size font-size
              :fill foreground :x text-x :y text-y)


    (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)) foreground))
             )
        (svg-node svg 'path :d path
                            :fill foreground
                            :transform icon-transform)))
    (svg-lib--image svg :ascent svg-ascent)))


(defun svg-lib-date (&optional date face-or-style &rest args)
  "Create a two lines date icon showing given DATE, using given
FACE-OR-STYLE and additional style elements ARGS."

  (let* ((date (or date (current-time)))
         (month (upcase (format-time-string "%b" date)))
         (day (format-time-string "%d" date)))
    (apply 'svg-lib-box month day face-or-style args)))

(defun svg-lib-week-date (&optional date face-or-style &rest args)
  "Create a two lines date icon showing given DATE, using given
FACE-OR-STYLE and additional style elements ARGS."

  (let* ((date (or date (current-time)))
         (week (format-time-string "%W" date)))
    (apply 'svg-lib-box "WEEK" week face-or-style args)))

(defun svg-lib-day-date (&optional date face-or-style &rest args)
  "Create a two lines date icon showing given DATE, using given
FACE-OR-STYLE and additional style elements ARGS."

  (let* ((weekday (upcase (format-time-string "%a" date)))
         (day (format-time-string "%d" date)))
    (apply 'svg-lib-box weekday day face-or-style args)))


(defun svg-lib-box (top bottom &optional face-or-style &rest args)
  "Create a two lines icon showing given TOP and BOTTOM text, using
given STYLE and style elements ARGS."

  (let* ((style (cond ((facep face-or-style)
                       (apply #'svg-lib-style-from-face face-or-style args))
                      (face-or-style
                       (apply #'svg-lib-style face-or-style args))
                      (t
                       (apply #'svg-lib-style (svg-lib-style-default--get) args))))
         (foreground  (plist-get style :foreground))
         (background  (plist-get style :background))
         (stroke      (plist-get style :stroke))
         (width       (or (plist-get args :width) 5))
         (height      (or (plist-get args :height) 2))
         (radius      (plist-get style :radius))
         (margin      (plist-get style :margin))
         (font-size   (plist-get style :font-size))
         (font-family (plist-get style :font-family))
         (txt-char-width  (window-font-width))
         (txt-char-height (window-font-height))
         (tag-width       (* width txt-char-width))
         (tag-height      (* height txt-char-height))
         (svg-width       (+ tag-width (* margin txt-char-width)))
         (svg-height      tag-height)
         (svg-ascent      (or (plist-get style :ascent) 'center))
         (tag-x           (/ (- svg-width tag-width) 2) )
         (svg (svg-create svg-width svg-height)))

    (when (>= stroke 0.25)
      (svg-rectangle svg tag-x 0 tag-width tag-height
                     :fill foreground :rx radius))
    (svg-rectangle svg (+ tag-x (/ stroke 2.0))
                       (/ stroke 2.0)
                       (- tag-width stroke)
                       (- tag-height stroke)
                       :fill background :rx (- radius (/ stroke 2.0)))
    (svg-rectangle svg (+ tag-x (/ stroke 2.0))
                       (/ stroke 2.0)
                       (- tag-width stroke)
                       (- (/ tag-height 2) stroke)
                       :fill foreground :rx (- radius (/ stroke 2.0)))
    (svg-rectangle svg (+ tag-x (/ stroke 2.0))
                       (+ (/ stroke 2.0) (/ tag-height 3))
                       (- tag-width stroke)
                       (- (/ tag-height 2) stroke)
                       :fill background :rx 0)
    (svg-text svg top
              :font-family font-family
              :font-weight "bold"
              :font-size (* font-size 0.9)
              :fill background
              :text-anchor "middle"
              :x (/ svg-width 2)
              :y "+0.95em")
    (svg-text svg bottom
              :font-family font-family
              :font-weight "bold"
              :font-size (* font-size 1.7)
              :fill foreground ;;(face-foreground 'default)
              :text-anchor "middle"
              :x (/ svg-width 2)
              :y "+1.6em")
    (svg-lib--image svg :ascent svg-ascent)))

(defun svg-lib-concat (svg-image-1 svg-image-2)
  "Concatenate two svg images horizontally."

 (let* ((svg (car (with-temp-buffer
                        (insert (plist-get (cdr svg-image-1) :data))
                        (xml-parse-region (point-min) (point-max)))))
        (attrs (xml-node-attributes svg))
        (width-1 (string-to-number (cdr (assq 'width attrs))))
        (height-1 (string-to-number (cdr (assq 'height attrs))))
        (children-1 (xml-node-children svg))

        (svg (car (with-temp-buffer
                        (insert (plist-get (cdr svg-image-2) :data))
                        (xml-parse-region (point-min) (point-max)))))
        (attrs (xml-node-attributes svg))
        (width-2 (string-to-number (cdr (assq 'width attrs))))
        (height-2 (string-to-number (cdr (assq 'height attrs))))
        (children-2 (xml-node-children svg))

        (width (+ width-1 width-2))
        (height (max height-1 height-2))
        (transform (format "translate(%f,0)" width-1))
        (svg (svg-create width height)))

   (dolist (child children-1)
     (dom-append-child svg child))

   (dolist (child children-2)
     (unless (stringp child)
       (dom-set-attribute child 'transform transform))
     (dom-append-child svg child))
   svg))


(defvar svg-lib-button--id-counter 0
  "SVG button unique id counter")

(defun svg-lib-button--search (id)
  "Return region for the button with given ID"

  (save-excursion
    (goto-char (point-min))
    (save-match-data
      (when-let* ((match (text-property-search-forward 'button-id id t)))
        (cons (prop-match-beginning match)
              (prop-match-end match))))))

(defun svg-lib-button--at-point (&optional pos)
  "Return the button at point"
  (get-text-property (or pos (point)) 'button-id))

(defun svg-lib-button--get-state (id &optional region)
  "Return the state of button ID"

  (when-let* ((region (or region (svg-lib-button--search id))))
    (get-text-property (car region) 'button-state)))

(defun svg-lib-button--set-state (id state &optional no-reset)
  "Set the state of button ID to STATE, reset the state of any
hovered button unless NO-RESET is t"

  ;; Reset previous hover button state (if any)
  (when (and svg-lib-button--hover-id (not no-reset))
    (let ((prev-id svg-lib-button--hover-id))
      (setq-local svg-lib-button--hover-id nil)
      (svg-lib-button--set-state prev-id 'active)))

  ;; Set new state
  (when-let* ((inhibit-read-only t)
              (region (svg-lib-button--search id))
              (cur-state (svg-lib-button--get-state id region))
              (button-list (get-text-property (car region) 'button-list))
              (display (cdr (assoc state button-list))))
        (put-text-property (car region) (cdr region) 'display display)
        (put-text-property (car region) (cdr region) 'button-state state)
        (cond ((eq state 'hover)
               (setq-local svg-lib-button--hover-id id))
              ((eq state 'press)
               (setq-local svg-lib-button--press-id id)))))

(defun svg-lib-button--tooltip-hide (&rest _args)
  "Set currently press or highlighted button to default
state (active) and hover button at point if any."

  (when svg-lib-button--press-id
    (svg-lib-button--set-state svg-lib-button--press-id 'active))
  (when svg-lib-button--hover-id
    (svg-lib-button--set-state svg-lib-button--hover-id 'active))

  ;; Hover button at point (if any)
  (svg-lib-button--set-state (svg-lib-button--at-point) 'hover)
  (advice-remove 'tooltip-hide #'svg-lib-button--tooltip-hide))

(defun svg-lib-button--tooltip-show (pos)
  "Set button under mouse state to hover or press depending
on whether mouse button 1 is down (press) or up (hover)"

  (if (and (consp last-input-event)
           (string-match-p "down-mouse-1" (format "%s" (car last-input-event))))
      (svg-lib-button--set-state (svg-lib-button--at-point pos) 'press)
    (svg-lib-button--set-state (svg-lib-button--at-point pos) 'hover))
  (advice-add 'tooltip-hide :before #'svg-lib-button--tooltip-hide))

(defun svg-lib-button--mouse-down ()
  "Set button under mouse state to press."

  (interactive)
  (save-excursion
    (mouse-set-point last-input-event)
    (svg-lib-button--set-state (svg-lib-button--at-point) 'press))
  (advice-add 'tooltip-hide :before #'svg-lib-button--tooltip-hide))

(defun svg-lib-button--mouse-press ()
    "Set button under mouse state to default state (active) and call
button hook. If current buffer is minibuffer, it aborts it. It
would be better to simply exit minibuffer but this leads to focus
problem if the hook creates a frame."

  (interactive)

  ;; Here we check if mouse is still over the button
  (let ((mouse-point (save-excursion
                       (mouse-set-point last-input-event)
                       (point))))
    (if-let ((id (svg-lib-button--at-point mouse-point)))
        (svg-lib-button--set-state svg-lib-button--press-id 'hover)
      (svg-lib-button--set-state svg-lib-button--press-id 'active)))

  (when-let* ((region (svg-lib-button--search svg-lib-button--press-id))
              (hook (get-text-property (car region) 'button-hook)))
    (if (minibufferp nil t)
        (unwind-protect
            (abort-minibuffers)
          (funcall hook))
      (funcall hook))))

(defun svg-lib-button--mouse-drag ()
  "Update the state of the button under mouse"

  (interactive)
  (save-excursion
    (mouse-set-point last-input-event)
    (svg-lib-button--set-state (svg-lib-button--at-point) 'press)))

(defun svg-lib-button (label &optional hook help active hover press)
  "Make a button with given LABEL that will call HOOK when
pressed. The HELP text is displayed when mouse is hovering the
button. ACTIVE, HOVER and PRESS correspond to the different
states of the button and can be specified as a face-or-style or a
cons of face-or-style and additional style elements. LABEL can be
composed as \"[collection:icon] label\" resulting in an icon+tag
button.

For proper highlighting, `svg-lib-button-mode' needs to be
activated before inserting a button into a buffer."

  ;; Having a SVG button highlighted when mouse cursor is hovering is
  ;; not totally straightforward because Emacs lacks the proper
  ;; machinery to do so. There is actually a mouse-face property but it
  ;; only changes the face and cannot change the display property (that
  ;; is needed for SVG). To solve the problem, we can take advantage of
  ;; the tooltip machinery because it offers a hackable enter/exit event
  ;; that can be used to update the display at the proper time.
  ;;
  ;; To make this works, a few properties needs to be removed from
  ;; `font-lock-extra-managed-props' and `yank-excluded-properties'.
  ;; For org-mode, another hack is necessary because when org-mode
  ;; unfontifies a region (see `org-unfontify-region'), it removes the
  ;; local keymap that is used. You thus need to activate the
  ;; svg-lib-button-mode to have this set for you.

  (let* ((active (cond ((facep active)
                        (svg-lib-tag label active))
                       ((and (listp active) active)
                        (apply #'svg-lib-tag label (car active) (cdr active)))
                       (t
                        (svg-lib-tag label 'default
                                     :font-family (plist-get (svg-lib-style-default--get) ':font-family)
                                     :font-weight 'regular))))
         (hover (cond ((facep hover)
                       (svg-lib-tag label hover))
                      ((and (listp hover) hover)
                       (apply #'svg-lib-tag label (car hover) (cdr hover)))
                      (t
                       (svg-lib-tag label 'default
                                    :foreground (face-background 'default nil 'default)
                                    :background (face-foreground 'font-lock-comment-face nil 'default)
                                    :stroke 0
                                    :font-family (plist-get (svg-lib-style-default--get) ':font-family)
                                    :font-weight 'semibold))))
         (press (cond ((facep press)
                        (svg-lib-tag label press))
                       ((and (listp press) press)
                        (apply #'svg-lib-tag label (car press) (cdr press)))
                       (t
                        (svg-lib-tag label 'default
                                     :foreground (face-background 'default)
                                     :background (face-foreground 'default)
                                     :stroke 0
                                     :font-family (plist-get (svg-lib-style-default--get) ':font-family)
                                     :font-weight 'semibold))))
         (buttons `((active . ,active)
                    (hover . ,hover)
                    (press . ,press)))
         (state 'active))
    (setq svg-lib-button--id-counter (1+ svg-lib-button--id-counter))

    (propertize (concat label " ")
                'display (cdr (assoc state buttons))
                'svg-lib-button t
                'button-id svg-lib-button--id-counter
                'button-state state
                'button-list buttons
                'button-hook hook
                'front-sticky nil
                'rear-nonsticky t
                'keymap (define-keymap :suppress t
                          "<down-mouse-1>" #'svg-lib-button--mouse-down
                          "<mouse-1>"      #'svg-lib-button--mouse-press
                          "<drag-mouse-1>" #'svg-lib-button--mouse-drag)
                'help-echo `(lambda (_window _object pos)
                              (svg-lib-button--tooltip-show pos)
                               ,help)
                'pointer 'hand)))

(defun svg-lib-button--remove-text-properties (orig-fun beg end properties &optional object)
  "This advice function ensures keymap is not removed when in svg-lib-button-mode"

  (let ((properties (if (and svg-lib-button-mode (derived-mode-p 'org-mode))
                        (svg--plist-delete properties 'keymap)
                       properties)))
    (apply orig-fun (list beg end properties object))))

(define-minor-mode svg-lib-button-mode
  "Activate svg-lib-button-mode that takes care of activating tooltip
mode and removing some properties from `yank-excluded-properties'
and `font-lock-extra-managed-props' in order for highlight to
work properly. This mode also installs an advice on
`remove-text-properties' in org-mode in order to not delete the
`keymap' property that is necessary to detect mouse press events."

  :lighter "B"

  (when svg-lib-button-mode
    ;; This is necessary for detecting when mouse cursor enter or
    ;; leave a button
    (require 'tooltip)
    (tooltip-mode 1)

    ;; This is necessary for preventing org-mode to remove keymap when
    ;; unfontiying a region
    (advice-add #'remove-text-properties :around #'svg-lib-button--remove-text-properties)

    ;; This prevents help-echo to be removed.when button is copied/yanked
    (dolist (property '(help-echo keymap))
      (setq-local yank-excluded-properties
                  (remove property yank-excluded-properties)))

    ;; This prevents help-echo to be removed.by font-lock
    (dolist (property '(help-echo keymap display))
      (setq-local font-lock-extra-managed-props
                  (remove property font-lock-extra-managed-props))))

  (unless svg-lib-button-mode
    (advice-remove #'remove-text-properties #'svg-lib-button--remove-text-properties)))

(provide 'svg-lib)
;;; svg-lib.el ends here
