Download
(require 'cl)
(defvar paint-buffer-name "*paint*")
(defvar paint-image nil)
(defvar paint-image-releaf 2)
(defvar paint-timer nil)
(defvar paint-timer-idle-delay 0.1)
(defvar paint-timer-pen-last-pos nil)
(defconst paint-motion-default-type
(if (featurep 'meadow) 'timer 'track))
(defvar paint-motion-type paint-motion-default-type
"*This variable specified motion type.
Following symbols are available:
- `timer': use a timer. this motion is a little slower, but can
be used on meadow.
- `track': use a mouse tracking. recommended to be used.
")
(defvar paint-bit-fliped-system-p
(and (eq system-type 'windows-nt) (not (featurep 'meadow))))
(defvar paint-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "s" 'paint-save)
(define-key map "l" 'paint-load)
(define-key map " " 'paint-toggle-erase)
(define-key map [down-mouse-2] 'paint-show-menu)
map)
"A keymap for `paint-mode'.")
(defvar paint-timer-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map paint-mode-map)
(define-key map [down-mouse-1] 'paint-timer-pen-down)
(define-key map [drag-mouse-1] 'paint-timer-pen-up)
(define-key map [mouse-1] 'paint-timer-pen-up)
map)
"A keymap used when `paint-motion-type' is a `timer'.")
(defvar paint-track-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map paint-mode-map)
(define-key map [down-mouse-1] 'paint-track-pen-down)
map)
"A keymap used when `paint-motion-type' is a `track'.")
(easy-menu-define paint-menu paint-mode-map
"A paint mode menu"
'("Paint"
["Eraser" paint-toggle-erase :style toggle :selected paint-eraser-mode]
["Load" paint-load t]
["Save" paint-save t]))
(defvar paint-motion-type-alist
'((timer . paint-timer-mode-map)
(track . paint-track-mode-map)))
(defvar paint-foreground-color "black"
"*Foreground color of xbm images.")
(defvar paint-background-color "white"
"*Background color of xbm images.")
(defvar paint-eraser-mode nil)
(defvar paint-eraser-size 5)
(defun paint-mode ()
"Paint Mode.
track motion map:
\\{paint-track-mode-map}
timer motion map:
\\{paint-timer-mode-map}"
(interactive)
(kill-all-local-variables)
(use-local-map (symbol-value
(assoc-default
paint-motion-type paint-motion-type-alist
'eq paint-motion-default-type)))
(setq buffer-read-only t)
(setq cursor-type nil)
(setq mode-name "Paint")
(setq major-mode 'paint-mode))
(defun paint-show-menu (event)
(interactive "@e")
(let ((ret (paint-menu event)))
(when ret
(call-interactively (lookup-key paint-menu (apply 'vector ret))))))
(defun paint-window-edge (edges key)
(let ((alist '((left . 0)
(top . 1)
(right . 2)
(buttom . 3))))
(nth (cdr (assq key alist)) edges)))
(defun paint-default-size (&optional win)
(let ((edges (window-inside-pixel-edges win)))
(cons (- (paint-window-edge edges 'right)
(paint-window-edge edges 'left)
8)
(- (paint-window-edge edges 'buttom)
(paint-window-edge edges 'top)
8))))
(defun paint (width height &optional data)
"Run a paint tool.
If DATA is non-nil, use that data for painting.
Otherwise, create a new bitmap image.
WIDTH and HEIGHT means bitmap image's width and height.
WIDTH should be multiple of eight number.
On interactive use, WIDTH is a round to multiple of eight number."
(interactive
(let* ((size (paint-default-size))
(width (read-number "width: " (car size)))
(height (read-number "height: " (cdr size))))
(list (- width (% width 8))
height)))
(unless (% width 8)
(error "width should be multiple of eight"))
(if data
(unless (= (* width height) (length data))
(error "data size is not width * height"))
(setq data (make-bool-vector (* width height) nil)))
(switch-to-buffer (get-buffer-create paint-buffer-name))
(paint-mode)
(let ((inhibit-read-only t))
(erase-buffer)
(remove-images (point-min) (point-max))
(setq paint-image
(apply 'create-image
data
'xbm t
:width width
:height height
:relief paint-image-releaf
:pointer 'arrow
(if paint-bit-fliped-system-p
(list :foreground paint-background-color
:background paint-foreground-color)
(list :foreground paint-foreground-color
:background paint-background-color))))
(put-image paint-image (point-min)))
(setq paint-eraser-mode nil)
(paint-update))
(defsubst paint-image-property (prop)
(plist-get (cdr paint-image) prop))
(defsubst paint-pos (x y)
(cons x y))
(defsubst paint-pos-x (pos)
(car pos))
(defsubst paint-pos-y (pos)
(cdr pos))
(defun paint-mouse-in-window-p (mouse-pxl-pos window)
(let ((edges (window-inside-pixel-edges window))
(frame (car mouse-pxl-pos))
(pos (cdr mouse-pxl-pos)))
(and (eq (window-frame window) frame)
(<= (paint-window-edge edges 'left) (paint-pos-x pos))
(>= (paint-window-edge edges 'right) (paint-pos-x pos))
(<= (paint-window-edge edges 'top) (paint-pos-y pos))
(>= (paint-window-edge edges 'buttom) (paint-pos-y pos)))))
(defun paint-in-canvas-p (pos &optional mouse-position)
(and
(< (paint-pos-x pos) (paint-image-property :width))
(< (paint-pos-y pos) (paint-image-property :height))
(or (null mouse-position)
(find-if (lambda (win) (paint-mouse-in-window-p mouse-position win))
(get-buffer-window-list (get-buffer paint-buffer-name))))))
(defsubst paint-plot (pos bit)
(aset (paint-image-property :data)
(+ (* (paint-image-property :width) (paint-pos-y pos))
(paint-pos-x pos))
bit))
(defun paint-get (pos)
(aref (paint-image-property :data)
(+ (* (paint-image-property :width) (paint-pos-y pos))
(paint-pos-x pos))))
(defmacro paint-swap (m n)
(let ((v (gensym)))
`(let ((,v ,m))
(setq ,m ,n
,n ,v))))
(defun paint-plot-line (pos0 pos1 bit &optional size)
(let* ((x0 (paint-pos-x pos0))
(y0 (paint-pos-y pos0))
(x1 (paint-pos-x pos1))
(y1 (paint-pos-y pos1))
(steep (> (abs (- y1 y0)) (abs (- x1 x0)))))
(when steep
(paint-swap x0 y0)
(paint-swap x1 y1))
(when (> x0 x1)
(paint-swap x0 x1)
(paint-swap y0 y1))
(let* ((dx (- x1 x0))
(dy (abs (- y1 y0)))
(err (/ (- (1+ dx)) 2))
(y y0)
(ystep (if (< y0 y1) 1 -1)))
(loop for x from x0 to x1 do
(let ((xx x)
(yy y))
(when steep
(paint-swap xx yy))
(if size
(paint-plot-square (paint-pos xx yy) (paint-pos (+ xx size) (+ yy size)) bit t)
(paint-plot (paint-pos xx yy) bit)))
(setq err (+ err dy))
(if (>= err 0)
(setq y (+ y ystep)
err (- err dx)))))))
(defun paint-plot-square (pos0 pos1 bit &optional fill-p)
(if fill-p
(loop for y from (paint-pos-y pos0) to (paint-pos-y pos1) do
(loop for x from (paint-pos-x pos0) to (paint-pos-x pos1) do
(paint-plot (paint-pos x y) bit)))
(paint-plot-line pos0 (paint-pos (paint-pos-x pos0) (paint-pos-y pos1)) bit)
(paint-plot-line pos0 (paint-pos (paint-pos-x pos1) (paint-pos-y pos0)) bit)
(paint-plot-line pos1 (paint-pos (paint-pos-x pos1) (paint-pos-y pos0)) bit)
(paint-plot-line pos1 (paint-pos (paint-pos-x pos0) (paint-pos-y pos1)) bit)))
(defun paint-erase-line (pos0 pos1)
(let ((n (/ paint-eraser-size 2)))
(setq pos0 (paint-pos (max (- (paint-pos-x pos0) n) 0) (max (- (paint-pos-y pos0) n) 0)))
(setq pos1 (paint-pos (max (- (paint-pos-x pos1) n) 0) (max (- (paint-pos-y pos1) n) 0)))
(paint-plot-line pos0 pos1 nil paint-eraser-size)))
(defun paint-update ()
(set-buffer paint-buffer-name)
(clear-image-cache))
(defun paint-toggle-erase ()
"Toggle erasing mode."
(interactive)
(setq paint-eraser-mode (not paint-eraser-mode)))
(defun paint-track-pen-down (event)
(interactive "e")
(paint-track-pen event))
(defun paint-track-pen (start-event)
(track-mouse
(let (event)
(while (progn
(setq event (read-event))
(mouse-movement-p event))
(let ((pos0 (posn-x-y (event-end start-event)))
(pos1 (posn-x-y (event-end event))))
(when (and (paint-in-canvas-p pos0)
(paint-in-canvas-p pos1 (mouse-pixel-position)))
(if paint-eraser-mode
(paint-erase-line pos0 pos1)
(paint-plot-line pos0 pos1 t))
(paint-update)))
(setq start-event event)))))
(defun paint-timer-pen-down (event)
(interactive "e")
(if paint-timer
(paint-timer-pen-cancel)
(setq paint-timer-pen-last-pos (posn-x-y (event-start event)))
(setq paint-timer
(run-at-time paint-timer-idle-delay
paint-timer-idle-delay
'paint-timer-pen-drag
(window-inside-pixel-edges
(get-buffer-window (get-buffer paint-buffer-name)))))))
(defun paint-timer-pen-up (event)
(interactive "e")
(timer-event-handler paint-timer)
(paint-timer-pen-cancel))
(defun paint-timer-pen-drag (edges)
(let* ((pxl-pos (mouse-pixel-position))
(pos (cdr pxl-pos)))
(setq pos (paint-pos (- (paint-pos-x pos)
(paint-window-edge edges 'left))
(- (paint-pos-y pos)
(paint-window-edge edges 'top))))
(when (and (paint-in-canvas-p paint-timer-pen-last-pos)
(paint-in-canvas-p pos pxl-pos))
(if paint-eraser-mode
(paint-erase-line paint-timer-pen-last-pos pos)
(paint-plot-line paint-timer-pen-last-pos pos t))
(paint-update))
(setq paint-timer-pen-last-pos pos)))
(defun paint-timer-pen-cancel ()
(cancel-timer paint-timer)
(setq paint-timer nil)
(setq paint-timer-pen-last-pos nil))
(defun paint-save (file)
"Save drawd bitmap to a FILE."
(interactive "FFile name: ")
(let ((coding-system-for-write
(coding-system-change-eol-conversion
default-buffer-file-coding-system 'unix))
(name (file-name-sans-extension (file-name-nondirectory file)))
(data ))
(with-temp-file file
(insert (format "#define %s_width %d\n"
name (paint-image-property :width)))
(insert (format "#define %s_height %d\n"
name (paint-image-property :height)))
(insert (format "static unsigned char %s_bits[] = {\n"
name))
(let ((x 0))
(dotimes (n (length (paint-image-property :data)))
(setq x (logior x
(lsh (if (aref (paint-image-property :data) n) 1 0)
(% n 8))))
(when (= (% n 8) 7)
(insert (format "0x%02x, " x))
(setq x 0))))
(delete-backward-char 2)
(insert "\n};"))))
(defun paint-load (file)
"Load bitmap from a FILE and run a `paint' with that data."
(interactive "fFile name:")
(let (width height data)
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
(setq width (and (re-search-forward "width \\([0-9]+\\)" nil t)
(string-to-number (match-string 1))))
(setq height (and (re-search-forward "height \\([0-9]+\\)" nil t)
(string-to-number (match-string 1))))
(unless (and width height)
(error "file is not xbm format"))
(setq data (make-bool-vector (* width height) nil))
(let ((n 0))
(while (re-search-forward "0x\\([0-9a-f]+\\)" nil t)
(let ((x (string-to-number (match-string 1) 16)))
(dotimes (m 8)
(aset data n (not (zerop (logand x (lsh 1 m)))))
(setq n (1+ n)))))))
(paint width height data)))
(defun paint-track-debug ()
(interactive)
(track-mouse
(let (event)
(while (progn
(setq event (read-event))
(mouse-movement-p event))
(message "%s" (posn-x-y (event-start event)))))))
(provide 'paint)