[elpa] externals/sketch-mode b944693 10/38: Add crop image feature AND add text transient into main

[ELPA Syncer]

branch: externals/sketch-mode
commit b9446933bcb21bf6ba558e0d640257f1748c7968
Author: Daniel Nicolai <dalanicolai@gmail.com>
Commit: Daniel Nicolai <dalanicolai@gmail.com>

    Add crop image feature AND add text transient into main
---
 README.org        |  15 +----
 sketch-mode.el    | 187 +++++++++++++++++++++++++++++++-----------------------
 sketch-scratch.el |  29 +++++++--
 3 files changed, 136 insertions(+), 95 deletions(-)

diff --git a/README.org b/README.org
index f198860..4e7bb4c 100644
--- a/README.org
+++ b/README.org
@@ -52,18 +52,9 @@
 
 * Sponsor the project
   Due to a combination of unfortunate circumstances, I am in an unfortunate
-  financial situation (dependent on my family), while I would love to get a
-  modest income. As you can see from my [projects page][link to be inserted]
-  this is not because I don't do (I hope useful) work. It is just that I don't
-  get paid, nor receive any allowance, for writing free software while working
-  on a thesis. Anyway, although I really prefer to make software available to
-  anyone who would like to use it (I know quite well the frustration of
-  "financial exclusion"), I would be very happy with a donation from users who
-  enjoy 'my' packages, and can easily afford it (e.g. by using the packages for
-  their work). Of course, if you'd like to see this package (or any of my other
-  packages) get developed further you could also consider to become a sponsor 
(I
-  have no experience with this kind of business, but I guess it starts with
-  letting users know about it).
+  financial situation (dependent on my family), therefore if you find [[my
+  package(s)]][project page link to be inserted] useful, and if you can afford 
it,
+  then I would be very happy with any small (or less small) donation.
 
   Accepted donation methods
   [[https://en.liberapay.com/dalanicolai/][liberapay]]
diff --git a/sketch-mode.el b/sketch-mode.el
index 05f2dd0..f4b3f2f 100644
--- a/sketch-mode.el
+++ b/sketch-mode.el
@@ -154,12 +154,12 @@ STOPS is a list of percentage/color pairs."
   "Create svg images using the mouse.
 In sketch-mode buffer press \\[sketch-transient] to activate the
 transient."
-  nil "sketch-mode"
+  :lighter "sketch-mode"
+  :keymap
   '(([drag-mouse-1] . sketch-interactively)
-    ([C-S-drag-mouse-1] . sketch-interactively)
+    ;; ([C-S-drag-mouse-1] . sketch-interactively)
     ("" . sketch-transient)))
 
-
 (defun sketch--circle-radius (start-coords end-coords)
   (sqrt (+ (expt (- (car end-coords) (car start-coords)) 2)
            (expt (- (cdr end-coords) (cdr start-coords)) 2))))
@@ -309,70 +309,6 @@ values"
                 (propertize (apply 'color-rgb-to-hex (color-name-to-rgb 
default))
                             'face 'transient-inactive-argument))))))
 
