[elpa] externals/sketch-mode 846f4a0 24/38: Implement layers (incl. reformat labels)

[ELPA Syncer]

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

    Implement layers (incl. reformat labels)
    
    Somehow the `sketch-modify-object`, possibly due to a bug in
    'save-current-buffer`
---
 sketch-mode.el | 289 ++++++++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 215 insertions(+), 74 deletions(-)

diff --git a/sketch-mode.el b/sketch-mode.el
index 16b9774..8b0e4f1 100644
--- a/sketch-mode.el
+++ b/sketch-mode.el
@@ -1,4 +1,4 @@
-;;; sketch-mode.el --- Quickly create svg sketches using keyboard and mouse 
-*- lexical-binding: t; -*-
+;; sketch-mode.el --- Quickly create svg sketches using keyboard and mouse -*- 
lexical-binding: t; -*-
 
 ;; Copyright (C) 2021  Free Software Foundation, Inc.
 
@@ -36,9 +36,9 @@
 
 ;; DONE move font transient (also its suffix) into main sketch transient 
(suffix)
 
-;; DONE add functionality to crop/select part of image (on save)
+;; DONE add functionality to crop/select part of image (on/before save)
 
-;; TODO add functionality to modify objects (see `add-object-modify-feature' 
branch)
+;; DONE(-partially) add functionality to modify objects (see 
`add-object-modify-feature' branch)
 
 ;; TODO enable defining global svg settings (object properties)
 
@@ -57,6 +57,13 @@
 ;; TODO create function to insert svg snippets (so you could design objects in
 ;; advanced software and use them quickly here in your sketches)
 
+;; TODO create function to save snippets
+
+;; TODO implement modularity. i.e. create 'layers' via svg groups <g> (related
+;; to snippet functionality)
+
+;; TODO create zoom functionality
+
 ;; NOTE this is a most straightforward sketch-mode. A more advanced/general 
version
 ;; could implement a drawing DSL based on nodes (a la tikz/asymptote etc.)
 
@@ -207,8 +214,10 @@ transient."
 
 (defvar sketch-svg)
 (defvar-local svg-canvas nil)
-(defvar-local svg-grid nil)
+(defvar-local sketch-grid nil)
 (defvar-local sketch-root nil)
+(defvar-local svg-layers nil)
+(defvar-local show-layers '(0))
 
 (defun sketch--create-canvas (width height &optional grid-parameter)
   "Create canvas for drawing svg using the mouse."
@@ -218,18 +227,18 @@ transient."
        (setq svg-canvas (svg-create width height :stroke "gray"))
        (svg-marker svg-canvas "arrow" 8 8 "black" t)
        (svg-rectangle svg-canvas 0 0 width height :fill "white")
-       (setq svg-grid (svg-create width height))
+       (setq sketch-grid (sketch-group "grid"))
        (let ((dash t))
          (dotimes (x (1- (/ width grid-parameter)))
            (let ((pos (* (1+ x) grid-parameter)))
-             (svg-line svg-grid pos 0 pos height :stroke-dasharray (when dash 
"2,4"))
+             (svg-line sketch-grid pos 0 pos height :stroke-dasharray (when 
dash "2,4"))
              (setq dash (if dash nil t)))))
        (let ((dash t))
          (dotimes (x (1- (/ height grid-parameter)))
            (let ((pos (* (1+ x) grid-parameter)))
-             (svg-line svg-grid 0 pos width pos :stroke-dasharray (when dash 
"2,4"))
+             (svg-line sketch-grid 0 pos width pos :stroke-dasharray (when 
dash "2,4"))
              (setq dash (if dash nil t)))))
-       (setq sketch-svg (append svg-canvas (when sketch-show-grid (cddr 
svg-grid))))
+       (setq sketch-svg (append svg-canvas (when sketch-show-grid (list 
sketch-grid))))
        (sketch-image sketch-svg
                   :grid-param grid-parameter
                   :pointer 'arrow
@@ -244,9 +253,14 @@ transient."
                                                                       (+ (cdr 
coords) sketch-im-y-offset)))))))))))
     (sketch-mode)
     (call-interactively 'sketch-transient)
-    (setq sketch-root (svg-create width height)))
+    (setq sketch-root (sketch-group "main"))
+    (sketch-add-layer))
 
