OS/2 Shareware BBS: 5 Edit/05-Edit.zip/me34src.zip/me3/mutt/package/picture.mut

Lisp/Scheme | 1995-01-14 | 23KB | 716 lines

;; "Picture mode" -- editing using quarter-plane screen model.
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; Principal author K. Shane Hartman
;; Converted to Mutt 6/88 C Durland
;; Made changes for ME3 12/92 C Durland

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;; Utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;; Eliminate whitespace at ends of lines.
(defun remove-trailing-whitespace
{
  (save-point
    {{
      (beginning-of-buffer)
      (re-search-replace "[ ^I]+$" "")
    }})
  (msg "Removed trailing whitespace")
})

    ; move to the next tab stop in the tabs list
(defun tab-to-tab-stop (int num-tabs) (array byte tabs 1)
{
  (int i col)

  (col (current-column))
  (for (i 0) (and (< i num-tabs)(>= col (tabs i))) (+= i 1) ())
  (if (< i num-tabs) { (to-col (i (tabs i))) i } col)
})

(include me.mh)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; Picture Movement Commands ;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;; Move to column in current line.
  ;; Differs from move-to-column in that it creates or modifies whitespace
  ;;   if necessary to attain exactly the specified column.
(defun move-to-column-force (int column) HIDDEN
{
  (current-column column) (to-col column)
})

  ;; Position point after last non-blank character on current line.
  ;; With ARG not nil, move forward ARG - 1 lines first.
  ;; If scan reaches end of buffer, stop there without error.
(defun picture-end-of-line
{
  (if (arg-flag) (forward-line (- (arg-prefix) 1)))
  (end-of-line)
  (if (previous-character)
  {
    (while (is-space) (previous-character))
    (next-character)
  })
})

  ;; Move cursor right, making whitespace if necessary.
  ;; With argument, move that many columns.
(defun picture-forward-column
{
  (move-to-column-force (+ (current-column) (arg-prefix)))
})

  ;; Move cursor left, making whitespace if necessary.
  ;; With argument, move that many columns.
(defun picture-backward-column
{
  (move-to-column-force (- (current-column) (arg-prefix)))
})

  ;; Move vertically down, making whitespace if necessary.
  ;; With argument, move that many lines.
(defun picture-move-down
{
  (int col)

  (col (current-column))
  (picture-newline (arg-prefix))
  (move-to-column-force col)
})

  ;; Move vertically up, making whitespace if necessary.
  ;; With argument, move that many lines.
(defun picture-move-up
{
  (int col n)

  (n (arg-prefix))
  (col (current-column))

  (while (>= (-= n 1) 0)
    (if (not (forward-line -1))    ; at top of buffer
    { (beginning-of-buffer)(open-line) })
  )
  (move-to-column-force col)
})

  ;; Amount to move vertically after text character in Picture mode.
(int picture-vertical-step)

  ;; Amount to move horizontally after text character in Picture mode.
(int picture-horizontal-step)

  ;; Set VERTICAL and HORIZONTAL increments for movement in Picture mode.
  ;; The mode line is updated to reflect the current direction.
