;;;; $Id: mdraw.el,v 1.7 1994/05/03 22:26:59 flee Exp $
;;;; Backpointer: ftp.cse.psu.edu:/pub/flee/mdraw.el

;;; Brush drawing with the mouse.

;;; 1. Byte-compile and load this file.

;;; 2. Edit a buffer and enter picture mode.  (M-x edit-picture)

;;; 3. Hold shift and a mouse button to draw with a brush.

;;; By default:
;;;   button 1 is a 1x1 "X" brush
;;;   button 2 is a 2x2 diamond-pattern brush
;;;   button 3 is a 1x1 " " brush (ie, an eraser)

;;; The brushes are actually rectangles stored in registers 1, 2, and 3.
;;; So, you can set a brush by selecting a rectangle of text and using
;;; copy-rectangle-to-register (C-x r r) to the appropriate register.

;;; XXX could use some better default brushes..

(require 'picture)

(define-key picture-mode-map [S-down-mouse-1] 'flee/draw-at-mouse-1)
(define-key picture-mode-map [S-down-mouse-2] 'flee/draw-at-mouse-2)
(define-key picture-mode-map [S-down-mouse-3] 'flee/draw-at-mouse-3)


;;; Set the default brushes.
(defvar flee/default-brush-1 '("X"))
(defvar flee/default-brush-2 '("/\\" "\\/"))
(defvar flee/default-brush-3 '(" "))

(or (get-register ?1) (set-register ?1 flee/default-brush-1))
(or (get-register ?2) (set-register ?2 flee/default-brush-2))
(or (get-register ?3) (set-register ?3 flee/default-brush-3))

(defun flee/draw-at-mouse-1 ()
  (interactive)
  (flee/internal-draw-at-mouse (flee/get-register-rectangle ?1)))

(defun flee/draw-at-mouse-2 ()
  (interactive)
  (flee/internal-draw-at-mouse (flee/get-register-rectangle ?2)))

(defun flee/draw-at-mouse-3 ()
  (interactive)
  (flee/internal-draw-at-mouse (flee/get-register-rectangle ?3)))

(defun flee/internal-draw-at-mouse (rectangle)
  (let ( (event nil)
	 (position nil)
	 (starting-window (selected-window)) )
    (track-mouse
      (while (mouse-movement-p (setq event (read-event)))
	(setq position (event-start event))
	;; Is position within the text area of the drawing window?
	(if (and (numberp (posn-point position))
		 (eq (posn-window position) starting-window))
	    (progn
	      (flee/move-to-position position)
	      (save-excursion
		(flee/insert-rectangle rectangle))))
	))
    ))

(defun flee/get-register-rectangle (name)
  ;; Returns the register NAME as a rectangle.  Signals an error if it
  ;; isn't a rectangle.
  (let ( (value (get-register name)) )
    (cond
     ;; If it's a cons, emacs vaguely guarantees it's a rectangle.
     ( (consp value)
       value)
     ;; XXX Could try coercing a string to a rectangle, but a
     ;; multi-line string would have to be broken up or else the
     ;; result is garbage.
     ( t
       (error "Register %c is not a rectangle." name) )
     )))

(defun flee/move-to-position (position)
  "Move to POSITION, which is an event position, inserting space
and newlines if necessary."
  ;; XXX This assumes that truncate-lines is t.
  (goto-char (window-start))
  (let ( (row (cdr (posn-col-row position)))
	 (indent-tabs-mode nil) )
    (setq row (forward-line row))
    (or (bolp)
	(insert ?\n))
    (while (< 0 row)
      (insert ?\n)
      (setq row (1- row)))
    (move-to-column
     (+ (car (posn-col-row position))
	(window-hscroll))
     'force)
    ))


;; Slightly different version than in picture-mode.el.  Mainly, never
;; uses tabs.
(defun move-to-column-force (column)
  "Move to column COLUMN in current line.
Differs from `move-to-column' in that it creates or modifies whitespace
if necessary to attain exactly the specified column."
  (let ( (indent-tabs-mode nil) )
    (move-to-column (max 0 column) 'force)))

(defun flee/insert-rectangle (rectangle)
  "Overlay RECTANGLE with upper left corner at point."
  (let ( (indent-tabs-mode nil)
	 (width nil) )
    (while rectangle
      (setq width (length (car rectangle)))
      (picture-forward-column width)
      (delete-char (- width))
      (insert (car rectangle))
      (forward-char (- width))
      (picture-move-down 1)
      (setq rectangle (cdr rectangle)))
    ))

;;; for debugging
(define-key picture-mode-map [C-S-down-mouse-1] 'flee/track-at-mouse)

(defun flee/track-at-mouse ()
  (interactive)
  (let ( (event nil)
	 (position nil)
	 (window (selected-window)) )
    (track-mouse
      (while (mouse-movement-p (setq event (read-event)))
	(setq position (event-start event))
	(message "coord: %s point: %s"
		 (posn-col-row position)
		 (posn-point position))
	))
    ))

;;; obsolete, but a little faster than painting with " ", because it's
;;; specialcased.
(defun flee/erase-at-mouse ()
  (interactive)
  (let ( (event nil)
	 (position nil)
	 (window (selected-window)) )
    (track-mouse
      (while (mouse-movement-p (setq event (read-event)))
	(setq position (event-start event))
	(if (and (eq window (posn-window position))
		 (numberp (posn-point position)))
	    (progn
	      (flee/move-to-position position)
	      (if (not (eolp))
		  (save-excursion
		    (delete-char 1)
		    (insert ? )))))
	))
    ))