-(transient-define-prefix sketch-text ()
-  "Some Emacs magic"
-  :transient-suffix     'transient--do-call
-  :transient-non-suffix 'transient--do-stay
-  ["Font definitions"
-   [("f" "family" sketch-select-font)]
-   [("s" "stroke-color" sketch-font-size)
-    ("w" "fill-color" sketch-font-weight)]
-   ;; [("w" "stroke-width" sketch-stroke-width)]
-   [("m" "end-marker" sketch-object-marker)]]
-  ["Commands"
-   ([mouse-1] "Sketch"  sketch-text-interactively)]
-  [("q" "Quit"           transient-quit-one)])
-
-(transient-define-infix sketch-select-font ()
-  :description "Option with list"
-  :class 'transient-option
-  :argument "--family="
-  :choices (font-family-list))
-
-(transient-define-infix sketch-font-size ()
-  :description "Option with list"
-  :class 'transient-option
-  :argument "--font-size="
-  :choices (mapcar (lambda (x)
-                     (number-to-string x))
-                   (number-sequence 1 100)))
-
-(transient-define-infix sketch-font-weight ()
-  :description "Option with list"
-  :class 'sketch-variable:choices
-  :argument "--object="
-  :choices '("bold")
-  :default "normal")
-
-
-(transient-define-suffix sketch-text-interactively (event)
-  (interactive "@e")
-  (let* ((sketch-args (when transient-current-prefix (transient-args 
'sketch-transient)))
-         (text-args (when transient-current-prefix (transient-args 
'sketch-text)))
-         (start (event-start event))
-         (grid-param (plist-get (cdr (posn-image start)) :grid-param))
-         (snap (transient-arg-value "--snap-to-grid=" sketch-args))
-         (coords (if (or (not snap) (string= snap "nil"))
-                           (posn-object-x-y start)
-                         (sketch-snap-to-grid (posn-object-x-y start) 
grid-param)))
-         (text (read-string "Enter text: "))
-         (object-props (list :font-size
-                             (transient-arg-value "--font-size=" text-args)
-                             :font-weight
-                             (transient-arg-value "--font-weight=" text-args)
-                             )))
-                             ;; :fill
-                             ;; (transient-arg-value "--fill-color=" 
sketch-args)
-                             ;; :marker-end (if sketch-args (pcase 
(transient-arg-value "--marker=" sketch-args)
-                             ;;                        ("arrow" "url(#arrow)")
-                             ;;                        ("point" "url(#point)")
-                             ;;                        (_ "none"))
-                             ;;               (if sketch-include-end-marker
-                             ;;                   "url(#arrow)"
-                             ;;                 "none"))))
-    (apply 'svg-text svg-sketch text :x (car coords) :y (cdr coords) 
object-props))
-    (sketch-redraw))
-
   ;; (let* ((args (when transient-current-prefix (transient-args 
'sketch-transient)))
   ;;        (print event))))
     ;;      (start (event-start event))
@@ -413,22 +349,26 @@ values"
   "Some Emacs magic"
   :transient-suffix     'transient--do-call
   :transient-non-suffix 'transient--do-stay
+  [[("c" "stroke-color" sketch-stroke-color)
+    ("C" "fill-color" sketch-fill-color)]
+   [("w" "stroke-width" sketch-stroke-width)]]
   ["Object definitions"
    [("o" "object" sketch-object)]
-   [("c" "stroke-color" sketch-stroke-color)
-    ("C" "fill-color" sketch-fill-color)]
-   [("w" "stroke-width" sketch-stroke-width)]
    [("m" "end-marker" sketch-object-marker)]]
-  ["Font"
-   ("f" "Add text" sketch-text)]
+  ["Font definitions"
+   [("-f" "family" sketch-select-font)
+    ("-w" "font-weight" sketch-font-weight)]
+   [("-s" "font-size" sketch-font-size)]]
   ["Grid"
    ("s" "Snap to grid" sketch-snap)
    ("g" "Toggle grid" sketch-toggle-grid)]
   ["Labels"
    ("l" "Toggle labels" sketch-toggle-labels)]
   ["Commands"
-   [([drag-mouse-1] "Sketch"  sketch-interactively-1)
-    ("R" "Remove object" sketch-remove-object)
+   [([drag-mouse-1] "Draw object"  sketch-interactively-1)
+    ([mouse-1] "Draw text"  sketch-text-interactively)
+    ([C-S-drag-mouse-1] "Crop image" sketch-crop)]
+   [("R" "Remove object" sketch-remove-object)
     ("u" "Undo" sketch-undo)
     ("r" "Redo" sketch-redo)]
    [("d" "Show definition" sketch-show-definition)
@@ -524,6 +464,25 @@ values"
   (setq sketch-show-labels (if sketch-show-labels nil t))
   (sketch-redraw))
 
+(defun sketch-translate-node-coords (node amount &rest args)
+  (dolist (coord args node)
+    (cl-decf (alist-get coord (cadr node)) amount)))
+
+(defun svg-translate (dx dy)
+  (interactive)
+  (mapcar (lambda (node)
+            (pcase (car node)
+              ('line (sketch-translate-node-coords node dx 'x1 'x2)
+                     (sketch-translate-node-coords node dy 'y1 'y2))
+              ('rect (sketch-translate-node-coords node dx 'x)
+                     (sketch-translate-node-coords node dy 'y))
+              ((or 'circle 'ellipse)
+               (sketch-translate-node-coords node dx 'cx)
+               (sketch-translate-node-coords node dy 'cy))
+              ('text (sketch-translate-node-coords node dx 'x)
+                     (sketch-translate-node-coords node dy 'y))))
+          (cddr svg-sketch)))
+
 (defun sketch-redraw ()
   (unless sketch-mode
     (user-error "Not in sketch-mode buffer"))
@@ -611,17 +570,20 @@ values"
 (transient-define-suffix sketch-show-definition ()
   :transient 'transient--do-exit
   (interactive)
-  (let ((buffer (get-buffer-create "svg")))
+  (let ((buffer (get-buffer-create "svg"))
+        (sketch svg-sketch))
     (transient-quit-one)
-    (pp svg-sketch buffer)
     (switch-to-buffer-other-window buffer)
-    (emacs-lisp-mode)))
+    (erase-buffer)
+    (pp svg-sketch (current-buffer)))
+    (emacs-lisp-mode))
 
 (transient-define-suffix sketch-copy-definition ()
   (interactive)
   (with-temp-buffer
     (pp svg (current-buffer))
-    (kill-new (buffer-string))))
+    (kill-new (buffer-string)))
+  (message "SVG definition added to kill-ring"))
 
 (defun sketch-load-definition ()
   (interactive)
@@ -642,6 +604,75 @@ values"
     (setq svg-sketch (nreverse sketch-reverse)))
   (sketch-redraw))
 
+(transient-define-suffix sketch-text-interactively (event)
+  (interactive "@e")
+  (let* ((sketch-args (when transient-current-prefix (transient-args 
'sketch-transient)))
+         (start (event-start event))
+         (grid-param (plist-get (cdr (posn-image start)) :grid-param))
+         (snap (transient-arg-value "--snap-to-grid=" sketch-args))
+         (coords (if (or (not snap) (string= snap "nil"))
+                           (posn-object-x-y start)
+                         (sketch-snap-to-grid (posn-object-x-y start) 
grid-param)))
+         (text (read-string "Enter text: "))
+         (object-props (list :font-size
+                             (transient-arg-value "--font-size=" sketch-args)
+                             :font-weight
+                             (transient-arg-value "--font-weight=" sketch-args)
+                             )))
+                             ;; :fill
+                             ;; (transient-arg-value "--fill-color=" 
sketch-args)
+                             ;; :marker-end (if sketch-args (pcase 
(transient-arg-value "--marker=" sketch-args)
+                             ;;                        ("arrow" "url(#arrow)")
+                             ;;                        ("point" "url(#point)")
+                             ;;                        (_ "none"))
+                             ;;               (if sketch-include-end-marker
+                             ;;                   "url(#arrow)"
+                             ;;                 "none"))))
+    (apply 'svg-text svg-sketch text :x (car coords) :y (cdr coords) 
object-props))
+    (sketch-redraw))
+
+(transient-define-infix sketch-select-font ()
+  :description "Option with list"
+  :class 'transient-option
+  :argument "--family="
+  :choices (font-family-list))
+
+(transient-define-infix sketch-font-size ()
+  :description "Option with list"
+  :class 'transient-option
+  :argument "--font-size="
+  :choices (mapcar (lambda (x)
+                     (number-to-string x))
+                   (number-sequence 1 100)))
+
+(transient-define-infix sketch-font-weight ()
+  :description "Option with list"
+  :class 'sketch-variable:choices
+  :argument "--font-weight="
+  :choices '("bold")
+  :default "normal")
+
+(transient-define-suffix sketch-crop (event)
+  (interactive "@e")
+  (let* ((args (when transient-current-prefix (transient-args 
'sketch-transient)))
+         (start (event-start event))
+         (grid-param (plist-get (cdr (posn-image start)) :grid-param))
+         (snap (transient-arg-value "--snap-to-grid=" args))
+         (start-coords (if (or (not snap) (string= snap "nil"))
+                           (posn-object-x-y start)
+                         (sketch-snap-to-grid (posn-object-x-y start) 
grid-param)))
+         (end (event-end event))
+         (end-coords (if (or (not snap) (string= snap "nil"))
+                         (posn-object-x-y end)
+                       (sketch-snap-to-grid (posn-object-x-y end) grid-param)))
+         (new-width (abs (- (car end-coords) (car start-coords))))
+         (new-height (abs (- (cdr end-coords) (cdr start-coords)))))
+    (setq svg-canvas (svg-create new-width new-height :stroke "gray"))
+    (svg-marker svg-canvas "arrow" 8 8 "black" t)
+    (svg-rectangle svg-canvas 0 0 new-width new-height :fill "white")
+    (setf (cddr svg-sketch) (svg-translate (car start-coords) (cdr 
start-coords)))
+    (sketch-redraw)))
+
 (transient-define-suffix sketch-save ()
   (interactive)
   (image-save))
diff --git a/sketch-scratch.el b/sketch-scratch.el
index 1108976..c9f60b2 100644
--- a/sketch-scratch.el
+++ b/sketch-scratch.el
@@ -1,7 +1,26 @@
-(setq svg-scratch (svg-create 100 100))
-(svg-rectangle svg-scratch 25 25 50 50 :id "a")
-(svg-line svg-scratch 25 25 75 75 :id "b" :stroke-color "black")
+;; (setq svg-scratch (svg-create 100 100))
+;; (svg-rectangle svg-scratch 25 25 50 50 :id "a")
+;; (svg-line svg-scratch 25 25 75 75 :id "b" :stroke-color "black")
 
-;; (svg-remove svg-scratch "a")
+;; ;; (svg-remove svg-scratch "a")
 
-(insert-image (svg-image (append svg-scratch (nthcdr 2 svg-labels))))
+;; (insert-image (svg-image (append svg-scratch (nthcdr 2 svg-labels))))
+
+(defun sketch-translate-node-coords (node amount &rest args)
+  (dolist (coord args node)
+    (cl-decf (alist-get coord (cadr node)) amount)))
+
+(defun svg-translate (dx dy)
+  (interactive)
+  (mapcar (lambda (node)
+            (pcase (car node)
+              ('line (sketch-translate-node-coords node dx 'x1 'x2)
+                     (sketch-translate-node-coords node dx 'y1 'y2))
+              ('rect (sketch-translate-node-coords node dx 'x)
+                            (sketch-translate-node-coords node dx 'y))
+              ((or 'circle 'ellipse)
+               (sketch-translate-node-coords node dx 'cx)
+               (sketch-translate-node-coords node dx 'cy))
+              ('text (sketch-translate-node-coords node dx 'x)
+                     (sketch-translate-node-coords node dx 'y))))
+          (cddr svg-sketch)))