(find-function-search-for-symbol): Strip extension from .emacs.el to
[bpt/emacs.git] / lisp / ses.el
1 ;;; ses.el -- Simple Emacs Spreadsheet -*- coding: utf-8 -*-
2
3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
4
5 ;; Author: Jonathan Yavner <jyavner@member.fsf.org>
6 ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org>
7 ;; Keywords: spreadsheet
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 3, or (at your option)
14 ;; any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
25
26 ;;; Commentary:
27
28 ;;; To-do list:
29
30 ;; * Use $ or … for truncated fields
31 ;; * Add command to make a range of columns be temporarily invisible.
32 ;; * Allow paste of one cell to a range of cells -- copy formula to each.
33 ;; * Do something about control characters & octal codes in cell print
34 ;; areas. Use string-width?
35 ;; * Input validation functions. How specified?
36 ;; * Faces (colors & styles) in print cells.
37 ;; * Move a column by dragging its letter in the header line.
38 ;; * Left-margin column for row number.
39 ;; * Move a row by dragging its number in the left-margin.
40
41
42 ;;; Code:
43
44 (require 'unsafep)
45
46
47 ;;----------------------------------------------------------------------------
48 ;; User-customizable variables
49 ;;----------------------------------------------------------------------------
50
51 (defgroup ses nil
52 "Simple Emacs Spreadsheet."
53 :group 'applications
54 :prefix "ses-"
55 :version "21.1")
56
57 (defcustom ses-initial-size '(1 . 1)
58 "Initial size of a new spreadsheet, as a cons (NUMROWS . NUMCOLS)."
59 :group 'ses
60 :type '(cons (integer :tag "numrows") (integer :tag "numcols")))
61
62 (defcustom ses-initial-column-width 7
63 "Initial width of columns in a new spreadsheet."
64 :group 'ses
65 :type '(integer :match (lambda (widget value) (> value 0))))
66
67 (defcustom ses-initial-default-printer "%.7g"
68 "Initial default printer for a new spreadsheet."
69 :group 'ses
70 :type '(choice string
71 (list :tag "Parenthesized string" string)
72 function))
73
74 (defcustom ses-after-entry-functions '(forward-char)
75 "Things to do after entering a value into a cell.
76 An abnormal hook that usually runs a cursor-movement function.
77 Each function is called with ARG=1."
78 :group 'ses
79 :type 'hook
80 :options '(forward-char backward-char next-line previous-line))
81
82 (defcustom ses-mode-hook nil
83 "Hook functions to be run upon entering SES mode."
84 :group 'ses
85 :type 'hook)
86
87
88 ;;----------------------------------------------------------------------------
89 ;; Global variables and constants
90 ;;----------------------------------------------------------------------------
91
92 (defvar ses-read-cell-history nil
93 "List of formulas that have been typed in.")
94
95 (defvar ses-read-printer-history nil
96 "List of printer functions that have been typed in.")
97
98 (easy-menu-define ses-header-line-menu nil
99 "Context menu when mouse-3 is used on the header-line in an SES buffer."
100 '("SES header row"
101 ["Set current row" ses-set-header-row t]
102 ["Unset row" ses-unset-header-row (> ses--header-row 0)]))
103
104 (defconst ses-mode-map
105 (let ((keys `("\C-c\M-\C-l" ses-reconstruct-all
106 "\C-c\C-l" ses-recalculate-all
107 "\C-c\C-n" ses-renarrow-buffer
108 "\C-c\C-c" ses-recalculate-cell
109 "\C-c\M-\C-s" ses-sort-column
110 "\C-c\M-\C-h" ses-set-header-row
111 "\C-c\C-t" ses-truncate-cell
112 "\C-c\C-j" ses-jump
113 "\C-c\C-p" ses-read-default-printer
114 "\M-\C-l" ses-reprint-all
115 [?\S-\C-l] ses-reprint-all
116 [header-line down-mouse-3] ,ses-header-line-menu
117 [header-line mouse-2] ses-sort-column-click))
118 (newmap (make-sparse-keymap)))
119 (while keys
120 (define-key (1value newmap) (car keys) (cadr keys))
121 (setq keys (cddr keys)))
122 newmap)
123 "Local keymap for Simple Emacs Spreadsheet.")
124
125 (easy-menu-define ses-menu ses-mode-map
126 "Menu bar menu for SES."
127 '("SES"
128 ["Insert row" ses-insert-row (ses-in-print-area)]
129 ["Delete row" ses-delete-row (ses-in-print-area)]
130 ["Insert column" ses-insert-column (ses-in-print-area)]
131 ["Delete column" ses-delete-column (ses-in-print-area)]
132 ["Set column printer" ses-read-column-printer t]
133 ["Set column width" ses-set-column-width t]
134 ["Set default printer" ses-read-default-printer t]
135 ["Jump to cell" ses-jump t]
136 ["Set cell printer" ses-read-cell-printer t]
137 ["Recalculate cell" ses-recalculate-cell t]
138 ["Truncate cell display" ses-truncate-cell t]
139 ["Export values" ses-export-tsv t]
140 ["Export formulas" ses-export-tsf t]))
141
142 (defconst ses-mode-edit-map
143 (let ((keys '("\C-c\C-r" ses-insert-range
144 "\C-c\C-s" ses-insert-ses-range
145 [S-mouse-3] ses-insert-range-click
146 [C-S-mouse-3] ses-insert-ses-range-click
147 "\M-\C-i" lisp-complete-symbol))
148 (newmap (make-sparse-keymap)))
149 (set-keymap-parent newmap minibuffer-local-map)
150 (while keys
151 (define-key newmap (pop keys) (pop keys)))
152 newmap)
153 "Local keymap for SES minibuffer cell-editing.")
154
155 ;Local keymap for SES print area
156 (defalias 'ses-mode-print-map
157 (let ((keys '([backtab] backward-char
158 [tab] ses-forward-or-insert
159 "\C-i" ses-forward-or-insert ;Needed for ses-coverage.el?
160 "\M-o" ses-insert-column
161 "\C-o" ses-insert-row
162 "\C-m" ses-edit-cell
163 "\M-k" ses-delete-column
164 "\M-y" ses-yank-pop
165 "\C-k" ses-delete-row
166 "\C-j" ses-append-row-jump-first-column
167 "\M-h" ses-mark-row
168 "\M-H" ses-mark-column
169 "\C-d" ses-clear-cell-forward
170 "\C-?" ses-clear-cell-backward
171 "(" ses-read-cell
172 "\"" ses-read-cell
173 "'" ses-read-symbol
174 "=" ses-edit-cell
175 "j" ses-jump
176 "p" ses-read-cell-printer
177 "w" ses-set-column-width
178 "x" ses-export-keymap
179 "\M-p" ses-read-column-printer))
180 (repl '(;;We'll replace these wherever they appear in the keymap
181 clipboard-kill-region ses-kill-override
182 end-of-line ses-end-of-line
183 kill-line ses-delete-row
184 kill-region ses-kill-override
185 open-line ses-insert-row))
186 (numeric "0123456789.-")
187 (newmap (make-keymap)))
188 ;;Get rid of printables
189 (suppress-keymap newmap t)
190 ;;These keys insert themselves as the beginning of a numeric value
191 (dotimes (x (length numeric))
192 (define-key newmap (substring numeric x (1+ x)) 'ses-read-cell))
193 ;;Override these global functions wherever they're bound
194 (while repl
195 (substitute-key-definition (car repl) (cadr repl) newmap
196 (current-global-map))
197 (setq repl (cddr repl)))
198 ;;Apparently substitute-key-definition doesn't catch this?
199 (define-key newmap [(menu-bar) edit cut] 'ses-kill-override)
200 ;;Define our other local keys
201 (while keys
202 (define-key newmap (car keys) (cadr keys))
203 (setq keys (cddr keys)))
204 newmap))
205
206 ;;Helptext for ses-mode wants keymap as variable, not function
207 (defconst ses-mode-print-map (symbol-function 'ses-mode-print-map))
208
209 ;;Key map used for 'x' key.
210 (defalias 'ses-export-keymap
211 (let ((map (make-sparse-keymap "SES export")))
212 (define-key map "T" (cons " tab-formulas" 'ses-export-tsf))
213 (define-key map "t" (cons " tab-values" 'ses-export-tsv))
214 map))
215
216 (defconst ses-print-data-boundary "\n\014\n"
217 "Marker string denoting the boundary between print area and data area.")
218
219 (defconst ses-initial-global-parameters
220 "\n( ;Global parameters (these are read first)\n 2 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n"
221 "Initial contents for the three-element list at the bottom of the data area.")
222
223 (defconst ses-initial-file-trailer
224 ";; Local Variables:\n;; mode: ses\n;; End:\n"
225 "Initial contents for the file-trailer area at the bottom of the file.")
226
227 (defconst ses-initial-file-contents
228 (concat " \n" ;One blank cell in print area
229 ses-print-data-boundary
230 "(ses-cell A1 nil nil nil nil)\n" ;One blank cell in data area
231 "\n" ;End-of-row terminator for the one row in data area
232 "(ses-column-widths [7])\n"
233 "(ses-column-printers [nil])\n"
234 "(ses-default-printer \"%.7g\")\n"
235 "(ses-header-row 0)\n"
236 ses-initial-global-parameters
237 ses-initial-file-trailer)
238 "The initial contents of an empty spreadsheet.")
239
240 (defconst ses-box-prop '(:box (:line-width 2 :style released-button))
241 "Display properties to create a raised box for cells in the header line.")
242
243 (defconst ses-standard-printer-functions
244 '(ses-center ses-center-span ses-dashfill ses-dashfill-span
245 ses-tildefill-span)
246 "List of print functions to be included in initial history of printer
247 functions. None of these standard-printer functions is suitable for use as a
248 column printer or a global-default printer because they invoke the column or
249 default printer and then modify its output.")
250
251
252 ;;----------------------------------------------------------------------------
253 ;; Local variables and constants
254 ;;----------------------------------------------------------------------------
255
256 (eval-and-compile
257 (defconst ses-localvars
258 '(ses--blank-line ses--cells ses--col-printers ses--col-widths ses--curcell
259 ses--curcell-overlay ses--default-printer ses--deferred-narrow
260 ses--deferred-recalc ses--deferred-write ses--file-format
261 ses--header-hscroll ses--header-row ses--header-string ses--linewidth
262 ses--numcols ses--numrows ses--symbolic-formulas ses--data-marker
263 ses--params-marker
264 ;;Global variables that we override
265 mode-line-process next-line-add-newlines transient-mark-mode)
266 "Buffer-local variables used by SES."))
267
268 ;;When compiling, create all the buffer locals and give them values
269 (eval-when-compile
270 (dolist (x ses-localvars)
271 (make-local-variable x)
272 (set x nil)))
273
274 (defconst ses-paramlines-plist
275 '(ses--col-widths -5 ses--col-printers -4 ses--default-printer -3
276 ses--header-row -2 ses--file-format 1 ses--numrows 2
277 ses--numcols 3)
278 "Offsets from 'Global parameters' line to various parameter lines in the
279 data area of a spreadsheet.")
280
281
282 ;;
283 ;; "Side-effect variables". They are set in one function, altered in
284 ;; another as a side effect, then read back by the first, as a way of
285 ;; passing back more than one value. These declarations are just to make
286 ;; the compiler happy, and to conform to standard Emacs-Lisp practice (I
287 ;; think the make-local-variable trick above is cleaner).
288 ;;
289
290 (defvar ses-relocate-return nil
291 "Set by `ses-relocate-formula' and `ses-relocate-range', read by
292 `ses-relocate-all'. Set to 'delete if a cell-reference was deleted from a
293 formula--so the formula needs recalculation. Set to 'range if the size of a
294 `ses-range' was changed--so both the formula's value and list of dependents
295 need to be recalculated.")
296
297 (defvar ses-call-printer-return nil
298 "Set to t if last cell printer invoked by `ses-call-printer' requested
299 left-justification of the result. Set to error-signal if ses-call-printer
300 encountered an error during printing. Otherwise nil.")
301
302 (defvar ses-start-time nil
303 "Time when current operation started. Used by `ses-time-check' to decide
304 when to emit a progress message.")
305
306
307 ;;----------------------------------------------------------------------------
308 ;; Macros
309 ;;----------------------------------------------------------------------------
310
311 (defmacro ses-get-cell (row col)
312 "Return the cell structure that stores information about cell (ROW,COL)."
313 `(aref (aref ses--cells ,row) ,col))
314
315 ;; We might want to use defstruct here, but cells are explicitly used as
316 ;; arrays in ses-set-cell, so we'd need to fix this first. --Stef
317 (defsubst ses-make-cell (&optional symbol formula printer references)
318 (vector symbol formula printer references))
319
320 (defmacro ses-cell-symbol (row &optional col)
321 "From a CELL or a pair (ROW,COL), get the symbol that names the local-variable holding its value. (0,0) => A1."
322 `(aref ,(if col `(ses-get-cell ,row ,col) row) 0))
323
324 (defmacro ses-cell-formula (row &optional col)
325 "From a CELL or a pair (ROW,COL), get the function that computes its value."
326 `(aref ,(if col `(ses-get-cell ,row ,col) row) 1))
327
328 (defmacro ses-cell-printer (row &optional col)
329 "From a CELL or a pair (ROW,COL), get the function that prints its value."
330 `(aref ,(if col `(ses-get-cell ,row ,col) row) 2))
331
332 (defmacro ses-cell-references (row &optional col)
333 "From a CELL or a pair (ROW,COL), get the list of symbols for cells whose
334 functions refer to its value."
335 `(aref ,(if col `(ses-get-cell ,row ,col) row) 3))
336
337 (defmacro ses-cell-value (row &optional col)
338 "From a CELL or a pair (ROW,COL), get the current value for that cell."
339 `(symbol-value (ses-cell-symbol ,row ,col)))
340
341 (defmacro ses-col-width (col)
342 "Return the width for column COL."
343 `(aref ses--col-widths ,col))
344
345 (defmacro ses-col-printer (col)
346 "Return the default printer for column COL."
347 `(aref ses--col-printers ,col))
348
349 (defmacro ses-sym-rowcol (sym)
350 "From a cell-symbol SYM, gets the cons (row . col). A1 => (0 . 0). Result
351 is nil if SYM is not a symbol that names a cell."
352 `(and (symbolp ,sym) (get ,sym 'ses-cell)))
353
354 (defmacro ses-cell (sym value formula printer references)
355 "Load a cell SYM from the spreadsheet file. Does not recompute VALUE from
356 FORMULA, does not reprint using PRINTER, does not check REFERENCES. This is a
357 macro to prevent propagate-on-load viruses. Safety-checking for FORMULA and
358 PRINTER are deferred until first use."
359 (let ((rowcol (ses-sym-rowcol sym)))
360 (ses-formula-record formula)
361 (ses-printer-record printer)
362 (or (atom formula)
363 (eq safe-functions t)
364 (setq formula `(ses-safe-formula ,formula)))
365 (or (not printer)
366 (stringp printer)
367 (eq safe-functions t)
368 (setq printer `(ses-safe-printer ,printer)))
369 (aset (aref ses--cells (car rowcol))
370 (cdr rowcol)
371 (ses-make-cell sym formula printer references)))
372 (set sym value)
373 sym)
374
375 (defmacro ses-column-widths (widths)
376 "Load the vector of column widths from the spreadsheet file. This is a
377 macro to prevent propagate-on-load viruses."
378 (or (and (vectorp widths) (= (length widths) ses--numcols))
379 (error "Bad column-width vector"))
380 ;;To save time later, we also calculate the total width of each line in the
381 ;;print area (excluding the terminating newline)
382 (setq ses--col-widths widths
383 ses--linewidth (apply '+ -1 (mapcar '1+ widths))
384 ses--blank-line (concat (make-string ses--linewidth ?\s) "\n"))
385 t)
386
387 (defmacro ses-column-printers (printers)
388 "Load the vector of column printers from the spreadsheet file and checks
389 them for safety. This is a macro to prevent propagate-on-load viruses."
390 (or (and (vectorp printers) (= (length printers) ses--numcols))
391 (error "Bad column-printers vector"))
392 (dotimes (x ses--numcols)
393 (aset printers x (ses-safe-printer (aref printers x))))
394 (setq ses--col-printers printers)
395 (mapc 'ses-printer-record printers)
396 t)
397
398 (defmacro ses-default-printer (def)
399 "Load the global default printer from the spreadsheet file and checks it
400 for safety. This is a macro to prevent propagate-on-load viruses."
401 (setq ses--default-printer (ses-safe-printer def))
402 (ses-printer-record def)
403 t)
404
405 (defmacro ses-header-row (row)
406 "Load the header row from the spreadsheet file and checks it
407 for safety. This is a macro to prevent propagate-on-load viruses."
408 (or (and (wholenump row) (or (zerop ses--numrows) (< row ses--numrows)))
409 (error "Bad header-row"))
410 (setq ses--header-row row)
411 t)
412
413 (defmacro ses-dorange (curcell &rest body)
414 "Execute BODY repeatedly, with the variables `row' and `col' set to each
415 cell in the range specified by CURCELL. The range is available in the
416 variables `minrow', `maxrow', `mincol', and `maxcol'."
417 (declare (indent defun) (debug (form body)))
418 (let ((cur (make-symbol "cur"))
419 (min (make-symbol "min"))
420 (max (make-symbol "max"))
421 (r (make-symbol "r"))
422 (c (make-symbol "c")))
423 `(let* ((,cur ,curcell)
424 (,min (ses-sym-rowcol (if (consp ,cur) (car ,cur) ,cur)))
425 (,max (ses-sym-rowcol (if (consp ,cur) (cdr ,cur) ,cur))))
426 (let ((minrow (car ,min))
427 (maxrow (car ,max))
428 (mincol (cdr ,min))
429 (maxcol (cdr ,max))
430 row col)
431 (if (or (> minrow maxrow) (> mincol maxcol))
432 (error "Empty range"))
433 (dotimes (,r (- maxrow minrow -1))
434 (setq row (+ ,r minrow))
435 (dotimes (,c (- maxcol mincol -1))
436 (setq col (+ ,c mincol))
437 ,@body))))))
438
439 ;;Support for coverage testing.
440 (defmacro 1value (form)
441 "For code-coverage testing, indicate that FORM is expected to always have
442 the same value."
443 form)
444 (defmacro noreturn (form)
445 "For code-coverage testing, indicate that FORM will always signal an error."
446 form)
447
448
449 ;;----------------------------------------------------------------------------
450 ;; Utility functions
451 ;;----------------------------------------------------------------------------
452
453 (defun ses-vector-insert (array idx new)
454 "Create a new vector which is one larger than ARRAY and has NEW inserted
455 before element IDX."
456 (let* ((len (length array))
457 (result (make-vector (1+ len) new)))
458 (dotimes (x len)
459 (aset result
460 (if (< x idx) x (1+ x))
461 (aref array x)))
462 result))
463
464 ;;Allow ARRAY to be a symbol for use in buffer-undo-list
465 (defun ses-vector-delete (array idx count)
466 "Create a new vector which is a copy of ARRAY with COUNT objects removed
467 starting at element IDX. ARRAY is either a vector or a symbol whose value
468 is a vector--if a symbol, the new vector is assigned as the symbol's value."
469 (let* ((a (if (arrayp array) array (symbol-value array)))
470 (len (- (length a) count))
471 (result (make-vector len nil)))
472 (dotimes (x len)
473 (aset result x (aref a (if (< x idx) x (+ x count)))))
474 (if (symbolp array)
475 (set array result))
476 result))
477
478 (defun ses-delete-line (count)
479 "Like `kill-line', but no kill ring."
480 (let ((pos (point)))
481 (forward-line count)
482 (delete-region pos (point))))
483
484 (defun ses-printer-validate (printer)
485 "Signals an error if PRINTER is not a valid SES cell printer."
486 (or (not printer)
487 (stringp printer)
488 (functionp printer)
489 (and (stringp (car-safe printer)) (not (cdr printer)))
490 (error "Invalid printer function"))
491 printer)
492
493 (defun ses-printer-record (printer)
494 "Add PRINTER to `ses-read-printer-history' if not already there, after first
495 checking that it is a valid printer function."
496 (ses-printer-validate printer)
497 ;;To speed things up, we avoid calling prin1 for the very common "nil" case.
498 (if printer
499 (add-to-list 'ses-read-printer-history (prin1-to-string printer))))
500
501 (defun ses-formula-record (formula)
502 "If FORMULA is of the form 'symbol, adds it to the list of symbolic formulas
503 for this spreadsheet."
504 (when (and (eq (car-safe formula) 'quote)
505 (symbolp (cadr formula)))
506 (add-to-list 'ses--symbolic-formulas
507 (list (symbol-name (cadr formula))))))
508
509 (defun ses-column-letter (col)
510 "Converts a column number to A..Z or AA..ZZ"
511 (if (< col 26)
512 (char-to-string (+ ?A col))
513 (string (+ ?@ (/ col 26)) (+ ?A (% col 26)))))
514
515 (defun ses-create-cell-symbol (row col)
516 "Produce a symbol that names the cell (ROW,COL). (0,0) => 'A1."
517 (intern (concat (ses-column-letter col) (number-to-string (1+ row)))))
518
519 (defun ses-create-cell-variable-range (minrow maxrow mincol maxcol)
520 "Create buffer-local variables for cells. This is undoable."
521 (push `(apply ses-destroy-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol)
522 buffer-undo-list)
523 (let (sym xrow xcol)
524 (dotimes (row (1+ (- maxrow minrow)))
525 (dotimes (col (1+ (- maxcol mincol)))
526 (setq xrow (+ row minrow)
527 xcol (+ col mincol)
528 sym (ses-create-cell-symbol xrow xcol))
529 (put sym 'ses-cell (cons xrow xcol))
530 (make-local-variable sym)))))
531
532 ;;We do not delete the ses-cell properties for the cell-variables, in case a
533 ;;formula that refers to this cell is in the kill-ring and is later pasted
534 ;;back in.
535 (defun ses-destroy-cell-variable-range (minrow maxrow mincol maxcol)
536 "Destroy buffer-local variables for cells. This is undoable."
537 (let (sym)
538 (dotimes (row (1+ (- maxrow minrow)))
539 (dotimes (col (1+ (- maxcol mincol)))
540 (setq sym (ses-create-cell-symbol (+ row minrow) (+ col mincol)))
541 (if (boundp sym)
542 (push `(apply ses-set-with-undo ,sym ,(symbol-value sym))
543 buffer-undo-list))
544 (kill-local-variable sym))))
545 (push `(apply ses-create-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol)
546 buffer-undo-list))
547
548 (defun ses-reset-header-string ()
549 "Flags the header string for update. Upon undo, the header string will be
550 updated again."
551 (push '(apply ses-reset-header-string) buffer-undo-list)
552 (setq ses--header-hscroll -1))
553
554 ;;Split this code off into a function to avoid coverage-testing difficulties
555 (defun ses-time-check (format arg)
556 "If `ses-start-time' is more than a second ago, call `message' with FORMAT
557 and (eval ARG) and reset `ses-start-time' to the current time."
558 (when (> (- (float-time) ses-start-time) 1.0)
559 (message format (eval arg))
560 (setq ses-start-time (float-time)))
561 nil)
562
563
564 ;;----------------------------------------------------------------------------
565 ;; The cells
566 ;;----------------------------------------------------------------------------
567
568 (defun ses-set-cell (row col field val)
569 "Install VAL as the contents for field FIELD (named by a quoted symbol) of
570 cell (ROW,COL). This is undoable. The cell's data will be updated through
571 `post-command-hook'."
572 (let ((cell (ses-get-cell row col))
573 (elt (plist-get '(value t symbol 0 formula 1 printer 2 references 3)
574 field))
575 change)
576 (or elt (signal 'args-out-of-range nil))
577 (setq change (if (eq elt t)
578 (ses-set-with-undo (ses-cell-symbol cell) val)
579 (ses-aset-with-undo cell elt val)))
580 (if change
581 (add-to-list 'ses--deferred-write (cons row col))))
582 nil) ;Make coverage-tester happy
583
584 (defun ses-cell-set-formula (row col formula)
585 "Store a new formula for (ROW . COL) and enqueues the cell for
586 recalculation via `post-command-hook'. Updates the reference lists for the
587 cells that this cell refers to. Does not update cell value or reprint the
588 cell. To avoid inconsistencies, this function is not interruptible, which
589 means Emacs will crash if FORMULA contains a circular list."
590 (let* ((cell (ses-get-cell row col))
591 (old (ses-cell-formula cell)))
592 (let ((sym (ses-cell-symbol cell))
593 (oldref (ses-formula-references old))
594 (newref (ses-formula-references formula))
595 (inhibit-quit t)
596 x xrow xcol)
597 (add-to-list 'ses--deferred-recalc sym)
598 ;;Delete old references from this cell. Skip the ones that are also
599 ;;in the new list.
600 (dolist (ref oldref)
601 (unless (memq ref newref)
602 (setq x (ses-sym-rowcol ref)
603 xrow (car x)
604 xcol (cdr x))
605 (ses-set-cell xrow xcol 'references
606 (delq sym (ses-cell-references xrow xcol)))))
607 ;;Add new ones. Skip ones left over from old list
608 (dolist (ref newref)
609 (setq x (ses-sym-rowcol ref)
610 xrow (car x)
611 xcol (cdr x)
612 x (ses-cell-references xrow xcol))
613 (or (memq sym x)
614 (ses-set-cell xrow xcol 'references (cons sym x))))
615 (ses-formula-record formula)
616 (ses-set-cell row col 'formula formula))))
617
618 (defun ses-calculate-cell (row col force)
619 "Calculate and print the value for cell (ROW,COL) using the cell's formula
620 function and print functions, if any. Result is nil for normal operation, or
621 the error signal if the formula or print function failed. The old value is
622 left unchanged if it was *skip* and the new value is nil.
623 Any cells that depend on this cell are queued for update after the end of
624 processing for the current keystroke, unless the new value is the same as
625 the old and FORCE is nil."
626 (let ((cell (ses-get-cell row col))
627 formula-error printer-error)
628 (let ((oldval (ses-cell-value cell))
629 (formula (ses-cell-formula cell))
630 newval)
631 (when (eq (car-safe formula) 'ses-safe-formula)
632 (setq formula (ses-safe-formula (cadr formula)))
633 (ses-set-cell row col 'formula formula))
634 (condition-case sig
635 (setq newval (eval formula))
636 (error
637 (setq formula-error sig
638 newval '*error*)))
639 (if (and (not newval) (eq oldval '*skip*))
640 ;;Don't lose the *skip* - previous field spans this one
641 (setq newval '*skip*))
642 (when (or force (not (eq newval oldval)))
643 (add-to-list 'ses--deferred-write (cons row col)) ;In case force=t
644 (ses-set-cell row col 'value newval)
645 (dolist (ref (ses-cell-references cell))
646 (add-to-list 'ses--deferred-recalc ref))))
647 (setq printer-error (ses-print-cell row col))
648 (or formula-error printer-error)))
649
650 (defun ses-clear-cell (row col)
651 "Delete formula and printer for cell (ROW,COL)."
652 (ses-set-cell row col 'printer nil)
653 (ses-cell-set-formula row col nil))
654
655 (defun ses-update-cells (list &optional force)
656 "Recalculate cells in LIST, checking for dependency loops. Prints
657 progress messages every second. Dependent cells are not recalculated
658 if the cell's value is unchanged and FORCE is nil."
659 (let ((ses--deferred-recalc list)
660 (nextlist list)
661 (pos (point))
662 curlist prevlist rowcol formula)
663 (with-temp-message " "
664 (while (and ses--deferred-recalc (not (equal nextlist prevlist)))
665 ;;In each loop, recalculate cells that refer only to other cells that
666 ;;have already been recalculated or aren't in the recalculation
667 ;;region. Repeat until all cells have been processed or until the
668 ;;set of cells being worked on stops changing.
669 (if prevlist
670 (message "Recalculating... (%d cells left)"
671 (length ses--deferred-recalc)))
672 (setq curlist ses--deferred-recalc
673 ses--deferred-recalc nil
674 prevlist nextlist)
675 (while curlist
676 (setq rowcol (ses-sym-rowcol (car curlist))
677 formula (ses-cell-formula (car rowcol) (cdr rowcol)))
678 (or (catch 'ref
679 (dolist (ref (ses-formula-references formula))
680 (when (or (memq ref curlist)
681 (memq ref ses--deferred-recalc))
682 ;;This cell refers to another that isn't done yet
683 (add-to-list 'ses--deferred-recalc (car curlist))
684 (throw 'ref t))))
685 ;;ses-update-cells is called from post-command-hook, so
686 ;;inhibit-quit is implicitly bound to t.
687 (when quit-flag
688 ;;Abort the recalculation. User will probably undo now.
689 (error "Quit"))
690 (ses-calculate-cell (car rowcol) (cdr rowcol) force))
691 (setq curlist (cdr curlist)))
692 (dolist (ref ses--deferred-recalc)
693 (add-to-list 'nextlist ref))
694 (setq nextlist (sort (copy-sequence nextlist) 'string<))
695 (if (equal nextlist prevlist)
696 ;;We'll go around the loop one more time.
697 (add-to-list 'nextlist t)))
698 (when ses--deferred-recalc
699 ;;Just couldn't finish these
700 (dolist (x ses--deferred-recalc)
701 (let ((rowcol (ses-sym-rowcol x)))
702 (ses-set-cell (car rowcol) (cdr rowcol) 'value '*error*)
703 (1value (ses-print-cell (car rowcol) (cdr rowcol)))))
704 (error "Circular references: %s" ses--deferred-recalc))
705 (message " "))
706 ;;Can't use save-excursion here: if the cell under point is
707 ;;updated, save-excusion's marker will move past the cell.
708 (goto-char pos)))
709
710
711 ;;----------------------------------------------------------------------------
712 ;; The print area
713 ;;----------------------------------------------------------------------------
714
715 (defun ses-in-print-area ()
716 "Returns t if point is in print area of spreadsheet."
717 (<= (point) ses--data-marker))
718
719 ;;We turn off point-motion-hooks and explicitly position the cursor, in case
720 ;;the intangible properties have gotten screwed up (e.g., when
721 ;;ses-goto-print is called during a recursive ses-print-cell).
722 (defun ses-goto-print (row col)
723 "Move point to print area for cell (ROW,COL)."
724 (let ((inhibit-point-motion-hooks t))
725 (goto-char (point-min))
726 (forward-line row)
727 (dotimes (c col)
728 (forward-char (1+ (ses-col-width c))))))
729
730 (defun ses-set-curcell ()
731 "Sets `ses--curcell' to the current cell symbol, or a cons (BEG,END) for a
732 region, or nil if cursor is not at a cell."
733 (if (or (not mark-active)
734 deactivate-mark
735 (= (region-beginning) (region-end)))
736 ;;Single cell
737 (setq ses--curcell (get-text-property (point) 'intangible))
738 ;;Range
739 (let ((bcell (get-text-property (region-beginning) 'intangible))
740 (ecell (get-text-property (1- (region-end)) 'intangible)))
741 (setq ses--curcell (if (and bcell ecell)
742 (cons bcell ecell)
743 nil))))
744 nil)
745
746 (defun ses-check-curcell (&rest args)
747 "Signal an error if ses--curcell is inappropriate. The end marker is
748 appropriate if some argument is 'end. A range is appropriate if some
749 argument is 'range. A single cell is appropriate unless some argument is
750 'needrange."
751 (if (eq ses--curcell t)
752 ;;curcell recalculation was postponed, but user typed ahead
753 (ses-set-curcell))
754 (cond
755 ((not ses--curcell)
756 (or (memq 'end args)
757 (error "Not at cell")))
758 ((consp ses--curcell)
759 (or (memq 'range args)
760 (memq 'needrange args)
761 (error "Can't use a range")))
762 ((memq 'needrange args)
763 (error "Need a range"))))
764
765 (defun ses-print-cell (row col)
766 "Format and print the value of cell (ROW,COL) to the print area.
767 Use the cell's printer function. If the cell's new print form is too wide,
768 it will spill over into the following cell, but will not run off the end of the
769 row or overwrite the next non-nil field. Result is nil for normal operation,
770 or the error signal if the printer function failed and the cell was formatted
771 with \"%s\". If the cell's value is *skip*, nothing is printed because the
772 preceding cell has spilled over."
773 (catch 'ses-print-cell
774 (let* ((cell (ses-get-cell row col))
775 (value (ses-cell-value cell))
776 (printer (ses-cell-printer cell))
777 (maxcol (1+ col))
778 text sig startpos x)
779 ;;Create the string to print
780 (cond
781 ((eq value '*skip*)
782 ;;Don't print anything
783 (throw 'ses-print-cell nil))
784 ((eq value '*error*)
785 (setq text (make-string (ses-col-width col) ?#)))
786 (t
787 ;;Deferred safety-check on printer
788 (if (eq (car-safe printer) 'ses-safe-printer)
789 (ses-set-cell row col 'printer
790 (setq printer (ses-safe-printer (cadr printer)))))
791 ;;Print the value
792 (setq text (ses-call-printer (or printer
793 (ses-col-printer col)
794 ses--default-printer)
795 value))
796 (if (consp ses-call-printer-return)
797 ;;Printer returned an error
798 (setq sig ses-call-printer-return))))
799 ;;Adjust print width to match column width
800 (let ((width (ses-col-width col))
801 (len (length text)))
802 (cond
803 ((< len width)
804 ;;Fill field to length with spaces
805 (setq len (make-string (- width len) ?\s)
806 text (if (eq ses-call-printer-return t)
807 (concat text len)
808 (concat len text))))
809 ((> len width)
810 ;;Spill over into following cells, if possible
811 (let ((maxwidth width))
812 (while (and (> len maxwidth)
813 (< maxcol ses--numcols)
814 (or (not (setq x (ses-cell-value row maxcol)))
815 (eq x '*skip*)))
816 (unless x
817 ;;Set this cell to '*skip* so it won't overwrite our spillover
818 (ses-set-cell row maxcol 'value '*skip*))
819 (setq maxwidth (+ maxwidth (ses-col-width maxcol) 1)
820 maxcol (1+ maxcol)))
821 (if (<= len maxwidth)
822 ;;Fill to complete width of all the fields spanned
823 (setq text (concat text (make-string (- maxwidth len) ?\s)))
824 ;;Not enough room to end of line or next non-nil field. Truncate
825 ;;if string or decimal; otherwise fill with error indicator
826 (setq sig `(error "Too wide" ,text))
827 (cond
828 ((stringp value)
829 (setq text (substring text 0 maxwidth)))
830 ((and (numberp value)
831 (string-match "\\.[0-9]+" text)
832 (>= 0 (setq width
833 (- len maxwidth
834 (- (match-end 0) (match-beginning 0))))))
835 ;; Turn 6.6666666666e+49 into 6.66e+49. Rounding is too hard!
836 (setq text (concat (substring text
837 0
838 (- (match-beginning 0) width))
839 (substring text (match-end 0)))))
840 (t
841 (setq text (make-string maxwidth ?#)))))))))
842 ;;Substitute question marks for tabs and newlines. Newlines are
843 ;;used as row-separators; tabs could confuse the reimport logic.
844 (setq text (replace-regexp-in-string "[\t\n]" "?" text))
845 (ses-goto-print row col)
846 (setq startpos (point))
847 ;;Install the printed result. This is not interruptible.
848 (let ((inhibit-read-only t)
849 (inhibit-quit t))
850 (delete-char (1+ (length text)))
851 ;;We use concat instead of inserting separate strings in order to
852 ;;reduce the number of cells in the undo list.
853 (setq x (concat text (if (< maxcol ses--numcols) " " "\n")))
854 ;;We use set-text-properties to prevent a wacky print function
855 ;;from inserting rogue properties, and to ensure that the keymap
856 ;;property is inherited (is it a bug that only unpropertied strings
857 ;;actually inherit from surrounding text?)
858 (set-text-properties 0 (length x) nil x)
859 (insert-and-inherit x)
860 (put-text-property startpos (point) 'intangible
861 (ses-cell-symbol cell))
862 (when (and (zerop row) (zerop col))
863 ;;Reconstruct special beginning-of-buffer attributes
864 (put-text-property (point-min) (point) 'keymap 'ses-mode-print-map)
865 (put-text-property (point-min) (point) 'read-only 'ses)
866 (put-text-property (point-min) (1+ (point-min)) 'front-sticky t)))
867 (if (= row (1- ses--header-row))
868 ;;This line is part of the header - force recalc
869 (ses-reset-header-string))
870 ;;If this cell (or a preceding one on the line) previously spilled over
871 ;;and has gotten shorter, redraw following cells on line recursively.
872 (when (and (< maxcol ses--numcols)
873 (eq (ses-cell-value row maxcol) '*skip*))
874 (ses-set-cell row maxcol 'value nil)
875 (ses-print-cell row maxcol))
876 ;;Return to start of cell
877 (goto-char startpos)
878 sig)))
879
880 (defun ses-call-printer (printer &optional value)
881 "Invokes PRINTER (a string or parenthesized string or function-symbol or
882 lambda of one argument) on VALUE. Result is the printed cell as a string.
883 The variable `ses-call-printer-return' is set to t if the printer used
884 parenthesis to request left-justification, or the error-signal if the
885 printer signaled one (and \"%s\" is used as the default printer), else nil."
886 (setq ses-call-printer-return nil)
887 (unless value
888 (setq value ""))
889 (condition-case signal
890 (cond
891 ((stringp printer)
892 (format printer value))
893 ((stringp (car-safe printer))
894 (setq ses-call-printer-return t)
895 (format (car printer) value))
896 (t
897 (setq value (funcall printer value))
898 (if (stringp value)
899 value
900 (or (stringp (car-safe value))
901 (error "Printer should return \"string\" or (\"string\")"))
902 (setq ses-call-printer-return t)
903 (car value))))
904 (error
905 (setq ses-call-printer-return signal)
906 (prin1-to-string value t))))
907
908 (defun ses-adjust-print-width (col change)
909 "Insert CHANGE spaces in front of column COL, or at end of line if
910 COL=NUMCOLS. Deletes characters if CHANGE < 0. Caller should bind
911 inhibit-quit to t."
912 (let ((inhibit-read-only t)
913 (blank (if (> change 0) (make-string change ?\s)))
914 (at-end (= col ses--numcols)))
915 (ses-set-with-undo 'ses--linewidth (+ ses--linewidth change))
916 ;;ses-set-with-undo always returns t for strings.
917 (1value (ses-set-with-undo 'ses--blank-line
918 (concat (make-string ses--linewidth ?\s) "\n")))
919 (dotimes (row ses--numrows)
920 (ses-goto-print row col)
921 (when at-end
922 ;;Insert new columns before newline
923 (let ((inhibit-point-motion-hooks t))
924 (backward-char 1)))
925 (if blank
926 (insert blank)
927 (delete-char (- change))))))
928
929 (defun ses-print-cell-new-width (row col)
930 "Same as ses-print-cell, except if the cell's value is *skip*, the preceding
931 nonskipped cell is reprinted. This function is used when the width of
932 cell (ROW,COL) has changed."
933 (if (not (eq (ses-cell-value row col) '*skip*))
934 (ses-print-cell row col)
935 ;;Cell was skipped over - reprint previous
936 (ses-goto-print row col)
937 (backward-char 1)
938 (let ((rowcol (ses-sym-rowcol (get-text-property (point) 'intangible))))
939 (ses-print-cell (car rowcol) (cdr rowcol)))))
940
941
942 ;;----------------------------------------------------------------------------
943 ;; The data area
944 ;;----------------------------------------------------------------------------
945
946 (defun ses-narrowed-p () (/= (- (point-max) (point-min)) (buffer-size)))
947
948 (defun ses-widen ()
949 "Turn off narrowing, to be reenabled at end of command loop."
950 (if (ses-narrowed-p)
951 (setq ses--deferred-narrow t))
952 (widen))
953
954 (defun ses-goto-data (def &optional col)
955 "Move point to data area for (DEF,COL). If DEF is a row
956 number, COL is the column number for a data cell -- otherwise DEF
957 is one of the symbols ses--col-widths, ses--col-printers,
958 ses--default-printer, ses--numrows, or ses--numcols."
959 (ses-widen)
960 (let ((inhibit-point-motion-hooks t)) ;In case intangible attrs are wrong
961 (if col
962 ;;It's a cell
963 (progn
964 (goto-char ses--data-marker)
965 (forward-line (+ 1 (* def (1+ ses--numcols)) col)))
966 ;;Convert def-symbol to offset
967 (setq def (plist-get ses-paramlines-plist def))
968 (or def (signal 'args-out-of-range nil))
969 (goto-char ses--params-marker)
970 (forward-line def))))
971
972 (defun ses-set-parameter (def value &optional elem)
973 "Set parameter DEF to VALUE (with undo) and write the value to the data area.
974 See `ses-goto-data' for meaning of DEF. Newlines in the data are escaped.
975 If ELEM is specified, it is the array subscript within DEF to be set to VALUE."
976 (save-excursion
977 ;;We call ses-goto-data early, using the old values of numrows and
978 ;;numcols in case one of them is being changed.
979 (ses-goto-data def)
980 (let ((inhibit-read-only t)
981 (fmt (plist-get '(ses--col-widths "(ses-column-widths %S)"
982 ses--col-printers "(ses-column-printers %S)"
983 ses--default-printer "(ses-default-printer %S)"
984 ses--header-row "(ses-header-row %S)"
985 ses--file-format " %S ;SES file-format"
986 ses--numrows " %S ;numrows"
987 ses--numcols " %S ;numcols")
988 def))
989 oldval)
990 (if elem
991 (progn
992 (setq oldval (aref (symbol-value def) elem))
993 (aset (symbol-value def) elem value))
994 (setq oldval (symbol-value def))
995 (set def value))
996 ;;Special undo since it's outside the narrowed buffer
997 (let (buffer-undo-list)
998 (delete-region (point) (line-end-position))
999 (insert (format fmt (symbol-value def))))
1000 (push `(apply ses-set-parameter ,def ,oldval ,elem) buffer-undo-list))))
1001
1002
1003 (defun ses-write-cells ()
1004 "Write cells in `ses--deferred-write' from local variables to data area.
1005 Newlines in the data are escaped."
1006 (let* ((inhibit-read-only t)
1007 (print-escape-newlines t)
1008 rowcol row col cell sym formula printer text)
1009 (setq ses-start-time (float-time))
1010 (with-temp-message " "
1011 (save-excursion
1012 (while ses--deferred-write
1013 (ses-time-check "Writing... (%d cells left)"
1014 '(length ses--deferred-write))
1015 (setq rowcol (pop ses--deferred-write)
1016 row (car rowcol)
1017 col (cdr rowcol)
1018 cell (ses-get-cell row col)
1019 sym (ses-cell-symbol cell)
1020 formula (ses-cell-formula cell)
1021 printer (ses-cell-printer cell))
1022 (if (eq (car-safe formula) 'ses-safe-formula)
1023 (setq formula (cadr formula)))
1024 (if (eq (car-safe printer) 'ses-safe-printer)
1025 (setq printer (cadr printer)))
1026 ;;This is noticably faster than (format "%S %S %S %S %S")
1027 (setq text (concat "(ses-cell "
1028 (symbol-name sym)
1029 " "
1030 (prin1-to-string (symbol-value sym))
1031 " "
1032 (prin1-to-string formula)
1033 " "
1034 (prin1-to-string printer)
1035 " "
1036 (if (atom (ses-cell-references cell))
1037 "nil"
1038 (concat "("
1039 (mapconcat 'symbol-name
1040 (ses-cell-references cell)
1041 " ")
1042 ")"))
1043 ")"))
1044 (ses-goto-data row col)
1045 (delete-region (point) (line-end-position))
1046 (insert text)))
1047 (message " "))))
1048
1049
1050 ;;----------------------------------------------------------------------------
1051 ;; Formula relocation
1052 ;;----------------------------------------------------------------------------
1053
1054 (defun ses-formula-references (formula &optional result-so-far)
1055 "Produce a list of symbols for cells that this formula's value
1056 refers to. For recursive calls, RESULT-SO-FAR is the list being constructed,
1057 or t to get a wrong-type-argument error when the first reference is found."
1058 (if (atom formula)
1059 (if (ses-sym-rowcol formula)
1060 ;;Entire formula is one symbol
1061 (add-to-list 'result-so-far formula)
1062 ) ;;Ignore other atoms
1063 (dolist (cur formula)
1064 (cond
1065 ((ses-sym-rowcol cur)
1066 ;;Save this reference
1067 (add-to-list 'result-so-far cur))
1068 ((eq (car-safe cur) 'ses-range)
1069 ;;All symbols in range are referenced
1070 (dolist (x (cdr (macroexpand cur)))
1071 (add-to-list 'result-so-far x)))
1072 ((and (consp cur) (not (eq (car cur) 'quote)))
1073 ;;Recursive call for subformulas
1074 (setq result-so-far (ses-formula-references cur result-so-far)))
1075 (t
1076 ;;Ignore other stuff
1077 ))))
1078 result-so-far)
1079
1080 (defsubst ses-relocate-symbol (sym rowcol startrow startcol rowincr colincr)
1081 "Relocate one symbol SYM, whichs corresponds to ROWCOL (a cons of ROW and
1082 COL). Cells starting at (STARTROW,STARTCOL) are being shifted
1083 by (ROWINCR,COLINCR)."
1084 (let ((row (car rowcol))
1085 (col (cdr rowcol)))
1086 (if (or (< row startrow) (< col startcol))
1087 sym
1088 (setq row (+ row rowincr)
1089 col (+ col colincr))
1090 (if (and (>= row startrow) (>= col startcol)
1091 (< row ses--numrows) (< col ses--numcols))
1092 ;;Relocate this variable
1093 (ses-create-cell-symbol row col)
1094 ;;Delete reference to a deleted cell
1095 nil))))
1096
1097 (defun ses-relocate-formula (formula startrow startcol rowincr colincr)
1098 "Produce a copy of FORMULA where all symbols that refer to cells in row
1099 STARTROW or above and col STARTCOL or above are altered by adding ROWINCR
1100 and COLINCR. STARTROW and STARTCOL are 0-based. Example:
1101 (ses-relocate-formula '(+ A1 B2 D3) 1 2 1 -1)
1102 => (+ A1 B2 C4)
1103 If ROWINCR or COLINCR is negative, references to cells being deleted are
1104 removed. Example:
1105 (ses-relocate-formula '(+ A1 B2 D3) 0 1 0 -1)
1106 => (+ A1 C3)
1107 Sets `ses-relocate-return' to 'delete if cell-references were removed."
1108 (let (rowcol result)
1109 (if (or (atom formula) (eq (car formula) 'quote))
1110 (if (setq rowcol (ses-sym-rowcol formula))
1111 (ses-relocate-symbol formula rowcol
1112 startrow startcol rowincr colincr)
1113 formula) ;Pass through as-is
1114 (dolist (cur formula)
1115 (setq rowcol (ses-sym-rowcol cur))
1116 (cond
1117 (rowcol
1118 (setq cur (ses-relocate-symbol cur rowcol
1119 startrow startcol rowincr colincr))
1120 (if cur
1121 (push cur result)
1122 ;;Reference to a deleted cell. Set a flag in ses-relocate-return.
1123 ;;don't change the flag if it's already 'range, since range
1124 ;;implies 'delete.
1125 (unless ses-relocate-return
1126 (setq ses-relocate-return 'delete))))
1127 ((eq (car-safe cur) 'ses-range)
1128 (setq cur (ses-relocate-range cur startrow startcol rowincr colincr))
1129 (if cur
1130 (push cur result)))
1131 ((or (atom cur) (eq (car cur) 'quote))
1132 ;;Constants pass through unchanged
1133 (push cur result))
1134 (t
1135 ;;Recursively copy and alter subformulas
1136 (push (ses-relocate-formula cur startrow startcol
1137 rowincr colincr)
1138 result))))
1139 (nreverse result))))
1140
1141 (defun ses-relocate-range (range startrow startcol rowincr colincr)
1142 "Relocate one RANGE, of the form '(ses-range min max). Cells starting
1143 at (STARTROW,STARTCOL) are being shifted by (ROWINCR,COLINCR). Result is the
1144 new range, or nil if the entire range is deleted. If new rows are being added
1145 just beyond the end of a row range, or new columns just beyond a column range,
1146 the new rows/columns will be added to the range. Sets `ses-relocate-return'
1147 if the range was altered."
1148 (let* ((minorig (cadr range))
1149 (minrowcol (ses-sym-rowcol minorig))
1150 (min (ses-relocate-symbol minorig minrowcol
1151 startrow startcol
1152 rowincr colincr))
1153 (maxorig (nth 2 range))
1154 (maxrowcol (ses-sym-rowcol maxorig))
1155 (max (ses-relocate-symbol maxorig maxrowcol
1156 startrow startcol
1157 rowincr colincr))
1158 field)
1159 (cond
1160 ((and (not min) (not max))
1161 (setq range nil)) ;;The entire range is deleted
1162 ((zerop colincr)
1163 ;;Inserting or deleting rows
1164 (setq field 'car)
1165 (if (not min)
1166 ;;Chopped off beginning of range
1167 (setq min (ses-create-cell-symbol startrow (cdr minrowcol))
1168 ses-relocate-return 'range))
1169 (if (not max)
1170 (if (> rowincr 0)
1171 ;;Trying to insert a nonexistent row
1172 (setq max (ses-create-cell-symbol (1- ses--numrows)
1173 (cdr minrowcol)))
1174 ;;End of range is being deleted
1175 (setq max (ses-create-cell-symbol (1- startrow) (cdr minrowcol))
1176 ses-relocate-return 'range))
1177 (and (> rowincr 0)
1178 (= (car maxrowcol) (1- startrow))
1179 (= (cdr minrowcol) (cdr maxrowcol))
1180 ;;Insert after ending row of vertical range - include it
1181 (setq max (ses-create-cell-symbol (+ startrow rowincr -1)
1182 (cdr maxrowcol))))))
1183 (t
1184 ;;Inserting or deleting columns
1185 (setq field 'cdr)
1186 (if (not min)
1187 ;;Chopped off beginning of range
1188 (setq min (ses-create-cell-symbol (car minrowcol) startcol)
1189 ses-relocate-return 'range))
1190 (if (not max)
1191 (if (> colincr 0)
1192 ;;Trying to insert a nonexistent column
1193 (setq max (ses-create-cell-symbol (car maxrowcol)
1194 (1- ses--numcols)))
1195 ;;End of range is being deleted
1196 (setq max (ses-create-cell-symbol (car maxrowcol) (1- startcol))
1197 ses-relocate-return 'range))
1198 (and (> colincr 0)
1199 (= (cdr maxrowcol) (1- startcol))
1200 (= (car minrowcol) (car maxrowcol))
1201 ;;Insert after ending column of horizontal range - include it
1202 (setq max (ses-create-cell-symbol (car maxrowcol)
1203 (+ startcol colincr -1)))))))
1204 (when range
1205 (if (/= (- (funcall field maxrowcol)
1206 (funcall field minrowcol))
1207 (- (funcall field (ses-sym-rowcol max))
1208 (funcall field (ses-sym-rowcol min))))
1209 ;;This range has changed size
1210 (setq ses-relocate-return 'range))
1211 (list 'ses-range min max))))
1212
1213 (defun ses-relocate-all (minrow mincol rowincr colincr)
1214 "Alter all cell values, symbols, formulas, and reference-lists to relocate
1215 the rectangle (MINROW,MINCOL)..(NUMROWS,NUMCOLS) by adding ROWINCR and COLINCR
1216 to each symbol."
1217 (let (reform)
1218 (let (mycell newval)
1219 (dotimes-with-progress-reporter
1220 (row ses--numrows) "Relocating formulas..."
1221 (dotimes (col ses--numcols)
1222 (setq ses-relocate-return nil
1223 mycell (ses-get-cell row col)
1224 newval (ses-relocate-formula (ses-cell-formula mycell)
1225 minrow mincol rowincr colincr))
1226 (ses-set-cell row col 'formula newval)
1227 (if (eq ses-relocate-return 'range)
1228 ;;This cell contains a (ses-range X Y) where a cell has been
1229 ;;inserted or deleted in the middle of the range.
1230 (push (cons row col) reform))
1231 (if ses-relocate-return
1232 ;;This cell referred to a cell that's been deleted or is no
1233 ;;longer part of the range. We can't fix that now because
1234 ;;reference lists cells have been partially updated.
1235 (add-to-list 'ses--deferred-recalc
1236 (ses-create-cell-symbol row col)))
1237 (setq newval (ses-relocate-formula (ses-cell-references mycell)
1238 minrow mincol rowincr colincr))
1239 (ses-set-cell row col 'references newval)
1240 (and (>= row minrow) (>= col mincol)
1241 (ses-set-cell row col 'symbol
1242 (ses-create-cell-symbol row col))))))
1243 ;;Relocate the cell values
1244 (let (oldval myrow mycol xrow xcol)
1245 (cond
1246 ((and (<= rowincr 0) (<= colincr 0))
1247 ;;Deletion of rows and/or columns
1248 (dotimes-with-progress-reporter
1249 (row (- ses--numrows minrow)) "Relocating variables..."
1250 (setq myrow (+ row minrow))
1251 (dotimes (col (- ses--numcols mincol))
1252 (setq mycol (+ col mincol)
1253 xrow (- myrow rowincr)
1254 xcol (- mycol colincr))
1255 (if (and (< xrow ses--numrows) (< xcol ses--numcols))
1256 (setq oldval (ses-cell-value xrow xcol))
1257 ;;Cell is off the end of the array
1258 (setq oldval (symbol-value (ses-create-cell-symbol xrow xcol))))
1259 (ses-set-cell myrow mycol 'value oldval))))
1260 ((and (wholenump rowincr) (wholenump colincr))
1261 ;;Insertion of rows and/or columns. Run the loop backwards.
1262 (let ((disty (1- ses--numrows))
1263 (distx (1- ses--numcols))
1264 myrow mycol)
1265 (dotimes-with-progress-reporter
1266 (row (- ses--numrows minrow)) "Relocating variables..."
1267 (setq myrow (- disty row))
1268 (dotimes (col (- ses--numcols mincol))
1269 (setq mycol (- distx col)
1270 xrow (- myrow rowincr)
1271 xcol (- mycol colincr))
1272 (if (or (< xrow minrow) (< xcol mincol))
1273 ;;Newly-inserted value
1274 (setq oldval nil)
1275 ;;Transfer old value
1276 (setq oldval (ses-cell-value xrow xcol)))
1277 (ses-set-cell myrow mycol 'value oldval)))
1278 t)) ;Make testcover happy by returning non-nil here
1279 (t
1280 (error "ROWINCR and COLINCR must have the same sign"))))
1281 ;;Reconstruct reference lists for cells that contain ses-ranges that
1282 ;;have changed size.
1283 (when reform
1284 (message "Fixing ses-ranges...")
1285 (let (row col)
1286 (setq ses-start-time (float-time))
1287 (while reform
1288 (ses-time-check "Fixing ses-ranges... (%d left)" '(length reform))
1289 (setq row (caar reform)
1290 col (cdar reform)
1291 reform (cdr reform))
1292 (ses-cell-set-formula row col (ses-cell-formula row col))))
1293 (message nil))))
1294
1295
1296 ;;----------------------------------------------------------------------------
1297 ;; Undo control
1298 ;;----------------------------------------------------------------------------
1299
1300 (defun ses-begin-change ()
1301 "For undo, remember point before we start changing hidden stuff."
1302 (let ((inhibit-read-only t))
1303 (insert-and-inherit "X")
1304 (delete-region (1- (point)) (point))))
1305
1306 (defun ses-set-with-undo (sym newval)
1307 "Like set, but undoable. Result is t if value has changed."
1308 ;;We try to avoid adding redundant entries to the undo list, but this is
1309 ;;unavoidable for strings because equal ignores text properties and there's
1310 ;;no easy way to get the whole property list to see if it's different!
1311 (unless (and (boundp sym)
1312 (equal (symbol-value sym) newval)
1313 (not (stringp newval)))
1314 (push (if (boundp sym)
1315 `(apply ses-set-with-undo ,sym ,(symbol-value sym))
1316 `(apply ses-unset-with-undo ,sym))
1317 buffer-undo-list)
1318 (set sym newval)
1319 t))
1320
1321 (defun ses-unset-with-undo (sym)
1322 "Set SYM to be unbound. This is undoable."
1323 (when (1value (boundp sym)) ;;Always bound, except after a programming error
1324 (push `(apply ses-set-with-undo ,sym ,(symbol-value sym)) buffer-undo-list)
1325 (makunbound sym)))
1326
1327 (defun ses-aset-with-undo (array idx newval)
1328 "Like aset, but undoable. Result is t if element has changed"
1329 (unless (equal (aref array idx) newval)
1330 (push `(apply ses-aset-with-undo ,array ,idx ,(aref array idx)) buffer-undo-list)
1331 (aset array idx newval)
1332 t))
1333
1334
1335 ;;----------------------------------------------------------------------------
1336 ;; Startup for major mode
1337 ;;----------------------------------------------------------------------------
1338
1339 (defun ses-load ()
1340 "Parse the current buffer and sets up buffer-local variables. Does not
1341 execute cell formulas or print functions."
1342 (widen)
1343 ;;Read our global parameters, which should be a 3-element list
1344 (goto-char (point-max))
1345 (search-backward ";; Local Variables:\n" nil t)
1346 (backward-list 1)
1347 (setq ses--params-marker (point-marker))
1348 (let ((params (condition-case nil (read (current-buffer)) (error nil))))
1349 (or (and (= (safe-length params) 3)
1350 (numberp (car params))
1351 (numberp (cadr params))
1352 (>= (cadr params) 0)
1353 (numberp (nth 2 params))
1354 (> (nth 2 params) 0))
1355 (error "Invalid SES file"))
1356 (setq ses--file-format (car params)
1357 ses--numrows (cadr params)
1358 ses--numcols (nth 2 params))
1359 (when (= ses--file-format 1)
1360 (let (buffer-undo-list) ;This is not undoable
1361 (ses-goto-data 'ses--header-row)
1362 (insert "(ses-header-row 0)\n")
1363 (ses-set-parameter 'ses--file-format 2)
1364 (message "Upgrading from SES-1 file format")))
1365 (or (= ses--file-format 2)
1366 (error "This file needs a newer version of the SES library code"))
1367 (ses-create-cell-variable-range 0 (1- ses--numrows) 0 (1- ses--numcols))
1368 ;;Initialize cell array
1369 (setq ses--cells (make-vector ses--numrows nil))
1370 (dotimes (row ses--numrows)
1371 (aset ses--cells row (make-vector ses--numcols nil))))
1372 ;;Skip over print area, which we assume is correct
1373 (goto-char (point-min))
1374 (forward-line ses--numrows)
1375 (or (looking-at ses-print-data-boundary)
1376 (error "Missing marker between print and data areas"))
1377 (forward-char 1)
1378 (setq ses--data-marker (point-marker))
1379 (forward-char (1- (length ses-print-data-boundary)))
1380 ;;Initialize printer and symbol lists
1381 (mapc 'ses-printer-record ses-standard-printer-functions)
1382 (setq ses--symbolic-formulas nil)
1383 ;;Load cell definitions
1384 (dotimes (row ses--numrows)
1385 (dotimes (col ses--numcols)
1386 (let* ((x (read (current-buffer)))
1387 (rowcol (ses-sym-rowcol (car-safe (cdr-safe x)))))
1388 (or (and (looking-at "\n")
1389 (eq (car-safe x) 'ses-cell)
1390 (eq row (car rowcol))
1391 (eq col (cdr rowcol)))
1392 (error "Cell-def error"))
1393 (eval x)))
1394 (or (looking-at "\n\n")
1395 (error "Missing blank line between rows")))
1396 ;;Load global parameters
1397 (let ((widths (read (current-buffer)))
1398 (n1 (char-after (point)))
1399 (printers (read (current-buffer)))
1400 (n2 (char-after (point)))
1401 (def-printer (read (current-buffer)))
1402 (n3 (char-after (point)))
1403 (head-row (read (current-buffer)))
1404 (n4 (char-after (point))))
1405 (or (and (eq (car-safe widths) 'ses-column-widths)
1406 (= n1 ?\n)
1407 (eq (car-safe printers) 'ses-column-printers)
1408 (= n2 ?\n)
1409 (eq (car-safe def-printer) 'ses-default-printer)
1410 (= n3 ?\n)
1411 (eq (car-safe head-row) 'ses-header-row)
1412 (= n4 ?\n))
1413 (error "Invalid SES global parameters"))
1414 (1value (eval widths))
1415 (1value (eval def-printer))
1416 (1value (eval printers))
1417 (1value (eval head-row)))
1418 ;;Should be back at global-params
1419 (forward-char 1)
1420 (or (looking-at (replace-regexp-in-string "1" "[0-9]+"
1421 ses-initial-global-parameters))
1422 (error "Problem with column-defs or global-params"))
1423 ;;Check for overall newline count in definitions area
1424 (forward-line 3)
1425 (let ((start (point)))
1426 (ses-goto-data 'ses--numrows)
1427 (or (= (point) start)
1428 (error "Extraneous newlines someplace?"))))
1429
1430 (defun ses-setup ()
1431 "Set up for display of only the printed cell values.
1432
1433 Narrows the buffer to show only the print area. Gives it `read-only' and
1434 `intangible' properties. Sets up highlighting for current cell."
1435 (interactive)
1436 (let ((end (point-min))
1437 (inhibit-read-only t)
1438 (was-modified (buffer-modified-p))
1439 pos sym)
1440 (ses-goto-data 0 0) ;;Include marker between print-area and data-area
1441 (set-text-properties (point) (point-max) nil) ;Delete garbage props
1442 (mapc 'delete-overlay (overlays-in (point-min) (point-max)))
1443 ;;The print area is read-only (except for our special commands) and uses a
1444 ;;special keymap.
1445 (put-text-property (point-min) (1- (point)) 'read-only 'ses)
1446 (put-text-property (point-min) (1- (point)) 'keymap 'ses-mode-print-map)
1447 ;;For the beginning of the buffer, we want the read-only and keymap
1448 ;;attributes to be inherited from the first character
1449 (put-text-property (point-min) (1+ (point-min)) 'front-sticky t)
1450 ;;Create intangible properties, which also indicate which cell the text
1451 ;;came from.
1452 (dotimes-with-progress-reporter (row ses--numrows) "Finding cells..."
1453 (dotimes (col ses--numcols)
1454 (setq pos end
1455 sym (ses-cell-symbol row col))
1456 ;;Include skipped cells following this one
1457 (while (and (< col (1- ses--numcols))
1458 (eq (ses-cell-value row (1+ col)) '*skip*))
1459 (setq end (+ end (ses-col-width col) 1)
1460 col (1+ col)))
1461 (setq end (+ end (ses-col-width col) 1))
1462 (put-text-property pos end 'intangible sym)))
1463 ;;Adding these properties did not actually alter the text
1464 (unless was-modified
1465 (restore-buffer-modified-p nil)
1466 (buffer-disable-undo)
1467 (buffer-enable-undo)))
1468 ;;Create the underlining overlay. It's impossible for (point) to be 2,
1469 ;;because column A must be at least 1 column wide.
1470 (setq ses--curcell-overlay (make-overlay (1+ (point-min)) (1+ (point-min))))
1471 (overlay-put ses--curcell-overlay 'face 'underline))
1472
1473 (defun ses-cleanup ()
1474 "Cleanup when changing a buffer from SES mode to something else.
1475 Delete overlays, remove special text properties."
1476 (widen)
1477 (let ((inhibit-read-only t)
1478 ;; When reverting, hide the buffer name, otherwise Emacs will ask
1479 ;; the user "the file is modified, do you really want to make
1480 ;; modifications to this buffer", where the "modifications" refer to
1481 ;; the irrelevant set-text-properties below.
1482 (buffer-file-name nil)
1483 (was-modified (buffer-modified-p)))
1484 ;;Delete read-only, keymap, and intangible properties
1485 (set-text-properties (point-min) (point-max) nil)
1486 ;;Delete overlay
1487 (mapc 'delete-overlay (overlays-in (point-min) (point-max)))
1488 (unless was-modified
1489 (restore-buffer-modified-p nil))))
1490
1491 ;;;###autoload
1492 (defun ses-mode ()
1493 "Major mode for Simple Emacs Spreadsheet.
1494 See \"ses-example.ses\" (in `data-directory') for more info.
1495
1496 Key definitions:
1497 \\{ses-mode-map}
1498 These key definitions are active only in the print area (the visible part):
1499 \\{ses-mode-print-map}
1500 These are active only in the minibuffer, when entering or editing a formula:
1501 \\{ses-mode-edit-map}"
1502 (interactive)
1503 (unless (and (boundp 'ses--deferred-narrow)
1504 (eq ses--deferred-narrow 'ses-mode))
1505 (kill-all-local-variables)
1506 (mapc 'make-local-variable ses-localvars)
1507 (setq major-mode 'ses-mode
1508 mode-name "SES"
1509 next-line-add-newlines nil
1510 truncate-lines t
1511 ;;SES deliberately puts lots of trailing whitespace in its buffer
1512 show-trailing-whitespace nil
1513 ;;Cell ranges do not work reasonably without this
1514 transient-mark-mode t)
1515 (1value (add-hook 'change-major-mode-hook 'ses-cleanup nil t))
1516 (1value (add-hook 'before-revert-hook 'ses-cleanup nil t))
1517 (setq ses--curcell nil
1518 ses--deferred-recalc nil
1519 ses--deferred-write nil
1520 ses--header-hscroll -1 ;Flag for "initial recalc needed"
1521 header-line-format '(:eval (progn
1522 (when (/= (window-hscroll)
1523 ses--header-hscroll)
1524 ;;Reset ses--header-hscroll first, to
1525 ;;avoid recursion problems when
1526 ;;debugging ses-create-header-string
1527 (setq ses--header-hscroll
1528 (window-hscroll))
1529 (ses-create-header-string))
1530 ses--header-string)))
1531 (let ((was-empty (zerop (buffer-size)))
1532 (was-modified (buffer-modified-p)))
1533 (save-excursion
1534 (if was-empty
1535 ;;Initialize buffer to contain one cell, for now
1536 (insert ses-initial-file-contents))
1537 (ses-load)
1538 (ses-setup))
1539 (when was-empty
1540 (unless (equal ses-initial-default-printer (1value ses--default-printer))
1541 (1value (ses-read-default-printer ses-initial-default-printer)))
1542 (unless (= ses-initial-column-width (1value (ses-col-width 0)))
1543 (1value (ses-set-column-width 0 ses-initial-column-width)))
1544 (ses-set-curcell)
1545 (if (> (car ses-initial-size) (1value ses--numrows))
1546 (1value (ses-insert-row (1- (car ses-initial-size)))))
1547 (if (> (cdr ses-initial-size) (1value ses--numcols))
1548 (1value (ses-insert-column (1- (cdr ses-initial-size)))))
1549 (ses-write-cells)
1550 (restore-buffer-modified-p was-modified)
1551 (buffer-disable-undo)
1552 (buffer-enable-undo)
1553 (goto-char (point-min))))
1554 (use-local-map ses-mode-map)
1555 ;;Set the deferred narrowing flag (we can't narrow until after
1556 ;;after-find-file completes). If .ses is on the auto-load alist and the
1557 ;;file has "mode: ses", our ses-mode function will be called twice! Use
1558 ;;a special flag to detect this (will be reset by ses-command-hook).
1559 ;;For find-alternate-file, post-command-hook doesn't get run for some
1560 ;;reason, so use an idle timer to make sure.
1561 (setq ses--deferred-narrow 'ses-mode)
1562 (1value (add-hook 'post-command-hook 'ses-command-hook nil t))
1563 (run-with-idle-timer 0.01 nil 'ses-command-hook)
1564 (run-mode-hooks 'ses-mode-hook)))
1565
1566 (put 'ses-mode 'mode-class 'special)
1567
1568 (defun ses-command-hook ()
1569 "Invoked from `post-command-hook'. If point has moved to a different cell,
1570 moves the underlining overlay. Performs any recalculations or cell-data
1571 writes that have been deferred. If buffer-narrowing has been deferred,
1572 narrows the buffer now."
1573 (condition-case err
1574 (when (eq major-mode 'ses-mode) ;Otherwise, not our buffer anymore
1575 (when ses--deferred-recalc
1576 ;;We reset the deferred list before starting on the recalc -- in case
1577 ;;of error, we don't want to retry the recalc after every keystroke!
1578 (let ((old ses--deferred-recalc))
1579 (setq ses--deferred-recalc nil)
1580 (ses-update-cells old)))
1581 (when ses--deferred-write
1582 ;;We don't reset the deferred list before starting -- the most
1583 ;;likely error is keyboard-quit, and we do want to keep trying
1584 ;;these writes after a quit.
1585 (ses-write-cells)
1586 (push '(apply ses-widen) buffer-undo-list))
1587 (when ses--deferred-narrow
1588 ;;We're not allowed to narrow the buffer until after-find-file has
1589 ;;read the local variables at the end of the file. Now it's safe to
1590 ;;do the narrowing.
1591 (narrow-to-region (point-min) ses--data-marker)
1592 (setq ses--deferred-narrow nil))
1593 ;;Update the modeline
1594 (let ((oldcell ses--curcell))
1595 (ses-set-curcell)
1596 (unless (eq ses--curcell oldcell)
1597 (cond
1598 ((not ses--curcell)
1599 (setq mode-line-process nil))
1600 ((atom ses--curcell)
1601 (setq mode-line-process (list " cell "
1602 (symbol-name ses--curcell))))
1603 (t
1604 (setq mode-line-process (list " range "
1605 (symbol-name (car ses--curcell))
1606 "-"
1607 (symbol-name (cdr ses--curcell))))))
1608 (force-mode-line-update)))
1609 ;;Use underline overlay for single-cells only, turn off otherwise
1610 (if (listp ses--curcell)
1611 (move-overlay ses--curcell-overlay 2 2)
1612 (let ((next (next-single-property-change (point) 'intangible)))
1613 (move-overlay ses--curcell-overlay (point) (1- next))))
1614 (when (not (pos-visible-in-window-p))
1615 ;;Scrolling will happen later
1616 (run-with-idle-timer 0.01 nil 'ses-command-hook)
1617 (setq ses--curcell t)))
1618 ;;Prevent errors in this post-command-hook from silently erasing the hook!
1619 (error
1620 (unless executing-kbd-macro
1621 (ding))
1622 (message "%s" (error-message-string err))))
1623 nil) ;Make coverage-tester happy
1624
1625 (defun ses-create-header-string ()
1626 "Set up `ses--header-string' as the buffer's header line.
1627 Based on the current set of columns and `window-hscroll' position."
1628 (let ((totwidth (- (window-hscroll)))
1629 result width x)
1630 ;;Leave room for the left-side fringe and scrollbar
1631 (push (propertize " " 'display '((space :align-to 0))) result)
1632 (dotimes (col ses--numcols)
1633 (setq width (ses-col-width col)
1634 totwidth (+ totwidth width 1))
1635 (if (= totwidth 1)
1636 ;;Scrolled so intercolumn space is leftmost
1637 (push " " result))
1638 (when (> totwidth 1)
1639 (if (> ses--header-row 0)
1640 (save-excursion
1641 (ses-goto-print (1- ses--header-row) col)
1642 (setq x (buffer-substring-no-properties (point)
1643 (+ (point) width)))
1644 ;; Strip trailing space.
1645 (if (string-match "[ \t]+\\'" x)
1646 (setq x (substring x 0 (match-beginning 0))))
1647 ;; Cut off excess text.
1648 (if (>= (length x) totwidth)
1649 (setq x (substring x 0 (- totwidth -1)))))
1650 (setq x (ses-column-letter col)))
1651 (push (propertize x 'face ses-box-prop) result)
1652 (push (propertize "."
1653 'display `((space :align-to ,(1- totwidth)))
1654 'face ses-box-prop)
1655 result)
1656 ;;Allow the following space to be squished to make room for the 3-D box
1657 ;;Coverage test ignores properties, thinks this is always a space!
1658 (push (1value (propertize " " 'display `((space :align-to ,totwidth))))
1659 result)))
1660 (if (> ses--header-row 0)
1661 (push (propertize (format " [row %d]" ses--header-row)
1662 'display '((height (- 1))))
1663 result))
1664 (setq ses--header-string (apply 'concat (nreverse result)))))
1665
1666
1667 ;;----------------------------------------------------------------------------
1668 ;; Redisplay and recalculation
1669 ;;----------------------------------------------------------------------------
1670
1671 (defun ses-jump (sym)
1672 "Move point to cell SYM."
1673 (interactive "SJump to cell: ")
1674 (let ((rowcol (ses-sym-rowcol sym)))
1675 (or rowcol (error "Invalid cell name"))
1676 (if (eq (symbol-value sym) '*skip*)
1677 (error "Cell is covered by preceding cell"))
1678 (ses-goto-print (car rowcol) (cdr rowcol))))
1679
1680 (defun ses-jump-safe (cell)
1681 "Like `ses-jump', but no error if invalid cell."
1682 (condition-case nil
1683 (ses-jump cell)
1684 (error)))
1685
1686 (defun ses-reprint-all (&optional nonarrow)
1687 "Recreate the display area. Calls all printer functions. Narrows to
1688 print area if NONARROW is nil."
1689 (interactive "*P")
1690 (widen)
1691 (unless nonarrow
1692 (setq ses--deferred-narrow t))
1693 (let ((startcell (get-text-property (point) 'intangible))
1694 (inhibit-read-only t))
1695 (ses-begin-change)
1696 (goto-char (point-min))
1697 (search-forward ses-print-data-boundary)
1698 (backward-char (length ses-print-data-boundary))
1699 (delete-region (point-min) (point))
1700 ;;Insert all blank lines before printing anything, so ses-print-cell can
1701 ;;find the data area when inserting or deleting *skip* values for cells
1702 (dotimes (row ses--numrows)
1703 (insert-and-inherit ses--blank-line))
1704 (dotimes-with-progress-reporter (row ses--numrows) "Reprinting..."
1705 (if (eq (ses-cell-value row 0) '*skip*)
1706 ;;Column deletion left a dangling skip
1707 (ses-set-cell row 0 'value nil))
1708 (dotimes (col ses--numcols)
1709 (ses-print-cell row col))
1710 (beginning-of-line 2))
1711 (ses-jump-safe startcell)))
1712
1713 (defun ses-recalculate-cell ()
1714 "Recalculate and reprint the current cell or range.
1715
1716 For an individual cell, shows the error if the formula or printer
1717 signals one, or otherwise shows the cell's complete value. For a range, the
1718 cells are recalculated in \"natural\" order, so cells that other cells refer
1719 to are recalculated first."
1720 (interactive "*")
1721 (ses-check-curcell 'range)
1722 (ses-begin-change)
1723 (let (sig)
1724 (setq ses-start-time (float-time))
1725 (if (atom ses--curcell)
1726 (setq sig (ses-sym-rowcol ses--curcell)
1727 sig (ses-calculate-cell (car sig) (cdr sig) t))
1728 ;;First, recalculate all cells that don't refer to other cells and
1729 ;;produce a list of cells with references.
1730 (ses-dorange ses--curcell
1731 (ses-time-check "Recalculating... %s" '(ses-cell-symbol row col))
1732 (condition-case nil
1733 (progn
1734 ;;The t causes an error if the cell has references.
1735 ;;If no references, the t will be the result value.
1736 (1value (ses-formula-references (ses-cell-formula row col) t))
1737 (setq sig (ses-calculate-cell row col t)))
1738 (wrong-type-argument
1739 ;;The formula contains a reference
1740 (add-to-list 'ses--deferred-recalc (ses-cell-symbol row col))))))
1741 ;;Do the update now, so we can force recalculation
1742 (let ((x ses--deferred-recalc))
1743 (setq ses--deferred-recalc nil)
1744 (condition-case hold
1745 (ses-update-cells x t)
1746 (error (setq sig hold))))
1747 (cond
1748 (sig
1749 (message "%s" (error-message-string sig)))
1750 ((consp ses--curcell)
1751 (message " "))
1752 (t
1753 (princ (symbol-value ses--curcell))))))
1754
1755 (defun ses-recalculate-all ()
1756 "Recalculate and reprint all cells."
1757 (interactive "*")
1758 (let ((startcell (get-text-property (point) 'intangible))
1759 (ses--curcell (cons 'A1 (ses-cell-symbol (1- ses--numrows)
1760 (1- ses--numcols)))))
1761 (ses-recalculate-cell)
1762 (ses-jump-safe startcell)))
1763
1764 (defun ses-truncate-cell ()
1765 "Reprint current cell, but without spillover into any following blank
1766 cells."
1767 (interactive "*")
1768 (ses-check-curcell)
1769 (let* ((rowcol (ses-sym-rowcol ses--curcell))
1770 (row (car rowcol))
1771 (col (cdr rowcol)))
1772 (when (and (< col (1- ses--numcols)) ;;Last column can't spill over, anyway
1773 (eq (ses-cell-value row (1+ col)) '*skip*))
1774 ;;This cell has spill-over. We'll momentarily pretend the following
1775 ;;cell has a `t' in it.
1776 (eval `(let ((,(ses-cell-symbol row (1+ col)) t))
1777 (ses-print-cell row col)))
1778 ;;Now remove the *skip*. ses-print-cell is always nil here
1779 (ses-set-cell row (1+ col) 'value nil)
1780 (1value (ses-print-cell row (1+ col))))))
1781
1782 (defun ses-reconstruct-all ()
1783 "Reconstruct buffer based on cell data stored in Emacs variables."
1784 (interactive "*")
1785 (ses-begin-change)
1786 ;;Reconstruct reference lists.
1787 (let (x yrow ycol)
1788 ;;Delete old reference lists
1789 (dotimes-with-progress-reporter
1790 (row ses--numrows) "Deleting references..."
1791 (dotimes (col ses--numcols)
1792 (ses-set-cell row col 'references nil)))
1793 ;;Create new reference lists
1794 (dotimes-with-progress-reporter
1795 (row ses--numrows) "Computing references..."
1796 (dotimes (col ses--numcols)
1797 (dolist (ref (ses-formula-references (ses-cell-formula row col)))
1798 (setq x (ses-sym-rowcol ref)
1799 yrow (car x)
1800 ycol (cdr x))
1801 (ses-set-cell yrow ycol 'references
1802 (cons (ses-cell-symbol row col)
1803 (ses-cell-references yrow ycol)))))))
1804 ;;Delete everything and reconstruct basic data area
1805 (ses-widen)
1806 (let ((inhibit-read-only t))
1807 (goto-char (point-max))
1808 (if (search-backward ";; Local Variables:\n" nil t)
1809 (delete-region (point-min) (point))
1810 ;;Buffer is quite screwed up - can't even save the user-specified locals
1811 (delete-region (point-min) (point-max))
1812 (insert ses-initial-file-trailer)
1813 (goto-char (point-min)))
1814 ;;Create a blank display area
1815 (dotimes (row ses--numrows)
1816 (insert ses--blank-line))
1817 (insert ses-print-data-boundary)
1818 (backward-char (1- (length ses-print-data-boundary)))
1819 (setq ses--data-marker (point-marker))
1820 (forward-char (1- (length ses-print-data-boundary)))
1821 ;;Placeholders for cell data
1822 (insert (make-string (* ses--numrows (1+ ses--numcols)) ?\n))
1823 ;;Placeholders for col-widths, col-printers, default-printer, header-row
1824 (insert "\n\n\n\n")
1825 (insert ses-initial-global-parameters)
1826 (backward-char (1- (length ses-initial-global-parameters)))
1827 (setq ses--params-marker (point-marker))
1828 (forward-char (1- (length ses-initial-global-parameters))))
1829 (ses-set-parameter 'ses--col-widths ses--col-widths)
1830 (ses-set-parameter 'ses--col-printers ses--col-printers)
1831 (ses-set-parameter 'ses--default-printer ses--default-printer)
1832 (ses-set-parameter 'ses--header-row ses--header-row)
1833 (ses-set-parameter 'ses--numrows ses--numrows)
1834 (ses-set-parameter 'ses--numcols ses--numcols)
1835 ;;Keep our old narrowing
1836 (ses-setup)
1837 (ses-recalculate-all)
1838 (goto-char (point-min)))
1839
1840
1841 ;;----------------------------------------------------------------------------
1842 ;; Input of cell formulas
1843 ;;----------------------------------------------------------------------------
1844
1845 (defun ses-edit-cell (row col newval)
1846 "Display current cell contents in minibuffer, for editing. Returns nil if
1847 cell formula was unsafe and user declined confirmation."
1848 (interactive
1849 (progn
1850 (barf-if-buffer-read-only)
1851 (ses-check-curcell)
1852 (let* ((rowcol (ses-sym-rowcol ses--curcell))
1853 (row (car rowcol))
1854 (col (cdr rowcol))
1855 (formula (ses-cell-formula row col))
1856 initial)
1857 (if (eq (car-safe formula) 'ses-safe-formula)
1858 (setq formula (cadr formula)))
1859 (if (eq (car-safe formula) 'quote)
1860 (setq initial (format "'%S" (cadr formula)))
1861 (setq initial (prin1-to-string formula)))
1862 (if (stringp formula)
1863 ;;Position cursor inside close-quote
1864 (setq initial (cons initial (length initial))))
1865 (list row col
1866 (read-from-minibuffer (format "Cell %s: " ses--curcell)
1867 initial
1868 ses-mode-edit-map
1869 t ;Convert to Lisp object
1870 'ses-read-cell-history)))))
1871 (when (ses-warn-unsafe newval 'unsafep)
1872 (ses-begin-change)
1873 (ses-cell-set-formula row col newval)
1874 t))
1875
1876 (defun ses-read-cell (row col newval)
1877 "Self-insert for initial character of cell function."
1878 (interactive
1879 (let* ((initial (this-command-keys))
1880 (rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))
1881 (curval (ses-cell-formula (car rowcol) (cdr rowcol))))
1882 (barf-if-buffer-read-only)
1883 (list (car rowcol)
1884 (cdr rowcol)
1885 (read-from-minibuffer
1886 (format "Cell %s: " ses--curcell)
1887 (cons (if (equal initial "\"") "\"\""
1888 (if (equal initial "(") "()" initial)) 2)
1889 ses-mode-edit-map
1890 t ;Convert to Lisp object
1891 'ses-read-cell-history
1892 (prin1-to-string (if (eq (car-safe curval) 'ses-safe-formula)
1893 (cadr curval)
1894 curval))))))
1895 (when (ses-edit-cell row col newval)
1896 (ses-command-hook) ;Update cell widths before movement
1897 (dolist (x ses-after-entry-functions)
1898 (funcall x 1))))
1899
1900 (defun ses-read-symbol (row col symb)
1901 "Self-insert for a symbol as a cell formula. The set of all symbols that
1902 have been used as formulas in this spreadsheet is available for completions."
1903 (interactive
1904 (let ((rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))
1905 newval)
1906 (barf-if-buffer-read-only)
1907 (setq newval (completing-read (format "Cell %s ': " ses--curcell)
1908 ses--symbolic-formulas))
1909 (list (car rowcol)
1910 (cdr rowcol)
1911 (if (string= newval "")
1912 nil ;Don't create zero-length symbols!
1913 (list 'quote (intern newval))))))
1914 (when (ses-edit-cell row col symb)
1915 (ses-command-hook) ;Update cell widths before movement
1916 (dolist (x ses-after-entry-functions)
1917 (funcall x 1))))
1918
1919 (defun ses-clear-cell-forward (count)
1920 "Delete formula and printer for current cell and then move to next cell.
1921 With prefix, deletes several cells."
1922 (interactive "*p")
1923 (if (< count 0)
1924 (1value (ses-clear-cell-backward (- count)))
1925 (ses-check-curcell)
1926 (ses-begin-change)
1927 (dotimes (x count)
1928 (ses-set-curcell)
1929 (let ((rowcol (ses-sym-rowcol ses--curcell)))
1930 (or rowcol (signal 'end-of-buffer nil))
1931 (ses-clear-cell (car rowcol) (cdr rowcol)))
1932 (forward-char 1))))
1933
1934 (defun ses-clear-cell-backward (count)
1935 "Move to previous cell and then delete it. With prefix, deletes several
1936 cells."
1937 (interactive "*p")
1938 (if (< count 0)
1939 (1value (ses-clear-cell-forward (- count)))
1940 (ses-check-curcell 'end)
1941 (ses-begin-change)
1942 (dotimes (x count)
1943 (backward-char 1) ;Will signal 'beginning-of-buffer if appropriate
1944 (ses-set-curcell)
1945 (let ((rowcol (ses-sym-rowcol ses--curcell)))
1946 (ses-clear-cell (car rowcol) (cdr rowcol))))))
1947
1948
1949 ;;----------------------------------------------------------------------------
1950 ;; Input of cell-printer functions
1951 ;;----------------------------------------------------------------------------
1952
1953 (defun ses-read-printer (prompt default)
1954 "Common code for `ses-read-cell-printer', `ses-read-column-printer', and `ses-read-default-printer'.
1955 PROMPT should end with \": \". Result is t if operation was cancelled."
1956 (barf-if-buffer-read-only)
1957 (if (eq default t)
1958 (setq default "")
1959 (setq prompt (format "%s [currently %S]: "
1960 (substring prompt 0 -2)
1961 default)))
1962 (let ((new (read-from-minibuffer prompt
1963 nil ;Initial contents
1964 ses-mode-edit-map
1965 t ;Evaluate the result
1966 'ses-read-printer-history
1967 (prin1-to-string default))))
1968 (if (equal new default)
1969 ;;User changed mind, decided not to change printer
1970 (setq new t)
1971 (ses-printer-validate new)
1972 (or (not new)
1973 (stringp new)
1974 (stringp (car-safe new))
1975 (ses-warn-unsafe new 'unsafep-function)
1976 (setq new t)))
1977 new))
1978
1979 (defun ses-read-cell-printer (newval)
1980 "Set the printer function for the current cell or range.
1981
1982 A printer function is either a string (a format control-string with one
1983 %-sequence -- result from format will be right-justified), or a list of one
1984 string (result from format will be left-justified), or a lambda-expression of
1985 one argument, or a symbol that names a function of one argument. In the
1986 latter two cases, the function's result should be either a string (will be
1987 right-justified) or a list of one string (will be left-justified)."
1988 (interactive
1989 (let ((default t)
1990 x)
1991 (ses-check-curcell 'range)
1992 ;;Default is none if not all cells in range have same printer
1993 (catch 'ses-read-cell-printer
1994 (ses-dorange ses--curcell
1995 (setq x (ses-cell-printer row col))
1996 (if (eq (car-safe x) 'ses-safe-printer)
1997 (setq x (cadr x)))
1998 (if (eq default t)
1999 (setq default x)
2000 (unless (equal default x)
2001 ;;Range contains differing printer functions
2002 (setq default t)
2003 (throw 'ses-read-cell-printer t)))))
2004 (list (ses-read-printer (format "Cell %S printer: " ses--curcell)
2005 default))))
2006 (unless (eq newval t)
2007 (ses-begin-change)
2008 (ses-dorange ses--curcell
2009 (ses-set-cell row col 'printer newval)
2010 (ses-print-cell row col))))
2011
2012 (defun ses-read-column-printer (col newval)
2013 "Set the printer function for the current column. See
2014 `ses-read-cell-printer' for input forms."
2015 (interactive
2016 (let ((col (cdr (ses-sym-rowcol ses--curcell))))
2017 (ses-check-curcell)
2018 (list col (ses-read-printer (format "Column %s printer: "
2019 (ses-column-letter col))
2020 (ses-col-printer col)))))
2021
2022 (unless (eq newval t)
2023 (ses-begin-change)
2024 (ses-set-parameter 'ses--col-printers newval col)
2025 (save-excursion
2026 (dotimes (row ses--numrows)
2027 (ses-print-cell row col)))))
2028
2029 (defun ses-read-default-printer (newval)
2030 "Set the default printer function for cells that have no other. See
2031 `ses-read-cell-printer' for input forms."
2032 (interactive
2033 (list (ses-read-printer "Default printer: " ses--default-printer)))
2034 (unless (eq newval t)
2035 (ses-begin-change)
2036 (ses-set-parameter 'ses--default-printer newval)
2037 (ses-reprint-all t)))
2038
2039
2040 ;;----------------------------------------------------------------------------
2041 ;; Spreadsheet size adjustments
2042 ;;----------------------------------------------------------------------------
2043
2044 (defun ses-insert-row (count)
2045 "Insert a new row before the current one. With prefix, insert COUNT rows
2046 before current one."
2047 (interactive "*p")
2048 (ses-check-curcell 'end)
2049 (or (> count 0) (signal 'args-out-of-range nil))
2050 (ses-begin-change)
2051 (let ((inhibit-quit t)
2052 (inhibit-read-only t)
2053 (row (or (car (ses-sym-rowcol ses--curcell)) ses--numrows))
2054 newrow)
2055 ;;Create a new set of cell-variables
2056 (ses-create-cell-variable-range ses--numrows (+ ses--numrows count -1)
2057 0 (1- ses--numcols))
2058 (ses-set-parameter 'ses--numrows (+ ses--numrows count))
2059 ;;Insert each row
2060 (ses-goto-print row 0)
2061 (dotimes-with-progress-reporter (x count) "Inserting row..."
2062 ;;Create a row of empty cells. The `symbol' fields will be set by
2063 ;;the call to ses-relocate-all.
2064 (setq newrow (make-vector ses--numcols nil))
2065 (dotimes (col ses--numcols)
2066 (aset newrow col (ses-make-cell)))
2067 (setq ses--cells (ses-vector-insert ses--cells row newrow))
2068 (push `(apply ses-vector-delete ses--cells ,row 1) buffer-undo-list)
2069 (insert ses--blank-line))
2070 ;;Insert empty lines in cell data area (will be replaced by
2071 ;;ses-relocate-all)
2072 (ses-goto-data row 0)
2073 (insert (make-string (* (1+ ses--numcols) count) ?\n))
2074 (ses-relocate-all row 0 count 0)
2075 ;;If any cell printers insert constant text, insert that text
2076 ;;into the line.
2077 (let ((cols (mapconcat #'ses-call-printer ses--col-printers nil))
2078 (global (ses-call-printer ses--default-printer)))
2079 (if (or (> (length cols) 0) (> (length global) 0))
2080 (dotimes (x count)
2081 (dotimes (col ses--numcols)
2082 ;;These cells are always nil, only constant formatting printed
2083 (1value (ses-print-cell (+ x row) col))))))
2084 (when (> ses--header-row row)
2085 ;;Inserting before header
2086 (ses-set-parameter 'ses--header-row (+ ses--header-row count))
2087 (ses-reset-header-string)))
2088 ;;Reconstruct text attributes
2089 (ses-setup)
2090 ;;Prepare for undo
2091 (push '(apply ses-widen) buffer-undo-list)
2092 ;;Return to current cell
2093 (if ses--curcell
2094 (ses-jump-safe ses--curcell)
2095 (ses-goto-print (1- ses--numrows) 0)))
2096
2097 (defun ses-delete-row (count)
2098 "Delete the current row. With prefix, Deletes COUNT rows starting from the
2099 current one."
2100 (interactive "*p")
2101 (ses-check-curcell)
2102 (or (> count 0) (signal 'args-out-of-range nil))
2103 (let ((inhibit-quit t)
2104 (inhibit-read-only t)
2105 (row (car (ses-sym-rowcol ses--curcell))))
2106 (setq count (min count (- ses--numrows row)))
2107 (ses-begin-change)
2108 (ses-set-parameter 'ses--numrows (- ses--numrows count))
2109 ;;Delete lines from print area
2110 (ses-goto-print row 0)
2111 (ses-delete-line count)
2112 ;;Delete lines from cell data area
2113 (ses-goto-data row 0)
2114 (ses-delete-line (* count (1+ ses--numcols)))
2115 ;;Relocate variables and formulas
2116 (ses-set-with-undo 'ses--cells (ses-vector-delete ses--cells row count))
2117 (ses-relocate-all row 0 (- count) 0)
2118 (ses-destroy-cell-variable-range ses--numrows (+ ses--numrows count -1)
2119 0 (1- ses--numcols))
2120 (when (> ses--header-row row)
2121 (if (<= ses--header-row (+ row count))
2122 ;;Deleting the header row
2123 (ses-set-parameter 'ses--header-row 0)
2124 (ses-set-parameter 'ses--header-row (- ses--header-row count)))
2125 (ses-reset-header-string)))
2126 ;;Reconstruct attributes
2127 (ses-setup)
2128 ;;Prepare for undo
2129 (push '(apply ses-widen) buffer-undo-list)
2130 (ses-jump-safe ses--curcell))
2131
2132 (defun ses-insert-column (count &optional col width printer)
2133 "Insert a new column before COL (default is the current one).
2134 With prefix, insert COUNT columns before current one.
2135 If COL is specified, the new column(s) get the specified WIDTH and PRINTER
2136 \(otherwise they're taken from the current column)."
2137 (interactive "*p")
2138 (ses-check-curcell)
2139 (or (> count 0) (signal 'args-out-of-range nil))
2140 (or col
2141 (setq col (cdr (ses-sym-rowcol ses--curcell))
2142 width (ses-col-width col)
2143 printer (ses-col-printer col)))
2144 (ses-begin-change)
2145 (let ((inhibit-quit t)
2146 (inhibit-read-only t)
2147 (widths ses--col-widths)
2148 (printers ses--col-printers)
2149 has-skip)
2150 ;;Create a new set of cell-variables
2151 (ses-create-cell-variable-range 0 (1- ses--numrows)
2152 ses--numcols (+ ses--numcols count -1))
2153 ;;Insert each column.
2154 (dotimes-with-progress-reporter (x count) "Inserting column..."
2155 ;;Create a column of empty cells. The `symbol' fields will be set by
2156 ;;the call to ses-relocate-all.
2157 (ses-adjust-print-width col (1+ width))
2158 (ses-set-parameter 'ses--numcols (1+ ses--numcols))
2159 (dotimes (row ses--numrows)
2160 (and (< (1+ col) ses--numcols) (eq (ses-cell-value row col) '*skip*)
2161 ;;Inserting in the middle of a spill-over
2162 (setq has-skip t))
2163 (ses-aset-with-undo ses--cells row
2164 (ses-vector-insert (aref ses--cells row)
2165 col (ses-make-cell)))
2166 ;;Insert empty lines in cell data area (will be replaced by
2167 ;;ses-relocate-all)
2168 (ses-goto-data row col)
2169 (insert ?\n))
2170 ;;Insert column width and printer
2171 (setq widths (ses-vector-insert widths col width)
2172 printers (ses-vector-insert printers col printer)))
2173 (ses-set-parameter 'ses--col-widths widths)
2174 (ses-set-parameter 'ses--col-printers printers)
2175 (ses-reset-header-string)
2176 (ses-relocate-all 0 col 0 count)
2177 (if has-skip
2178 (ses-reprint-all t)
2179 (when (or (> (length (ses-call-printer printer)) 0)
2180 (> (length (ses-call-printer ses--default-printer)) 0))
2181 ;;Either column printer or global printer inserts some constant text
2182 ;;Reprint the new columns to insert that text.
2183 (dotimes (x ses--numrows)
2184 (dotimes (y count)
2185 ;Always nil here - this is a blank column
2186 (1value (ses-print-cell-new-width x (+ y col))))))
2187 (ses-setup)))
2188 (ses-jump-safe ses--curcell))
2189
2190 (defun ses-delete-column (count)
2191 "Delete the current column. With prefix, Deletes COUNT columns starting
2192 from the current one."
2193 (interactive "*p")
2194 (ses-check-curcell)
2195 (or (> count 0) (signal 'args-out-of-range nil))
2196 (let ((inhibit-quit t)
2197 (inhibit-read-only t)
2198 (rowcol (ses-sym-rowcol ses--curcell))
2199 (width 0)
2200 col origrow has-skip)
2201 (setq origrow (car rowcol)
2202 col (cdr rowcol)
2203 count (min count (- ses--numcols col)))
2204 (if (= count ses--numcols)
2205 (error "Can't delete all columns!"))
2206 ;;Determine width of column(s) being deleted
2207 (dotimes (x count)
2208 (setq width (+ width (ses-col-width (+ col x)) 1)))
2209 (ses-begin-change)
2210 (ses-set-parameter 'ses--numcols (- ses--numcols count))
2211 (ses-adjust-print-width col (- width))
2212 (dotimes-with-progress-reporter (row ses--numrows) "Deleting column..."
2213 ;;Delete lines from cell data area
2214 (ses-goto-data row col)
2215 (ses-delete-line count)
2216 ;;Delete cells. Check if deletion area begins or ends with a skip.
2217 (if (or (eq (ses-cell-value row col) '*skip*)
2218 (and (< col ses--numcols)
2219 (eq (ses-cell-value row (+ col count)) '*skip*)))
2220 (setq has-skip t))
2221 (ses-aset-with-undo ses--cells row
2222 (ses-vector-delete (aref ses--cells row) col count)))
2223 ;;Update globals
2224 (ses-set-parameter 'ses--col-widths
2225 (ses-vector-delete ses--col-widths col count))
2226 (ses-set-parameter 'ses--col-printers
2227 (ses-vector-delete ses--col-printers col count))
2228 (ses-reset-header-string)
2229 ;;Relocate variables and formulas
2230 (ses-relocate-all 0 col 0 (- count))
2231 (ses-destroy-cell-variable-range 0 (1- ses--numrows)
2232 ses--numcols (+ ses--numcols count -1))
2233 (if has-skip
2234 (ses-reprint-all t)
2235 (ses-setup))
2236 (if (>= col ses--numcols)
2237 (setq col (1- col)))
2238 (ses-goto-print origrow col)))
2239
2240 (defun ses-forward-or-insert (&optional count)
2241 "Move to next cell in row, or inserts a new cell if already in last one, or
2242 inserts a new row if at bottom of print area. Repeat COUNT times."
2243 (interactive "p")
2244 (ses-check-curcell 'end)
2245 (setq deactivate-mark t) ;Doesn't combine well with ranges
2246 (dotimes (x count)
2247 (ses-set-curcell)
2248 (if (not ses--curcell)
2249 (progn ;At bottom of print area
2250 (barf-if-buffer-read-only)
2251 (ses-insert-row 1))
2252 (let ((col (cdr (ses-sym-rowcol ses--curcell))))
2253 (when (/= 32
2254 (char-before (next-single-property-change (point)
2255 'intangible)))
2256 ;;We're already in last nonskipped cell on line. Need to create a
2257 ;;new column.
2258 (barf-if-buffer-read-only)
2259 (ses-insert-column (- count x)
2260 ses--numcols
2261 (ses-col-width col)
2262 (ses-col-printer col)))))
2263 (forward-char)))
2264
2265 (defun ses-append-row-jump-first-column ()
2266 "Insert a new row after current one and jumps to its first column."
2267 (interactive "*")
2268 (ses-check-curcell)
2269 (ses-begin-change)
2270 (beginning-of-line 2)
2271 (ses-set-curcell)
2272 (ses-insert-row 1))
2273
2274 (defun ses-set-column-width (col newwidth)
2275 "Set the width of the current column."
2276 (interactive
2277 (let ((col (cdr (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))))
2278 (barf-if-buffer-read-only)
2279 (list col
2280 (if current-prefix-arg
2281 (prefix-numeric-value current-prefix-arg)
2282 (read-from-minibuffer (format "Column %s width [currently %d]: "
2283 (ses-column-letter col)
2284 (ses-col-width col))
2285 nil ;No initial contents
2286 nil ;No override keymap
2287 t ;Convert to Lisp object
2288 nil ;No history
2289 (number-to-string
2290 (ses-col-width col))))))) ;Default value
2291 (if (< newwidth 1)
2292 (error "Invalid column width"))
2293 (ses-begin-change)
2294 (ses-reset-header-string)
2295 (save-excursion
2296 (let ((inhibit-quit t))
2297 (ses-adjust-print-width col (- newwidth (ses-col-width col)))
2298 (ses-set-parameter 'ses--col-widths newwidth col))
2299 (dotimes (row ses--numrows)
2300 (ses-print-cell-new-width row col))))
2301
2302
2303 ;;----------------------------------------------------------------------------
2304 ;; Cut and paste, import and export
2305 ;;----------------------------------------------------------------------------
2306
2307 (defadvice copy-region-as-kill (around ses-copy-region-as-kill
2308 activate preactivate)
2309 "It doesn't make sense to copy read-only or intangible attributes into the
2310 kill ring. It probably doesn't make sense to copy keymap properties.
2311 We'll assume copying front-sticky properties doesn't make sense, either.
2312
2313 This advice also includes some SES-specific code because otherwise it's too
2314 hard to override how mouse-1 works."
2315 (when (> beg end)
2316 (let ((temp beg))
2317 (setq beg end
2318 end temp)))
2319 (if (not (and (eq major-mode 'ses-mode)
2320 (eq (get-text-property beg 'read-only) 'ses)
2321 (eq (get-text-property (1- end) 'read-only) 'ses)))
2322 ad-do-it ;Normal copy-region-as-kill
2323 (kill-new (ses-copy-region beg end))
2324 (if transient-mark-mode
2325 (setq deactivate-mark t))
2326 nil))
2327
2328 (defun ses-copy-region (beg end)
2329 "Treat the region as rectangular. Convert the intangible attributes to
2330 SES attributes recording the contents of the cell as of the time of copying."
2331 (let* ((inhibit-point-motion-hooks t)
2332 (x (mapconcat 'ses-copy-region-helper
2333 (extract-rectangle beg (1- end)) "\n")))
2334 (remove-text-properties 0 (length x)
2335 '(read-only t
2336 intangible t
2337 keymap t
2338 front-sticky t)
2339 x)
2340 x))
2341
2342 (defun ses-copy-region-helper (line)
2343 "Converts one line (of a rectangle being extracted from a spreadsheet) to
2344 external form by attaching to each print cell a 'ses attribute that records
2345 the corresponding data cell."
2346 (or (> (length line) 1)
2347 (error "Empty range"))
2348 (let ((inhibit-read-only t)
2349 (pos 0)
2350 mycell next sym rowcol)
2351 (while pos
2352 (setq sym (get-text-property pos 'intangible line)
2353 next (next-single-property-change pos 'intangible line)
2354 rowcol (ses-sym-rowcol sym)
2355 mycell (ses-get-cell (car rowcol) (cdr rowcol)))
2356 (put-text-property pos (or next (length line))
2357 'ses
2358 (list (ses-cell-symbol mycell)
2359 (ses-cell-formula mycell)
2360 (ses-cell-printer mycell))
2361 line)
2362 (setq pos next)))
2363 line)
2364
2365 (defun ses-kill-override (beg end)
2366 "Generic override for any commands that kill text. We clear the killed
2367 cells instead of deleting them."
2368 (interactive "r")
2369 (ses-check-curcell 'needrange)
2370 ;;For some reason, the text-read-only error is not caught by
2371 ;;`delete-region', so we have to use subterfuge.
2372 (let ((buffer-read-only t))
2373 (1value (condition-case x
2374 (noreturn (funcall (lookup-key (current-global-map)
2375 (this-command-keys))
2376 beg end))
2377 (buffer-read-only nil)))) ;The expected error
2378 ;;Because the buffer was marked read-only, the kill command turned itself
2379 ;;into a copy. Now we clear the cells or signal the error. First we
2380 ;;check whether the buffer really is read-only.
2381 (barf-if-buffer-read-only)
2382 (ses-begin-change)
2383 (ses-dorange ses--curcell
2384 (ses-clear-cell row col))
2385 (ses-jump (car ses--curcell)))
2386
2387 (defadvice yank (around ses-yank activate preactivate)
2388 "In SES mode, the yanked text is inserted as cells.
2389
2390 If the text contains 'ses attributes (meaning it went to the kill-ring from a
2391 SES buffer), the formulas and print functions are restored for the cells. If
2392 the text contains tabs, this is an insertion of tab-separated formulas.
2393 Otherwise the text is inserted as the formula for the current cell.
2394
2395 When inserting cells, the formulas are usually relocated to keep the same
2396 relative references to neighboring cells. This is best if the formulas
2397 generally refer to other cells within the yanked text. You can use the C-u
2398 prefix to specify insertion without relocation, which is best when the
2399 formulas refer to cells outsite the yanked text.
2400
2401 When inserting formulas, the text is treated as a string constant if it doesn't
2402 make sense as a sexp or would otherwise be considered a symbol. Use 'sym to
2403 explicitly insert a symbol, or use the C-u prefix to treat all unmarked words
2404 as symbols."
2405 (if (not (and (eq major-mode 'ses-mode)
2406 (eq (get-text-property (point) 'keymap) 'ses-mode-print-map)))
2407 ad-do-it ;Normal non-SES yank
2408 (ses-check-curcell 'end)
2409 (push-mark (point))
2410 (let ((text (current-kill (cond
2411 ((listp arg) 0)
2412 ((eq arg '-) -1)
2413 (t (1- arg))))))
2414 (or (ses-yank-cells text arg)
2415 (ses-yank-tsf text arg)
2416 (ses-yank-one (ses-yank-resize 1 1)
2417 text
2418 0
2419 (if (memq (aref text (1- (length text))) '(?\t ?\n))
2420 ;;Just one cell - delete final tab or newline
2421 (1- (length text)))
2422 arg)))
2423 (if (consp arg)
2424 (exchange-point-and-mark))))
2425
2426 (defun ses-yank-pop (arg)
2427 "Replace just-yanked stretch of killed text with a different stretch.
2428 This command is allowed only immediately after a `yank' or a `yank-pop', when
2429 the region contains a stretch of reinserted previously-killed text. We
2430 replace it with a different stretch of killed text.
2431 Unlike standard `yank-pop', this function uses `undo' to delete the
2432 previous insertion."
2433 (interactive "*p")
2434 (or (eq last-command 'yank)
2435 ;;Use noreturn here just to avoid a "poor-coverage" warning in its
2436 ;;macro definition.
2437 (noreturn (error "Previous command was not a yank")))
2438 (undo)
2439 (ses-set-curcell)
2440 (yank (1+ (or arg 1)))
2441 (setq this-command 'yank))
2442
2443 (defun ses-yank-cells (text arg)
2444 "If the TEXT has a proper set of 'ses attributes, inserts the text as
2445 cells, else return nil. The cells are reprinted--the supplied text is
2446 ignored because the column widths, default printer, etc. at yank time might
2447 be different from those at kill-time. ARG is a list to indicate that
2448 formulas are to be inserted without relocation."
2449 (let ((first (get-text-property 0 'ses text))
2450 (last (get-text-property (1- (length text)) 'ses text)))
2451 (when (and first last) ;;Otherwise not proper set of attributes
2452 (setq first (ses-sym-rowcol (car first))
2453 last (ses-sym-rowcol (car last)))
2454 (let* ((needrows (- (car last) (car first) -1))
2455 (needcols (- (cdr last) (cdr first) -1))
2456 (rowcol (ses-yank-resize needrows needcols))
2457 (rowincr (- (car rowcol) (car first)))
2458 (colincr (- (cdr rowcol) (cdr first)))
2459 (pos 0)
2460 myrow mycol x)
2461 (dotimes-with-progress-reporter (row needrows) "Yanking..."
2462 (setq myrow (+ row (car rowcol)))
2463 (dotimes (col needcols)
2464 (setq mycol (+ col (cdr rowcol))
2465 last (get-text-property pos 'ses text)
2466 pos (next-single-property-change pos 'ses text)
2467 x (ses-sym-rowcol (car last)))
2468 (if (not last)
2469 ;;Newline - all remaining cells on row are skipped
2470 (setq x (cons (- myrow rowincr) (+ needcols colincr -1))
2471 last (list nil nil nil)
2472 pos (1- pos)))
2473 (if (/= (car x) (- myrow rowincr))
2474 (error "Cell row error"))
2475 (if (< (- mycol colincr) (cdr x))
2476 ;;Some columns were skipped
2477 (let ((oldcol mycol))
2478 (while (< (- mycol colincr) (cdr x))
2479 (ses-clear-cell myrow mycol)
2480 (setq col (1+ col)
2481 mycol (1+ mycol)))
2482 (ses-print-cell myrow (1- oldcol)))) ;;This inserts *skip*
2483 (when (car last) ;Skip this for *skip* cells
2484 (setq x (nth 2 last))
2485 (unless (equal x (ses-cell-printer myrow mycol))
2486 (or (not x)
2487 (stringp x)
2488 (eq (car-safe x) 'ses-safe-printer)
2489 (setq x `(ses-safe-printer ,x)))
2490 (ses-set-cell myrow mycol 'printer x))
2491 (setq x (cadr last))
2492 (if (atom arg)
2493 (setq x (ses-relocate-formula x 0 0 rowincr colincr)))
2494 (or (atom x)
2495 (eq (car-safe x) 'ses-safe-formula)
2496 (setq x `(ses-safe-formula ,x)))
2497 (ses-cell-set-formula myrow mycol x)))
2498 (when pos
2499 (if (get-text-property pos 'ses text)
2500 (error "Missing newline between rows"))
2501 (setq pos (next-single-property-change pos 'ses text))))
2502 t))))
2503
2504 (defun ses-yank-one (rowcol text from to arg)
2505 "Insert the substring [FROM,TO] of TEXT as the formula for cell ROWCOL (a
2506 cons of ROW and COL). Treat plain symbols as strings unless ARG is a list."
2507 (let ((val (condition-case nil
2508 (read-from-string text from to)
2509 (error (cons nil from)))))
2510 (cond
2511 ((< (cdr val) (or to (length text)))
2512 ;;Invalid sexp - leave it as a string
2513 (setq val (substring text from to)))
2514 ((and (car val) (symbolp (car val)))
2515 (if (consp arg)
2516 (setq val (list 'quote (car val))) ;Keep symbol
2517 (setq val (substring text from to)))) ;Treat symbol as text
2518 (t
2519 (setq val (car val))))
2520 (let ((row (car rowcol))
2521 (col (cdr rowcol)))
2522 (or (atom val)
2523 (setq val `(ses-safe-formula ,val)))
2524 (ses-cell-set-formula row col val))))
2525
2526 (defun ses-yank-tsf (text arg)
2527 "If TEXT contains tabs and/or newlines, treats the tabs as
2528 column-separators and the newlines as row-separators and inserts the text as
2529 cell formulas--else return nil. Treat plain symbols as strings unless ARG
2530 is a list. Ignore a final newline."
2531 (if (or (not (string-match "[\t\n]" text))
2532 (= (match-end 0) (length text)))
2533 ;;Not TSF format
2534 nil
2535 (if (/= (aref text (1- (length text))) ?\n)
2536 (setq text (concat text "\n")))
2537 (let ((pos -1)
2538 (spots (list -1))
2539 (cols 0)
2540 (needrows 0)
2541 needcols rowcol)
2542 ;;Find all the tabs and newlines
2543 (while (setq pos (string-match "[\t\n]" text (1+ pos)))
2544 (push pos spots)
2545 (setq cols (1+ cols))
2546 (when (eq (aref text pos) ?\n)
2547 (if (not needcols)
2548 (setq needcols cols)
2549 (or (= needcols cols)
2550 (error "Inconsistent row lengths")))
2551 (setq cols 0
2552 needrows (1+ needrows))))
2553 ;;Insert the formulas
2554 (setq rowcol (ses-yank-resize needrows needcols))
2555 (dotimes (row needrows)
2556 (dotimes (col needcols)
2557 (ses-yank-one (cons (+ (car rowcol) needrows (- row) -1)
2558 (+ (cdr rowcol) needcols (- col) -1))
2559 text (1+ (cadr spots)) (car spots) arg)
2560 (setq spots (cdr spots))))
2561 (ses-goto-print (+ (car rowcol) needrows -1)
2562 (+ (cdr rowcol) needcols -1))
2563 t)))
2564
2565 (defun ses-yank-resize (needrows needcols)
2566 "If this yank will require inserting rows and/or columns, asks for
2567 confirmation and then inserts them. Result is (row,col) for top left of yank
2568 spot, or error signal if user requests cancel."
2569 (ses-begin-change)
2570 (let ((rowcol (if ses--curcell
2571 (ses-sym-rowcol ses--curcell)
2572 (cons ses--numrows 0)))
2573 rowbool colbool)
2574 (setq needrows (- (+ (car rowcol) needrows) ses--numrows)
2575 needcols (- (+ (cdr rowcol) needcols) ses--numcols)
2576 rowbool (> needrows 0)
2577 colbool (> needcols 0))
2578 (when (or rowbool colbool)
2579 ;;Need to insert. Get confirm
2580 (or (y-or-n-p (format "Yank will insert %s%s%s. Continue? "
2581 (if rowbool (format "%d rows" needrows) "")
2582 (if (and rowbool colbool) " and " "")
2583 (if colbool (format "%d columns" needcols) "")))
2584 (error "Cancelled"))
2585 (when rowbool
2586 (let (ses--curcell)
2587 (save-excursion
2588 (ses-goto-print ses--numrows 0)
2589 (ses-insert-row needrows))))
2590 (when colbool
2591 (ses-insert-column needcols
2592 ses--numcols
2593 (ses-col-width (1- ses--numcols))
2594 (ses-col-printer (1- ses--numcols)))))
2595 rowcol))
2596
2597 (defun ses-export-tsv (beg end)
2598 "Export values from the current range, with tabs between columns and
2599 newlines between rows. Result is placed in kill ring."
2600 (interactive "r")
2601 (ses-export-tab nil))
2602
2603 (defun ses-export-tsf (beg end)
2604 "Export formulas from the current range, with tabs between columns and
2605 newlines between rows. Result is placed in kill ring."
2606 (interactive "r")
2607 (ses-export-tab t))
2608
2609 (defun ses-export-tab (want-formulas)
2610 "Export the current range with tabs between columns and newlines between
2611 rows. Result is placed in kill ring. The export is values unless
2612 WANT-FORMULAS is non-nil. Newlines and tabs in the export text are escaped."
2613 (ses-check-curcell 'needrange)
2614 (let ((print-escape-newlines t)
2615 result item)
2616 (ses-dorange ses--curcell
2617 (setq item (if want-formulas
2618 (ses-cell-formula row col)
2619 (ses-cell-value row col)))
2620 (if (eq (car-safe item) 'ses-safe-formula)
2621 ;;Hide our deferred safety-check marker
2622 (setq item (cadr item)))
2623 (if (or (not item) (eq item '*skip*))
2624 (setq item ""))
2625 (when (eq (car-safe item) 'quote)
2626 (push "'" result)
2627 (setq item (cadr item)))
2628 (setq item (prin1-to-string item t))
2629 (setq item (replace-regexp-in-string "\t" "\\\\t" item))
2630 (push item result)
2631 (cond
2632 ((< col maxcol)
2633 (push "\t" result))
2634 ((< row maxrow)
2635 (push "\n" result))))
2636 (setq result (apply 'concat (nreverse result)))
2637 (kill-new result)))
2638
2639
2640 ;;----------------------------------------------------------------------------
2641 ;; Other user commands
2642 ;;----------------------------------------------------------------------------
2643
2644 (defun ses-unset-header-row ()
2645 "Select the default header row."
2646 (interactive)
2647 (ses-set-header-row 0))
2648
2649 (defun ses-set-header-row (row)
2650 "Set the ROW to display in the header-line.
2651 With a numerical prefix arg, use that row.
2652 With no prefix arg, use the current row.
2653 With a \\[universal-argument] prefix arg, prompt the user.
2654 The top row is row 1. Selecting row 0 displays the default header row."
2655 (interactive
2656 (list (if (numberp current-prefix-arg) current-prefix-arg
2657 (let ((currow (1+ (car (ses-sym-rowcol ses--curcell)))))
2658 (if current-prefix-arg
2659 (read-number "Header row: " currow)
2660 currow)))))
2661 (if (or (< row 0) (> row ses--numrows))
2662 (error "Invalid header-row"))
2663 (ses-begin-change)
2664 (let ((oldval ses--header-row))
2665 (let (buffer-undo-list)
2666 (ses-set-parameter 'ses--header-row row))
2667 (push `(apply ses-set-header-row ,oldval) buffer-undo-list))
2668 (ses-reset-header-string))
2669
2670 (defun ses-mark-row ()
2671 "Marks the entirety of current row as a range."
2672 (interactive)
2673 (ses-check-curcell 'range)
2674 (let ((row (car (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell)))))
2675 (push-mark (point))
2676 (ses-goto-print (1+ row) 0)
2677 (push-mark (point) nil t)
2678 (ses-goto-print row 0)))
2679
2680 (defun ses-mark-column ()
2681 "Marks the entirety of current column as a range."
2682 (interactive)
2683 (ses-check-curcell 'range)
2684 (let ((col (cdr (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell))))
2685 (row 0))
2686 (push-mark (point))
2687 (ses-goto-print (1- ses--numrows) col)
2688 (forward-char 1)
2689 (push-mark (point) nil t)
2690 (while (eq '*skip* (ses-cell-value row col))
2691 ;;Skip over initial cells in column that can't be selected
2692 (setq row (1+ row)))
2693 (ses-goto-print row col)))
2694
2695 (defun ses-end-of-line ()
2696 "Move point to last cell on line."
2697 (interactive)
2698 (ses-check-curcell 'end 'range)
2699 (when ses--curcell ;Otherwise we're at the bottom row, which is empty anyway
2700 (let ((col (1- ses--numcols))
2701 row rowcol)
2702 (if (symbolp ses--curcell)
2703 ;;Single cell
2704 (setq row (car (ses-sym-rowcol ses--curcell)))
2705 ;;Range - use whichever end of the range the point is at
2706 (setq rowcol (ses-sym-rowcol (if (< (point) (mark))
2707 (car ses--curcell)
2708 (cdr ses--curcell))))
2709 ;;If range already includes the last cell in a row, point is actually
2710 ;;in the following row
2711 (if (<= (cdr rowcol) (1- col))
2712 (setq row (car rowcol))
2713 (setq row (1+ (car rowcol)))
2714 (if (= row ses--numrows)
2715 ;;Already at end - can't go anywhere
2716 (setq col 0))))
2717 (when (< row ses--numrows) ;Otherwise it's a range that includes last cell
2718 (while (eq (ses-cell-value row col) '*skip*)
2719 ;;Back to beginning of multi-column cell
2720 (setq col (1- col)))
2721 (ses-goto-print row col)))))
2722
2723 (defun ses-renarrow-buffer ()
2724 "Narrow the buffer so only the print area is visible. Use after \\[widen]."
2725 (interactive)
2726 (setq ses--deferred-narrow t))
2727
2728 (defun ses-sort-column (sorter &optional reverse)
2729 "Sorts the range by a specified column. With prefix, sorts in
2730 REVERSE order."
2731 (interactive "*sSort column: \nP")
2732 (ses-check-curcell 'needrange)
2733 (let ((min (ses-sym-rowcol (car ses--curcell)))
2734 (max (ses-sym-rowcol (cdr ses--curcell))))
2735 (let ((minrow (car min))
2736 (mincol (cdr min))
2737 (maxrow (car max))
2738 (maxcol (cdr max))
2739 keys extracts end)
2740 (setq sorter (cdr (ses-sym-rowcol (intern (concat sorter "1")))))
2741 (or (and sorter (>= sorter mincol) (<= sorter maxcol))
2742 (error "Invalid sort column"))
2743 ;;Get key columns and sort them
2744 (dotimes (x (- maxrow minrow -1))
2745 (ses-goto-print (+ minrow x) sorter)
2746 (setq end (next-single-property-change (point) 'intangible))
2747 (push (cons (buffer-substring-no-properties (point) end)
2748 (+ minrow x))
2749 keys))
2750 (setq keys (sort keys #'(lambda (x y) (string< (car x) (car y)))))
2751 ;;Extract the lines in reverse sorted order
2752 (or reverse
2753 (setq keys (nreverse keys)))
2754 (dolist (x keys)
2755 (ses-goto-print (cdr x) (1+ maxcol))
2756 (setq end (point))
2757 (ses-goto-print (cdr x) mincol)
2758 (push (ses-copy-region (point) end) extracts))
2759 (deactivate-mark)
2760 ;;Paste the lines sequentially
2761 (dotimes (x (- maxrow minrow -1))
2762 (ses-goto-print (+ minrow x) mincol)
2763 (ses-set-curcell)
2764 (ses-yank-cells (pop extracts) nil)))))
2765
2766 (defun ses-sort-column-click (event reverse)
2767 "Mouse version of `ses-sort-column'."
2768 (interactive "*e\nP")
2769 (setq event (event-end event))
2770 (select-window (posn-window event))
2771 (setq event (car (posn-col-row event))) ;Click column
2772 (let ((col 0))
2773 (while (and (< col ses--numcols) (> event (ses-col-width col)))
2774 (setq event (- event (ses-col-width col) 1)
2775 col (1+ col)))
2776 (if (>= col ses--numcols)
2777 (ding)
2778 (ses-sort-column (ses-column-letter col) reverse))))
2779
2780 (defun ses-insert-range ()
2781 "Inserts into minibuffer the list of cells currently highlighted in the
2782 spreadsheet."
2783 (interactive "*")
2784 (let (x)
2785 (with-current-buffer (window-buffer minibuffer-scroll-window)
2786 (ses-command-hook) ;For ses-coverage
2787 (ses-check-curcell 'needrange)
2788 (setq x (cdr (macroexpand `(ses-range ,(car ses--curcell)
2789 ,(cdr ses--curcell))))))
2790 (insert (substring (prin1-to-string (nreverse x)) 1 -1))))
2791
2792 (defun ses-insert-ses-range ()
2793 "Inserts \"(ses-range x y)\" in the minibuffer to represent the currently
2794 highlighted range in the spreadsheet."
2795 (interactive "*")
2796 (let (x)
2797 (with-current-buffer (window-buffer minibuffer-scroll-window)
2798 (ses-command-hook) ;For ses-coverage
2799 (ses-check-curcell 'needrange)
2800 (setq x (format "(ses-range %S %S)"
2801 (car ses--curcell)
2802 (cdr ses--curcell))))
2803 (insert x)))
2804
2805 (defun ses-insert-range-click (event)
2806 "Mouse version of `ses-insert-range'."
2807 (interactive "*e")
2808 (mouse-set-point event)
2809 (ses-insert-range))
2810
2811 (defun ses-insert-ses-range-click (event)
2812 "Mouse version of `ses-insert-ses-range'."
2813 (interactive "*e")
2814 (mouse-set-point event)
2815 (ses-insert-ses-range))
2816
2817
2818 ;;----------------------------------------------------------------------------
2819 ;; Checking formulas for safety
2820 ;;----------------------------------------------------------------------------
2821
2822 (defun ses-safe-printer (printer)
2823 "Returns PRINTER if safe, or the substitute printer `ses-unsafe' otherwise."
2824 (if (or (stringp printer)
2825 (stringp (car-safe printer))
2826 (not printer)
2827 (ses-warn-unsafe printer 'unsafep-function))
2828 printer
2829 'ses-unsafe))
2830
2831 (defun ses-safe-formula (formula)
2832 "Returns FORMULA if safe, or the substitute formula *unsafe* otherwise."
2833 (if (ses-warn-unsafe formula 'unsafep)
2834 formula
2835 `(ses-unsafe ',formula)))
2836
2837 (defun ses-warn-unsafe (formula checker)
2838 "Applies CHECKER to FORMULA. If result is non-nil, asks user for
2839 confirmation about FORMULA, which might be unsafe. Returns t if formula
2840 is safe or user allows execution anyway. Always returns t if
2841 `safe-functions' is t."
2842 (if (eq safe-functions t)
2843 t
2844 (setq checker (funcall checker formula))
2845 (if (not checker)
2846 t
2847 (y-or-n-p (format "Formula %S\nmight be unsafe %S. Process it? "
2848 formula checker)))))
2849
2850
2851 ;;----------------------------------------------------------------------------
2852 ;; Standard formulas
2853 ;;----------------------------------------------------------------------------
2854
2855 (defmacro ses-range (from to)
2856 "Expands to a list of cell-symbols for the range. The range automatically
2857 expands to include any new row or column inserted into its middle. The SES
2858 library code specifically looks for the symbol `ses-range', so don't create an
2859 alias for this macro!"
2860 (let (result)
2861 (ses-dorange (cons from to)
2862 (push (ses-cell-symbol row col) result))
2863 (cons 'list result)))
2864
2865 (defun ses-delete-blanks (&rest args)
2866 "Return ARGS reversed, with the blank elements (nil and *skip*) removed."
2867 (let (result)
2868 (dolist (cur args)
2869 (unless (memq cur '(nil *skip*))
2870 (push cur result)))
2871 result))
2872
2873 (defun ses+ (&rest args)
2874 "Compute the sum of the arguments, ignoring blanks."
2875 (apply '+ (apply 'ses-delete-blanks args)))
2876
2877 (defun ses-average (list)
2878 "Computes the sum of the numbers in LIST, divided by their length. Blanks
2879 are ignored. Result is always floating-point, even if all args are integers."
2880 (setq list (apply 'ses-delete-blanks list))
2881 (/ (float (apply '+ list)) (length list)))
2882
2883 (defmacro ses-select (fromrange test torange)
2884 "Select cells in FROMRANGE that are `equal' to TEST. For each match, return
2885 the corresponding cell from TORANGE. The ranges are macroexpanded but not
2886 evaluated so they should be either (ses-range BEG END) or (list ...). The
2887 TEST is evaluated."
2888 (setq fromrange (cdr (macroexpand fromrange))
2889 torange (cdr (macroexpand torange))
2890 test (eval test))
2891 (or (= (length fromrange) (length torange))
2892 (error "ses-select: Ranges not same length"))
2893 (let (result)
2894 (dolist (x fromrange)
2895 (if (equal test (symbol-value x))
2896 (push (car torange) result))
2897 (setq torange (cdr torange)))
2898 (cons 'list result)))
2899
2900 ;;All standard formulas are safe
2901 (dolist (x '(ses-cell-value ses-range ses-delete-blanks ses+ ses-average
2902 ses-select))
2903 (put x 'side-effect-free t))
2904
2905
2906 ;;----------------------------------------------------------------------------
2907 ;; Standard print functions
2908 ;;----------------------------------------------------------------------------
2909
2910 ;;These functions use the variables 'row' and 'col' that are
2911 ;;dynamically bound by ses-print-cell. We define these variables at
2912 ;;compile-time to make the compiler happy.
2913 (eval-when-compile
2914 (dolist (x '(row col))
2915 (make-local-variable x)
2916 (set x nil)))
2917
2918 (defun ses-center (value &optional span fill)
2919 "Print VALUE, centered within column. FILL is the fill character for
2920 centering (default = space). SPAN indicates how many additional rightward
2921 columns to include in width (default = 0)."
2922 (let ((printer (or (ses-col-printer col) ses--default-printer))
2923 (width (ses-col-width col))
2924 half)
2925 (or fill (setq fill ?\s))
2926 (or span (setq span 0))
2927 (setq value (ses-call-printer printer value))
2928 (dotimes (x span)
2929 (setq width (+ width 1 (ses-col-width (+ col span (- x))))))
2930 (setq width (- width (length value)))
2931 (if (<= width 0)
2932 value ;Too large for field, anyway
2933 (setq half (make-string (/ width 2) fill))
2934 (concat half value half
2935 (if (> (% width 2) 0) (char-to-string fill))))))
2936
2937 (defun ses-center-span (value &optional fill)
2938 "Print VALUE, centered within the span that starts in the current column
2939 and continues until the next nonblank column. FILL specifies the fill
2940 character (default = space)."
2941 (let ((end (1+ col)))
2942 (while (and (< end ses--numcols)
2943 (memq (ses-cell-value row end) '(nil *skip*)))
2944 (setq end (1+ end)))
2945 (ses-center value (- end col 1) fill)))
2946
2947 (defun ses-dashfill (value &optional span)
2948 "Print VALUE centered using dashes. SPAN indicates how many rightward
2949 columns to include in width (default = 0)."
2950 (ses-center value span ?-))
2951
2952 (defun ses-dashfill-span (value)
2953 "Print VALUE, centered using dashes within the span that starts in the
2954 current column and continues until the next nonblank column."
2955 (ses-center-span value ?-))
2956
2957 (defun ses-tildefill-span (value)
2958 "Print VALUE, centered using tildes within the span that starts in the
2959 current column and continues until the next nonblank column."
2960 (ses-center-span value ?~))
2961
2962 (defun ses-unsafe (value)
2963 "Substitute for an unsafe formula or printer"
2964 (error "Unsafe formula or printer"))
2965
2966 ;;All standard printers are safe, including ses-unsafe!
2967 (dolist (x (cons 'ses-unsafe ses-standard-printer-functions))
2968 (put x 'side-effect-free t))
2969
2970 (defun ses-unload-function ()
2971 "Unload the Simple Emacs Spreadsheet."
2972 (dolist (fun '(copy-region-as-kill yank))
2973 (ad-remove-advice fun 'around (intern (concat "ses-" (symbol-name fun))))
2974 (ad-update fun))
2975 (save-current-buffer
2976 (dolist (buf (buffer-list))
2977 (set-buffer buf)
2978 (when (eq major-mode 'ses-mode)
2979 (funcall (or default-major-mode 'fundamental-mode)))))
2980 ;; continue standard unloading
2981 nil)
2982
2983 (provide 'ses)
2984
2985 ;; arch-tag: 88c1ccf0-4293-4824-8c5d-0757b52217f3
2986 ;;; ses.el ends here