;;; linedraw.el --- draw pictures with line characters

;; Copyright (C) 1994-1996 Eberhard Mattes

;; Author: Eberhard Mattes <mattes@azu.informatik.uni-stuttgart.de>
;; Keywords: emx

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:
;;
;; Use M-S-left, M-S-up, M-S-down, and M-S-right to draw pictures.
;; Use M-x linedraw-frame-inside and M-x linedraw-frame-outside to draw frames.
;;

;;; Bugs:
;;
;; To be able to put the cursor at positions beyond the end of the line,
;; this code has sometimes to add whitespace to the end of lines.  After
;; drawing a picture, you might want to remove all whitespace at the end
;; of all lines with (replace-regexp "[ \t]+$" "").
;;

;;; Code:

(require 'picture)

;; User interface

(defun linedraw-style (style)
  "Set the style for drawing lines.
STYLE is a number indicating the style.  Available styles are:
0  use characters - | and +
1  use single line graphic characters
2  use double line graphic characters
3  use mixed line graphic characters: single lines horizontally,
     double lines vertically (code page 437 only)
4  use mixed line graphic characters: double lines horizontally,
     single lines vertically (code page 437 only)."
  (interactive "NStyle (0 through 4): ")
  (cond ((memq style '(0 1 2))
         (setq linedraw-style (vector style style style style)))
        ((= style 3)
         (setq linedraw-style '[1 2 2 1]))
        ((= style 4)
         (setq linedraw-style '[2 1 1 2]))
        (t (error "Invalid style")))
  ;; As finding the closest matching character depends on the current
  ;; style, flush the cache now
  (setq linedraw-cache nil))

(defun linedraw-left ()
  "Draw line graphic, move point to the left."
  (interactive)
  (linedraw-move 0 -1 0))

(defun linedraw-right ()
  "Draw line graphic, move point to the right."
  (interactive)
  (linedraw-move 3 1 0))

(defun linedraw-up ()
  "Draw line graphic, move point up."
  (interactive)
  (linedraw-move 1 0 -1))

(defun linedraw-down ()
  "Draw line graphic, move point down."
  (interactive)
  (linedraw-move 2 0 1))

(defun linedraw-frame-inside (start end)
  "Draw a frame inside rectangular region."
  (interactive "r")
  (let* ((start-xy (linedraw-get-xy start))
         (end-xy (linedraw-get-xy end))
         (min-x (min (car start-xy) (car end-xy)))
         (max-x (1- (max (car start-xy) (car end-xy))))
         (min-y (min (cdr start-xy) (cdr end-xy)))
         (max-y (max (cdr start-xy) (cdr end-xy))))
    (if (>= min-y max-y)
        (error "Zero height"))
    (if (>= min-x max-x)
        (error "Zero width"))
    (linedraw-frame min-x min-y max-x max-y)))

(defun linedraw-frame-outside (start end)
  "Draw a frame outside rectangular region."
  (interactive "r")
  (let* ((start-xy (linedraw-get-xy start))
         (end-xy (linedraw-get-xy end))
         (min-x (min (car start-xy) (car end-xy)))
         (max-x (1- (max (car start-xy) (car end-xy))))
         (min-y (min (cdr start-xy) (cdr end-xy)))
         (max-y (max (cdr start-xy) (cdr end-xy))))
    (if (zerop min-y)
        (error "Does not work in first line"))
    (if (<= min-x 0)
        (error "Does not work in first column"))
    (linedraw-frame (1- min-x) (1- min-y) (1+ max-x) (1+ max-y))))

(global-set-key [M-S-left] 'linedraw-left)
(global-set-key [M-S-up] 'linedraw-up)
(global-set-key [M-S-down] 'linedraw-down)
(global-set-key [M-S-right] 'linedraw-right)

;; Internal code

(defvar linedraw-style '[1 1 1 1]
  "The style used for drawing lines.
The value is a vector [LEFT UP DOWN RIGHT] of style codes.
Use the command `linedraw-style' to set this variable.")

(defconst linedraw-characters
  '((205 [2 nil nil 2])
    (186 [nil 2 2 nil])
    (196 [1 nil nil 1])
    (179 [nil 1 1 nil])
    (218 [nil nil 1 1])
    (194 [1 nil 1 1])
    (191 [1 nil 1 nil])
    (195 [nil 1 1 1])
    (197 [1 1 1 1])
    (180 [1 1 1 nil])
    (192 [nil 1 nil 1])
    (193 [1 1 nil 1])
    (217 [1 1 nil nil])
    (201 [nil nil 2 2])
    (203 [2 nil 2 2])
    (187 [2 nil 2 nil])
    (204 [nil 2 2 2])
    (206 [2 2 2 2])
    (185 [2 2 2 nil])
    (200 [nil 2 nil 2])
    (202 [2 2 nil 2])
    (188 [2 2 nil nil])
    (213 [nil nil 1 2])
    (209 [2 nil 1 2])
    (184 [2 nil 1 nil])
    (198 [nil 1 1 2])
    (216 [2 1 1 2])
    (181 [2 1 1 nil])
    (212 [nil 1 nil 2])
    (207 [2 1 nil 2])
    (190 [2 1 nil nil])
    (214 [nil nil 2 1])
    (210 [1 nil 2 1])
    (183 [1 nil 2 nil])
    (199 [nil 2 2 1])
    (215 [1 2 2 1])
    (182 [1 2 2 nil])
    (211 [nil 2 nil 1])
    (208 [1 2 nil 1])
    (189 [1 2 nil nil])
    (43 [0 0 0 0 ])
    (45 [0 nil nil 0])
    (124 [nil 0 0 nil]))
  "Alist of elements (CHAR VECTOR) for defining linedraw characters.
CHAR is a character code, VECTOR is a vector [LEFT UP DOWN RIGHT]
of style codes.")

(defvar linedraw-cache nil
  "Alist of elements (VECTOR CHAR).
This is a reverse of linedraw-characters, built as needed.")

(defun linedraw-move (dir dx dy)
  "Draw line graphic and move.
DIR is the direction slot of a vector (0 through 3), DX and DY
are the distances to move right and down, respectively."
  (let ((char-left (preceding-char))
        (char-right (char-after (1+ (point))))
        (char-up (above-char))
        (char-down (below-char))
        (char-point (following-char))
        attr char)
    (if (eq char-point 10)
        (setq char-right 0))
    (setq attr (copy-sequence (linedraw-decode char-point)))
    (aset attr 0 (aref (linedraw-decode char-left) 3))
    (aset attr 1 (aref (linedraw-decode char-up) 2))
    (aset attr 2 (aref (linedraw-decode char-down) 1))
    (aset attr 3 (aref (linedraw-decode char-right) 0))
    (aset attr dir (aref linedraw-style dir))
    (setq char (linedraw-make attr))
    (if char
        (linedraw-overwrite char))
    (or (= dx 1)
        (forward-char (1- dx)))
    (or (= dy 0)
        (picture-move-down dy))))

(defun linedraw-overwrite (char)
  (insert char)
  (or (eolp)
      (delete-char 1)))

(defun above-char ()
  "Return the character above point, or 0 if not possible."
  (let ((col (current-column)))
    (save-excursion
      (if (/= (forward-line -1) 0)
          0
        (move-to-column col)
        (string-to-char (buffer-substring (point) (1+ (point))))))))

(defun below-char ()
  "Return the character below point, or 0 if not possible."
  (let ((col (current-column)))
    (save-excursion
      (if (/= (forward-line 1) 0)
          0
        (move-to-column col)
        (if (eobp)
            0
          (string-to-char (buffer-substring (point) (1+ (point)))))))))

(defun linedraw-decode (char)
  (or (car (cdr (assoc char linedraw-characters)))
      [nil nil nil nil]))

(defun linedraw-make (attr)
  "Return a character matching ATTR in the current linedraw style.
ATTR is a vector [LEFT UP DOWN RIGHT] of style codes.  The character
shall have a line in direction i if the ith element of the vector
is non-nil.  The element specifies the style of the line.
If no matching character is found, return nil."
  (let ((elt (assoc attr linedraw-cache))
        (tail linedraw-characters)
        (best-score -1)
        vec result score idx)
    (if elt
        (car (cdr elt))
      (while (consp tail)
        (setq elt (car tail))
        (setq tail (cdr tail))
        (setq vec (car (cdr elt)))
        (setq score 0 idx 0)
        (while (< idx 4)
          (cond ((eq (aref attr idx) (aref vec idx))
                 (setq score (+ 25 score)))
                ((eq (aref vec idx) (aref linedraw-style idx))
                 (setq score (+ 5 score)))
                ((aref vec idx)
                 (setq score (1+ score))))
          (setq idx (1+ idx)))
        (if (> score best-score)
            (setq result (car elt)
                  best-score score)))
      (setq linedraw-cache (append (list (list attr result)) linedraw-cache))
      result)))

(defun linedraw-get-xy (position)
  "Return (COLUMN . LINE) for POSITION."
  (save-excursion
    (goto-char position)
    (cons (current-column) (count-lines 1 position))))

(defun linedraw-frame (min-x min-y max-x max-y)
  (let (start char i)
    (save-excursion
      (goto-line min-y)
      (move-to-column min-x t)
      (setq start (point))
      (linedraw-put [nil nil t t])
      (setq i (1+ min-x))
      (while (< i max-x)
        (linedraw-put [t nil nil t])
        (setq i (1+ i)))
      (linedraw-put [t nil t nil])
      (goto-char start)
      (setq i (1+ min-y))
      (while (< i max-y)
        (picture-move-down 1)
        (linedraw-put [nil t t nil])
        (move-to-column max-x)
        (linedraw-put [nil t t nil])
        (move-to-column min-x)
        (setq i (1+ i)))
      (picture-move-down 1)
      (linedraw-put [nil t nil t])
      (setq i (1+ min-x))
      (while (< i max-x)
        (linedraw-put [t nil nil t])
        (setq i (1+ i)))
      (linedraw-put [t t nil nil]))))

(defun linedraw-put (vec)
  (let ((attr (copy-sequence (linedraw-decode (following-char)))))
    (and (aref vec 0) (aset attr 0 (aref linedraw-style 0)))
    (and (aref vec 1) (aset attr 1 (aref linedraw-style 1)))
    (and (aref vec 2) (aset attr 2 (aref linedraw-style 2)))
    (and (aref vec 3) (aset attr 3 (aref linedraw-style 3)))
    (linedraw-overwrite (linedraw-make attr))))

;;; linedraw.el ends here