+;; FIXME: `defvar' can't be meaningfully inside a function like that.
+;; FIXME: Use a `sketch-' prefix for all dynbound vars.
 (defvar-local sketch-elements nil)
+(defvar-local grid-param 25)
+(defvar-local active-layer 0)
 
 ;;;###autoload
 (defun sketch (arg)
@@ -261,9 +275,6 @@ values"
       (let ((width (if arg (car sketch-default-image-size) (read-number "Enter 
width: ") ))
             (height (if arg 600 (read-number "Enter height: "))))
         (switch-to-buffer (get-buffer-create "*sketch*"))
-        ;; FIXME: `defvar' can't be meaningfully inside a function like that.
-        ;; FIXME: Use a `sketch-' prefix for all dynbound vars.
-        (setq grid-param 25)
         (setq grid-param (if arg 25 (read-number "Enter grid parameter (enter 
0 for no grid): ")))
         (sketch--create-canvas width height grid-param)))))
 
@@ -406,12 +417,16 @@ values"
    ["Font definitions"
     ("-f" "family" sketch-select-font)
     ("-w" "font-weight" sketch-font-weight)
-    ("-s" "font-size" sketch-font-size)]
-   ["Grid"
+    ("-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)]]
+    ("l" sketch-cycle-labels)]
+   ["Layers"
+    ("L" sketch-layer)
+    ("-L" sketch-layers)
+    ("A" "Add layer" sketch-add-layer)]]
   ["Commands"
    [([sketch drag-mouse-1] "Draw object"  sketch-interactively-1)
     ([sketch mouse-1] "Draw text"  sketch-text-interactively)
@@ -466,15 +481,38 @@ values"
   :choices '("t")
   :default "nil")
 
-(defun sketch-toggle-grid ()
-  (interactive)
-  (with-current-buffer "*sketch*"
-    (setq sketch-show-grid (if sketch-show-grid nil t))
-    (sketch-redraw)))
+;; (defun sketch-toggle-grid ()
+;;   (interactive)
+;;   (with-current-buffer "*sketch*"
+;;     (setq sketch-show-grid (if sketch-show-grid nil t))
+;;     (sketch-redraw)))
+
+(cl-defmethod transient-infix-set ((obj sketch-variable:choices) value)
+  (let ((variable (oref obj variable)))
+    (oset obj value value)
+    (setq sketch-show-labels value)
+    (magit-refresh)
+    (sketch-redraw)
+    (unless (or value transient--prefix)
+      (message "Unset %s" variable))))
+
+(transient-define-infix sketch-cycle-labels ()
+  :description "Show labels"
+  :class 'sketch-variable:choices
+  ;; :variable "sketch-show-labels"
+  :variable 'sketch-show-labels
+  :argument "--labels="
+  :choices '("layer" "all")
+  :default "nil")
 
 (defun sketch-labels ()
   (interactive)
-  (let ((svg-labels (svg-create 100 100)))
+  (let ((nodes (pcase sketch-show-labels
+                 ("layer" (dom-children (nth active-layer svg-layers)))
+                 ("all" (apply #'append (mapcar (lambda (l)
+                                                  (dom-children (nth l 
svg-layers)))
+                                                show-layers)))))
+        (svg-labels (sketch-group "labels")))
     (mapc (lambda (node)
             (pcase (car node)
               ('rect (svg-text svg-labels
@@ -492,28 +530,52 @@ values"
                                :font-size 20
                                :stroke "red"
                                :fill "red"))))
-        (cddr sketch-root))
-    (cddr svg-labels)))
+        nodes)
+    svg-labels))
 
 (defun sketch-labels-list ()
-  (mapcar (lambda (node)
-            (dom-attr node 'id))
-          (cddr sketch-root)))
-
-(defun sketch-create-label ()
+  (apply #'append (mapcar (lambda (l)
+                            (mapcar (lambda (node)
+                                      (dom-attr node 'id))
+                                    (dom-children (nth l svg-layers))))
+                          show-layers)))
+
+;; (defun sketch-create-label (type)
+;;   (interactive)
+;;   (let* ((alphabet "abcdefghijklmnopqrstuvwxyz")
+;;          (labels-list (mapcar #'string (concat alphabet (upcase alphabet))))
+;;          (labels (sketch-labels-list)))
+;;     (while (member (car labels-list) labels)
+;;       (setq labels-list (cdr labels-list)))
+;;     (car labels-list)))
+
+(defun sketch-create-label (type)
   (interactive)
-  (let* ((alphabet "abcdefghijklmnopqrstuvwxyz")
-         (labels-list (mapcar #'string (concat alphabet (upcase alphabet))))
+  (let* ((prefix (concat (when (/= active-layer 0)
+                           (number-to-string active-layer))
+                         (pcase type
+                           ("line" "l")
+                           ("rectangle" "r")
+                           ("circle" "c")
+                           ("ellipse" "e"))))
+         (idx 0)
+         (label (concat prefix (number-to-string idx)))
          (labels (sketch-labels-list)))
-    (while (member (car labels-list) labels)
-      (setq labels-list (cdr labels-list)))
-    (car labels-list)))
-
-(defun sketch-toggle-labels ()
-  (interactive)
-  (with-current-buffer "*sketch*"
-    (setq sketch-show-labels (if sketch-show-labels nil t))
-    (sketch-redraw)))
+    (while (member label labels)
+      (setq idx (1+ idx))
+      (setq label (concat prefix (number-to-string idx))))
+    label))
+
+(transient-define-infix sketch-layer ()
+  "Layer that is currently active when sketching."
+  :description "Active layer"
+  :class 'transient-lisp-variable
+  :variable 'active-layer)
+
+(defun sketch-list-layers ()
+  (mapcar #'number-to-string (number-sequence 0 (length svg-layers))))
+  ;; (with-current-buffer (get-buffer "*sketch*")
+  ;;   (mapcar (lambda (layer) (alist-get 'id (cadr layer))) svg-layers)))
 
 (defun sketch-translate-node-coords (node amount &rest args)
   (dolist (coord args node)
@@ -532,36 +594,56 @@ values"
                (sketch-translate-node-coords node dy 'cy))
               ('text (sketch-translate-node-coords node dx 'x)
                      (sketch-translate-node-coords node dy 'y))))
-          (cddr sketch-root)))
+          (cddr (nth active-layer svg-layers))))
+  ;; (let ((node (car (dom-by-id svg-sketch label))))
+  ;;   (pcase (car node)
+  ;;     ('g (setf (alist-get 'transform (cadr node))
+  ;;               (format "translate(%s %s)" (- dx) (- dy))))
+  ;;     ;; ('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)))
+
+  ;;     ) ;; TODO make it work for all types of elements
+  ;;   node))
 
 (defun sketch-redraw (&optional lisp lisp-buffer)
   (unless sketch-mode
     (user-error "Not in sketch-mode buffer"))
-  (when lisp-buffer
-    (sketch-update-lisp-window lisp lisp-buffer))
-  ;; (let ((lisp-window (or (get-buffer-window "*sketch-root*")
-  ;;                        (get-buffer-window lisp-buffer))))
-  ;;   (unless (string= (buffer-name (window-buffer lisp-window)) "*sketch*")
-  ;;     (if-let (buf (get-buffer"*sketch-root*"))
-  ;;         (sketch-update-lisp-window sketch-root buf)
-  ;;       (sketch-update-lisp-window lisp lisp-buffer))))
-  (setq sketch-svg (append svg-canvas
-                    (when sketch-show-grid (cddr svg-grid))
-                    (cddr sketch-root)
-                    (when sketch-show-labels (sketch-labels))))
-  (erase-buffer) ;; a (not exact) alternative is to use (kill-backward-chars 1)
-  (insert-image (sketch-image sketch-svg
-                           :pointer 'arrow
-                           :grid-param grid-param
-                           :map `(((rect . ((0 . 0) . (,(dom-attr sketch-svg 
'width) . ,(dom-attr sketch-svg 'height))))
-                           ;; :map '(((rect . ((0 . 0) . (800 . 600)))
-                                   sketch
-                                   (pointer arrow help-echo (lambda (_ _ pos)
-                                                              (let 
((message-log-max nil)
-                                                                    (coords 
(mouse-pixel-position)))
-                                                                (print (format 
"(%s, %s)"
-                                                                               
(- (cadr coords) pos)
-                                                                               
(cddr coords)))))))))))
+  (save-current-buffer
+    (when lisp-buffer
+      (sketch-update-lisp-window lisp lisp-buffer))
+    ;; (let ((lisp-window (or (get-buffer-window "*sketch-root*")
+    ;;                        (get-buffer-window lisp-buffer))))
+    ;;   (unless (string= (buffer-name (window-buffer lisp-window)) "*sketch*")
+    ;;     (if-let (buf (get-buffer"*sketch-root*"))
+    ;;         (sketch-update-lisp-window sketch-root buf)
+    ;;       (sketch-update-lisp-window lisp lisp-buffer))))
+    (setq sketch-root (append (subseq sketch-root 0 2) (list (nth (car 
show-layers) svg-layers))))
+    (dolist (layer (cdr show-layers))
+      (setq sketch-root (append sketch-root (list (nth layer svg-layers)))))
+    (setq sketch-svg (append svg-canvas
+                             (when sketch-show-grid (list sketch-grid))
+                             (when sketch-show-labels (list (sketch-labels)))
+                             (list sketch-root)))
+    (erase-buffer) ;; a (not exact) alternative is to use (kill-backward-chars 
1)
+    (insert-image (sketch-image sketch-svg
+                                :pointer 'arrow
+                                :grid-param grid-param
+                                :map `(((rect . ((0 . 0) . (,(dom-attr 
sketch-svg 'width) . ,(dom-attr sketch-svg 'height))))
+                                        ;; :map '(((rect . ((0 . 0) . (800 . 
600)))
+                                        sketch
+                                        (pointer arrow help-echo (lambda (_ _ 
pos)
+                                                                   (let 
((message-log-max nil)
+                                                                         
(coords (mouse-pixel-position)))
+                                                                     (print 
(format "(%s, %s)"
+                                                                               
     (- (cadr coords) pos)
+                                                                               
     (cddr coords))))))))))))
 
 (transient-define-suffix sketch-interactively-1 (event)
   (interactive "@e")
@@ -589,7 +671,8 @@ values"
                                            (if sketch-include-end-marker
                                                "url(#arrow)"
                                              "none"))))
-         (command-and-coords (pcase (transient-arg-value "--object=" args)
+         (object-type (transient-arg-value "--object=" args))
+         (command-and-coords (pcase object-type
                                ("line" (list 'svg-line
                                              (car start-coords) (cdr 
start-coords) (car end-coords) (cdr end-coords)))
                                ("rectangle" `(svg-rectangle 
,@(sketch--rectangle-coords start-coords end-coords)))
@@ -597,7 +680,7 @@ values"
                                                (car start-coords) (cdr 
start-coords)
                                                (sketch--circle-radius 
start-coords end-coords)))
                                ("ellipse" `(svg-ellipse 
,@(sketch--ellipse-coords start-coords end-coords))))))
-    (apply (car command-and-coords) sketch-root `(,@(cdr command-and-coords) 
,@object-props :id ,(sketch-create-label)))
+    (apply (car command-and-coords) (nth active-layer svg-layers) `(,@(cdr 
command-and-coords) ,@object-props :id ,(sketch-create-label object-type)))
     (when-let (buf (get-buffer "*sketch-root*"))
       (sketch-update-lisp-window sketch-root buf))
     (sketch-redraw)))
@@ -740,6 +823,65 @@ values"
   :choices '("bold")
   :default "normal")
 
+;; (defclass sketch-variable:layers (transient-variable)
+;;   ((fallback    :initarg :fallback    :initform nil)
+;;    (default     :initarg :default     :initform nil)))
+
+;; (cl-defmethod transient-infix-read ((obj sketch-variable:layers))
+;;   (let ((value (if-let (val (oref obj value))
+;;                    val
+;;                  (oref obj default)))
+;;         (layer (read-number "Type number of layer for toggle: ")))
+;;     (if (memq layer value)
+;;         (delq layer value)
+;;       (push layer value))))
+
+;; (cl-defmethod transient-infix-value ((obj sketch-variable:layers))
+;;   (let ((default (oref obj default)))
+;;     (if-let ((value (oref obj value)))
+;;         value)
+;;     (when default
+;;       default)))
+
+;; (cl-defmethod transient-format-value ((obj sketch-variable:layers))
+;;   (let ((value (oref obj value))
+;;         (default  (oref obj default)))
+;;     (format "%s" (if value
+;;                      (oref obj value)
+;;                    (oref obj default)))))
+  ;; (let ((value (oref obj value))
+  ;;       (default  (oref obj default)))
+  ;;   (if value
+  ;;       (format "%s (%s)"
+  ;;               (propertize value 'face (cons 'foreground-color value))
+  ;;               (propertize (apply 'color-rgb-to-hex (color-name-to-rgb 
value))
+  ;;                           'face 'transient-inactive-argument))
+  ;;     (if (string= default "none")
+  ;;         (propertize "none" 'face 'transient-inactive-argument)
+  ;;       (format "%s (%s)"
+  ;;               (propertize default 'face (cons 'foreground-color default))
+  ;;               (propertize (apply 'color-rgb-to-hex (color-name-to-rgb 
default))
+  ;;                           'face 'transient-inactive-argument))))))
+
+(transient-define-suffix sketch-add-layer ()
+  (interactive)
+  (setq svg-layers (append svg-layers
+                           (list (sketch-group (format "layer-%s" (length 
svg-layers))))))
+  (message "Existing layers (indices): %s" (mapconcat #'number-to-string
+                                            (number-sequence 0 (1- (length 
svg-layers)))
+                                            ", ")))
+
+(transient-define-infix sketch-layers ()
+  "List with layers that should be added to the image.
+Should be a list of numbers containing the number of the layers
+that should be added to the image. Initial value: (0)"
+  :description "Show layers"
+  :class 'transient-lisp-variable
+  :variable 'show-layers)
+  ;; :argument "--layers="
+  ;; :default '(0))
+  ;; :default (number-sequence (length svg-layers)))
+
 (transient-define-suffix sketch-crop (event)
   (interactive "@e")
   (let* ((args (when transient-current-prefix (transient-args 
'sketch-transient)))
@@ -758,7 +900,7 @@ values"
     (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 sketch-root) (sketch--svg-translate (car start-coords) (cdr 
start-coords)))
+    (setq sketch-root (svg-translate "main" (car start-coords) (cdr 
start-coords)))
     (sketch-redraw)))
 
 (defun sketch-image (svg &rest props)
@@ -827,7 +969,7 @@ PROPS is passed on to `create-image' as its PROPS list."
    ("<up>" "up" sketch-translate-up)]
    [("S-<down>" "fast down" sketch-translate-fast-down)
     ("S-<up>" "fast up" sketch-translate-fast-up)]]
-  [("l" "Toggle labels" sketch-toggle-labels)
+  [("l" sketch-cycle-labels)
    ("q" "Quit" transient-quit-one)]
   (interactive)
   (let* ((object (completing-read "Transform element with id: "
@@ -845,11 +987,10 @@ PROPS is passed on to `create-image' as its PROPS list."
 
 (defun sketch-update-lisp-window (lisp buffer)
   ;; (let ((sketch sketch-root))
-  (save-current-buffer
-    (switch-to-buffer-other-window buffer)
-    (erase-buffer)
-    (pp lisp (current-buffer))
-    (end-of-buffer)))
+    (with-current-buffer buffer
+      (erase-buffer)
+      (pp lisp (current-buffer))
+      (end-of-buffer)))
 
 
  (provide 'sketch-mode)