(defun picture-set-motion (int vert horiz) HIDDEN
{
  (picture-vertical-step vert)
  (picture-horizontal-step horiz)
;  (setq mode-name
;    (format "Picture:%s"
;        (car (nthcdr (+ 1 (% horiz 2) (* 3 (1+ (% vert 2))))
;                 '(nw up ne left none right sw down se)))))
  (major-mode
    (concat "Picture:"
      (switch (+ 1 horiz (* 3 (+ 1 vert)))
    0 "NW"
    1 "up"
    2 "NE"
    3 "left"
    4 "none"
    5 "right"
    6 "SW"
    7 "down"
    8 "SE"
      )))
})

  ;; Move right after self-inserting character in Picture mode.
(defun picture-movement-right { (picture-set-motion 0 1) })

  ;; Move left after self-inserting character in Picture mode.
(defun picture-movement-left { (picture-set-motion 0 -1) })

  ;; Move up after self-inserting character in Picture mode.
(defun picture-movement-up { (picture-set-motion -1 0) })

  ;; Move down after self-inserting character in Picture mode.
(defun picture-movement-down { (picture-set-motion 1 0) })

  ;; Move up and left after self-inserting character in Picture mode.
(defun picture-movement-nw { (picture-set-motion -1 -1) })

  ;; Move up and right after self-inserting character in Picture mode.
(defun picture-movement-ne { (picture-set-motion -1 1) })

  ;; Move down and left after self-inserting character in Picture mode.
(defun picture-movement-sw { (picture-set-motion 1 -1) })

  ;; Move down and right after self-inserting character in Picture mode.
(defun picture-movement-se { (picture-set-motion 1 1) })

  ;; Move in direction of picture-vertical-step and picture-horizontal-step.
  ;; With ARG do it that many times.
  ;; Useful for delineating rectangles in conjunction with diagonal
  ;;   picture motion.
  ;; Do apropos picture-movement  to see commands which control motion.
(defun picture-move
{
  (int col)

  (col (+ (current-column) (* picture-horizontal-step (arg-prefix))))
  (cond
    (< picture-vertical-step 0) (picture-move-up)
    (> picture-vertical-step 0) (picture-move-down)
  )
  (move-to-column-force col)
})

  ;; Move point in direction opposite of current picture motion in Picture mode.
  ;; With ARG do it that many times.
  ;; Useful for delineating rectangles in conjunction with diagonal
  ;;   picture motion.
  ;; Do apropos picture-movement  to see commands which control motion.
(defun picture-move-reverse
{
  (*= picture-vertical-step -1)(*= picture-horizontal-step -1)
  (picture-move)
  (*= picture-vertical-step -1)(*= picture-horizontal-step -1)
})

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;; Picture insertion and deletion ;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;; Insert character in place of character previously at the cursor.
  ;; The cursor then moves in the direction previously specified
  ;;   with the picture-movement- commands.
  ;; Do apropos  picture-movement  to see those commands.
(defun picture-insert (string c)(int n) HIDDEN
{
  (int i)

  (i n)
  (while (> i 0)
  {
    (-= i 1)
    (move-to-column-force (+ 1 (current-column)))    ; break up any tabs
    (delete-previous-character)
    (insert-text c)
    (previous-character)
    (arg-prefix 1)(picture-move)
  })
})

(defun picture-self-insert
{
  (picture-insert (convert-to CHARACTER (key-pressed)) (arg-prefix))
})

  ;; Clear out ARG columns after point without moving.
(defun picture-clear-column
{
  (int col)

  (set-mark)
  (col (current-column (+ (current-column) (arg-prefix))))
  (delete-region)(to-col col)
  (swap-marks)
})

  ;; Clear out ARG columns before point, moving back over them.
(defun picture-backward-clear-column
{
  (if (== 1 (current-column)) (done))    ; no op if at begining of line
  (move-to-column-force (- (current-column) (arg-prefix)))
  (picture-clear-column)
})

  ;; Clear out rest of line; if at end of line, advance to next line.
  ;; Cleared-out line text goes into the kill ring, as do
  ;;   newlines that are advanced over.
  ;; With argument, clear out (and save in kill ring) that many lines.
(defun picture-clear-line
{
  (int n)

  (if (arg-flag)
    {
      (arg-prefix (n (arg-prefix))) (cut-line)
      (arg-prefix n)(newline)
    }
    {
      (if (looking-at '.+$')(cut-line))
        ; tack a newline to end of cut buffer
      (append-to-bag CUT-BUFFER APPEND-TEXT "^J")
      (forward-line 1)
    }
  )
})

  ;; Move to the beginning of the following line.
  ;; With argument, moves that many lines (up, if negative argument).
  ;; Always moves to the beginning of a line.
(defun picture-newline
{
  (int n)

  (if (< (n (arg-prefix)) 0)    ; negative arg => move up
    (forward-line n)
    (while (>= (-= n 1) 0) (if (not (forward-line 1)) (newline)))
  )
})

  ;; Insert an empty line after the current line.
  ;; With positive argument insert that many lines.
(defun picture-open-line
{
  (save-point {{ (end-of-line)(open-line) }})
})

  ;; Insert a duplicate of the current line, below it.
(defun picture-duplicate-line
{
  (int col)

  (col (current-column))
  (beginning-of-line)(clear-bag CUT-BUFFER)
  (arg-prefix 1)(cut-line)
  (yank)(yank)
  (forward-line -2)(current-column col)
})

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;; Picture Tabs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;; A character set which controls behavior of commands
  ;;  (picture-set-tab-stops) and (picture-tab-search).  It is NOT a
  ;;  regular expression, any regexp special characters will be quoted.
  ;; It defines a set of "interesting characters" to look for when setting
  ;; (or searching for) tab stops, initially "!-~" (all printing characters).
  ;; For example, suppose that you are editing a table which is formatted thus:
  ;;    | foo        | bar + baz | 23  *
  ;;    | bubbles    | and + etc | 97  *
  ;;   and that picture-tab-chars is "|+*".  Then invoking
  ;;   [picture-set-tab-stops] on either of the previous lines would result
  ;;   in the following tab stops:
  ;;            :     :     :     :
  ;; Another example - "A-Za-z0-9" would produce the tab stops
  ;;      :          :    :     :

  ;; Note that if you want the character `-' to be in the set, it must be
  ;;   included in a range or else appear in a context where it cannot be
  ;;   taken for indicating a range (e.g. "-A-Z" declares the set to be the
  ;;   letters `A' through `Z' and the character `-').  If you want the
  ;;   character `\' in the set it must be preceded by itself: "\\".

  ;; The command (picture-tab-search) is defined to move beneath (or to) a
  ;;   character belonging to this set independent of the tab stops list.

(const default-pic-tab-chars '-!~|')
(string picture-tab-chars)
(array byte pic-tabs 70)
(int num-pic-tabs)

  ;; Set value of  tab-stop-list  according to context of this line.
  ;; This controls the behavior of (picture-tab).  A tab stop
  ;;   is set at every column occupied by an "interesting character" that is
  ;;   preceded by whitespace.  Interesting characters are defined by the
  ;;   variable  picture-tab-chars,  see its documentation for an example
  ;;   of usage.
  ;; With ARG, just (re)set  tab-stop-list  to its default value.
  ;; The tab stops computed are displayed in the minibuffer with `:' at
  ;; each stop.
(defun sleeze-ball (array byte str 1) HIDDEN
{
  (int i)

  (for (i 0) (< i num-pic-tabs)(+= i 1) (str (- (pic-tabs i) 1) 0x3A)) ; ":"
  str
})
(defun picture-set-tab-stops
{
  (int i)
  (string regexp)

;(if arg (setq tabs (default-value 'tab-stop-list))

  (set-mark)
  (regexp (concat '\ +[' picture-tab-chars "]"))
  (beginning-of-line)
  (for (num-pic-tabs 0)
       (and (re-search-forward regexp)
        (== DOT-ON-SAME-LINE-AS-MARK (compare-marks)))
       (+= num-pic-tabs 1)
     (pic-tabs num-pic-tabs (- (current-column) 1))
;; ??? (skip-chars-forward " \t")
  )
  (swap-marks)
  (if (== 0 num-pic-tabs)
  {
    (msg "No characters in set \"" picture-tab-chars "\" on this line.")
    (done)
  })
  (msg (sleeze-ball "                                                                             "))
})

  ;; Move to column beneath next interesting char in previous line.
  ;;   The cursor stays in the current line.
  ;; With ARG move to column occupied by next interesting character in this
  ;;   line.  The character must be preceded by whitespace.
  ;; "Interesting characters" are defined by variable  picture-tab-chars.
  ;; If no such character is found, move to beginning of line.
(defun picture-tab-search
{
  (int i)
  (string regexp)

  (set-mark)
  (regexp (concat '\ +[' picture-tab-chars "]"))
  (if (arg-flag)
  {
    (if (and (re-search-forward regexp)
         (== DOT-ON-SAME-LINE-AS-MARK (compare-marks)))
    { (previous-character)(done) })
  }
  {
    (i (current-column))
    (while TRUE        ; look for non blank line
    {
      (if (forward-line -1)
      {
    (if (looking-at '^\ *$') (continue)    ; blank line
      (break)                ; non blank line
    )
      })
      (goto done)    ; hit top of buffer
    })
    (current-column i)
    (if (and (re-search-forward regexp)
         (== DOT-ABOVE-MARK (compare-marks)))
    {
      (i (current-column))
      (swap-marks)
      (move-to-column-force (- i 1))
      (done)
    })
  })
(label done)
  (swap-marks)(beginning-of-line)
})

  ;; Tab transparently (move) to next tab stop.
  ;; With ARG overwrite the traversed text with spaces.
  ;; The tab stop list can be changed by (picture-set-tab-stops) and
  ;;   (edit-tab-stops).
  ;; See also documentation for variable  picture-tab-chars.
(defun picture-tab
{
  (int target)

  (set-mark)
  (target (tab-to-tab-stop num-pic-tabs pic-tabs))
  (delete-region)
  (move-to-column-force target)
  (if (arg-flag) { (delete-region)(to-col target) })
})


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;; Picture Rectangles ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;; Rectangle killed or copied by (picture-clear-rectangle) in Picture mode.
  ;; The contents can be retrieved by (picture-yank-rectangle)
(const picture-killed-rectangle CUT-BUFFER)

 ;; Clear and save rectangle delineated by point and mark.
 ;; The rectangle is saved for yanking by picture-yank-rectangle and
 ;;   replaced with whitespace.  The previously saved rectangle, if any, is
 ;;   lost.
 ;; With prefix argument, the rectangle is actually killed, shifting
 ;;   remaining text.
(defun picture-clear-rectangle
{
  (append-to-bag picture-killed-rectangle APPEND-RECTANGLE)
  (erase-rectangle (arg-flag))
})

  ;; Clear rectangle delineated by point and mark into REGISTER.
  ;; The rectangle is saved in REGISTER and replaced with whitespace.
  ;; With prefix argument, the rectangle is actually killed, shifting
  ;;   remaining text.
(defun picture-clear-rectangle-to-register
{
  (bool clear)

  (clear (arg-flag))(arg-flag FALSE)

  (copy-region-to-rectangle)
  (erase-rectangle clear)
})

  ;; Overlay RECTANGLE with upper left corner at point.
  ;; Optional argument INSERTP, if non-nil causes RECTANGLE to be inserted.
  ;; Leaves the region surrounding the rectangle.
(defun picture-insert-rectangle (int rectangle) (bool insert) HIDDEN
{
  (byte type)(small-int width height)(int size)    ;; struct BagInfo
  (int col)

  (bag-stats rectangle (loc type))
  (if (!= type 1) { (msg "Not a rectangle.") (done) })
  (if (not insert)
  {
    (set-mark)(col (current-column))    ; set mark at upper left column
    ; put dot as close as possible to lower right column
    (forward-line (- height 1))(move-to-column-force (+ col width))
    (erase-rectangle TRUE)
  })
  (insert-bag rectangle)
})

  ;; Overlay rectangle saved by picture-clear-rectangle.
  ;; The rectangle is positioned with upper left corner at point,
  ;;   overwriting existing text.  With prefix argument, the rectangle is
  ;;   inserted instead, shifting existing text.  Leaves mark at one corner
  ;;   of rectangle and point at the other (diagonally opposed) corner.
(defun picture-yank-rectangle
{
  (picture-insert-rectangle picture-killed-rectangle (arg-flag))
})

  ;; Overlay rectangle saved in REGISTER.
  ;; The rectangle is positioned with upper left corner at point,
  ;;   overwriting existing text.
  ;; With prefix argument, the rectangle is inserted instead, shifting
  ;;   existing text.
  ;; Leaves mark at one corner of rectangle and point at the other
  ;;  (diagonally opposed) corner.
(defun picture-yank-rectangle-from-register
{
(msg "Not currently implemented.  Use picture-clear-rectangle.")
(done)
;  (picture-insert-rectangle bag-id (arg-flag))
})

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; Misc goodies ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(const
  UPPER-LEFT-CORNER "." UPPER-EDGE "-" UPPER-RIGHT-CORNER "."
  LOWER-LEFT-CORNER "`" LOWER-EDGE "-" LOWER-RIGHT-CORNER "'"
  LEFT-SIDE "|" RIGHT-SIDE "|"
)

  ;; Draw a box around the region-rectangle
(defun picture-box
{
  (byte type)(small-int ulcol width height)(int size)    ;; struct RegionInfo

  (region-stats (loc type) THE-DOT THE-MARK TRUE)

  (move-to-column-force ulcol)    ;; move dot to upper left corner of box

  (if (or (< (-= width 1) 1)(< (-= height 2) 1))
     { (msg "Box too small")(done) })
    ;; draw top of box
  (picture-movement-right)
  (picture-insert UPPER-LEFT-CORNER 1)(picture-insert UPPER-EDGE width)
    ;; draw right side of box
  (picture-movement-down)
  (picture-insert UPPER-RIGHT-CORNER 1)(picture-insert RIGHT-SIDE height)
    ;; draw bottom of box
  (picture-movement-left)
  (picture-insert LOWER-RIGHT-CORNER 1)(picture-insert LOWER-EDGE width)
    ;; draw left side of box
  (picture-movement-up)
  (picture-insert LOWER-LEFT-CORNER 1)(picture-insert LEFT-SIDE height)
    ;; finished
  (picture-movement-right)
})

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;; Picture Keymap, entry and exit points ;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(int picture-mode-keymap)

(defun MAIN
{
  (int i)
  (string str pkey)

  (picture-mode-keymap (create-keymap))

  (for (i 0x20) (< i 0x7F) (+= i 1)
    (bind-key picture-mode-keymap
    "picture-self-insert" (convert-to CHARACTER i)))

  (pkey (prefix-key 2))
  (prefix-key 2 "C-C")

  (bind-key picture-mode-keymap
    "picture-forward-column"        "C-f"
    "picture-backward-column"        "C-b"
    "picture-clear-column"            "C-d"
    "delete-character"            "C-cC-d"
    "picture-backward-clear-column"     "C-H"
    "picture-clear-line"            "C-k"
    "picture-open-line"            "C-o"
    "picture-newline"            "C-m"
    "picture-move-down"            "C-n"
    "picture-move-up"            "C-p"
    "picture-end-of-line"            "C-e"
    "picture-duplicate-line"        "C-j"

    "picture-tab"                "C-I"
    "picture-tab-search"            "M-C-I"
    "picture-set-tab-stops"            "C-cC-i"

    "picture-mode-exit"            "C-cC-c"
    "picture-move"                "C-cC-f"
    "picture-move-reverse"            "C-cC-b"

    "picture-movement-left"            "C-c<"
    "picture-movement-right"        "C-c>"
    "picture-movement-up"            'C-c^'
    "picture-movement-down"            "C-c."
    "picture-movement-nw"            "C-c`"
    "picture-movement-ne"            "C-c'"
    "picture-movement-sw"            "C-c/"
    "picture-movement-se"            "C-c\\"

    "picture-clear-rectangle"        "C-cC-k"
    "picture-clear-rectangle-to-register"    "C-cC-w"
    "picture-yank-rectangle"        "C-cC-y"
    "picture-yank-rectangle-from-register"    "C-cC-x")

  (prefix-key 2 pkey)
})

  ;; Switch to Picture mode, in which a quarter-plane screen model is used.
  ;; Printing characters replace instead of inserting themselves with motion
  ;;   afterwards settable by these commands:
  ;;   C-c <    Move left after insertion.
  ;;   C-c >    Move right after insertion.
  ;;   C-c ^    Move up after insertion.
  ;;   C-c .    Move down after insertion.
  ;;   C-c `    Move northwest (nw) after insertion.
  ;;   C-c '    Move northeast (ne) after insertion.
  ;;   C-c /    Move southwest (sw) after insertion.
  ;;   C-c \    Move southeast (se) after insertion.
  ;; The current direction is displayed in the mode line.  The initial
  ;;   direction is right.  Whitespace is inserted and tabs are changed to
  ;;   spaces when required by movement.  You can move around in the buffer
  ;;   with these commands:
  ;;   C-p    Move vertically to SAME column in previous line.
  ;;   C-n    Move vertically to SAME column in next line.
  ;;   C-e    Move to column following last non-whitespace character.
  ;;   C-f    Move right inserting spaces if required.
  ;;   C-b    Move left changing tabs to spaces if required.
  ;;   C-c C-f    Move in direction of current picture motion.
  ;;   C-c C-b    Move in opposite direction of current picture motion.
  ;;   Return    Move to beginning of next line.
  ;; You can edit tabular text with these commands:
  ;;   M-Tab    Move to column beneath (or at) next interesting character.
  ;;        `Indents' relative to a previous line.
  ;;   Tab    Move to next stop in tab stop list.
  ;;   C-c Tab    Set tab stops according to context of this line.
  ;;         With ARG resets tab stops to default (global) value.
  ;;         See also documentation of variable    picture-tab-chars
  ;;         which defines "interesting character".  You can manually
  ;;         change the tab stop list with command [edit-tab-stops].
  ;; You can manipulate text with these commands:
  ;;   C-d      Clear (replace) ARG columns after point without moving.
  ;;   C-c C-d    Delete char at point - the command normally assigned to C-d.
  ;;   Delete    Clear (replace) ARG columns before point, moving back over them.
  ;;   C-k    Clear ARG lines, advancing over them.     The cleared
  ;;         text is saved in the kill ring.
  ;;   C-o    Open blank line(s) beneath current line.
  ;; You can manipulate rectangles with these commands:
  ;;   C-c C-k    Clear (or kill) a rectangle and save it.
  ;;   C-c C-w    Like C-c C-k except rectangle is saved in named register.
  ;;   C-c C-y    Overlay (or insert) currently saved rectangle at point.
  ;;   C-c C-x    Like C-c C-y except rectangle is taken from named register.
  ;; You can return to the previous mode with:
  ;;   C-c C-c    Which also strips trailing whitespace from every line.
  ;;         Stripping is suppressed by supplying an argument.

  ;; Note that Picture mode commands will work outside of Picture mode, but
  ;; they are not defaultly assigned to keys.
(defun edit-picture
{
  (list context)
  (string the-mode)

  (if (== "Picture" (extract-elements (major-mode) 0 7))
  {
    (msg "You are already editing a Picture.")
    (done)
  })

  (create-buffer-var LIST "pic-stuff")

  (insert-object context 10000 (the-mode (major-mode)))
  (insert-object context 10000 (minor-mode))
  (insert-object context 10000 (install-keymap LOCAL-KEYMAP))
  (insert-object context 10000 (prefix-key 2))
  (insert-object context 10000 (word-wrap))
  (buffer-var "pic-stuff" context)

  (word-wrap 0)

  (picture-set-motion 0 1)
  (picture-tab-chars default-pic-tab-chars)
  (num-pic-tabs 0)

  (prefix-key 2 "C-C")

  (install-keymap picture-mode-keymap LOCAL-KEYMAP)

  (if (pgm-exists "edit-picture-hook") (floc "edit-picture-hook"()))

  (msg "Type C-cC-c"    ;;!!! gack - need (list-keys "picture-mode-exit")
    " in this buffer to "
    (if (== "" the-mode)
      "exit picture mode."
      (concat "return to " the-mode " mode.")))
})

  ;; Undo edit-picture and return to previous major mode.
  ;; With no argument strips whitespace from end of every line in Picture
  ;;   buffer otherwise just return to previous mode.
(defun picture-mode-exit
{
  (int kid)
  (list context)

  (if (!= "Picture" (extract-elements (major-mode) 0 7))
  {
    (msg "You aren't editing a Picture.")
    (done)
  })

  (if (not (arg-flag)) (remove-trailing-whitespace))

  (context (buffer-var "pic-stuff"))

  (major-mode        (extract-element context 0))
  (minor-mode        (extract-element context 1))
;  (install-keymap    (extract-element context 2)  LOCAL-KEYMAP)
  (prefix-key 2        (extract-element context 3))
  (word-wrap        (extract-element context 4))

(kid            (extract-element context 2))
(install-keymap (if (!= -1 (install-keymap kid)) kid NULL-KEYMAP) LOCAL-KEYMAP)

  (msg "Picture done")
})