branch: externals/sketch-mode
commit 846f4a0c517520b97de34752064f1272aab876f4
Author: Daniel Nicolai <dalanico...@gmail.com>
Commit: Daniel Nicolai <dalanico...@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)
