cgit.sxemacs.org Git - packages/blob - xemacs-packages/cogre/picture-hack.el

   1 ;;; picture-hack.el --- Updates to picture mode
   2
   3 ;;; Copyright (C) 2001 Eric M. Ludlam
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6 ;; Keywords: picture
   7 ;; X-RCS: $Id: picture-hack.el,v 1.1 2007-11-26 15:04:25 michaels Exp $
   8
   9 ;; Semantic is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; This software is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  22 ;; Boston, MA 02110-1301, USA.
  23
  24 ;;; Commentary:
  25 ;;
  26 ;; Picture-hack is a series of modifications to functions in picture.el
  27 ;; and rect.el.
  28 ;; It also contains new functions which should live in picture.el
  29 ;;
  30 ;; These are hacks needed by COGRE.  Long term, I would like to see
  31 ;; these features merged back into picture mode.
  32
  33 (require 'picture)
  34 (require 'rect)
  35
  36 ;;; Code:
  37
  38 ;;; XEmacs is missing some stuff
  39 ;;
  40 (unless (fboundp 'picture-current-line)
  41   ;; copied from Emacs 20.6:
  42   (defun picture-current-line ()
  43     "Return the vertical position of point.  Top line is 1."
  44     (+ (count-lines (point-min) (point))
  45        (if (= (current-column) 0) 1 0))))
  46
  47 (unless (fboundp 'picture-update-desired-column)
  48   ;; copied from Emacs 20.6:
  49   ;; If the value of picture-desired-column is far from the current
  50   ;; column, or if the arg ADJUST-TO-CURRENT is non-nil, set it to the
  51   ;; current column.   Return the current column.
  52   (defun picture-update-desired-column (adjust-to-current)
  53     (let ((current-column (current-column)))
  54       (if (or adjust-to-current
  55               (< picture-desired-column (1- current-column))
  56               (> picture-desired-column (1+ current-column)))
  57           (setq picture-desired-column current-column))
  58       current-column)))
  59
  60 (unless (fboundp 'char-width)
  61   (defun char-width (CH)
  62     "XEmacs doesn't have this, always return 1."
  63     1))
  64
  65 (unless (boundp 'picture-rectangle-v)
  66   (defcustom picture-rectangle-v   ?|
  67     "*Character `picture-draw-rectangle' uses for vertical lines."
  68     :type 'character
  69     :group 'picture))
  70
  71 (unless (boundp 'picture-rectangle-h)
  72   (defcustom picture-rectangle-h   ?-
  73     "*Character `picture-draw-rectangle' uses for horizontal lines."
  74     :type 'character
  75     :group 'picture))
  76
  77 ;;; Changes to exsiting functions
  78 ;;
  79 (defun picture-insert-rectangle (rectangle &optional insertp)
  80   "Overlay RECTANGLE with upper left corner at point.
  81 Optional argument INSERTP, if non-nil causes RECTANGLE to be inserted.
  82 Leaves the region surrounding the rectangle."
  83   (let ((indent-tabs-mode nil))
  84     (if (not insertp)
  85         (save-excursion
  86           (delete-rectangle (point)
  87                             (progn
  88                               (picture-forward-column
  89                                (length (car rectangle)))
  90                               (picture-move-down (1- (length rectangle)))
  91                               (point)))))
  92     ;; This line is different from the one in Emacs 21, and enables
  93     ;; the mark to only be pushed if it is interactivly called.
  94     (if (interactive-p) (push-mark))
  95     (insert-rectangle rectangle)))
  96
  97 (if (condition-case nil
  98         (and (clear-rectangle 0 0 t)
  99              nil)
 100       (error t))
 101
 102     ;; In emacs 20, FILL is not an argument to clear rectangle as it is
 103     ;; in emacs 21.  Add it here.  Fortunatly, `operate-on-rectangle' does
 104     ;; take a fill argument.
 105     (defun clear-rectangle (start end &optional fill)
 106       "Blank out rectangle with corners at point and mark.
 107 The text previously in the region is overwritten by the blanks.
 108 When called from a program, requires two args which specify the corners."
 109       (interactive "r")
 110       (operate-on-rectangle 'clear-rectangle-line start end t))
 111 )
 112
 113 ;; This is a modified version which takes text properties
 114 (defun picture-insert (ch arg &rest textproperties)
 115   "Insert character CH, and move in the current picture motion direction.
 116 Repeat ARG times.
 117 Apply TEXTPROPERTIES to the character inserted."
 118   (let* ((width (char-width ch))
 119          ;; We must be sure that the succeeding insertion won't delete
 120          ;; the just inserted character.
 121          (picture-horizontal-step
 122           (if (and (= picture-vertical-step 0)
 123                    (> width 1)
 124                    (< (abs picture-horizontal-step) 2))
 125               (* picture-horizontal-step 2)
 126             picture-horizontal-step)))
 127     (while (> arg 0)
 128       (setq arg (1- arg))
 129       ;; The following is in Emacs 21, but it hoses over earlier Emacsen
 130       ;; which do not have `picture-desired-column'
 131       ;;
 132       ;; (if (/= picture-desired-column (current-column))
 133       ;; (move-to-column picture-desired-column t))
 134       (let ((col (+ (current-column) width)))
 135         (or (eolp)
 136             (let ((pos (point)))
 137               (move-to-column col t)
 138               (delete-region pos (point)))))
 139       (insert ch)
 140       (forward-char -1)
 141       (if textproperties
 142           (add-text-properties (point) (1+ (point))
 143                                (append
 144                                 ;; These two are special defaults
 145                                 ;; useful for pictures.
 146                                 '(rear-nonsticky t detachable t)
 147                                 textproperties))
 148         )
 149       (picture-move))))
 150
 151 ;;; New functions
 152 ;;
 153 (defun picture-goto-coordinate (x y)
 154   "Goto coordinate X, Y."
 155   (goto-char (point-min))
 156   (picture-newline y)
 157   (move-to-column x t)
 158   )
 159
 160 (defun picture-set-motion (vert horiz)
 161   "Set VERTICAL and HORIZONTAL increments for movement in Picture mode.
 162 The mode line is updated to reflect the current direction."
 163   (setq picture-vertical-step vert
 164         picture-horizontal-step horiz)
 165   (if (eq major-mode 'picture-mode)
 166       (progn
 167         (setq mode-name
 168               (format "Picture:%s"
 169                       (nth (+ 2 (% horiz 3) (* 5 (1+ (% vert 2))))
 170                            '(wnw nw up ne ene Left left none right Right
 171                                  wsw sw down se ese))))
 172         (force-mode-line-update)
 173         (message ""))))
 174
 175 (defun picture-draw-rectilinear-line (x1 y1 x2 y2 &optional direction
 176                                          &rest textproperties)
 177   "Draw a line from X1, Y1 to X2, Y2.
 178 If optional argument DIRECTION is specified as 'verticle, or 'horizontal,
 179 then the line is drawn with the major direction in that orientation.
 180 If DIRECTION is not specified, the greatest distance between X or Y
 181 coordinates is used to choose.
 182 Arguments TEXTPROPERTIES are applied to the characters inserted.
 183 The line is drawn in a rectilinear fashion."
 184   ;; A rectilinear line for us (short term) is a line travelling
 185   ;; in the direction of greatest distance, with a jog in the middle.
 186   (let (xdir ydir halfway htwiddle
 187         )
 188     ;; Travelling
 189     (if (> x1 x2)
 190         (setq xdir -1)
 191       (setq xdir 1))
 192     (if (> y1 y2)
 193         (setq ydir -1)
 194       (setq ydir 1))
 195     ;; Get there
 196     (picture-goto-coordinate x1 y1)
 197     (picture-update-desired-column t)
 198     ;; Determine primary direction
 199     (if (or (and direction (eq direction 'horizontal))
 200             (and (not direction) (> (abs (- x1 x2)) (abs (- y1 y2)))))
 201         ;; This means that X is primary direction
 202         (progn
 203           (setq halfway (/ (abs (- x1 x2)) 2)
 204                 htwiddle (% (abs (- x1 x2)) 2))
 205           (picture-set-motion 0 xdir)
 206           (apply 'picture-insert picture-rectangle-h (+ halfway htwiddle)
 207                  textproperties)
 208           (if (/= y1 y2)
 209               (progn
 210                 (picture-set-motion ydir 0)
 211                 (apply 'picture-insert picture-rectangle-ctl 1
 212                        textproperties)
 213                 (apply 'picture-insert picture-rectangle-v (1- (abs (- y1 y2)))
 214                        textproperties)
 215                 (picture-set-motion 0 xdir)
 216                 (apply 'picture-insert picture-rectangle-ctl 1
 217                        textproperties)
 218                 ;;(setq halfway (1- halfway))
 219                 )
 220             (apply 'picture-insert picture-rectangle-h 1
 221                    textproperties)
 222             )
 223           (apply 'picture-insert picture-rectangle-h halfway
 224                  textproperties)
 225           )
 226       ;; This means that Y is the primary direction
 227       (setq halfway (/ (abs (- y1 y2)) 2)
 228             htwiddle (% (abs (- y1 y2)) 2))
 229       (picture-set-motion ydir 0)
 230       (apply 'picture-insert picture-rectangle-v (+ halfway htwiddle)
 231              textproperties)
 232       (if (/= x1 x2)
 233           (progn
 234             (picture-set-motion 0 xdir)
 235             (apply 'picture-insert picture-rectangle-ctl 1
 236                    textproperties)
 237             (apply 'picture-insert picture-rectangle-h (1- (abs (- x1 x2)))
 238                    textproperties)
 239             (picture-set-motion ydir 0)
 240             (apply 'picture-insert picture-rectangle-ctl 1
 241                    textproperties)
 242             ;(setq halfway (1- halfway))
 243             )
 244         (apply 'picture-insert picture-rectangle-v 1
 245                textproperties)
 246         )
 247       (apply 'picture-insert picture-rectangle-v halfway
 248              textproperties)
 249       )
 250     ))
 251
 252 (provide 'picture-hack)
 253
 254 ;;; picture-hack.el ends here