[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/sketch-mode 443e095 15/15: Merge branch 'develop', publ
|
From: |
ELPA Syncer |
|
Subject: |
[elpa] externals/sketch-mode 443e095 15/15: Merge branch 'develop', publish package :tada: |
|
Date: |
Wed, 20 Oct 2021 05:57:37 -0400 (EDT) |
branch: externals/sketch-mode
commit 443e095958cf66ec7fc6a24c28158a05674934d5
Merge: 457ba48 02b1c05
Author: Daniel Nicolai <dalanicolai@gmail.com>
Commit: Daniel Nicolai <dalanicolai@gmail.com>
Merge branch 'develop', publish package :tada:
---
README.org | 91 +-
sketch-mode.el | 2798 ++++++++++++++++++++++++++++----------------------------
2 files changed, 1471 insertions(+), 1418 deletions(-)
diff --git a/README.org b/README.org
index f417424..9cb7585 100644
--- a/README.org
+++ b/README.org
@@ -1,26 +1,45 @@
#+TITLE: Sketch mode
#+DESCRIPTION: Quickly create simple SVG sketches using the mouse
+* Prepreliminary comment
+ The initial version with the transient can be found in the
'transient-version'
+ branch. This version introduced a toolbar which made the transient
+ unnecessary. Also removing the transient frees up drawing space. It has been
+ replaced by a hydra which can togglable. Also an earlier version showed the
+ mouse coordinate position in the mode-line. However, this functionality
+ hinders the 'interactive' drawing (which might could be considered an emacs
+ bug). Anyway, you can toggle showing the coordinates by pressing =t c= (maybe
+ it works more fluently on your system).
+
* Preliminary comment
- This is a new package that is still in development. However, its main
- functionality is very usable already. On the other hand, several (or most)
- features are not implemented completely, simply because implementing these
- things take time, and I should first focus on keeping myself alive:|. But if
- you know some elisp, than it should be quite straightforward to complete the
- implementation of those features. Any feedback, for example suggestions for
- enhancing the interface/usability, is very welcome (probably best by opening
- an issue). Also, any contributions are very welcome. The code of the package
- is very accessible (especially if you quickly read how to use
[[https://www.gnu.org/software/emacs/manual/html_node/elisp/Edebug.html][edebug]]).
+ This is a new package that is still in development. It has been on ELPA-devel
+ for a while now, but it did not yet attract any code contributors. However,
+ despite that the code and docs are far from polished/finished, its main
+ functionality is very usable already, so that it is probably a good time to
+ publish it on ELPA. On the other hand, several (or most) features are not
+ implemented completely, simply because implementing these things take time,
+ and I should first focus on keeping myself alive 😐. But if you know some
+ elisp, than it should be quite straightforward to complete the implementation
+ of those features (and create a PR). The idea is that elisp users can add
+ functionalities easily so that the package becomes ever more versatile. Users
+ can also contribute by creating SVG snippets (in a separate repo, or create a
+ PR). Any feedback, for example suggestions for enhancing the
+ interface/usability (and of course bug reports), is very welcome (probably
+ best by opening an issue). Also, any contributions are very welcome. The code
+ of the package is very accessible (especially if you quickly read how to use
+
[[https://www.gnu.org/software/emacs/manual/html_node/elisp/Edebug.html][edebug]]).
A list of ideas for implementation can be found in the preliminary comment in
the =sketch.el= file and additionally in the
[[https://github.com/dalanicolai/sketch-mode/wiki/vision][wiki]] section.
-
** Included features
- - snap to grid
+ - mnemonic shortcuts + hydra and (alternatively) a toolbar
+ - quickly insert image definition into new type (image) org-block (no
+ external file required)
+ - snap to grid (on minor-grid, however major and minor grid are fully
+ configurable)
- draw text
- crop finale image
- - quickly insert image + definition into (org-mode) buffer
- set stroke, fill, width etc.
- show dom (lisp) in other window
- draw angle arcs (between lines, available soon, I hope. See
@@ -30,16 +49,11 @@
** Incomplete features (merged into main)
- Draw labels (not implemented for all type of objects. Easy to implement)
- - Modify object (not, at all, fully implemented for all object. Easy to
- implement).
It would be handy to have a 'transform group' option also.
[[https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/transform][SVG
groups allow
for easy transformations]]. Then it would probably be handy to wrap all
objects in group tags.
-** Incomplete features (not merged into main)
- - Implement layers (see/try out =implement-layers= branch)
-
** Delicious low hanging fruit
- use svg snippets (i.e. design object in external programs like inkscape,
geogebra etc., end quickly insert them in your sketches)
@@ -95,24 +109,39 @@
package, the usage is more or less self explanatory, it is wise to take note
of the following comments:
- - use =I= to quickly insert the xml-definition into the (org-mode) buffer
from
- which sketch-mode was called and create the image as an overlay.
- - to remove an object (without using undo), you should toggle labels by
- pressing =l=, and then to remove an object enter its label after pressing
- =R=.
+ - use =C-c C-c= to quickly insert the xml-definition into the (org-mode)
+ buffer from which sketch-mode was called and create the image as an
overlay.
+ The image will get inserted within a new =image= org block type. SVG/XML is
+ suitable for inserting directly in an org file so that you do not need to
+ store the image separately on disk (which is nice feature when sharing
+ files). The new block type is not yet 'officially supported' by org-mode,
so
+ that it will not yet get exported as an image (HELP WANTED :nerd:), but the
+ image in the code block can be toggle with =C-c C-c=.
+ - Alternatively you can write the image to a file by pressing =S= (S-ave).
+ - Before you insert the image you can use =C-S mouse-drag= to crop the image.
+ - You can move an object by pressing =m= to open the 'modify-object' state.
+ This will select the object and activate the =translate= mouse action so
+ that you can drag the object using the mouse.
+ - to remove an object (without using undo), you should press =d=, and then
the
+ label of the object you want removed.
- You can also modify the drawing by changing the object definition (i.e.
elisp). For that press =d= to open the definition in a side-window, then
press =q= to hide (deactivate the) transient (keymap). Now modify the code
- and press =C-c C=c=, to load it and update the =\*sketch\*= buffer.
- - After you've hidden the transient by pressing =q=, you can go back to
- sketch mode via =M-x sketch= (or =C-c C-s= when still in the sketch-mode
- buffer)
-
- Create your sketch and then save
- the file by pressing =S=.
-
+ and press =C-c C=c=, to load it and update the =\*sketch\*= buffer.
+
+* Bugs
+ Currently when undoing all (drawing of) objects, sketch-mode gets confused
and
+ further drawing is not possible anymore (although redoing is). This is
+ probably a very easy to solve bug, but has not been a priority yet.
+
+* Alternatives
+
[[https://lifeofpenguin.blogspot.com/2021/08/scribble-notes-in-gnu-emacs.html][canvas-mode]]:
An even newer package is being created which provides some
+ additional features (although =sketch-mode= is still in development and most
+ probably will get most of these features too). Unfortunately, the package is
+ not (yet?) very compatible with =sketch-mode=.
+
* Sponsor the project
- It takes me a lot of time to develop these packages, while, as we would say
in
+ It takes me a lot of time to develop (this) package(s), while, as we would
say in
the Netherlands, I have no penny to scratch my butt. Therefore, although I am
also really happy to offer it for free, if you find
[[https://github.com/dalanicolai][my package(s)]] (real
projects page in the making) useful (e.g. for you work), and if you can
afford
diff --git a/sketch-mode.el b/sketch-mode.el
index 74a8a40..6572349 100644
--- a/sketch-mode.el
+++ b/sketch-mode.el
@@ -4,7 +4,7 @@
;; Author: D.L. Nicolai <dalanicolai@gmail.com>
;; Created: 17 Jul 2021
-;; Version: 0
+;; Version: 1.0
;; Keywords: multimedia
;; URL: https://github.com/dalanicolai/sketch-mode
@@ -31,28 +31,10 @@
;; DONE implement (simple) undo mechanism
-;; DONE add remove (objects) functionality (see `svg-remove')
-
-;; DONE move font transient (also its suffix) into main sketch transient
(suffix)
-
-;; DONE add functionality to crop/select part of image (on/before save)
-
-;; DONE(-partially) add functionality to modify objects (see
`add-object-modify-feature' branch)
-
-;; TODO add functionality to customize markers
-
-;; TODO Add options to hide transient suffixes (e.g. commands are trivial and
could be hidden to get more drawing space.
-;; unfortunately transient levels (de)activate instead of hide/show suffixes)
-
-;; TODO enable defining global svg settings (object properties)
-
-;; TODO maybe transform relevant transient argument (strings) to variables
-
-;; TODO add function to open svg code in 'other buffer' and quickly reload
-;; (after editing, DONE see `add-object-modify-feature' branch)
+;; TODO maybe transform relevant transient argument (strings) to variables ;;
(af`add-object-modify-feature' branch)
;; TODO add functionality to start drawing from org-mode source block and
update
-;; source block after each draw/edit
+;; source block after each draw/edit (showing the image as the block'ss output)
;; TODO maybe add keybindings (save/bind transient setting to specific 'mouse
keys')
@@ -72,87 +54,49 @@
;; could implement a drawing DSL based on nodes (a la tikz/asymptote etc.)
-;;; Code:
+;;;; Code
(require 'svg)
-(require 'transient)
-(require 'cl-lib)
-(require 'sgml-mode)
+;; (require 'seq)
(require 'shr-color)
-
-(defgroup sketch nil
- "Configure default sketch (object) properties."
- :group 'Applications)
-
-(defcustom sketch-im-x-offset 7
- "Horizontal offset in pixels of image position within frame.
-Set this value to correct for cursor 'bias'."
- :type 'integer)
-
-(defcustom sketch-im-y-offset 1
- "Vertical offset in pixels of image position within frame.
-Set this value to correct for cursor 'bias'."
- :type 'integer)
-
-(defcustom sketch-default-image-size '(800 . 600)
- "Default size for sketch canvas.
-Cons cell with car and cdr both integers, respectively
-representing the image width and image height
-default: (800 . 600)."
- :type '(cons integer integer))
-
-(defcustom sketch-show-grid t
- "When non-nil, show grid lines (default: t)."
- :type 'boolean)
-
-(defcustom sketch-show-labels nil
- "When non-nil, show object labels (default: t)."
- :type 'boolean)
-
-(defcustom sketch-default-grid-parameter 25
- "Default grid line separation distance (integer)."
- :type 'integer)
-
-(defcustom sketch-label-size 15
- "Size of object labels."
- :type 'integer)
-
-(defcustom sketch-default-shape 'line
- "Default object type for `sketch-interactively'."
- :type '(choice
- (const :tag "Line" 'line)
- (const :tag "Rectangle" 'rectangle)
- (const :tag "Circle" 'circle)
- (const :tag "Ellipse" 'ellipse)))
-
-(defcustom sketch--snap-to-grid t
- "Default value of snap to grid.
-If non-nil then snap to grid."
- :type 'boolean)
-
-(defcustom sketch-include-start-marker nil
- "Start marker type."
- :type '(choice
- (const :tag "No marker" nil)
- (const :tag "Arrow" 'arrow)
- (const :tag "Dot" 'dot)))
-
-(defcustom sketch-include-mid-marker nil
- "Mid marker type."
- :type '(choice
- (const :tag "No marker" nil)
- (const :tag "Arrow" 'arrow)
- (const :tag "Dot" 'dot)))
-
-(defcustom sketch-include-end-marker nil
- "End marker type."
- :type '(choice
- (const :tag "No marker" nil)
- (const :tag "Arrow" 'arrow)
- (const :tag "Dot" 'dot)))
-
-
-;;; SVG-definitions
-
+(require 'sgml-mode)
+(require 'hydra nil t)
+
+
+;;; Rendering
+(defvar sketch-svg nil)
+(defvar sketch-size '(1200 . 900))
+(defvar sketch-grid nil)
+(defvar sketch-show-grid t)
+(defvar sketch-background "white")
+(defvar sketch-grid-param 50)
+(defvar sketch-minor-grid-param nil)
+(defvar sketch-minor-grid-freq 4)
+(defvar sketch-grid-colors '("gray" . "gray"))
+(defvar sketch-default-stroke "black")
+(defvar sketch-snap-to-grid t)
+
+(defvar sketch-canvas nil)
+(defvar sketch-root nil)
+
+(defvar sketch-active-layer 0)
+(defvar sketch-layers-list nil)
+(defvar show-layers nil)
+
+(defvar sketch-show-labels nil)
+(defvar sketch-label-size 15)
+
+(defvar sketch-lisp-buffer-name nil)
+(defvar sketch-side-window-max-width (lambda () (- 1 (/ (float (car
+ (image-size
+
(get-text-property (point-min) 'display) t)))
+ (frame-pixel-width)))))
+(defvar sketch-im-x-offset nil)
+(defvar sketch-cursor-position "")
+(defvar sketch-show-coords nil)
+(defvar sketch-coordless-mode-line-format nil)
+
+
+;;; Some snippets for svg.el
(defun svg-marker (svg id width height &optional color reverse)
"Define a marker with ID to SVG.
TYPE is `linear' or `radial'.
@@ -190,493 +134,60 @@ STOPS is a list of percentage/color pairs."
'g
`(,(svg--arguments nil args))))
-
-;;; Resume sketch-code
-
(defun sketch-group (id &rest args)
(apply #'svg-group
:id id
:transform "translate(0,0)"
args))
-;; Web/SVG colors
-(defun sketch-colors-sort (colors-rgb-alist)
- (let ((list-colors-sort 'hsv))
- ;; color sort function in courtesy of facemenu.el
- ;; (colors-sorted (mapcar (lambda (c) (cons c (color-name-to-rgb c)))
(defined-colors)))
- ;; Schwartzian transform with `(color key1 key2 key3 ...)'.
- (mapcar
- 'car
- (sort (delq nil (mapcar
- (lambda (c)
- (let ((key (list-colors-sort-key
- (car
c))))
- (when key
- (cons c (if (consp
key)
- key
- (list
key))))))
- colors-rgb-alist)) ;; HERE IS THE
LIST
- (lambda (a b)
- (let* ((a-keys (cdr a))
- (b-keys (cdr b))
- (a-key (car a-keys))
- (b-key (car b-keys)))
- ;; Skip common keys at the beginning of key
lists.
- (while (and a-key b-key (equal a-key b-key))
- (setq a-keys (cdr a-keys) a-key (car a-keys)
- b-keys (cdr b-keys) b-key (car
b-keys)))
- (cond
- ((and (numberp a-key) (numberp b-key))
- (< a-key b-key))
- ((and (stringp a-key) (stringp b-key))
- (string< a-key b-key)))))))))
-
-;; Adapted from `read-color'
-(defun read-color-web (&optional prompt convert-to-RGB)
- "Read a color name or RGB triplet.
-Completion is available for color names, but not for RGB triplets.
-
-RGB triplets have the form \"#RRGGBB\". Each of the R, G, and B
-components can have one to four digits, but all three components
-must have the same number of digits. Each digit is a hex value
-between 0 and F; either upper case or lower case for A through F
-are acceptable.
-
-In addition to standard color names and RGB hex values, the
-following are available as color candidates. In each case, the
-corresponding color is used.
-
- * `foreground at point' - foreground under the cursor
- * `background at point' - background under the cursor
-
-Optional arg PROMPT is the prompt; if nil, use a default prompt.
-
-Interactively, or with optional arg CONVERT-TO-RGB-P non-nil,
-convert an input color name to an RGB hex string. Return the RGB
-hex string.
-
-Interactively, displays a list of colored completions. If optional
-argument FOREGROUND is non-nil, shows them as foregrounds, otherwise
-as backgrounds."
- (interactive "i\np") ; Always convert to RGB interactively.
- (let* ((completion-ignore-case t)
- (colors (mapcar
- (lambda (color-name)
- (let ((color (copy-sequence color-name)))
- (propertize color 'face
- (list :foreground
(readable-foreground-color color-name)
- :background color))))
- (mapcar #'car (sketch-colors-sort
shr-color-html-colors-alist))))
- (color (completing-read
- (or prompt "Color (name or #RGB triplet): ")
- ;; Completing function for reading colors, accepting
- ;; both color names and RGB triplets.
- (lambda (string pred flag)
- (cond
- ((null flag) ; Try completion.
- (or (try-completion string colors pred)
- (if (color-defined-p string)
- string)))
- ((eq flag t) ; List all completions.
- (or (all-completions string colors pred)
- (if (color-defined-p string)
- (list string))))
- ((eq flag 'lambda) ; Test completion.
- (or (member string colors)
- (color-defined-p string)))))
- nil t)))
-
- ;; Process named colors.
- (when (member color colors)
- (cond ((string-equal color "foreground at point")
- (setq color (foreground-color-at-point)))
- ((string-equal color "background at point")
- (setq color (background-color-at-point))))
- (when (and convert-to-RGB
- (not (string-equal color "")))
- (let ((components (x-color-values color)))
- (unless (string-match-p
"^#\\(?:[[:xdigit:]][[:xdigit:]][[:xdigit:]]\\)+$" color)
- (setq color (format "#%04X%04X%04X"
- (logand 65535 (nth 0 components))
- (logand 65535 (nth 1 components))
- (logand 65535 (nth 2 components))))))))
- color))
-
-;; minor-mode
-(define-minor-mode sketch-mode
- "Create svg images using the mouse.
-In sketch-mode buffer press \\[sketch-transient] to activate the
-transient."
- :lighter "sketch-mode"
- :keymap
- `(
- ;; ([sketch drag-mouse-1] . sketch-interactively)
- ;; ([C-S-drag-mouse-1] . sketch-interactively)
- (,(kbd "C-c C-s") . sketch-transient))
- (if (boundp 'undo-tree-mode)
- (undo-tree-mode)
- (buffer-enable-undo)
- (blink-cursor-mode 0)))
-
-(defun sketch-mapcons (fn &rest cons-cells)
- "Apply FN to list of car's and cdr's of CONS-CELLS.
-Return a single cons cell."
- (cons (apply fn (mapcar #'car cons-cells))
- (apply fn (mapcar #'cdr cons-cells))))
-
-(defun sketch-norm (vec)
- "Return norm of a vector.
-VEC should be a cons or a list containing only number elements."
- (let ((sum-of-squares (if (consp vec)
- (+ (expt (car vec) 2)
- (expt (cdr vec) 2))
- (apply #'+
- (mapcar (lambda (x) (* x x))
- vec)))))
- (expt sum-of-squares (/ 1.0 (if (consp vec)
- 2
- (length vec))))))
-
-(defun sketch--circle-radius (start-coords end-coords)
- (sketch-norm
- (sketch-mapcons #'- end-coords start-coords)))
-
-(defun sketch--rectangle-coords (start-coords end-coords)
- (let ((base-coords (cons (apply #'min (list (car start-coords) (car
end-coords)))
- (apply #'min (list (cdr start-coords) (cdr
end-coords))))))
- (list (car base-coords)
- (cdr base-coords)
- (abs (- (car end-coords) (car start-coords)))
- (abs (- (cdr end-coords) (cdr start-coords))))))
-
-(defun sketch--ellipse-coords (start-coords end-coords)
- (list (/ (+ (car start-coords) (car end-coords)) 2)
- (/ (+ (cdr start-coords) (cdr end-coords)) 2)
- (abs (/ (- (car end-coords) (car start-coords)) 2))
- (abs (/ (- (cdr end-coords) (cdr start-coords)) 2))))
+(defun sketch-create (w h &optional scale pan-x pan-y &rest args)
+ (let ((scale (or scale 1)))
+ (apply #'svg-create w h
+ :viewBox (format "%s %s %s %s"
+ (or pan-x 0)
+ (or pan-y 0)
+ (/ (float w) scale)
+ (/ (float h) scale))
+ args)))
-(defvar-local sketch-svg nil)
-(defvar-local svg-canvas nil)
-(defvar-local sketch-grid nil)
-(defvar-local sketch-root nil)
-(defvar-local sketch-layers-list nil)
-(defvar-local show-layers nil)
-(defvar-local sketch-cursor-position nil)
-
-(defun sketch--create-canvas (width height &optional grid-parameter)
- "Create canvas of size WIDTH x HEIGHT for drawing svg.
-Optionally set a custom GRID-PARAMETER (default is value of
-`sketch-default-grid-parameter')."
- (let ((width width)
- (height height))
- (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 sketch-grid (sketch-group "grid"))
- (let ((dash t))
- (dotimes (x (1- (/ width grid-parameter)))
- (let ((pos (* (1+ x) grid-parameter)))
- (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 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 (list
sketch-grid))))
- (setq sketch-root (sketch-group "root"))
- (setq sketch-layers-list (list (sketch-group "layer-0")))
- (setq show-layers '(0))
- (sketch-insert-image sketch-svg
- (prin1-to-string sketch-root)
- :grid-param grid-parameter
- :pointer 'arrow
- :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 (cdr (mouse-pixel-position))))
- (setq
sketch-cursor-position (format "(%s, %s)"
-
(- (car coords) sketch-im-x-offset)
-
(+ (cdr coords) sketch-im-y-offset))))
-
(force-mode-line-update))))))
- (beginning-of-line)))
-
-;; 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 sketch-grid-param 25)
-(defvar-local sketch-active-layer 0)
-(defvar-local sketch-call-buffer nil)
+(defun sketch-image (svg &rest props)
+ "Return an image object-label from SVG.
+PROPS is passed on to `create-image' as its PROPS list."
+ (apply
+ #'create-image
+ (with-temp-buffer
+ (insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
+<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"
\"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\";>\n")
+ (svg-print svg)
+ (buffer-string))
+ 'svg t props))
-;;;###autoload
-(defun sketch (arg)
- "Initialize or switch to (new) SVG image.
-With prefix ARG, create sketch using default (customizable)
-values"
- (interactive "P")
- (let ((call-buffer (current-buffer)) ;; to set value as local variable later
in '*sketch*' buffer
- (buffer (get-buffer "*sketch*")))
- (if buffer
- (progn (switch-to-buffer buffer)
- (call-interactively 'sketch-transient))
- (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*"))
- (add-to-list 'mode-line-format '(:eval sketch-cursor-position) t)
- (setq sketch-grid-param (if arg 25 (read-number "Enter grid parameter
(enter 0 for no grid): ")))
- (sketch--create-canvas width height sketch-grid-param))
- (setq sketch-call-buffer call-buffer) ;; variable is buffer local
- (sketch-mode)
- (call-interactively 'sketch-transient))))
-
-
-(defun sketch--snap-to-grid (coord grid-parameter)
- (cons (* (round (/ (float (car coord)) grid-parameter)) grid-parameter)
- (* (round (/ (float (cdr coord)) grid-parameter)) grid-parameter)))
-
-
-;;; Transient
-
-(defclass sketch-variable:choices (transient-variable)
- ((choices :initarg :choices)
- (fallback :initarg :fallback :initform nil)
- (default :initarg :default :initform nil)))
-
-(cl-defmethod transient-infix-read ((obj sketch-variable:choices))
- (let ((choices (oref obj choices)))
- (if-let ((value (oref obj value)))
- (cadr (member value choices))
- (car choices))))
-
-(cl-defmethod transient-infix-value ((obj sketch-variable:choices))
- "Return the value of OBJ's `value' slot if non-nil,
-else return value of OBJ's `default' slot if non-nil,
-else return nil"
- (let ((default (oref obj default)))
- (if-let ((value (oref obj value)))
- (concat (oref obj argument) value)
- (when default
- (concat (oref obj argument) default)))))
-
-(cl-defmethod transient-format-value ((obj sketch-variable:choices))
- (let ((value (oref obj value))
- (choices (oref obj choices))
- (default (oref obj default)))
- (concat
- (propertize "[" 'face 'transient-inactive-value)
- (mapconcat (lambda (choice)
- (propertize choice 'face (if (equal choice value)
- (if (member choice choices)
- 'transient-value
- 'font-lock-warning-face)
- 'transient-inactive-value)))
- choices
- (propertize "|" 'face 'transient-inactive-value))
- (and (or default)
- (concat
- (propertize "|" 'face 'transient-inactive-value)
- (cond
- (default
- (propertize (concat "default:" default)
- 'face
- (if value
- 'transient-inactive-value
- 'transient-value))))))
- (propertize "]" 'face 'transient-inactive-value))))
-
-(defclass sketch-variable:colors (transient-variable)
- ((fallback :initarg :fallback :initform nil)
- (default :initarg :default :initform nil)))
-
-(cl-defmethod transient-infix-read ((_obj sketch-variable:colors))
- (read-color-web "Select color: "))
-
-(cl-defmethod transient-infix-value ((obj sketch-variable:colors))
- (let ((default (oref obj default)))
- (if-let ((value (oref obj value)))
- (concat (oref obj argument) (substring-no-properties value))
- (when default
- (concat (oref obj argument) (substring-no-properties default))))))
-
-;; We always call the autoloaded `color-name-to-rgb' before calling this
-;; function, so we know it's available even tho the compiler doesn't.
-(declare-function color-rgb-to-hex "color"
- (red green blue &optional digits-per-component))
-
-(cl-defmethod transient-format-value ((obj sketch-variable:colors))
- (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))))))
-
-;; (let* ((args (when transient-current-prefix (transient-args
'sketch-transient)))
-;; (print event))))
-;; (start (event-start event))
-;; (sketch-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)
sketch-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)
sketch-grid-param)))
-;; (object-props (list :stroke-width
-;; (transient-arg-value "--stroke-width=" args)
-;; :stroke
-;; (transient-arg-value "--stroke-color=" args)
-;; :fill
-;; (transient-arg-value "--fill-color=" args)
-;; :marker-end (if args (pcase (transient-arg-value
"--marker=" args)
-;; ("arrow" "url(#arrow)")
-;; ("point" "url(#point)")
-;; (_ "none"))
-;; (if sketch-include-end-marker
-;; "url(#arrow)"
-;; "none"))))
-;; (command-and-coords (pcase (transient-arg-value "--object=" args)
-;; ("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)))
-;; ("circle" (list 'svg-circle
-;; (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)))
-;; (sketch-redraw)))
-
-(transient-define-prefix sketch-transient ()
- "Some Emacs magic"
- :transient-suffix 'transient--do-call
- :transient-non-suffix 'transient--do-stay
- [["General definitions"
- ("c" "stroke-color" sketch-stroke-color)
- ("C" "fill-color" sketch-fill-color)
- ("w" "stroke-width" sketch-stroke-width)
- ("d" "stroke-dasharray" sketch-dasharray)]
- ["Object definitions"
- ("o" "object" sketch-object)
- ("m" "end-marker" sketch-object-marker)]
- ["Font definitions"
- ("ff" "family" sketch-select-font)
- ("fw" "font-weight" sketch-font-weight)
- ("fs" "font-size" sketch-font-size)]]
- [["Grid"
- ("s" "Snap to grid" sketch-snap)
- ("g" "Toggle grid" sketch-toggle-grid)]
- ["Labels"
- ("l" sketch-cycle-labels)]
- ["Layers"
- ("L" sketch-layer)
- ("-L" sketch-layers)
- ("A" "Add layer" sketch-add-layer)]]
- ["Commands"
- [([sketch down-mouse-1] "Draw object" sketch-interactively-1)
- ([sketch mouse-1] "Draw text" sketch-text-interactively)
- ([sketch C-S-drag-mouse-1] "Crop image" sketch-crop)
- ;; ("T" "Polyline" test-mouse)
- ;; ([sketch S-down-mouse-1] "Track mouse" sketch-line)
- ]
- [("t" "Transform object" sketch-modify-object)
- ("r" "Remove object" sketch-remove-object)
- ("i" "Import object" sketch-import)]
- [("u" "Undo" sketch-undo)
- ("U" "Redo" sketch-redo)]
- [("D" "Show definition" sketch-show-definition)
- ("K" "Copy definition" sketch-copy-definition)
- ("S" "Save image" sketch-save)]
- [("b" "Insert image to buffer" sketch-insert-image-to-buffer
- :transient transient--do-exit)
- ("I" "Insert image to buffer" sketch-quick-insert-image
- :transient transient--do-exit)
- ("q" "Quit transient" transient-quit-one)]])
-
-(transient-define-infix sketch-object ()
- :description "Option with list"
- :class 'sketch-variable:choices
- :argument "--object="
- :choices '("rectangle" "circle" "ellipse" "polyline" "polygon" "freehand")
- :default "line")
-
-(transient-define-infix sketch-stroke-color ()
- :description "Option with list"
- :class 'sketch-variable:colors
- :argument "--stroke-color="
- :default "black")
-
-(transient-define-infix sketch-fill-color ()
- :description "Option with list"
- :class 'sketch-variable:colors
- :argument "--fill-color="
- :default "none")
-
-(transient-define-infix sketch-stroke-width ()
- :description "Option with list"
- :class 'transient-option
- :argument "--stroke-width="
- :choices (mapcar (lambda (x)
- (number-to-string x))
- (number-sequence 1 100)))
-
-(transient-define-infix sketch-dasharray ()
- :description "stroke-dasharray"
- :class 'sketch-variable:choices
- :argument "--stroke-dasharray="
- :choices '("8" "8,4")
- :default "none")
-
-(transient-define-infix sketch-object-marker ()
- :description "Option with list"
- :class 'sketch-variable:choices
- :argument "--marker="
- :choices '("arrow" "dot")
- :default "none")
-
-(transient-define-infix sketch-snap ()
- :description "Option with list"
- :class 'sketch-variable:choices
- :argument "--snap-to-grid="
- :choices '("t")
- :default "nil")
+(defun sketch-insert-image (svg string &rest props)
+ "Insert SVG as an image at point.
+If the SVG is later changed, the image will also be updated."
+ (let ((image (apply #'sketch-image svg props))
+ (marker (point-marker)))
+ (insert-image image string)
+ (dom-set-attribute svg :image marker)))
-(defun sketch-toggle-grid ()
+(defun sketch-add-layer ()
(interactive)
- (with-current-buffer "*sketch*"
- (setq sketch-show-grid (if sketch-show-grid nil t))
- (sketch-redraw)))
+ (let ((new-layer (length sketch-layers-list)))
+ (setq sketch-layers-list (append
+ sketch-layers-list
+ (list (sketch-group
+ (format "layer-%s" new-layer)))))
+ (setq sketch-active-layer new-layer)
+ (setq show-layers (append show-layers (list new-layer)))
+ (message "Existing layers (indices): %s"
+ (mapconcat #'number-to-string
+ (number-sequence 0 (1- (length sketch-layers-list)))
+ ", "))))
-(cl-defmethod transient-infix-set ((obj sketch-variable:choices) value)
- ;; (let ((variable (oref obj variable)))
- (oset obj value value)
- (setq sketch-show-labels value)
- ;; (auto-revert-buffers)
- (transient--redisplay)
- (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 ()
+ "Create svg-group with svg text nodes for all elements in layer.
+If value of variable ‘sketch-show-labels' is ‘layer', create ..."
(interactive)
(let ((nodes (pcase sketch-show-labels
("layer" (dom-children (nth sketch-active-layer
sketch-layers-list)))
@@ -684,94 +195,85 @@ else return nil"
(dom-children (nth l
sketch-layers-list)))
show-layers)))))
(svg-labels (sketch-group "labels")))
+
+ (defun sketch-label-text-node (node x y &rest props)
+ (apply #'svg-text
+ svg-labels
+ (dom-attr node 'id)
+ (append (list :x x
+ :y y
+ :font-size sketch-label-size
+ :stroke "red"
+ :fill "red")
+ (when-let (x (dom-attr node 'transform))
+ (list :transform x))
+ props)))
+
(mapc (lambda (node)
(pcase (dom-tag node)
- ('rect (svg-text svg-labels
- (dom-attr node 'id)
- :x (+ (dom-attr node 'x) 2)
- :y (+ (dom-attr node 'y)
- (- (dom-attr node 'height) 2))
- :font-size sketch-label-size
- :stroke "red"
- :fill "red"))
- ('line (svg-text svg-labels
- (dom-attr node 'id)
- :x (dom-attr node 'x1)
- :y (dom-attr node 'y1)
- :font-size sketch-label-size
- :stroke "red"
- :fill "red"))
- ((or 'circle 'ellipse) (svg-text svg-labels
- (dom-attr node 'id)
- :x (dom-attr node 'cx)
- :y (dom-attr node 'cy)
- :font-size sketch-label-size
- :stroke "red"
- :fill "red"))
- ((or 'polyline 'polygon) (let ((coords (split-string
- (car (split-string
(dom-attr node 'points) ","))
- nil
- t)))
- (svg-text svg-labels
- (dom-attr node 'id)
- :x (string-to-number (car
coords))
- :y (string-to-number (cadr
coords))
- :font-size sketch-label-size
- :stroke "red"
- :fill "red")))
- ('text (svg-text svg-labels
- (dom-attr node 'id)
- :x (dom-attr node 'x)
- :y (+ (dom-attr node 'y)
- sketch-label-size)
- :font-size sketch-label-size
- :stroke "red"
- :fill "red"))
+ ('rect (sketch-label-text-node
+ node
+ (+ (dom-attr node 'x) 2)
+ (+ (dom-attr node 'y)
+ (- (dom-attr node 'height) 2))))
+ ('line (sketch-label-text-node
+ node
+ (dom-attr node 'x1)
+ (dom-attr node 'y1)))
+ ((or 'circle 'ellipse)
+ (sketch-label-text-node
+ node
+ (dom-attr node 'cx)
+ (dom-attr node 'cy)))
+ ((or 'polyline 'polygon)
+ (let ((coords (split-string
+ (car (split-string (dom-attr node 'points) ","))
+ nil
+ t)))
+ (sketch-label-text-node
+ node
+ (string-to-number (car coords))
+ (string-to-number (cadr coords)))))
+ ('text (sketch-label-text-node
+ node
+ (dom-attr node 'x)
+ (+ (dom-attr node 'y)
+ sketch-label-size)))
('g (let ((s (dom-attr node
'transform)))
(string-match "translate\(\\([0-9]*\\)[, ]*\\([0-9]*\\)" s)
(let ((x (match-string 1 s))
(y (match-string 2 s)))
- (svg-text svg-labels
- (dom-attr node 'id)
- :x x
- :y y
- :font-size sketch-label-size
- :stroke "red"
- :fill "red"))))))
+ (sketch-label-text-node
+ node
+ x
+ y))))))
nodes)
svg-labels))
+
(defun sketch-labels-list ()
- (apply #'append (mapcar (lambda (l)
- (mapcar (lambda (node)
- (dom-attr node 'id))
- (dom-children (nth l sketch-layers-list))))
- 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)))
+ (apply #'append
+ (mapcar (lambda (l)
+ (mapcar (lambda (node)
+ (dom-attr node 'id))
+ (dom-children (nth l sketch-layers-list))))
+ show-layers)))
(defun sketch-create-label (type)
(interactive)
(let* ((prefix (concat (when (/= sketch-active-layer 0)
(number-to-string sketch-active-layer))
(pcase type
- ("line" "l")
- ("rectangle" "r")
- ("circle" "c")
- ("ellipse" "e")
- ("polyline" "p")
- ("polygon" "g")
- ("freehand" "f")
- ("text" "t")
- ("group" "g"))))
+ ('line "l")
+ ('rectangle "r")
+ ('circle "c")
+ ('ellipse "e")
+ ('polyline "p")
+ ('polygon "g")
+ ('freehand "f")
+ ('text "t")
+ ('group "g"))))
(idx 0)
(label (concat prefix (number-to-string idx)))
(labels (sketch-labels-list)))
@@ -780,315 +282,618 @@ else return nil"
(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 'sketch-active-layer)
-
-(defun sketch-list-layers ()
- (mapcar #'number-to-string (number-sequence 0 (length sketch-layers-list))))
-;; (with-current-buffer (get-buffer "*sketch*")
-;; (mapcar (lambda (layer) (alist-get 'id (cadr layer)))
sketch-layers-list)))
-
-;; (defun sketch-translate-node-coords (node amount &rest args)
-;; (dolist (coord args node)
-;; (cl-decf (alist-get coord (cadr node)) amount)))
-
-(defun sketch--svg-translate (dx dy &optional object-def)
- (interactive)
- (let ((transform (sketch-parse-transform-value
- (dom-attr object-def
- 'transform))))
- (cl-decf (cl-first (alist-get 'translate transform)) dx)
- (cl-decf (cl-second (alist-get 'translate transform)) dy)
- (dom-set-attribute object-def
- 'transform
- (sketch-format-transfrom-value transform))))
-
-;; (mapcar (lambda (node)
-;; (pcase (dom-tag 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 (nth sketch-active-layer sketch-layers-list))))
-;; (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"))
- (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 (cl-subseq sketch-root 0 2) (list (nth (car
show-layers) sketch-layers-list))))
- (dolist (layer (cdr show-layers))
- (setq sketch-root (append sketch-root (list (nth layer
sketch-layers-list)))))
- (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)
- (sketch-insert-image sketch-svg
- (prin1-to-string sketch-root)
- :pointer 'arrow
- :grid-param sketch-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 (cdr (mouse-pixel-position))))
- (setq
sketch-cursor-position (format "(%s, %s)"
-
(- (car coords) sketch-im-x-offset)
-
(+ (cdr coords) sketch-im-y-offset))))
-
(force-mode-line-update))))))
- (beginning-of-line)))
-
-(defun sketch-update (&optional lisp lisp-buffer)
- (unless sketch-mode
- (user-error "Not in sketch-mode buffer"))
- (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 (cl-subseq sketch-root 0 2) (list (nth (car
show-layers) sketch-layers-list))))
- (dolist (layer (cdr show-layers))
- (setq sketch-root (append sketch-root (list (nth layer
sketch-layers-list)))))
- (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)
- (sketch-insert-image sketch-svg
- nil
- :pointer 'arrow
- :grid-param sketch-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))))
- (beginning-of-line)))
-
-
-(defun sketch-object-preview-update (object-type node start-coords end-coords)
+(defun sketch--create-canvas (width height)
+ (setq sketch-canvas (sketch-create width height nil nil nil :stroke
sketch-default-stroke))
+ (apply #'svg-rectangle sketch-canvas 0 0 "100%" "100%"
+ :id "bg"
+ (when (or sketch-show-grid sketch-background)
+ (list :fill
+ (if sketch-show-grid
+ "url(#grid)"
+ sketch-background)
+ )))) ; sketch-background)
+
+(defun sketch-create-grid (&optional grid-param minor-grid-freq)
+ (setq sketch-grid-param (or grid-param sketch-grid-param))
+ (setq sketch-minor-grid-param (/ (float grid-param) (or minor-grid-freq 4)))
+ (setq sketch-grid (cons
+ ;; major-grid
+ (dom-node 'pattern
+ `((id . "grid")
+ (width . ,grid-param)
+ (height . ,grid-param)
+ (patternUnits . "userSpaceOnUse"))
+ (dom-node 'rect `((width . ,grid-param) (height
. ,grid-param)
+ (x . 0) (y . 0)
+ (stroke-width . 0.8) (stroke
. ,(car sketch-grid-colors))
+ (fill . "url(#minorGrid)"))))
+ ;; minor grid
+ (dom-node 'pattern
+ `((id . "minorGrid")
+ (width . ,sketch-minor-grid-param)
+ (height . ,sketch-minor-grid-param)
+ (patternUnits . "userSpaceOnUse"))
+ (dom-node 'rect `((width .
,sketch-minor-grid-param) (height . ,sketch-minor-grid-param)
+ (x . 0) (y . 0)
+ (stroke-width . 0.4) (stroke
. ,(cdr sketch-grid-colors))
+ ,(when sketch-background
+ `(fill .
,sketch-background))))))))
+
+(defun sketch-maybe-update-modeline ()
+ (when sketch-show-coords
+ (force-mode-line-update)))
+
+(defun sketch-draw-insert-image (width height)
+ (sketch-insert-image sketch-svg
+ (prin1-to-string sketch-root)
+ :map `(((rect . ((0 . 0) . (,(dom-attr sketch-svg
'width) . ,(dom-attr sketch-svg 'height))))
+ ;; :map '(((rect . ((0 . 0) . (800 . 600)))
+ sketch
+ ,(append '(pointer
+ arrow)
+ (when sketch-show-coords
+ (list 'help-echo (lambda (_ _ pos)
+ (let ((coords
(cdr (mouse-pixel-position))))
+ (setq
sketch-cursor-position
+ (format
"(%s, %s)"
+
(- (car coords) sketch-im-x-offset)
+
(cdr coords))))
+ ;; (+ (cdr
coords) sketch-im-y-offset))))
+
(force-mode-line-update)))))))))
+
+(defun sketch-update-insert-image (width height)
+ (sketch-insert-image sketch-svg
+ nil
+ ;; :pointer 'arrow
+ :map `(((rect . ((0 . 0) . (,(dom-attr sketch-svg
'width) . ,(dom-attr sketch-svg 'height))))
+ ;; :map '(((rect . ((0 . 0) . (800 . 600)))
+ sketch
+ (pointer arrow))))
+ (backward-char))
+
+(defun sketch-object-preview-update (object-type node start-coords end-coords
&optional start-node)
(pcase object-type
- ("line"
+ ('line
(setf (dom-attr node 'x2) (car end-coords))
(setf (dom-attr node 'y2) (cdr end-coords)))
- ("rectangle"
+ ('rectangle
(setf (dom-attr node 'x) (car (sketch--rectangle-coords start-coords
end-coords)))
(setf (dom-attr node 'y) (cadr (sketch--rectangle-coords start-coords
end-coords)))
(setf (dom-attr node 'width) (caddr (sketch--rectangle-coords
start-coords end-coords)))
(setf (dom-attr node 'height) (cadddr (sketch--rectangle-coords
start-coords end-coords))))
- ("circle"
+ ('circle
(setf (dom-attr node 'r) (sketch--circle-radius start-coords end-coords)))
- ("ellipse"
+ ('ellipse
(setf (dom-attr node 'cx) (car (sketch--ellipse-coords start-coords
end-coords)))
(setf (dom-attr node 'cy) (cadr (sketch--ellipse-coords start-coords
end-coords)))
(setf (dom-attr node 'rx) (caddr (sketch--ellipse-coords start-coords
end-coords)))
- (setf (dom-attr node 'ry) (cadddr (sketch--ellipse-coords start-coords
end-coords))))))
+ (setf (dom-attr node 'ry) (cadddr (sketch--ellipse-coords start-coords
end-coords))))
+ ('translate
+ (message "deze %s" start-node)
+ (let ((dx (- (car end-coords) (car start-coords)))
+ (dy (- (cdr end-coords) (cdr start-coords))))
+ (sketch--svg-move dx dy node start-node)))))
+
+(defun sketch-redraw (&optional lisp lisp-buffer update)
+ ;; (unless sketch-mode
+ ;; (user-error "Not in sketch-mode buffer"))
+ ;; (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 (cl-subseq sketch-root 0 2) (list (nth (car
show-layers) sketch-layers-list))))
+ (dolist (layer (cdr show-layers))
+ (setq sketch-root (append sketch-root (list (nth layer
sketch-layers-list)))))
+ (setq sketch-svg (append sketch-canvas
+ (list sketch-root)
+ (when sketch-show-labels (list (sketch-labels)))))
+ (when sketch-show-grid
+ (svg--def sketch-svg (cdr sketch-grid))
+ (svg--def sketch-svg (car sketch-grid)))
+ (with-current-buffer "*sketch*"
+ (let ((inhibit-read-only t))
+ (erase-buffer) ;; a (not exact) alternative is to use
(kill-backward-chars 1)
+ (let ((w (car sketch-size))
+ (h (cdr sketch-size)))
+ (if update
+ (sketch-update-insert-image w h)
+ (sketch-draw-insert-image w h))
+ (goto-char (point-min))))))
+
+(defun sketch--init (width height &optional grid-param minor-grid-freq)
+ (setq sketch-grid-param (or grid-param sketch-grid-param))
+ (setq sketch-minor-grid-freq (or minor-grid-freq sketch-minor-grid-freq))
+ (let* (svg)
+ ;; (when sketch-background
+ ;; (unless (memq "none" (list sketch-start-marker sketch-mid-marker
sketch-end-marker))
+ ;; (svg-marker sketch-canvas "arrow" 8 8 "black" t))
+ (sketch--create-canvas width height)
+ (setq sketch-svg (seq-copy sketch-canvas))
+ (when sketch-show-grid
+ (sketch-create-grid grid-param)
+ (svg--def sketch-svg (cdr sketch-grid))
+ (svg--def sketch-svg (car sketch-grid)))
+ (setq sketch-root (sketch-group "root"))
+ (setq sketch-layers-list (list (sketch-group "layer-0")))
+ (setq show-layers '(0))
+ (sketch-draw-insert-image width height)
+ (goto-char (point-min)) ; cursor over image looks better
+ (setq sketch-im-x-offset (car (window-absolute-pixel-position)))
+ (sketch-toggle-toolbar)
+ (when (featurep 'hydra) (hydra-sketch/body))
+ (add-hook 'kill-buffer-hook 'sketch-kill-toolbar nil t)
+ (special-mode)
+ (sketch-mode)))
+;; (evil-emacs-state)))
+
+(defun sketch (arg)
+ "Initialize or switch to (new) SVG image.
+With prefix ARG, create sketch using default (customizable)
+values"
+ (interactive "P")
+ (let ((buffer (get-buffer "*sketch*")))
+ (cond (buffer
+ (switch-to-buffer buffer)
+ (sketch-toggle-toolbar)
+ (when (featurep 'hydra) (hydra-sketch/body)))
+ (t
+ (let ((call-buffer (current-buffer))
+ (width (if arg (car sketch-size) (read-number "Enter width:
") ))
+ (height (if arg (cdr sketch-size) (read-number "Enter height:
"))))
+ (switch-to-buffer (get-buffer-create "*sketch*"))
+ (setq sketch-action 'line)
+ (setq sketch-grid-param (if arg 50 (read-number "Enter grid
parameter (enter 0 for no grid): ")))
+ (sketch--init width height sketch-grid-param)
+ (when sketch-show-coords
+ (setq sketch-coordless-mode-line-format mode-line-format)
+ (add-to-list 'mode-line-format '(:eval sketch-cursor-position)
t))
+ (setq sketch-call-buffer call-buffer)))))) ;; variable is buffer
local))
+
+(define-key image-map "o" nil)
+
+(define-minor-mode sketch-mode
+ "Create svg images using the mouse.
+In sketch-mode buffer press \\[sketch-transient] to activate the
+transient."
+ :lighter "sketch-mode"
+ :keymap
+ `(
+ ([sketch down-mouse-1] . sketch-interactively)
+ ([sketch mouse-3] . sketch-text-interactively)
+ ([sketch C-S-drag-mouse-1] . sketch-crop)
+ ;; ([sketch S-down-mouse-1] . sketch-select)
+ ("a" . sketch-set-action)
+ ("c" . sketch-set-colors)
+ ("w" . sketch-set-width)
+ ("sd" . sketch-set-dasharray)
+ ("fw" . sketch-set-font-with-keyboard)
+ ("fs" . sketch-set-font-size)
+ ("v" . sketch-keyboard-select)
+ ("m" . sketch-modify-object)
+ ("d" . sketch-remove-object)
+ ("tg" . sketch-toggle-grid)
+ ("ts" . sketch-toggle-snap)
+ ("l" . sketch-cycle-labels)
+ ("D" . sketch-show-definition)
+ ("u" . sketch-undo)
+ ("U" . sketch-redo)
+ ("S" . image-save)
+ ("tt" . sketch-toggle-toolbar)
+ ("tc" . sketch-toggle-coords)
+ ("?" . sketch-help)
+ (,(kbd "C-c C-c") . sketch-quick-insert-image))
+ ;; (,(kbd "C-c C-s") . sketch-transient))
+ (when (boundp 'spacemacs-version)
+ (evil-emacs-state)
+ ;; (evil-local-set-key 'motion "g" 'sketch-toggle-grid)
+ ;; (evil-local-set-key 'motion "l" 'sketch-cycle-labels)
+ ;; (evil-local-set-key 'motion "?" 'sketch-help)
+ ;; (evil-local-set-key 'motion "tg" 'sketch-toggle-grid)
+ ;; (evil-local-set-key 'motion "ts" 'sketch-toggle-snap)
+ ;; (evil-local-set-key 'motion "tt" 'sketch-toggle-toolbar)
+ ;; (evil-local-set-key 'motion "tc" 'sketch-toggle-coords)
+ ;; (evil-local-set-key 'motion "fw" 'sketch-set-font-with-keyboard)
+ ;; (evil-local-set-key 'motion "fs" 'sketch-set-font-size)
+ )
+ (if (boundp 'undo-tree-mode)
+ (undo-tree-mode)
+ (buffer-enable-undo))
+ (setq-local global-hl-line-mode nil)
+ (blink-cursor-mode 0))
+
+(when (featurep 'hydra)
+ (defhydra hydra-sketch (:hint nil :foreign-keys run)
+ "
+^Stroke/Fill^ ^Font^ ^Edit^ ^Toggle^
+^^^^^^^^-------------------------------------------------------------
+_a_ : action _fw_: font _v_ : select _tg_: grid
+_c_ : color _fs_: sont-size _m_ : modify _ts_: snap
+_w_ : width ^ ^ _d_ : delete _tt_: toolbar
+_sd_: dasharray ^ ^ _u_/_U_: undo/redo _tc_: coords
+"
+ ("a" sketch-set-action)
+ ("c" sketch-set-colors)
+ ("w" sketch-set-width)
+ ("sd" sketch-set-dasharray)
+ ("fw" sketch-set-font-with-keyboard)
+ ("fs" sketch-set-font-size)
+ ("v" sketch-keyboard-select)
+ ("m" sketch-modify-object)
+ ("d" sketch-remove-object)
+ ("tg" sketch-toggle-grid)
+ ("ts" sketch-toggle-snap)
+ ("l" sketch-cycle-labels)
+ ("D" sketch-show-definition)
+ ("u" sketch-undo)
+ ("U" sketch-redo)
+ ("S" image-save)
+ ("tt" sketch-toggle-toolbar)
+ ("tc" sketch-toggle-coords)
+ ("?" sketch-help "help" :color blue)
+ ("." nil "exit hydra" :color blue :exit t)
+ ("q" sketch-quit-window "quit-restore" :exit t)
+ ("Q" sketch-quit "quit" :exit t)))
+
+
+(defun sketch-hydra ()
+ (interactive)
+ (if (featurep 'hydra)
+ (hydra-sketch/body)
+ (user-error "This feature requires the hydra package to be installed")))
+
+(define-key sketch-mode-map "." 'sketch-hydra)
+
+(defun sketch-quit-window ()
+ "Quit sketch window. The window can be restores with ‘M-x sketch'"
+ (interactive)
+ (when (get-buffer "*sketch-toolbar*")
+ (kill-buffer "*sketch-toolbar*"))
+ (quit-window))
+
+(defun sketch-quit ()
+ "Quit sketch-mode and kill buffers."
+ (interactive)
+ (when (get-buffer "*sketch-toolbar*")
+ (kill-buffer "*sketch-toolbar*"))
+ (kill-buffer "*sketch*"))
+
+;;; Actions
+(defvar sketch-action 'line)
+(defvar sketch-stroke-color "Black")
+(defvar sketch-fill-color "none")
+(defvar sketch-stroke-width 1)
+(defvar sketch-stroke-dasharray nil)
+
+(defvar sketch-font nil)
+
+
+(defun sketch-norm (vec)
+ "Return norm of a vector (list of numbers).
+VEC should be a cons or a list containing only number elements."
+ (let ((sum-of-squares (apply #'+
+ (mapcar (lambda (x) (expt x 2))
+ vec))))
+ (expt sum-of-squares 0.5)))
+
+(defun sketch--circle-radius (start-coords end-coords)
+ (sketch-norm
+ (list (- (car end-coords) (car start-coords))
+ (- (cdr end-coords) (cdr start-coords)))))
+
+(defun sketch--rectangle-coords (start-coords end-coords)
+ (let ((base-coords (cons (apply #'min (list (car start-coords) (car
end-coords)))
+ (apply #'min (list (cdr start-coords) (cdr
end-coords))))))
+ (list (car base-coords)
+ (cdr base-coords)
+ (abs (- (car end-coords) (car start-coords)))
+ (abs (- (cdr end-coords) (cdr start-coords))))))
+
+(defun sketch--ellipse-coords (start-coords end-coords)
+ (list (/ (+ (car start-coords) (car end-coords)) 2)
+ (/ (+ (cdr start-coords) (cdr end-coords)) 2)
+ (abs (/ (- (car end-coords) (car start-coords)) 2))
+ (abs (/ (- (cdr end-coords) (cdr start-coords)) 2))))
-(defun sketch-interactively-1 (event)
+(defun sketch--snap-to-grid (coord grid-param)
+ (cons (* (round (/ (float (car coord)) grid-param)) grid-param)
+ (* (round (/ (float (cdr coord)) grid-param)) grid-param)))
+
+(defun sketch-interactively (event)
+ "Draw objects interactively via a mouse drag 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)))
+ (let* ((start (event-start event))
+ (start-coords (if sketch-snap-to-grid
+ (sketch--snap-to-grid (posn-object-x-y start)
sketch-minor-grid-param)
+ (posn-object-x-y start)))
(points (list (cons (car start-coords) (cdr start-coords)))) ;; list
of point needed for polyline/gon
- (object-props (list :stroke-width
- (transient-arg-value "--stroke-width=" args)
- :stroke
- (transient-arg-value "--stroke-color=" args)
- :fill
- (transient-arg-value "--fill-color=" args)
- :stroke-dasharray
- (transient-arg-value "--stroke-dasharray=" args)
- :marker-end (if args (pcase (transient-arg-value
"--marker=" args)
- ("arrow" "url(#arrow)")
- ("dot" "url(#dot)")
- (_ "none"))
- (if sketch-include-end-marker
- "url(#arrow)"
- "none"))))
- (object-type (transient-arg-value "--object=" args))
- (start-command-and-coords (pcase object-type
- ("line" (list 'svg-line
- (car start-coords) (cdr
start-coords)
- (car start-coords) (cdr
start-coords)))
- ("rectangle" `(svg-rectangle
-
,@(sketch--rectangle-coords start-coords start-coords)))
- ("circle" (list 'svg-circle
- (car start-coords) (cdr
start-coords)
- (sketch--circle-radius
start-coords start-coords)))
- ("ellipse" `(svg-ellipse
,@(sketch--ellipse-coords start-coords start-coords)))
- (var (list (pcase var
- ((or "polyline" "freehand")
'svg-polyline)
- ("polygon" 'svg-polygon))
+ (object-props (if (eq sketch-action 'text)
+ (append (list :font-size sketch-font-size
+ :font-weight sketch-font-weight)
+ (when sketch-font
+ (list :font-family sketch-font))
+ (when sketch-stroke-color
+ (list :stroke sketch-stroke-color))
+ (when sketch-fill-color
+ (list :fill sketch-fill-color)))
+ (list :stroke-width
+ sketch-stroke-width
+ :stroke
+ sketch-stroke-color
+ :fill
+ sketch-fill-color
+ :stroke-dasharray
+ sketch-stroke-dasharray
+ ;; :marker-end (if args (pcase
(transient-arg-value "--marker=" args)
+ ;; ("arrow"
"url(#arrow)")
+ ;; ("dot" "url(#dot)")
+ ;; (_ "none"))
+ ;; (if sketch-include-end-marker
+ ;; "url(#arrow)"
+ ;; "none"))
+ )))
+ (start-command-and-coords (pcase sketch-action
+ ('line (list 'svg-line
+ (car start-coords) (cdr
start-coords)
+ (car start-coords) (cdr
start-coords)))
+ ('rectangle `(svg-rectangle
+ ,@(sketch--rectangle-coords
start-coords start-coords)))
+ ('circle (list 'svg-circle
+ (car start-coords) (cdr
start-coords)
+ (sketch--circle-radius
start-coords start-coords)))
+ ('ellipse `(svg-ellipse
,@(sketch--ellipse-coords start-coords start-coords)))
+ (var (list (pcase var
+ ((or 'polyline 'freehand)
'svg-polyline)
+ ('polygon 'svg-polygon))
points))))
- (label (sketch-create-label object-type)))
- (apply (car start-command-and-coords)
- (nth sketch-active-layer sketch-layers-list)
- `(,@(cdr start-command-and-coords) ,@object-props :id ,label))
- (let ((node (car (dom-by-id (nth sketch-active-layer sketch-layers-list)
label))))
- (cond ((member object-type '("line" "rectangle" "circle" "ellipse"))
+ (label (unless (memq sketch-action '(move translate))
+ (sketch-create-label sketch-action))))
+ (if (eq sketch-action 'text)
+ (let ((text (read-string "Enter text: ")))
+ (apply #'svg-text
+ (nth sketch-active-layer sketch-layers-list)
+ text
+ :x (car start-coords) (cdr start-coords)
+ :id label object-props))
+ (unless (memq sketch-action '(move translate))
+ (apply (car start-command-and-coords)
+ (nth sketch-active-layer sketch-layers-list)
+ `(,@(cdr start-command-and-coords) ,@object-props :id ,label)))
+ (let* ((node (car (dom-by-id (nth sketch-active-layer sketch-layers-list)
+ (if (memq sketch-action '(move translate))
+ (car sketch-selection)
+ label))))
+ (translate-start (dom-attr node 'transform)))
(track-mouse
- (while (not (eq (car event) 'drag-mouse-1))
- (setq event (read-event))
- (let* ((end (event-start 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))))
- (sketch-object-preview-update object-type node start-coords
end-coords)
- (sketch-update)
- (setq sketch-cursor-position (format "(%s, %s)"
- (car end-coords)
- (cdr end-coords)))
- (force-mode-line-update))))
- ;; (sketch-possibly-update-image sketch-svg)))
- (let* ((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))))
- (sketch-object-preview-update object-type node start-coords
end-coords)))
- ((member object-type '("polyline" "polygon"))
- (track-mouse
- (while (not (eq (car event) 'double-mouse-1))
- (setq event (read-event))
- (let* ((end (event-start 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))))
+ (cond ((member sketch-action '(line rectangle circle ellipse move
translate))
+ (let ((event (read-event)))
+ (while (not (memq (car event) '(mouse-1 drag-mouse-1)))
+ (let* ((end (event-start event))
+ (end-coords (if sketch-snap-to-grid
+ (sketch--snap-to-grid
(posn-object-x-y end) sketch-minor-grid-param)
+ (posn-object-x-y end))))
+ (sketch-object-preview-update sketch-action
+ node
+ start-coords
+ end-coords
+ (when (eq sketch-action
'translate)
+ translate-start))
+ (sketch-redraw nil nil t)
+ (when (and sketch-lisp-buffer-name (buffer-live-p
(get-buffer sketch-lisp-buffer-name)))
+ (sketch-update-lisp-window node
sketch-lisp-buffer-name))
+ (setq event (read-event))
+ (when sketch-show-coords
+ (setq sketch-cursor-position (format "(%s, %s)"
+ (car end-coords)
+ (cdr
end-coords))))
+ (sketch-maybe-update-modeline)
+ ))
+ (let* ((end (event-end event))
+ (end-coords (if sketch-snap-to-grid
+ (sketch--snap-to-grid
(posn-object-x-y end) sketch-minor-grid-param)
+ (posn-object-x-y end))))
+ (if (and (equal (car start-coords) (car end-coords))
+ (equal (cdr start-coords) (cdr end-coords)))
+ (dom-remove-node (nth sketch-active-layer
sketch-layers-list) node)
+ (sketch-object-preview-update sketch-action
+ node
+ start-coords
+ end-coords
+ (when (eq sketch-action
'translate)
+ translate-start))
+ (sketch-redraw nil nil t)
+ (when (and sketch-lisp-buffer-name (buffer-live-p
(get-buffer sketch-lisp-buffer-name)))
+ (sketch-update-lisp-window node
sketch-lisp-buffer-name))
+ ))))
+
+
+ ((member sketch-action '(polyline polygon))
+ (while (not (eq (car event) 'double-mouse-1))
+ (setq event (read-event))
+ (let* ((end (event-start event))
+ (end-coords (if sketch-snap-to-grid
+ (sketch--snap-to-grid
(posn-object-x-y end) sketch-minor-grid-param)
+ (posn-object-x-y end))))
+ (let (message-log-max)
+ (message "Press double click finish by inserting a
final node"))
+ (setf (dom-attr node 'points) (mapconcat (lambda (pair)
+ (format "%s
%s" (car pair) (cdr pair)))
+ (reverse
+ (if (eq (car
event) 'down-mouse-1)
+ (push
end-coords points)
+ (cons
end-coords points)))
+ ", "))
+ (sketch-redraw nil nil t)
+ (setq sketch-cursor-position (format "(%s, %s)"
+ (car end-coords)
+ (cdr end-coords)))
+ (sketch-maybe-update-modeline)))
+ (let* ((end (event-end event))
+ (end-coords (if sketch-snap-to-grid
+ (sketch--snap-to-grid (posn-object-x-y
end) sketch-minor-grid-param)
+ (posn-object-x-y end))))
(setf (dom-attr node 'points) (mapconcat (lambda (pair)
-
(format "%s %s" (car pair) (cdr pair)))
-
(reverse
+ (format "%s %s"
(car pair) (cdr pair)))
+ (reverse
(if (eq (car
event) 'down-mouse-1)
(push
end-coords points)
(cons
end-coords points)))
-
", "))
- (sketch-update)
- (setq sketch-cursor-position (format "(%s, %s)"
- (car end-coords)
- (cdr end-coords)))
- (force-mode-line-update)))
- ;; (sketch-possibly-update-image sketch-svg)))
- (let* ((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))))
- (setf (dom-attr node 'points) (mapconcat (lambda (pair)
-
(format "%s %s" (car pair) (cdr pair)))
-
(reverse
- (if (eq (car event)
'down-mouse-1)
- (push
end-coords points)
- (cons end-coords
points)))
- ",
")))))
- ((string= object-type "freehand")
- (track-mouse
- (while (not (eq (car event) 'drag-mouse-1))
- (setq event (read-event))
- (let* ((end (if (eq (car event) 'drag-mouse-1)
- (event-end event)
- (event-start 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))))
- (setf (dom-attr node 'points) (mapconcat (lambda (pair)
-
(format "%s %s" (car pair) (cdr pair)))
-
(reverse (cl-pushnew end-coords points))
-
", "))
- (sketch-update)
- (setq sketch-cursor-position (format "(%s, %s)"
- (car end-coords)
- (cdr end-coords)))
- (force-mode-line-update))))))
- ;; (sketch-possibly-update-image sketch-svg)))
- ;; (sketch-possibly-update-image sketch-svg
- ;; :pointer 'arrow
- ;; :map `(((rect . ((0 . 0) .
(,(dom-attr sketch-svg 'width) . ,(dom-attr sketch-svg 'height))))
- ;; ;; :map '(((rect . ((0 . 0) .
(800 . 600)))
- ;; sketch
- ;; (pointer arrow))))
- (when-let (buf (get-buffer "*sketch-root*"))
- (sketch-update-lisp-window sketch-root buf))
- (sketch-redraw))))
-
-(transient-define-suffix sketch-remove-object ()
- (interactive)
- (svg-remove sketch-root (completing-read "Remove element with id: "
- (sketch-labels-list)))
- (sketch-redraw))
+ ", "))))
+
+
+ ((string= sketch-action 'freehand)
+ (while (not (memq (car event) '(mouse-1 drag-mouse-1)))
+ (setq event (read-event))
+ (let* ((end (if (eq (car event) 'drag-mouse-1)
+ (event-end event)
+ (event-start event)))
+ (end-coords (if sketch-snap-to-grid
+ (sketch--snap-to-grid
(posn-object-x-y end) sketch-minor-grid-param)
+ (posn-object-x-y end))))
+ (setf (dom-attr node 'points) (mapconcat (lambda (pair)
+ (format "%s
%s" (car pair) (cdr pair)))
+ (reverse
(cl-pushnew end-coords points))
+ ", "))
+ (sketch-redraw nil nil t)
+ (setq sketch-cursor-position (format "(%s, %s)"
+ (car end-coords)
+ (cdr end-coords)))
+ (sketch-maybe-update-modeline))))))))
+ (when-let (buf (get-buffer "*sketch-root*"))
+ (sketch-update-lisp-window sketch-root buf))
+ (sketch-redraw)))
-(transient-define-suffix sketch-insert-snippet (event)
+(defvar sketch-font-size 20)
+(defvar sketch-font-weight "normal")
+
+(defun sketch-text-interactively (event)
(interactive "@e")
- (let ((coords (posn-object-x-y (event-start event)))
- (node (oref transient-current-prefix value))
- (label (sketch-create-label "group")))
- (dom-set-attribute node
+ (let* ((start (event-start event))
+ (coords (if sketch-snap-to-grid
+ (posn-object-x-y start)
+ (sketch--snap-to-grid (posn-object-x-y start)
sketch-grid-param)))
+ (text (read-string "Enter text: "))
+ (object-props (append (list :font-size sketch-font-size
+ :font-weight sketch-font-weight)
+ (when sketch-font
+ (list :font-family sketch-font))
+ (when sketch-stroke-color
+ (list :stroke sketch-stroke-color))
+ (when sketch-fill-color
+ (list :fill sketch-fill-color)))))
+ ;; :fill
+ ;; (transient-arg-value "--fill-color=" sketch-args)
+ ;; :marker-end (if sketch-args (pcase (transient-arg-value "--marker="
sketch-args)
+ ;; ("arrow" "url(#arrow)")
+ ;; ("dot" "url(#dot)")
+ ;; (_ "none"))
+ ;; (if sketch-include-end-marker
+ ;; "url(#arrow)"
+ ;; "none"))))
+ (apply #'svg-text
+ (nth sketch-active-layer sketch-layers-list)
+ text
+ :x (car coords) (cdr coords)
+ :id (sketch-create-label 'text) object-props))
+ (sketch-redraw))
+
+;;; Modify object-label
+
+(defvar sketch-selection nil)
+
+(defun sketch-keyboard-select (&optional arg)
+ "Select labels to include in selection.
+Initial input shows current selection. With prefix ARG initial
+selection shows all object in sketch."
+ (interactive "P")
+ (setq sketch-selection (completing-read-multiple "Select labels for
selection (separated by ,): "
+ (sketch-labels-list)
+ nil
+ t
+ (mapconcat #'identity
+ (if all
+
(sketch-labels-list)
+
sketch-selection)
+ ","))))
+
+
+(defun sketch-move-object (buffer object-def props coords amount)
+ (dolist (coord coords)
+ (cl-incf (alist-get coord props) amount))
+ (sketch-redraw object-def buffer))
+
+(defun sketch-parse-transform-value (value)
+ (let ((transforms (mapcar (lambda (val)
+ (split-string val "[(,)]" t))
+ (split-string value))))
+ (mapcar (lambda (x)
+ (cons (intern (car x)) (mapcar (lambda (val)
+ (string-to-number val))
+ (cdr x))))
+ transforms)))
+
+(defun sketch-format-transfrom-value (value)
+ (string-join (mapcar (lambda (x) (concat (symbol-name (car x))
+ "("
+ (number-to-string (cadr x))
+ (if-let (y (caddr x))
+ (concat "," (number-to-string
y)))
+ ")"))
+ value)
+ " "))
+
+(defun sketch--svg-translate (dx dy &optional object-def)
+ (interactive)
+ (let ((transform (sketch-parse-transform-value
+ (or (dom-attr object-def 'transform)
+ "translate(0,0)"))))
+ (cl-decf (cl-first (alist-get 'translate transform)) dx)
+ (cl-decf (cl-second (alist-get 'translate transform)) dy)
+ (dom-set-attribute object-def
'transform
- (format "translate(%s,%s)" (car coords) (cdr coords)))
- (dom-set-attribute node
- 'id
- label)
- (dom-append-child (nth sketch-active-layer sketch-layers-list) node)
- (sketch-redraw)
- (sketch-modify-object label)))
-
-(transient-define-prefix sketch-import (svg-file)
- [([sketch mouse-1] "Insert snippet" sketch-insert-snippet)]
- (interactive (list (let ((default-directory (concat
- (file-name-directory
(locate-library "sketch-mode"))
- "snippet-files/")))
- (read-file-name "Import (object) from file: "))))
- (let* ((dom (sketch-snippet-get-dom svg-file))
- (has-groups (dom-by-tag dom 'g)))
- (when has-groups (sketch-snippets-add-labels dom))
- (let* ((idx (when has-groups (read-number "Number of object for import:
")))
- (snippet (if (dom-by-tag dom 'g)
- (dom-elements dom 'id (number-to-string idx))
- (list (dom-append-child
- (sketch-group (sketch-create-label "group"))
- (car (dom-children dom)))))))
- (sketch-redraw)
- (transient-setup 'sketch-import nil nil :value (car snippet)))))
-
-;; (transient-define-suffix sketch-import-object (svg-file)
-;; (interactive "fImport object from file: ")
+ (sketch-format-transfrom-value transform))))
+
+(defun sketch--svg-move (dx dy &optional object-def start-node)
+ (interactive)
+ (let ((transform (sketch-parse-transform-value
+ (if start-node
+ start-node
+ "translate(0,0)"))))
+
+ ;; (or (print (dom-attr start-node 'transform))
+ ;; "translate(0,0)"))
+ (cond
+ ;; (end
+ ;; (cl-incf (cl-first (alist-get 'translate transform)) dx)
+ ;; (cl-incf (cl-second (alist-get 'translate transform)) dy))
+ (t
+ (cl-incf (cl-first (alist-get 'translate transform)) dx)
+ (cl-incf (cl-second (alist-get 'translate transform)) dy)))
+ (dom-set-attribute object-def
+ 'transform
+ (sketch-format-transfrom-value transform))
+ start-node))
+
+(defun sketch-group-scale (buffer object-def direction &optional fast)
+ (let ((transform (sketch-parse-transform-value
+ (dom-attr object-def
+ 'transform)))
+ (amount (if fast
+ 1
+ 0.1)))
+ (unless (alist-get 'scale transform)
+ (push '(scale 1) transform))
+ (pcase direction
+ ('up (cl-incf (car (alist-get 'scale transform)) amount))
+ ('down (cl-decf (car (alist-get 'scale transform)) amount)))
+ (dom-set-attribute object-def
+ 'transform
+ (sketch-format-transfrom-value transform))
+ (sketch-redraw object-def buffer)))
(define-minor-mode sketch-lisp-mode
"Minor mode for svg lisp buffers."
@@ -1097,31 +902,29 @@ else return nil"
`((,(kbd "C-c C-s") . sketch-transient)
(,(kbd "C-c C-c") . sketch-load-definition)))
-(transient-define-suffix sketch-show-definition ()
+(defun sketch-show-definition ()
;; :transient 'transient--do-exit
(interactive)
+ (when (get-buffer "*sketch-toolbar*")
+ (kill-buffer "*sketch-toolbar*"))
(if-let (win (get-buffer-window "*sketch-root*"))
(delete-window win)
(let ((buffer (get-buffer-create "*sketch-root*"))
(sketch sketch-root))
(set-window-dedicated-p
- (get-buffer-window
- (pop-to-buffer buffer
- '(display-buffer-in-side-window . ((side . right)
(window-width . 70)))))
+ (get-buffer-window (pop-to-buffer
+ buffer
+ `(display-buffer-in-side-window
+ . ((side . right)
+ (window-width . ,(funcall
sketch-side-window-max-width))))))
t)
+ (window-resize (get-buffer-window buffer) -3 t)
(erase-buffer)
(with-current-buffer buffer
(dom-pp sketch)))
(emacs-lisp-mode)
(sketch-lisp-mode)))
-(transient-define-suffix sketch-copy-definition ()
- (interactive)
- (with-temp-buffer
- (dom-pp sketch-svg)
- (kill-new (buffer-string)))
- (message "SVG definition added to kill-ring"))
-
(defun sketch-load-definition ()
(interactive)
(let ((def (read (buffer-string))))
@@ -1130,233 +933,384 @@ else return nil"
(setq sketch-layers-list (dom-by-id sketch-root "layer"))
(sketch-redraw))))
-;; (defvar sketch-undo-redo nil)
-
-(transient-define-suffix sketch-undo (&optional count)
- (interactive "*p")
- (cond ((fboundp 'evil-undo)
- (evil-undo count))
- ((fboundp 'undo-tree-undo)
- (undo-tree-undo))
- (t (undo)))
- (setq sketch-svg (read (buffer-string)))
- (setq sketch-root (car (dom-by-id sketch-svg "root")))
- (setq sketch-layers-list (dom-elements sketch-root 'id "layer"))
- (unless sketch-layers-list (sketch-add-layer)))
-;; (let ((sketch-reverse (nreverse sketch-root)))
-;; (push (pop sketch-reverse) sketch-undo-redo)
-;; (setq sketch-root (nreverse sketch-reverse)))
-;; (sketch-redraw))
-
-(transient-define-suffix sketch-redo (count)
- (interactive "*p")
- (cond ((fboundp 'evil-undo)
- (evil-redo count))
- ((fboundp 'undo-tree-redo)
- (undo-tree-redo))
- (t (user-error "This command requires `undo-tree' or `evil' to be
available")))
- (setq sketch-root (read (buffer-string)))
- (setq sketch-layers-list (dom-elements sketch-root 'id "layer"))
- (unless sketch-layers-list (sketch-add-layer)))
-;; (let ((sketch-reverse (nreverse sketch-root)))
-;; (push (pop sketch-undo-redo) sketch-reverse)
-;; (setq sketch-root (nreverse sketch-reverse)))
-;; (sketch-redraw))
+(defun sketch-modify-object (&optional group)
+ (interactive)
+ (let ((show-labels sketch-show-labels))
+ (setq sketch-show-labels "all")
+ (sketch-toolbar-refresh)
+ (sketch-redraw)
+ (let* ((object-label (if group
+ group
+ (completing-read "Transform element with id: "
+ (sketch-labels-list))))
+ (buffer (get-buffer-create (format "*sketch-object-%s*"
object-label))))
+ (setq sketch-selection (list object-label))
+ (display-buffer
+ buffer
+ `(display-buffer-in-side-window
+ . ((side . right)
+ (window-width . ,(funcall sketch-side-window-max-width)))))
+ (window-resize (get-buffer-window buffer) -3 t)
+ (pp (cadar (dom-by-id sketch-svg (format "^%s$" object-label))) buffer)
+ (setq sketch-action 'translate)
+ (with-current-buffer buffer
+ (emacs-lisp-mode))
+ (setq sketch-lisp-buffer-name buffer))
+ (setq sketch-show-labels sketch-show-labels)
+ (sketch-toolbar-refresh)
+ (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)")
- ;; ("dot" "url(#dot)")
- ;; (_ "none"))
- ;; (if sketch-include-end-marker
- ;; "url(#arrow)"
- ;; "none"))))
- (apply #'svg-text (nth sketch-active-layer sketch-layers-list) text :x
(car coords) :y (cdr coords) :id (sketch-create-label "text") object-props))
- (sketch-redraw))
+(defun sketch-update-lisp-window (lisp buffer)
+ ;; (let ((sketch sketch-root))
+ (with-current-buffer buffer
+ (erase-buffer)
+ (pp lisp (current-buffer))
+ (goto-char (point-max)))
+ (setq sketch-lisp-buffer-name buffer))
-(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")
-
-;; (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 ()
+(defun sketch-remove-object ()
(interactive)
- (let ((new-layer (length sketch-layers-list))
- (active-layer-infix (object-assoc "Active layer" 'description
transient-current-suffixes))
- (show-layers-infix (object-assoc "Show layers" 'description
transient-current-suffixes)))
- (setq sketch-layers-list (append sketch-layers-list
- (list (sketch-group (format "layer-%s"
new-layer)))))
- (setq sketch-active-layer new-layer)
- (setq show-layers (append show-layers (list new-layer)))
- (transient-infix-set active-layer-infix new-layer)
- (transient-infix-set show-layers-infix show-layers))
- (transient--redisplay)
- (message "Existing layers (indices): %s" (mapconcat #'number-to-string
- (number-sequence 0 (1-
(length sketch-layers-list)))
- ", ")))
-
-(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 sketch-layers-list)))
-
-(transient-define-suffix sketch-crop (event)
+ (let ((show-labels sketch-show-labels))
+ (setq sketch-show-labels "all")
+ (sketch-toolbar-refresh)
+ (sketch-redraw)
+ (svg-remove sketch-root (completing-read "Remove element with id: "
+ (sketch-labels-list)))
+ (setq sketch-show-labels show-labels)
+ (sketch-toolbar-refresh)
+ (sketch-redraw)))
+
+;;; Web/SVG colors
+(defun sketch-colors-sort (colors-rgb-alist)
+ (let ((list-colors-sort 'hsv))
+ ;; color sort function in courtesy of facemenu.el
+ ;; (colors-sorted (mapcar (lambda (c) (cons c (color-name-to-rgb c)))
(defined-colors)))
+ ;; Schwartzian transform with `(color key1 key2 key3 ...)'.
+ (mapcar
+ 'car
+ (sort (delq nil (mapcar
+ (lambda (c)
+ (let ((key (list-colors-sort-key
+ (car c))))
+ (when key
+ (cons c (if (consp key)
+ key
+ (list key))))))
+ colors-rgb-alist)) ;; HERE IS THE LIST
+ (lambda (a b)
+ (let* ((a-keys (cdr a))
+ (b-keys (cdr b))
+ (a-key (car a-keys))
+ (b-key (car b-keys)))
+ ;; Skip common keys at the beginning of key lists.
+ (while (and a-key b-key (equal a-key b-key))
+ (setq a-keys (cdr a-keys) a-key (car a-keys)
+ b-keys (cdr b-keys) b-key (car b-keys)))
+ (cond
+ ((and (numberp a-key) (numberp b-key))
+ (< a-key b-key))
+ ((and (stringp a-key) (stringp b-key))
+ (string< a-key b-key)))))))))
+
+(defun sketch-crop (event)
+ "Crop the image to selection.
+Translate the svg-root via its transform attribute and resizes
+the canvas.
+
+Because the grid is implemented as a pattern on the background
+rectangle, the corners of the cropping area should coincide with
+major-grid nodes if the object should stay aligned with the
+grid (using snap to grid)."
(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))
+ (let* ((start (event-start event))
+ (snap sketch-snap-to-grid)
(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)))
+ (sketch--snap-to-grid (posn-object-x-y start)
sketch-minor-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)))
+ (sketch--snap-to-grid (posn-object-x-y end)
sketch-minor-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")
+ ;; (dom-set-attribute sketch-svg 'viewBox (format "%s %s %s %s"
+ ;; (car start-coords)
+ ;; (cdr start-coords)
+ ;; (car end-coords)
+ ;; (cdr end-coords)))
+ (sketch--create-canvas new-width new-height)
+ ;; (svg-marker sketch-canvas "arrow" 8 8 "black" t)
+ ;; (svg-rectangle sketch-canvas 0 0 new-width new-height :fill "white")
(sketch--svg-translate (car start-coords) (cdr start-coords) sketch-root)
(sketch-redraw)))
-(defun sketch-image (svg &rest props)
- "Return an image object from SVG.
-PROPS is passed on to `create-image' as its PROPS list."
- (apply
- #'create-image
- (with-temp-buffer
- (insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
-<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"
\"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\";>\n")
- (svg-print svg)
- (buffer-string))
- 'svg t props))
+(defun sketch-undo (&optional count)
+ (interactive)
+ ;; (let ((inhibit-read-only t))
+ (cond ((fboundp 'evil-undo)
+ (evil-undo count))
+ ((fboundp 'undo-tree-undo)
+ (undo-tree-undo))
+ (t (undo)))
+ ;; )
+ (setq sketch-svg (read (buffer-string)))
+ (setq sketch-root (car (dom-by-id sketch-svg "root")))
+ (setq sketch-layers-list (dom-elements sketch-root 'id "layer"))
+ (unless sketch-layers-list (call-interactively #'sketch-add-layer)))
-(defun sketch-insert-image (svg string &rest props)
- "Insert SVG as an image at point.
-If the SVG is later changed, the image will also be updated."
- (let ((image (apply #'sketch-image svg props))
- (marker (point-marker)))
- (insert-image image string)
- (dom-set-attribute svg :image marker)))
+(defun sketch-redo (&optional count)
+ (interactive)
+ (let ((inhibit-read-only t))
+ (cond ((fboundp 'evil-undo)
+ (evil-redo count))
+ ((fboundp 'undo-tree-redo)
+ (undo-tree-redo))
+ (t (user-error "This command requires `undo-tree' or `evil' to be
available"))))
+ (setq sketch-root (read (buffer-string)))
+ (setq sketch-layers-list (dom-elements sketch-root 'id "layer"))
+ (unless sketch-layers-list (call-interactively #'sketch-add-layer)))
+
+;; Adapted from `read-color'
+(defun read-color-web (&optional prompt convert-to-RGB)
+ "Read a color name or RGB triplet.
+Completion is available for color names, but not for RGB triplets.
+
+RGB triplets have the form \"#RRGGBB\". Each of the R, G, and B
+components can have one to four digits, but all three components
+must have the same number of digits. Each digit is a hex value
+between 0 and F; either upper case or lower case for A through F
+are acceptable.
+
+In addition to standard color names and RGB hex values, the
+following are available as color candidates. In each case, the
+corresponding color is used.
+
+ * `foreground at point' - foreground under the cursor
+ * `background at point' - background under the cursor
+
+Optional arg PROMPT is the prompt; if nil, use a default prompt.
+
+Interactively, or with optional arg CONVERT-TO-RGB-P non-nil,
+convert an input color name to an RGB hex string. Return the RGB
+hex string.
+
+Interactively, displays a list of colored completions. If optional
+argument FOREGROUND is non-nil, shows them as foregrounds, otherwise
+as backgrounds."
+ (interactive "i\np") ; Always convert to RGB interactively.
+ (let* ((completion-ignore-case t)
+ (colors (mapcar
+ (lambda (color-name)
+ (let ((color (copy-sequence color-name)))
+ (propertize color 'face
+ (list :foreground (readable-foreground-color
color-name)
+ :background color))))
+ (mapcar #'car (sketch-colors-sort
shr-color-html-colors-alist))))
+ (color (completing-read
+ (or prompt "Color (name or #RGB triplet): ")
+ ;; Completing function for reading colors, accepting
+ ;; both color names and RGB triplets.
+ (lambda (string pred flag)
+ (cond
+ ((null flag) ; Try completion.
+ (or (try-completion string colors pred)
+ (if (color-defined-p string)
+ string)))
+ ((eq flag t) ; List all completions.
+ (or (all-completions string colors pred)
+ (if (color-defined-p string)
+ (list string))))
+ ((eq flag 'lambda) ; Test completion.
+ (or (member string colors)
+ (color-defined-p string)))))
+ nil t)))
+
+ ;; Process named colors.
+ (when (member color colors)
+ (cond ((string-equal color "foreground at point")
+ (setq color (foreground-color-at-point)))
+ ((string-equal color "background at point")
+ (setq color (background-color-at-point))))
+ (when (and convert-to-RGB
+ (not (string-equal color "")))
+ (let ((components (x-color-values color)))
+ (unless (string-match-p
"^#\\(?:[[:xdigit:]][[:xdigit:]][[:xdigit:]]\\)+$" color)
+ (setq color (format "#%04X%04X%04X"
+ (logand 65535 (nth 0 components))
+ (logand 65535 (nth 1 components))
+ (logand 65535 (nth 2 components))))))))
+ color))
-(defun sketch-possibly-update-image (svg)
- (let ((marker (dom-attr svg :image)))
- (when (and marker
- (buffer-live-p (marker-buffer marker)))
- (with-current-buffer (marker-buffer marker)
- (put-text-property marker (1+ marker) 'display (svg-image
svg))))))
+(defvar sketch-colors-basic '("White" "Silver" "Gray" "Black"
+ "Red" "Maroon" "Yellow" "Olive"
+ "Lime" "Green" "Aqua" "Teal"
+ "Blue" "Navy" "Fuchsia" "Purple"))
-(transient-define-suffix sketch-save ()
+
+;;; Configuration
+(defun sketch-set-action ()
(interactive)
- (let ((image (get-char-property (point) 'display))
- (file (read-file-name "Save as: ")))
- (with-temp-file file
- (insert (plist-get (cdr image) :data)))))
-
-(transient-define-suffix sketch-insert-image-to-buffer (&optional
insert-at-end-of-file)
- "Insert image to buffer at point.
-When prefixed with a universal argument \\[universal-argument]
-then insert at end of file.
-
-Prompts for buffer for insert, then for the image file name for
-save. If the image is saved in a sub-directory of the buffer file
-then insert a relative link, otherwise insert an absolute link."
+ (setq sketch-action
+ (intern
+ (let ((read-answer-short t))
+ (read-answer "Select object: "
+ '(("freehand" ?f "draw freehand with mouse drag")
+ ("line" ?l "draw line with mouse drag")
+ ("rectangle" ?r "draw rectangle with mouse drag")
+ ("circle" ?c "draw circle with mouse drag")
+ ("ellipse" ?e "draw-ellipse with mouse drag")
+ ("polyline" ?p "draw polyline by clicking. Double
click to insert end.")
+ ("polygon" ?g "draw polygon by clicking. Double
click to insert end.")
+ ("select" ?s "select objects")
+ ("move" ?m "move selected objects")
+ ("translate" ?t "translate selected objects"))))))
+ (sketch-toolbar-refresh))
+
+(defun sketch-set-colors (&optional arg)
+ "Set stroke, fill or both colors simultaneously.
+With single prefix ARG, set fill color. With double prefix ARG,
+set stroke and fill color simultaneously. Otherwise set stroke
+color."
+ (interactive "p")
+ (print arg)
+ (let ((color (substring-no-properties (read-color-web "Select color: ")))
+ (fns (pcase arg
+ (1 '(sketch-stroke-color))
+ (4 '(sketch-fill-color))
+ (16 '(sketch-stroke-color
+ sketch-fill-color)))))
+ (dolist (fn fns)
+ (set fn color)))
+ (sketch-toolbar-refresh))
+
+(defun sketch-set-font-with-keyboard (arg)
(interactive "P")
- (let* ((buffer (get-buffer (read-buffer "Add to buffer: ")))
- (buffer-dir (file-name-directory (buffer-file-name buffer)))
- (image (get-char-property (point) 'display))
- (file (read-file-name "Save as: " buffer-dir)))
- (kill-buffer "*sketch*")
- (with-temp-file file
- (insert (plist-get (cdr image) :data)))
- (switch-to-buffer buffer)
- (when insert-at-end-of-file
- (goto-char (point-max)))
- (insert (format "[[%s]]" (if (string-match buffer-dir file)
- (concat "./" (file-name-nondirectory file))
- file)))))
+ (if arg
+ (sketch-set-font)
+ (completing-read "Select font: " (font-family-list))))
+
+(defun sketch-set-font-size ()
+ (interactive)
+ (setq sketch-font-size (string-to-number
+ (completing-read "Select font size: "
(number-sequence 8 60)))))
+
+(defun sketch-set-width ()
+ (interactive)
+ (setq sketch-stroke-width (string-to-number
+ (completing-read "Enter width (floats allowed): "
+ (number-sequence 1 10)))))
+
+(defun sketch-set-dasharray ()
+ (interactive)
+ (setq sketch-stroke-dasharray (completing-read "Enter dasharry (custom
values allowed): "
+ '("8" "8,4"))))
+
+(defun sketch-set-font ()
+ (interactive)
+ (pop-to-buffer "*sketch-fonts*")
+ (let ((button-width (* 4 5 (default-font-width)))
+ (button-height (* 2 (default-font-height)))
+ (counter 0))
+ (dolist (x (sort (seq-uniq (font-family-list)) #'string-lessp))
+ (insert-text-button x
+ 'action
+ (lambda (button) (interactive)
+ (setq sketch-font (button-label button))
+ (kill-buffer)
+ (sketch-toolbar-refresh))
+ 'display (svg-image (let ((svg (svg-create
button-width button-height)))
+ (svg-rectangle svg 0 0
button-width button-height
+ :fill "white")
+ (svg-text svg "ABC abc"
+ :font-size
button-height
+ :font-family x
+ :stroke "black"
+ :fill "black"
+ :x 4
+ (- button-height 4))
+ svg)))
+ (insert " ")
+ (insert x)
+ (setq counter (1+ counter))
+ (if (/= counter 2)
+ (insert (make-string
+ (- 30 (length x)) (string-to-char " ")))
+ (insert "\n\n")
+ (setq counter 0)))
+ (goto-char (point-min))
+ (special-mode)))
+
+
-(transient-define-suffix sketch-quick-insert-image (&optional
insert-at-end-of-file)
+(defun sketch-toggle-grid ()
+ (interactive)
+ (setq sketch-show-grid (if sketch-show-grid nil t))
+ (if (not sketch-show-grid)
+ (dom-set-attribute (car (dom-by-id sketch-canvas "bg")) 'fill
sketch-background)
+ (unless sketch-grid
+ (sketch-create-grid))
+ (dom-set-attribute (car (dom-by-id sketch-canvas "bg")) 'fill
"url(#grid)"))
+ ;; (svg--def sketch-svg (cdr sketch-grid))
+ ;; (svg--def sketch-svg (car sketch-grid)))
+ ;; (t
+ ;; (dom-remove-node sketch-svg (car (dom-by-id sketch-svg "^grid$")))
+ (sketch-redraw)
+ (sketch-toolbar-refresh))
+
+(defun sketch-toggle-snap ()
+ (interactive)
+ (setq sketch-snap-to-grid (if sketch-snap-to-grid nil t))
+ (sketch-toolbar-refresh)
+ (message "Snap-to-grid %s" (if sketch-snap-to-grid "on" "off")))
+
+(defun sketch-cycle-labels ()
+ (interactive)
+ (setq sketch-show-labels (pcase sketch-show-labels
+ ("layer" "all")
+ ("all" nil)
+ (_ "layer")))
+ (sketch-redraw)
+ (sketch-toolbar-refresh))
+
+(defun sketch-toggle-coords ()
+ (interactive)
+ (setq sketch-show-coords (if sketch-show-coords nil t))
+ (if (not sketch-show-coords)
+ (setq mode-line-format sketch-coordless-mode-line-format)
+ (setq sketch-coordless-mode-line-format mode-line-format)
+ (add-to-list 'mode-line-format '(:eval sketch-cursor-position) t)))
+
+
+(defvar-local sketch-call-buffer nil)
+
+(add-hook 'org-ctrl-c-ctrl-c-final-hook 'sketch-org-toggle-image)
+
+(defun sketch-org-toggle-image ()
+ (let* ((context (org-element-lineage
+ (org-element-context)
+ ;; Limit to supported contexts.
+ '(babel-call clock dynamic-block footnote-definition
+ footnote-reference inline-babel-call
inline-src-block
+ inlinetask item keyword node-property paragraph
+ plain-list planning property-drawer
radio-target
+ src-block statistics-cookie table table-cell
table-row
+ timestamp)
+ t))
+ (type (org-element-type context)))
+ (when (eq type 'paragraph)
+ (let ((parent (org-element-property :parent context)))
+ (when (eq (org-element-type parent) 'special-block)
+ (let* ((props (cadr parent))
+ (beg (plist-get props :contents-begin))
+ (end (plist-get props :contents-end)))
+ (if (get-char-property (point) 'display)
+ (remove-text-properties beg end '(display nil))
+ (let* ((xml (buffer-substring-no-properties beg end))
+ (image (create-image xml 'svg t)))
+ (put-text-property beg (1- end) 'display image)
+ (goto-char beg)))))))))
+
+(defun sketch-quick-insert-image (&optional insert-at-end-of-file)
"Insert image at point as overlay wrapped in org image block.
The image overlay is created over the inserted xml
definition and is wrapped inside an image block (not yet
@@ -1381,248 +1335,318 @@ then insert the image at the end"
(buffer-string)))
(insert "\n#+END_IMAGE"))))
-;;; Modify object
-
-(defun sketch-translate-object (buffer object-def props coords amount)
- (dolist (coord coords)
- (cl-incf (alist-get coord props) amount))
- (sketch-redraw object-def buffer))
-
-(defun sketch-parse-transform-value (value)
- (let ((transforms (mapcar (lambda (val)
- (split-string val "[(,)]" t))
- (split-string value))))
- (mapcar (lambda (x)
- (cons (intern (car x)) (mapcar (lambda (val)
- (string-to-number val))
- (cdr x))))
- transforms)))
-
-(defun sketch-format-transfrom-value (value)
- (string-join (mapcar (lambda (x) (concat (symbol-name (car x))
- "("
- (number-to-string (cadr x))
- (if-let (y (caddr x))
- (concat "," (number-to-string
y)))
- ")"))
- value)
- " "))
-
-(defun sketch-group-translate (buffer object-def direction &optional fast)
- (let ((transform (sketch-parse-transform-value
- (dom-attr object-def
- 'transform)))
- (amount (if fast
- 10
- 1)))
- (pcase direction
- ('up (cl-decf (second (alist-get 'translate transform)) amount))
- ('down (cl-incf (second (alist-get 'translate transform)) amount)))
- (dom-set-attribute object-def
- 'transform
- (sketch-format-transfrom-value transform))
- (sketch-redraw object-def buffer)))
+(defun sketch-help ()
+ (interactive)
+ (if (> emacs-major-version 27)
+ (describe-keymap 'sketch-mode-map)
+ (let ((help-window-select t))
+ (describe-bindings)
+ (search-forward "sketch-mode"))))
-(defun sketch-group-scale (buffer object-def direction &optional fast)
- (let ((transform (sketch-parse-transform-value
- (dom-attr object-def
- 'transform)))
- (amount (if fast
- 1
- 0.1)))
- (unless (alist-get 'scale transform)
- (push '(scale 1) transform))
- (pcase direction
- ('up (cl-incf (car (alist-get 'scale transform)) amount))
- ('down (cl-decf (car (alist-get 'scale transform)) amount)))
- (dom-set-attribute object-def
- 'transform
- (sketch-format-transfrom-value transform))
- (sketch-redraw object-def buffer)))
-(transient-define-suffix sketch-group-scale-up (args)
- (interactive (list (oref transient-current-prefix value)))
- (let* ((object (transient-arg-value "--object=" args))
- (buffer (transient-arg-value "--buffer=" args))
- (object-def (dom-by-id sketch-svg (format "^%s$" object))))
- (sketch-group-scale buffer (car object-def) 'up)))
-
-(transient-define-suffix sketch-group-scale-up-fast (args)
- (interactive (list (oref transient-current-prefix value)))
- (let* ((object (transient-arg-value "--object=" args))
- (buffer (transient-arg-value "--buffer=" args))
- (object-def (dom-by-id sketch-svg (format "^%s$" object))))
- (sketch-group-scale buffer (car object-def) 'up t)))
-
-(transient-define-suffix sketch-group-scale-down (args)
- (interactive (list (oref transient-current-prefix value)))
- (let* ((object (transient-arg-value "--object=" args))
- (buffer (transient-arg-value "--buffer=" args))
- (object-def (dom-by-id sketch-svg (format "^%s$" object))))
- (sketch-group-scale buffer (car object-def) 'down)))
-
-(transient-define-suffix sketch-group-scale-down-fast (args)
- (interactive (list (oref transient-current-prefix value)))
- (let* ((object (transient-arg-value "--object=" args))
- (buffer (transient-arg-value "--buffer=" args))
- (object-def (dom-by-id sketch-svg (format "^%s$" object))))
- (sketch-group-scale buffer (car object-def) 'down t)))
-
-;; TODO 'refactor' subsequent suffixes (e.g. create general function/macro)
-(transient-define-suffix sketch-translate-down (args)
- (interactive (list (oref transient-current-prefix value)))
- (let* ((object (transient-arg-value "--object=" args))
- (buffer (transient-arg-value "--buffer=" args))
- (object-def (dom-by-id sketch-svg (format "^%s$" object)))
- (props (cadar object-def)))
- (if (eq (caar object-def) 'g)
- (sketch-group-translate buffer (car object-def) 'down)
- (sketch-translate-object buffer
- object-def
- props
- (pcase (caar object-def)
- ('line '(y1 y2))
- ('text '(y)))
- 1))))
-
-(transient-define-suffix sketch-translate-fast-down (args)
- (interactive (list (oref transient-current-prefix value)))
- (let* ((object (transient-arg-value "--object=" args))
- (buffer (transient-arg-value "--buffer=" args))
- (object-def (dom-by-id sketch-svg (format "^%s$" object)))
- (props (cadar object-def)))
- (if (eq (caar object-def) 'g)
- (sketch-group-translate buffer (car object-def) 'down t)
- (sketch-translate-object buffer
- object-def
- props
- (pcase (caar object-def)
- ('line '(y1 y2))
- ('text '(y)))
- 10))))
-
-(transient-define-suffix sketch-translate-up (args)
- (interactive (list (oref transient-current-prefix value)))
- (let* ((object (transient-arg-value "--object=" args))
- (buffer (transient-arg-value "--buffer=" args))
- (object-def (dom-by-id sketch-svg (format "^%s$" object)))
- (props (cadar object-def)))
- (if (eq (caar object-def) 'g)
- (sketch-group-translate buffer (car object-def) 'up)
- (sketch-translate-object buffer
- object-def
- props
- (pcase (caar object-def)
- ('line '(y1 y2))
- ('text '(y)))
- -1))))
-
-(transient-define-suffix sketch-translate-fast-up (args)
- (interactive (list (oref transient-current-prefix value)))
- (let* ((object (transient-arg-value "--object=" args))
- (buffer (transient-arg-value "--buffer=" args))
- (object-def (dom-by-id sketch-svg (format "^%s$" object)))
- (props (cadar object-def)))
- (if (eq (caar object-def) 'g)
- (sketch-group-translate buffer (car object-def) 'up t)
- (sketch-translate-object buffer
- object-def
- props
- (pcase (caar object-def)
- ('line '(y1 y2))
- ('text '(y)))
- -10))))
-
-(transient-define-prefix sketch-modify-object (&optional group)
- "Set object properties."
- :transient-suffix 'transient--do-call
- ["Properties"
- [("o" "object" sketch-modify-object 'transient--do-exit)]]
- [[("<down>" "down" sketch-translate-down)
- ("<up>" "up" sketch-translate-up)]
- [("S-<down>" "fast down" sketch-translate-fast-down)
- ("S-<up>" "fast up" sketch-translate-fast-up)]
- [("u" "scale up" sketch-group-scale-up)
- ("d" "scale up" sketch-group-scale-down)]]
- [("l" sketch-cycle-labels)
- ("q" "Quit" transient-quit-one)]
+;;; Toolbar
+(defun sketch-toolbar-refresh ()
+ (with-current-buffer (get-buffer "*sketch-toolbar*")
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert (propertize "Press . for hydra or press ? for help\n\n" 'face
'bold))
+ (sketch-toolbar-colors)
+ (insert "\n")
+ (sketch-toolbar-widths)
+ (insert "\n")
+ (sketch-toolbar-objects)
+ (insert "\n\n")
+ (sketch-toolbar-toggles)
+ (insert "\n\n")
+ (sketch-toolbar-font)
+ (goto-char (point-min)))))
+
+(defun sketch-toggle-toolbar ()
(interactive)
- (let* ((object (if group
- group
- (completing-read "Transform element with id: "
- (sketch-labels-list))))
- (buffer (get-buffer-create (format "*sketch-object-%s*" object))))
- (display-buffer buffer '(display-buffer-in-side-window . ((side . right)
(window-width . 70))))
- (pp (cadar (dom-by-id sketch-svg (format "^%s$" object))) buffer)
- (with-current-buffer buffer
- (emacs-lisp-mode))
- (transient-setup 'sketch-modify-object
- nil
- nil
- :value (list (format "--object=%s" object)
- (format "--buffer=%s" buffer)))))
+ (let ((win (get-buffer-window "*sketch-toolbar*")))
+ (if win
+ (delete-window win)
+ (let ((buffer (get-buffer-create "*sketch-toolbar*")))
+ (set-window-dedicated-p
+ (display-buffer-in-side-window (get-buffer-create "*sketch-toolbar*")
+ `((side . right)
+ (window-width . ,(funcall
sketch-side-window-max-width))))
+ t)
+ (window-resize (get-buffer-window buffer) -3 t)
+ (with-current-buffer buffer
+ (setq cursor-type nil)
+ (special-mode))
+ (sketch-toolbar-refresh)))))
+
+(defun sketch-toolbar-colors ()
+ ;; STROKE COLOR
+ (insert (propertize "STROKE COLOR: "))
+ (insert-text-button " "
+ 'action
+ (lambda (button) (interactive)
+ (setq sketch-stroke-color (plist-get (button-get
button 'face) :background)))
+ 'face (list :background
+ (alist-get sketch-stroke-color
+ shr-color-html-colors-alist
+ nil nil 'string=)))
+ (insert " ")
+ (insert (if (string= sketch-stroke-color "none")
+ "none"
+ sketch-stroke-color))
+ (insert "\n")
+ (insert-text-button "none"
+ 'action (lambda (button) (interactive)
+ (setq sketch-stroke-color "none")
+ (sketch-toolbar-refresh)))
+ (insert "\n\n")
+ (let ((counter 0))
+ (dolist (color sketch-colors-basic)
+ (insert-text-button " "
+ 'action
+ (lambda (button) (interactive)
+ (setq sketch-stroke-color
+ (car (rassoc (plist-get (button-get button
'face) :background)
+ shr-color-html-colors-alist)))
+ (sketch-toolbar-refresh)
+ ;; (transient-quit-all)
+ ;; (call-interactively #'sketch-transient)
+ )
+ 'face (list
+ :background (alist-get color
+
shr-color-html-colors-alist
+ nil nil 'string=)))
+ (setq counter (1+ counter))
+ (if (not (= counter 8))
+ (insert " ")
+ (insert "\n\n")
+ ;; (when (= counter 8)
+ ;; (insert "\n")
+ (setq counter 0))))
+
+ (insert "\n")
+
+ ;; FILL COLOR
+ (insert (propertize "FILL COLOR: "))
+ (apply #'insert-text-button " "
+ 'action
+ (lambda (button) (interactive)
+ (print sketch-fill-color))
+ (pcase sketch-fill-color
+ ("none" nil)
+ (_ (list 'face (when sketch-fill-color
+ (list :background (alist-get sketch-fill-color
+
shr-color-html-colors-alist
+ nil nil
'string=)))))))
+ (insert " ")
+ (insert (if (string= sketch-fill-color "none")
+ "none"
+ sketch-fill-color))
+ (insert "\n")
+ (insert-text-button "none"
+ 'action (lambda (_) (interactive)
+ (setq sketch-fill-color "none")
+ (sketch-toolbar-refresh)))
+ (insert "\n\n")
+ (let ((counter 0))
+ (dolist (color sketch-colors-basic)
+ (insert-text-button " "
+ 'action
+ (lambda (button) (interactive)
+ (setq sketch-fill-color
+ (car (rassoc
+ (plist-get (button-get button 'face)
:background)
+ shr-color-html-colors-alist)))
+ (sketch-toolbar-refresh)
+ ;; (transient-quit-all)
+ ;; (call-interactively #'sketch-transient)
+ )
+ 'face (list
+ :background (alist-get color
+
shr-color-html-colors-alist
+ nil nil 'string=)))
+ (setq counter (1+ counter))
+ (if (not (= counter 8))
+ (insert " ")
+ (insert "\n\n")
+ (setq counter 0)))))
+
+(defun sketch-toolbar-widths ()
+ (insert "STROKE WIDTH: ")
+ (insert (number-to-string sketch-stroke-width))
+ (insert "\n")
+ (let* ((widths 12)
+ (button-width (+ (* 4 (default-font-width)) 3))
+ (button-height (default-font-height))
+ (stroke-height (/ button-height 2)))
+ (let ((counter 0))
+ (dotimes (w widths)
+ (insert-text-button (format "%s" (1+ w))
+ 'action
+ (lambda (button) (interactive)
+ (setq sketch-stroke-width (string-to-number
(button-label button)))
+ (sketch-toolbar-refresh)
+ ;; (transient-quit-all)
+ ;; (call-interactively #'sketch-transient)
+ )
+ 'display (svg-image (let ((svg (svg-create
button-width button-height)))
+ (svg-rectangle svg 0 0
button-width button-height
+ :fill "white")
+ (svg-line svg 5 stroke-height
+ (- button-width 5)
stroke-height
+ :stroke "black"
:stroke-width (1+ w))
+ svg)))
+ (setq counter (1+ counter))
+ (if (not (= counter 6))
+ (insert " ")
+ (insert "\n\n")
+ (setq counter 0))))))
+
+(defun sketch-toolbar-objects ()
+ (insert "MOUSE ACTION\n")
+ (insert "draw\n")
+ (let ((objects '(line polyline circle ellipse rectangle polygon)))
+ (let ((counter 0))
+ (while objects
+ (let ((o (car objects)))
+ (apply #'insert-text-button
+ (symbol-name o)
+ 'action (lambda (button) (interactive)
+ (setq sketch-action (intern (button-label button)))
+ (sketch-toolbar-refresh))
+ (when (eq o sketch-action)
+ (list 'face 'link-visited)))
+ (setq counter (1+ counter))
+ (cond ((/= counter 4)
+ (dotimes (_ (- 10 (length (symbol-name o))))
+ (insert " ")))
+ ;; (let ((o (cadr objects)))
+ ;; (apply #'insert-text-button
+ ;; (symbol-name o)
+ ;; 'action (lambda (button) (interactive)
+ ;; (setq sketch-action (intern
(button-label button)))
+ ;; (sketch-toolbar-refresh))
+ ;; (when (eq o sketch-action)
+ ;; (list 'face 'link-visited))))
+ ;; ;; (list 'face (if (eq o sketch-action)
+ ;; ;; 'widget-button-pressed
+ ;; ;; 'widget-button)))
+ (t
+ (insert "\n")
+ (setq counter 0)))
+ (setq objects (cdr objects))))))
+ (apply #'insert-text-button
+ "freehand"
+ 'action (lambda (button) (interactive)
+ (setq sketch-action (intern (button-label button)))
+ (sketch-toolbar-refresh))
+ (when (eq 'freehand sketch-action)
+ (list 'face 'link-visited)))
+ (insert " ")
+ (apply #'insert-text-button
+ "text"
+ 'action (lambda (button) (interactive)
+ (setq sketch-action (intern (button-label button)))
+ (sketch-toolbar-refresh))
+ (when (eq 'text sketch-action)
+ (list 'face 'link-visited)))
+ (insert "\n\n")
+ (insert "edit\n")
+ (dolist (e '(select move translate))
+ (apply #'insert-text-button
+ (symbol-name e)
+ 'action (lambda (button) (interactive)
+ ;; (setq sketch-action (intern (button-label button)))
+ (pcase (intern (button-label button))
+ ('select (user-error "Feature not yet implemented,
instead press `v' to select with keyboard"))
+ ((or 'move 'translate) (user-error "Feature not yet
implemented, instead press `m' to select and translate")))
+ (sketch-toolbar-refresh))
+ (when (eq e sketch-action)
+ (list 'face 'link-visited)))
+ (insert " ")
+ ))
+
+(defun sketch-toolbar-toggles ()
+ (insert "TOGGLES\n")
+ (insert "Grid: ")
+ (apply #'insert-text-button (if sketch-show-grid "show" "hide")
+ 'action
+ (lambda (button) (interactive)
+ (sketch-toggle-grid)
+ (sketch-toolbar-refresh))
+ (when sketch-show-grid
+ (list 'face 'link-visited)))
+ ;; (list 'face (if sketch-grid
+ ;; 'widget-button-pressed
+ ;; 'widget-button)))
+ (insert " ")
+ (insert "Snap: ")
+ (apply #'insert-text-button (if sketch-snap-to-grid "on" "off")
+ 'action
+ (lambda (button) (interactive)
+ (sketch-toggle-snap)
+ (sketch-toolbar-refresh))
+ (when sketch-snap-to-grid
+ (list 'face 'link-visited)))
+ (insert " ")
+ (insert "Labels: ")
+ (apply #'insert-text-button (or sketch-show-labels "hide")
+ 'action
+ (lambda (button) (interactive)
+ (sketch-cycle-labels)
+ (sketch-toolbar-refresh))
+ (when sketch-show-labels
+ (list 'face 'link-visited))))
+;; (list 'face (if sketch-snap-to-grid
+;; 'widget-button-pressed
+;; 'widget-button))))
+
+(defun sketch-toolbar-font ()
+ (interactive)
+ (insert "FONT\n")
+ (insert "family: ")
+ (if sketch-font
+ (let ((button-width (* 2 5 (default-font-width)))
+ (button-height (default-font-height))
+ (counter 0))
+ (insert-text-button sketch-font
+ 'action
+ (lambda (_) (interactive)
+ (sketch-set-font)
+ ;; (transient-quit-all)
+ ;; (call-interactively #'sketch-transient)
+ )
+ 'display (svg-image (let ((svg (svg-create
button-width button-height)))
+ (svg-rectangle svg 0 0
button-width button-height
+ :fill "white")
+ (svg-text svg "ABC abc"
+ :font-size
button-height
+ :font-family
sketch-font
+ :stroke "black"
+ :fill "black"
+ :x 3
+ (- button-height
3))
+ svg))))
+ (insert-text-button "none"
+ 'action
+ (lambda (_) (interactive)
+ (sketch-set-font))))
+ (insert" ")
+ (insert "Size: ")
+ (insert-text-button (number-to-string sketch-font-size)
+ 'action
+ (lambda (_) (interactive)
+ (setq sketch-font-size (string-to-number
+ (completing-read "Select font
size: "
+
(number-sequence 8 40 2))))
+ ;; (transient-quit-all)
+ ;; (call-interactively #'sketch-transient)
+ )))
+
+(defun sketch-kill-toolbar ()
+ (let ((toolbar (get-buffer "*sketch-toolbar*")))
+ (when toolbar
+ (kill-buffer toolbar))))
-(defun sketch-update-lisp-window (lisp buffer)
- ;; (let ((sketch sketch-root))
- (with-current-buffer buffer
- (erase-buffer)
- (pp lisp (current-buffer))
- (goto-char (point-max))))
-
-;;; import/snippets
-
-(defun sketch-snippet-get-dom (svg-file)
- (interactive "fCreate dom from file: ")
- (with-temp-buffer "svg"
- (insert-file-contents-literally svg-file)
- (xml-remove-comments (point-min) (point-max))
- (libxml-parse-xml-region (point-min) (point-max))))
-
-(defun sketch-snippets-add-ids (dom)
- (let ((idx 0))
- (dolist (n (dom-by-tag dom 'g))
- (dom-set-attribute n 'id (number-to-string idx))
- (setq idx (1+ idx)))))
-
-(defun sketch-snippets-add-labels (dom)
- (interactive "f")
- (sketch-snippets-add-ids dom)
- (mapc (lambda (n)
- (let* ((s (dom-attr n 'transform))
- (coords (when s
- (split-string
- (string-trim
- s
- "translate(" ")")
- ","))))
- (svg-text dom
- (dom-attr n 'id)
- :x (car coords)
- :y (cadr coords)
- :font-size 10
- :stroke "red"
- :fill "red")))
- (cdr (dom-by-tag dom 'g)))
- (unless sketch-mode
- (user-error "Not in sketch-mode buffer"))
- ;; (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 (cl-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 (svg-image dom)))
(provide 'sketch-mode)
;;; sketch-mode.el ends here
- [elpa] externals/sketch-mode updated (457ba48 -> 443e095), ELPA Syncer, 2021/10/20
- [elpa] externals/sketch-mode bcb639e 02/15: Transfrom transient object argument to local variable, ELPA Syncer, 2021/10/20
- [elpa] externals/sketch-mode d604e04 03/15: Implement real side-toolbar (instead of buttons in draw buffer), ELPA Syncer, 2021/10/20
- [elpa] externals/sketch-mode 443e095 15/15: Merge branch 'develop', publish package :tada:,
ELPA Syncer <=
- [elpa] externals/sketch-mode 3214edb 13/15: Add hydra, ELPA Syncer, 2021/10/20
- [elpa] externals/sketch-mode d23fdd7 04/15: Minor cleanup and corrections, ELPA Syncer, 2021/10/20
- [elpa] externals/sketch-mode ad9c926 01/15: Add toolbars (transform transient arguments to local-variables), ELPA Syncer, 2021/10/20
- [elpa] externals/sketch-mode c8dcf93 09/15: Orginal toolbar (almost finished), ELPA Syncer, 2021/10/20
- [elpa] externals/sketch-mode 5abc729 11/15: Fix coordinates (hinders interactivity), and make them togglable, ELPA Syncer, 2021/10/20
- [elpa] externals/sketch-mode 02b1c05 14/15: Ready for publish :tada: (small fixes + sketch Quit), ELPA Syncer, 2021/10/20
- [elpa] externals/sketch-mode f728eef 10/15: First 'reasonably complete' version of cleanedup sketch-mode, ELPA Syncer, 2021/10/20
- [elpa] externals/sketch-mode 726e923 08/15: Continue cleanup and create vertically compressed toolbar, ELPA Syncer, 2021/10/20
- [elpa] externals/sketch-mode f3d6f45 07/15: Further cleanup and finish toolbar, ELPA Syncer, 2021/10/20
- [elpa] externals/sketch-mode 47d8432 06/15: Add org-ctrl-c-ctrl-c-hook-function to toggle image in org file, ELPA Syncer, 2021/10/20