1;;; ses.el --- Simple Emacs Spreadsheet -*- lexical-binding:t -*- 2 3;; Copyright (C) 2002-2021 Free Software Foundation, Inc. 4 5;; Author: Jonathan Yavner <jyavner@member.fsf.org> 6;; Maintainer: Vincent Belaïche <vincentb1@users.sourceforge.net> 7;; Keywords: spreadsheet Dijkstra 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 of the License, or 14;; (at your option) 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. If not, see <https://www.gnu.org/licenses/>. 23 24;;; Commentary: 25 26;;; To-do list: 27 28;; * M-w should deactivate the mark. 29;; * offer some way to use absolute cell addressing. 30;; * Maybe some way to copy a reference to a cell's formula rather than the 31;; formula itself. 32;; * split (catch 'cycle ...) call back into one or more functions 33;; * Use $ or … for truncated fields 34;; * M-t to transpose 2 columns. 35;; * M-d should kill the cell under point. 36;; * C-t to transpose 2 rows. 37;; * C-k and M-k should be ses-kill-row and ses-kill-column. 38;; * C-o should insert the row below point rather than above? 39;; * rows inserted with C-o should inherit formulas from surrounding rows. 40;; * Add command to make a range of columns be temporarily invisible. 41;; * Allow paste of one cell to a range of cells -- copy formula to each. 42;; * Do something about control characters & octal codes in cell print 43;; areas. Use string-width? 44;; * Input validation functions. How specified? 45;; * Faces (colors & styles) in print cells. 46;; * Move a column by dragging its letter in the header line. 47;; * Left-margin column for row number. 48;; * Move a row by dragging its number in the left-margin. 49 50;;; Cycle detection 51 52;; Cycles used to be detected by stationarity of ses--deferred-recalc. This was 53;; working fine in most cases, however failed in some cases of several path 54;; racing together. 55;; 56;; The current algorithm is based on Dijkstra's algorithm. The cycle length is 57;; stored in some cell property. In order not to reset in all cells such 58;; property at each update, the cycle length is stored in this property along 59;; with some update attempt id that is incremented at each update. The current 60;; update id is ses--Dijkstra-attempt-nb. In case there is a cycle the cycle 61;; length diverge to infinite so it will exceed ses--Dijkstra-weight-bound at 62;; some point of time that allows detection. Otherwise it converges to the 63;; longest path length in the update tree. 64 65 66;;; Code: 67 68(require 'unsafep) 69(require 'macroexp) 70(eval-when-compile (require 'cl-lib)) 71 72 73;;---------------------------------------------------------------------------- 74;; User-customizable variables 75;;---------------------------------------------------------------------------- 76 77(defgroup ses nil 78 "Simple Emacs Spreadsheet." 79 :tag "SES" 80 :group 'applications 81 :link '(custom-manual "(ses) Top") 82 :prefix "ses-" 83 :version "21.1") 84 85(defcustom ses-initial-size '(1 . 1) 86 "Initial size of a new spreadsheet, as a cons (NUMROWS . NUMCOLS)." 87 :group 'ses 88 :type '(cons (integer :tag "numrows") (integer :tag "numcols"))) 89 90(defcustom ses-initial-column-width 7 91 "Initial width of columns in a new spreadsheet." 92 :group 'ses 93 :type '(integer :match (lambda (widget value) (> value 0)))) 94 95(defcustom ses-initial-default-printer "%.7g" 96 "Initial default printer for a new spreadsheet." 97 :group 'ses 98 :type '(choice string 99 (list :tag "Parenthesized string" string) 100 function)) 101 102(defcustom ses-after-entry-functions '(forward-char) 103 "Things to do after entering a value into a cell. 104An abnormal hook that usually runs a cursor-movement function. 105Each function is called with ARG=1." 106 :group 'ses 107 :type 'hook 108 :options '(forward-char backward-char next-line previous-line)) 109 110(defcustom ses-mode-hook nil 111 "Hook functions to be run upon entering SES mode." 112 :group 'ses 113 :type 'hook) 114 115 116;;---------------------------------------------------------------------------- 117;; Global variables and constants 118;;---------------------------------------------------------------------------- 119 120(defvar ses-read-cell-history nil 121 "List of formulas that have been typed in.") 122 123(defvar ses-read-printer-history nil 124 "List of printer functions that have been typed in.") 125 126(easy-menu-define ses-header-line-menu nil 127 "Context menu when mouse-3 is used on the header-line in an SES buffer." 128 '("SES header row" 129 ["Set current row" ses-set-header-row t] 130 ["Unset row" ses-unset-header-row (> ses--header-row 0)])) 131 132(defconst ses-mode-map 133 (let ((keys `("\C-c\M-\C-l" ses-reconstruct-all 134 "\C-c\C-l" ses-recalculate-all 135 "\C-c\C-n" ses-renarrow-buffer 136 "\C-c\C-c" ses-recalculate-cell 137 "\C-c\M-\C-s" ses-sort-column 138 "\C-c\M-\C-h" ses-set-header-row 139 "\C-c\C-t" ses-truncate-cell 140 "\C-c\C-j" ses-jump 141 "\C-c\C-p" ses-read-default-printer 142 "\M-\C-l" ses-reprint-all 143 [?\S-\C-l] ses-reprint-all 144 [header-line down-mouse-3] ,ses-header-line-menu 145 [header-line mouse-2] ses-sort-column-click)) 146 (newmap (make-sparse-keymap))) 147 (while keys 148 (define-key (1value newmap) (car keys) (cadr keys)) 149 (setq keys (cddr keys))) 150 newmap) 151 "Local keymap for Simple Emacs Spreadsheet.") 152 153(easy-menu-define ses-menu ses-mode-map 154 "Menu bar menu for SES." 155 '("SES" 156 ["Insert row" ses-insert-row (ses-in-print-area)] 157 ["Delete row" ses-delete-row (ses-in-print-area)] 158 ["Insert column" ses-insert-column (ses-in-print-area)] 159 ["Delete column" ses-delete-column (ses-in-print-area)] 160 ["Set column printer" ses-read-column-printer t] 161 ["Set column width" ses-set-column-width t] 162 ["Set default printer" ses-read-default-printer t] 163 ["Jump to cell" ses-jump t] 164 ["Set cell printer" ses-read-cell-printer t] 165 ["Recalculate cell" ses-recalculate-cell t] 166 ["Truncate cell display" ses-truncate-cell t] 167 ["Export values" ses-export-tsv t] 168 ["Export formulas" ses-export-tsf t])) 169 170(defconst ses-completion-keys '("\M-\C-i" "\C-i") 171 "List for keys that can be used for completion while editing.") 172 173(defvar ses--completion-table nil 174 "Set globally to what completion table to use depending on type 175of completion (local printers, cells, etc.). We need to go 176through a local variable to pass the SES buffer local variable 177to completing function while the current buffer is the 178minibuffer.") 179 180(defvar ses--list-orig-buffer nil 181 "Calling buffer for SES listing help. 182Used for listing local printers or renamed cells.") 183 184 185(defconst ses-mode-edit-map 186 (let ((keys '("\C-c\C-r" ses-insert-range 187 "\C-c\C-s" ses-insert-ses-range 188 [S-mouse-3] ses-insert-range-click 189 [C-S-mouse-3] ses-insert-ses-range-click 190 "\C-h\C-p" ses-list-local-printers 191 "\C-h\C-n" ses-list-named-cells 192 "\M-\C-i" lisp-complete-symbol)) ; redefined 193 ; dynamically in 194 ; editing 195 ; functions 196 (newmap (make-sparse-keymap))) 197 (set-keymap-parent newmap minibuffer-local-map) 198 (while keys 199 (define-key newmap (pop keys) (pop keys))) 200 newmap) 201 "Local keymap for SES minibuffer cell-editing.") 202 203;Local keymap for SES print area 204(defalias 'ses-mode-print-map 205 (let ((keys '([backtab] backward-char 206 [tab] ses-forward-or-insert 207 "\C-i" ses-forward-or-insert ; Needed for ses-coverage.el? 208 "\M-o" ses-insert-column 209 "\C-o" ses-insert-row 210 "\C-m" ses-edit-cell 211 "\M-k" ses-delete-column 212 "\M-y" ses-yank-pop 213 "\C-k" ses-delete-row 214 "\C-j" ses-append-row-jump-first-column 215 "\M-h" ses-mark-row 216 "\M-H" ses-mark-column 217 "\C-d" ses-clear-cell-forward 218 "\C-?" ses-clear-cell-backward 219 "(" ses-read-cell 220 "\"" ses-read-cell 221 "'" ses-read-symbol 222 "=" ses-edit-cell 223 "c" ses-recalculate-cell 224 "j" ses-jump 225 "p" ses-read-cell-printer 226 "t" ses-truncate-cell 227 "w" ses-set-column-width 228 "x" ses-export-keymap 229 "\M-p" ses-read-column-printer)) 230 (numeric "0123456789.-") 231 (newmap (make-keymap))) 232 ;;Get rid of printables 233 (suppress-keymap newmap t) 234 ;;These keys insert themselves as the beginning of a numeric value 235 (dotimes (x (length numeric)) 236 (define-key newmap (substring numeric x (1+ x)) 'ses-read-cell)) 237 (define-key newmap [remap clipboard-kill-region] #'ses-kill-override) 238 (define-key newmap [remap end-of-line] #'ses-end-of-line) 239 (define-key newmap [remap kill-line] #'ses-delete-row) 240 (define-key newmap [remap kill-region] #'ses-kill-override) 241 (define-key newmap [remap open-line] #'ses-insert-row) 242 ;;Define our other local keys 243 (while keys 244 (define-key newmap (car keys) (cadr keys)) 245 (setq keys (cddr keys))) 246 newmap)) 247 248;;Helptext for ses-mode wants keymap as variable, not function 249(defconst ses-mode-print-map (symbol-function 'ses-mode-print-map)) 250 251;;Key map used for 'x' key. 252(defalias 'ses-export-keymap 253 (let ((map (make-sparse-keymap "SES export"))) 254 (define-key map "T" (cons " tab-formulas" 'ses-export-tsf)) 255 (define-key map "t" (cons " tab-values" 'ses-export-tsv)) 256 map)) 257 258(defconst ses-print-data-boundary "\n\014\n" 259 "Marker string denoting the boundary between print area and data area.") 260 261(defconst ses-initial-global-parameters 262 "\n( ;Global parameters (these are read first)\n 2 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n" 263 "Initial contents for the three-element list at the bottom of the data area.") 264 265(defconst ses-initial-global-parameters-re 266 "\n( ;Global parameters (these are read first)\n [23] ;SES file-format\n [0-9]+ ;numrows\n [0-9]+ ;numcols\n\\( [0-9]+ ;numlocprn\n\\)?)\n\n" 267 "Match Global parameters for .") 268 269(defconst ses-initial-file-trailer 270 ";; Local Variables:\n;; mode: ses\n;; End:\n" 271 "Initial contents for the file-trailer area at the bottom of the file.") 272 273(defconst ses-initial-file-contents 274 (concat " \n" ; One blank cell in print area. 275 ses-print-data-boundary 276 "(ses-cell A1 nil nil nil nil)\n" ; One blank cell in data area. 277 "\n" ; End-of-row terminator for the one row in data area. 278 "(ses-column-widths [7])\n" 279 "(ses-column-printers [nil])\n" 280 "(ses-default-printer \"%.7g\")\n" 281 "(ses-header-row 0)\n" 282 ses-initial-global-parameters 283 ses-initial-file-trailer) 284 "The initial contents of an empty spreadsheet.") 285 286(defconst ses-box-prop '(:box (:line-width 2 :style released-button)) 287 "Display properties to create a raised box for cells in the header line.") 288 289(defconst ses-standard-printer-functions 290 '(ses-center 291 ses-center-span ses-dashfill ses-dashfill-span 292 ses-tildefill-span 293 ses-prin1) 294 "List of print functions to be included in initial history of printer functions. 295None of these standard-printer functions, except function 296`ses-prin1', is suitable for use as a column printer or a 297global-default printer because they invoke the column or default 298printer and then modify its output.") 299 300 301;;---------------------------------------------------------------------------- 302;; Local variables and constants 303;;---------------------------------------------------------------------------- 304 305(eval-and-compile 306 (defconst ses-localvars 307 '(ses--blank-line ses--cells ses--col-printers 308 ses--col-widths ses--curcell ses--curcell-overlay 309 ses--default-printer 310 (ses--local-printer-hashmap . :hashmap) 311 (ses--numlocprn . 0); count of local printers 312 ses--deferred-narrow ses--deferred-recalc 313 ses--deferred-write ses--file-format 314 ses--named-cell-hashmap 315 (ses--header-hscroll . -1) ; Flag for "initial recalc needed" 316 ses--header-row ses--header-string ses--linewidth 317 ses--numcols ses--numrows ses--symbolic-formulas 318 ses--data-marker ses--params-marker (ses--Dijkstra-attempt-nb . 0) 319 ses--Dijkstra-weight-bound 320 ;; This list is useful for clean-up of symbols when an area 321 ;; containing renamed cell is deleted. 322 ses--in-killing-named-cell-list 323 ;; Global variables that we override 324 next-line-add-newlines transient-mark-mode) 325 "Buffer-local variables used by SES.")) 326 327(defmacro ses--\,@ (exp) (declare (debug t)) (macroexp-progn (eval exp t))) 328(ses--\,@ 329 (mapcar (lambda (x) `(defvar ,(or (car-safe x) x))) ses-localvars)) 330 331(defun ses-set-localvars () 332 "Set buffer-local and initialize some SES variables." 333 (dolist (x ses-localvars) 334 (cond 335 ((symbolp x) 336 (set (make-local-variable x) nil)) 337 ((consp x) 338 (cond 339 ((integerp (cdr x)) 340 (set (make-local-variable (car x)) (cdr x))) 341 ((eq (cdr x) :hashmap) 342 (set (make-local-variable (car x)) (make-hash-table :test 'eq))) 343 (t (error "Unexpected initializer `%S' in list `ses-localvars' for entry %S" 344 (cdr x) (car x)) ) )) 345 (t (error "Unexpected elements `%S' in list `ses-localvars'" x))))) 346 347;;; This variable is documented as being permitted in file-locals: 348(put 'ses--symbolic-formulas 'safe-local-variable 'consp) 349 350(defconst ses-paramlines-plist 351 '(ses--col-widths -5 ses--col-printers -4 ses--default-printer -3 352 ses--header-row -2 ses--file-format 1 ses--numrows 2 353 ses--numcols 3 ses--numlocprn 4) 354 "Offsets from \"Global parameters\" line to various parameter lines in the 355data area of a spreadsheet.") 356 357(defconst ses-paramfmt-plist 358 '(ses--col-widths "(ses-column-widths %S)" 359 ses--col-printers "(ses-column-printers %S)" 360 ses--default-printer "(ses-default-printer %S)" 361 ses--header-row "(ses-header-row %S)" 362 ses--file-format " %S ;SES file-format" 363 ses--numrows " %S ;numrows" 364 ses--numcols " %S ;numcols" 365 ses--numlocprn " %S ;numlocprn") 366 "Formats of \"Global parameters\" various parameters in the data 367area of a spreadsheet.") 368 369;; 370;; "Side-effect variables". They are set in one function, altered in 371;; another as a side effect, then read back by the first, as a way of 372;; passing back more than one value. These declarations are just to make 373;; the compiler happy, and to conform to standard Emacs Lisp practice (I 374;; think the make-local-variable trick above is cleaner). 375;; 376 377(defvar ses-relocate-return nil 378 "Set by `ses-relocate-formula' and `ses-relocate-range', read by 379`ses-relocate-all'. Set to `delete' if a cell-reference was deleted from a 380formula--so the formula needs recalculation. Set to `range' if the size of a 381`ses-range' was changed--so both the formula's value and list of dependents 382need to be recalculated.") 383 384(defvar ses-call-printer-return nil 385 "Set to t if last cell printer invoked by `ses-call-printer' requested 386left-justification of the result. Set to error-signal if `ses-call-printer' 387encountered an error during printing. Otherwise nil.") 388 389(defvar ses-start-time nil 390 "Time when current operation started. 391Used by `ses--time-check' to decide when to emit a progress 392message.") 393 394 395;;---------------------------------------------------------------------------- 396;; Macros 397;;---------------------------------------------------------------------------- 398 399(defmacro ses-get-cell (row col) 400 "Return the cell structure that stores information about cell (ROW,COL)." 401 (declare (debug t)) 402 `(aref (aref ses--cells ,row) ,col)) 403 404(cl-defstruct (ses-cell 405 (:constructor nil) 406 (:constructor ses-make-cell 407 (&optional symbol formula printer references)) 408 (:copier nil) 409 ;; This is treated as an 4-elem array in various places. 410 ;; Mostly in ses-set-cell. 411 (:type vector) ;Not named. 412 (:conc-name ses-cell--)) 413 symbol formula printer references properties) 414 415(cl-defstruct (ses--locprn 416 (:constructor) 417 (:constructor ses-make-local-printer-info 418 (def &optional (compiled (ses-local-printer-compile def)) 419 (number ses--numlocprn)))) 420 def 421 compiled 422 number 423 local-printer-list) 424 425(defmacro ses-cell-symbol (row &optional col) 426 "Return symbol of the local-variable holding value of CELL or pair (ROW,COL). 427For example, (0,0) => A1." 428 (declare (debug t)) 429 `(ses-cell--symbol ,(if col `(ses-get-cell ,row ,col) row))) 430(put 'ses-cell-symbol 'safe-function t) 431 432(defmacro ses-cell-formula (row &optional col) 433 "From a CELL or a pair (ROW,COL), get the function that computes its value." 434 (declare (debug t)) 435 `(ses-cell--formula ,(if col `(ses-get-cell ,row ,col) row))) 436 437(defmacro ses-cell-printer (row &optional col) 438 "From a CELL or a pair (ROW,COL), get the function that prints its value." 439 (declare (debug t)) 440 `(ses-cell--printer ,(if col `(ses-get-cell ,row ,col) row))) 441 442(defmacro ses-cell-references (row &optional col) 443 "From a CELL or a pair (ROW,COL), get the list of symbols for cells whose 444functions refer to its value." 445 (declare (debug t)) 446 `(ses-cell--references ,(if col `(ses-get-cell ,row ,col) row))) 447 448(defmacro ses-sym-rowcol (sym) 449 "From a cell-symbol SYM, gets the cons (row . col). A1 => (0 . 0). 450Result is nil if SYM is not a symbol that names a cell." 451 (declare (debug t)) 452 `(let ((rc (and (symbolp ,sym) (get ,sym 'ses-cell)))) 453 (if (eq rc :ses-named) 454 (and ses--named-cell-hashmap (gethash ,sym ses--named-cell-hashmap)) 455 rc))) 456 457(defun ses-cell-p (cell) 458 "Return non-nil if CELL is a cell of current buffer." 459 (and (vectorp cell) 460 (= (length cell) 5) 461 (eq cell (let ((rowcol (ses-sym-rowcol (ses-cell-symbol cell)))) 462 (and (consp rowcol) 463 (ses-get-cell (car rowcol) (cdr rowcol))))))) 464 465(defun ses-plist-delq (plist prop) 466 "Return PLIST after deleting the first pair (if any) with symbol PROP. 467This can alter PLIST." 468 (cond 469 ((null plist) nil) 470 ((eq (car plist) prop) (cddr plist)) 471 (t (let* ((plist-1 (cdr plist)) 472 (plist-2 (cdr plist-1))) 473 (setcdr plist-1 (ses-plist-delq plist-2 prop)) 474 plist)))) 475 476(defvar ses--ses-buffer-list nil "A list of buffers containing a SES spreadsheet.") 477 478(defun ses--unbind-cell-name (name) 479 "Make NAME non longer a renamed cell name." 480 (remhash name ses--named-cell-hashmap) 481 (kill-local-variable name) 482 ;; remove symbol property 'ses-cell from symbol NAME, unless this 483 ;; symbol is also a renamed cell name in another SES buffer. 484 (let (used-elsewhere (buffer-list ses--ses-buffer-list) buf) 485 (while buffer-list 486 (setq buf (pop buffer-list)) 487 (cond 488 ((eq buf (current-buffer))) 489 ;; This case should not happen, some SES buffer has been 490 ;; killed without the ses-killbuffer-hook being called. 491 ((null (buffer-live-p buf)) 492 ;; Silently repair ses--ses-buffer-list 493 (setq ses--ses-buffer-list (delq buf ses--ses-buffer-list))) 494 (t 495 (with-current-buffer buf 496 (when (gethash name ses--named-cell-hashmap) 497 (setq used-elsewhere t 498 buffer-list nil)))))) 499 (unless used-elsewhere 500 (setplist name (ses-plist-delq (symbol-plist name) 'ses-cell))) )) 501 502(defmacro ses--letref (vars place &rest body) 503 (declare (indent 2) (debug (sexp form body))) 504 (gv-letplace (getter setter) place 505 `(cl-macrolet ((,(nth 0 vars) () ',getter) 506 (,(nth 1 vars) (v) (funcall ',setter v))) 507 ,@body))) 508 509(defmacro ses-cell-property (property-name row &optional col) 510 "Get property named PROPERTY-NAME from a CELL or a pair (ROW,COL). 511 512When COL is omitted, CELL=ROW is a cell object. When COL is 513present ROW and COL are the integer coordinates of the cell of 514interest." 515 (declare (debug t)) 516 `(alist-get ,property-name 517 (ses-cell--properties 518 ,(if col `(ses-get-cell ,row ,col) row)))) 519 520(defmacro ses-cell-property-pop (property-name row &optional col) 521 "From a CELL or a pair (ROW,COL), get and remove the property value of 522the corresponding cell with name PROPERTY-NAME." 523 `(ses--letref (pget pset) 524 (alist-get ,property-name 525 (ses-cell--properties 526 ,(if col `(ses-get-cell ,row ,col) row)) 527 nil t) 528 (prog1 (pget) (pset nil)))) 529 530(defmacro ses-cell-value (row &optional col) 531 "From a CELL or a pair (ROW,COL), get the current value for that cell." 532 (declare (debug t)) 533 `(symbol-value (ses-cell-symbol ,row ,col))) 534 535(defmacro ses-col-width (col) 536 "Return the width for column COL." 537 (declare (debug t)) 538 `(aref ses--col-widths ,col)) 539 540(defmacro ses-col-printer (col) 541 "Return the default printer for column COL." 542 (declare (debug t)) 543 `(aref ses--col-printers ,col)) 544 545(defun ses-is-cell-sym-p (sym) 546 "Check whether SYM point at a cell of this spread sheet." 547 (let ((rowcol (get sym 'ses-cell))) 548 (and rowcol 549 (if (eq rowcol :ses-named) 550 (and ses--named-cell-hashmap (gethash sym ses--named-cell-hashmap)) 551 (and (< (car rowcol) ses--numrows) 552 (< (cdr rowcol) ses--numcols) 553 (eq (ses-cell-symbol (car rowcol) (cdr rowcol)) sym)))))) 554 555(defun ses--cell (sym value formula printer references) 556 "Load a cell SYM from the spreadsheet file. 557Does not recompute VALUE from FORMULA, does not reprint using 558PRINTER, does not check REFERENCES. Safety-checking for FORMULA 559and PRINTER are deferred until first use." 560 (let ((rowcol (ses-sym-rowcol sym))) 561 (ses-formula-record formula) 562 (ses-printer-record printer) 563 (unless (or formula (eq value '*skip*)) 564 (setq formula (macroexp-quote value))) 565 (or (atom formula) 566 (eq safe-functions t) 567 (setq formula `(ses-safe-formula ,formula))) 568 (or (not printer) 569 (stringp printer) 570 (eq safe-functions t) 571 (setq printer `(ses-safe-printer ,printer))) 572 (setf (ses-get-cell (car rowcol) (cdr rowcol)) 573 (ses-make-cell sym formula printer references))) 574 (set sym value)) 575 576(defun ses-local-printer-compile (printer) 577 "Convert local printer function into faster printer definition." 578 (cond 579 ((functionp printer) printer) 580 ((stringp printer) 581 `(lambda (x) 582 (if (null x) "" 583 (format ,printer x)))) 584 ((stringp (car-safe printer)) 585 `(lambda (x) 586 (if (null x) "" 587 (setq ses-call-printer-return t) 588 (format ,(car printer) x)))) 589 (t (error "Invalid printer %S" printer)))) 590 591(defun ses--local-printer (name def) 592 "Define a local printer with name NAME and definition DEF. 593Return the printer info." 594 (or 595 (and (symbolp name) 596 (ses-printer-validate def)) 597 (error "Invalid local printer definition")) 598 (and (gethash name ses--local-printer-hashmap) 599 (error "Duplicate printer definition %S" name)) 600 (add-to-list 'ses-read-printer-history (symbol-name name)) 601 (puthash name 602 (ses-make-local-printer-info (ses-safe-printer def)) 603 ses--local-printer-hashmap)) 604 605(defmacro ses-column-widths (widths) 606 "Load the vector of column widths from the spreadsheet file. 607This is a macro to prevent propagate-on-load viruses." 608 (or (and (vectorp widths) (= (length widths) ses--numcols)) 609 (error "Bad column-width vector")) 610 ;;To save time later, we also calculate the total width of each line in the 611 ;;print area (excluding the terminating newline) 612 (setq ses--col-widths widths 613 ses--linewidth (apply #'+ -1 (mapcar #'1+ widths)) 614 ses--blank-line (concat (make-string ses--linewidth ?\s) "\n")) 615 t) 616 617(defmacro ses-column-printers (printers) 618 "Load the vector of column printers from the spreadsheet file and check 619them for safety. This is a macro to prevent propagate-on-load viruses." 620 (or (and (vectorp printers) (= (length printers) ses--numcols)) 621 (error "Bad column-printers vector")) 622 (dotimes (x ses--numcols) 623 (aset printers x (ses-safe-printer (aref printers x)))) 624 (setq ses--col-printers printers) 625 (mapc #'ses-printer-record printers) 626 t) 627 628(defmacro ses-default-printer (def) 629 "Load the global default printer from the spreadsheet file and check it 630for safety. This is a macro to prevent propagate-on-load viruses." 631 (setq ses--default-printer (ses-safe-printer def)) 632 (ses-printer-record def) 633 t) 634 635(defmacro ses-header-row (row) 636 "Load the header row from the spreadsheet file and check it 637for safety. This is a macro to prevent propagate-on-load viruses." 638 (or (and (wholenump row) (or (zerop ses--numrows) (< row ses--numrows))) 639 (error "Bad header-row")) 640 (setq ses--header-row row) 641 t) 642 643(defmacro ses-dorange (curcell &rest body) 644 "Execute BODY repeatedly, with the variables `row' and `col' set to each 645cell in the range specified by CURCELL. The range is available in the 646variables `minrow', `maxrow', `mincol', and `maxcol'." 647 (declare (indent defun) (debug (form body))) 648 (let ((cur (make-symbol "cur")) 649 (min (make-symbol "min")) 650 (max (make-symbol "max")) 651 (r (make-symbol "r")) 652 (c (make-symbol "c"))) 653 `(let* ((,cur ,curcell) 654 (,min (ses-sym-rowcol (if (consp ,cur) (car ,cur) ,cur))) 655 (,max (ses-sym-rowcol (if (consp ,cur) (cdr ,cur) ,cur)))) 656 (let ((minrow (car ,min)) 657 (maxrow (car ,max)) 658 (mincol (cdr ,min)) 659 (maxcol (cdr ,max))) 660 (if (or (> minrow maxrow) (> mincol maxcol)) 661 (error "Empty range")) 662 (dotimes (,r (- maxrow minrow -1)) 663 (let ((row (+ ,r minrow))) 664 (dotimes (,c (- maxcol mincol -1)) 665 (let ((col (+ ,c mincol))) 666 ,@body)))))))) 667 668 669;;---------------------------------------------------------------------------- 670;; Utility functions 671;;---------------------------------------------------------------------------- 672 673(defun ses-vector-insert (array idx new) 674 "Create a new vector which is one larger than ARRAY and has NEW inserted 675before element IDX." 676 (let* ((len (length array)) 677 (result (make-vector (1+ len) new))) 678 (dotimes (x len) 679 (aset result 680 (if (< x idx) x (1+ x)) 681 (aref array x))) 682 result)) 683 684;;Allow ARRAY to be a symbol for use in buffer-undo-list 685(defun ses-vector-delete (array idx count) 686 "Create a new vector which is a copy of ARRAY with COUNT objects removed 687starting at element IDX. ARRAY is either a vector or a symbol whose value 688is a vector--if a symbol, the new vector is assigned as the symbol's value." 689 (let* ((a (if (arrayp array) array (symbol-value array))) 690 (len (- (length a) count)) 691 (result (make-vector len nil))) 692 (dotimes (x len) 693 (aset result x (aref a (if (< x idx) x (+ x count))))) 694 (if (symbolp array) 695 (set array result)) 696 result)) 697 698(defun ses-delete-line (count) 699 "Like `kill-line', but no kill ring." 700 (let ((pos (point))) 701 (forward-line count) 702 (delete-region pos (point)))) 703 704(defun ses-printer-validate (printer) 705 "Signal an error if PRINTER is not a valid SES cell printer." 706 (or (not printer) 707 (stringp printer) 708 ;; printer is a local printer 709 (and (symbolp printer) (gethash printer ses--local-printer-hashmap)) 710 (functionp printer) 711 (and (stringp (car-safe printer)) (not (cdr printer))) 712 (error "Invalid printer function %S" printer)) 713 printer) 714 715(defun ses-printer-record (printer) 716 "Add PRINTER to `ses-read-printer-history' if not already there, after first 717checking that it is a valid printer function." 718 (ses-printer-validate printer) 719 ;;To speed things up, we avoid calling prin1 for the very common "nil" case. 720 (if printer 721 (add-to-list 'ses-read-printer-history (prin1-to-string printer)))) 722 723(defun ses-formula-record (formula) 724 "If FORMULA is of the form \\='SYMBOL, add it to the list of symbolic formulas 725for this spreadsheet." 726 (when (and (eq (car-safe formula) 'quote) 727 (symbolp (cadr formula))) 728 (add-to-list 'ses--symbolic-formulas 729 (list (symbol-name (cadr formula)))))) 730 731(defun ses-column-letter (col) 732 "Return the alphabetic name of column number COL. 7330-25 become A-Z; 26-701 become AA-ZZ, and so on." 734 (let ((units (char-to-string (+ ?A (% col 26))))) 735 (if (< col 26) 736 units 737 (concat (ses-column-letter (1- (/ col 26))) units)))) 738 739(defun ses-create-cell-symbol (row col) 740 "Produce a symbol that names the cell (ROW,COL). (0,0) => A1." 741 (intern (concat (ses-column-letter col) (number-to-string (1+ row))))) 742 743(defun ses-decode-cell-symbol (str) 744 "Decode a symbol \"A1\" => (0,0). 745Return nil if STR is not a canonical cell name." 746 (let (case-fold-search) 747 (and (string-match "\\`\\([A-Z]+\\)\\([0-9]+\\)\\'" str) 748 (let* ((col-str (match-string-no-properties 1 str)) 749 (col 0) 750 (col-base 1) 751 (col-idx (1- (length col-str))) 752 (row (1- (string-to-number 753 (match-string-no-properties 2 str))))) 754 (and (>= row 0) 755 (progn 756 (while 757 (progn 758 (setq col (+ col (* (- (aref col-str col-idx) ?A) 759 col-base)) 760 col-base (* col-base 26) 761 col-idx (1- col-idx)) 762 (and (>= col-idx 0) 763 (setq col (+ col col-base))))) 764 (cons row col))))))) 765 766(defun ses-create-cell-variable-range (minrow maxrow mincol maxcol) 767 "Create buffer-local variables for cells. This is undoable." 768 (push `(apply ses-destroy-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol) 769 buffer-undo-list) 770 (let (sym xrow xcol) 771 (dotimes (row (1+ (- maxrow minrow))) 772 (dotimes (col (1+ (- maxcol mincol))) 773 (setq xrow (+ row minrow) 774 xcol (+ col mincol) 775 sym (ses-create-cell-symbol xrow xcol)) 776 (put sym 'ses-cell (cons xrow xcol)) 777 (make-local-variable sym))))) 778 779(defun ses-create-cell-variable (sym row col) 780 "Create a buffer-local variable `SYM' for cell at position (ROW, COL). 781 782SYM is the symbol for that variable, ROW and COL are integers for 783row and column of the cell, with numbering starting from 0. 784 785Return nil in case of failure." 786 (unless (local-variable-p sym) 787 (make-local-variable sym) 788 (if (let (case-fold-search) (string-match-p "\\`[A-Z]+[0-9]+\\'" (symbol-name sym))) 789 (put sym 'ses-cell (cons row col)) 790 (put sym 'ses-cell :ses-named) 791 (setq ses--named-cell-hashmap (or ses--named-cell-hashmap (make-hash-table :test 'eq))) 792 (puthash sym (cons row col) ses--named-cell-hashmap)))) 793 794;; We do not delete the ses-cell properties for the cell-variables, in 795;; case a formula that refers to this cell is in the kill-ring and is 796;; later pasted back in. 797(defun ses-destroy-cell-variable-range (minrow maxrow mincol maxcol) 798 "Destroy buffer-local variables for cells. This is undoable." 799 (let (sym) 800 (dotimes (row (1+ (- maxrow minrow))) 801 (dotimes (col (1+ (- maxcol mincol))) 802 (let ((xrow (+ row minrow)) (xcol (+ col mincol))) 803 (setq sym (if (and (< xrow ses--numrows) (< xcol ses--numcols)) 804 (ses-cell-symbol xrow xcol) 805 (ses-create-cell-symbol xrow xcol)))) 806 (if (boundp sym) 807 (push `(apply ses-set-with-undo ,sym ,(symbol-value sym)) 808 buffer-undo-list)) 809 (kill-local-variable sym)))) 810 (push `(apply ses-create-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol) 811 buffer-undo-list)) 812 813(defun ses-reset-header-string () 814 "Flag the header string for update. 815Upon undo, the header string will be updated again." 816 (push '(apply ses-reset-header-string) buffer-undo-list) 817 (setq ses--header-hscroll -1)) 818 819;;Split this code off into a function to avoid coverage-testing difficulties 820(defmacro ses--time-check (format &rest args) 821 "If `ses-start-time' is more than a second ago, call `message' with FORMAT 822and ARGS and reset `ses-start-time' to the current time." 823 `(when (time-less-p 1 (time-since ses-start-time)) 824 (message ,format ,@args) 825 (setq ses-start-time (float-time)))) 826 827 828;;---------------------------------------------------------------------------- 829;; The cells 830;;---------------------------------------------------------------------------- 831 832(defmacro ses-set-cell (row col field val) 833 "Install VAL as the contents for field FIELD (named by a quoted symbol) of 834cell (ROW,COL). This is undoable. The cell's data will be updated through 835`post-command-hook'." 836 (macroexp-let2 nil row row 837 (macroexp-let2 nil col col 838 (macroexp-let2 nil val val 839 `(let* ((cell (ses-get-cell ,row ,col)) 840 (change 841 ,(let ((field (progn (cl-assert (eq (car field) 'quote)) 842 (cadr field)))) 843 (if (eq field 'value) 844 `(ses-set-with-undo (ses-cell-symbol cell) ,val) 845 ;; (let* ((slots (get 'ses-cell 'cl-struct-slots)) 846 ;; (slot (or (assq field slots) 847 ;; (error "Unknown field %S" field))) 848 ;; (idx (- (length slots) 849 ;; (length (memq slot slots))))) 850 ;; `(ses-aset-with-undo cell ,idx ,val)) 851 (let ((getter (intern-soft (format "ses-cell--%s" field)))) 852 `(ses-setter-with-undo 853 (eval-when-compile 854 (cons #',getter 855 (lambda (newval cell) 856 (setf (,getter cell) newval)))) 857 ,val cell)))))) 858 (if change 859 (add-to-list 'ses--deferred-write (cons ,row ,col))) 860 nil))))) ; Make coverage-tester happy. 861 862(defun ses-cell-set-formula (row col formula) 863 "Store a new formula for (ROW . COL) and enqueue the cell for 864recalculation via `post-command-hook'. Updates the reference lists for the 865cells that this cell refers to. Does not update cell value or reprint the 866cell. To avoid inconsistencies, this function is not interruptible, which 867means Emacs will crash if FORMULA contains a circular list." 868 (let* ((cell (ses-get-cell row col)) 869 (old (ses-cell-formula cell))) 870 (let ((sym (ses-cell-symbol cell)) 871 (oldref (ses-formula-references old)) 872 (newref (ses-formula-references formula)) 873 (inhibit-quit t) 874 not-a-cell-ref-list 875 x xrow xcol) 876 (cl-pushnew sym ses--deferred-recalc) 877 ;;Delete old references from this cell. Skip the ones that are also 878 ;;in the new list. 879 (dolist (ref oldref) 880 (unless (memq ref newref) 881 ;; because we do not cancel edit when the user provides a 882 ;; false reference in it, then we need to check that ref 883 ;; points to a cell that is within the spreadsheet. 884 (setq x (ses-sym-rowcol ref)) 885 (and x 886 (< (setq xrow (car x)) ses--numrows) 887 (< (setq xcol (cdr x)) ses--numcols) 888 (ses-set-cell xrow xcol 'references 889 (delq sym (ses-cell-references xrow xcol)))))) 890 ;;Add new ones. Skip ones left over from old list 891 (dolist (ref newref) 892 (setq x (ses-sym-rowcol ref)) 893 ;;Do not trust the user, the reference may be outside the spreadsheet 894 (if (and 895 x 896 (< (setq xrow (car x)) ses--numrows) 897 (< (setq xcol (cdr x)) ses--numcols)) 898 (progn 899 (setq x (ses-cell-references xrow xcol)) 900 (or (memq sym x) 901 (ses-set-cell xrow xcol 'references (cons sym x)))) 902 (cl-pushnew ref not-a-cell-ref-list))) 903 (ses-formula-record formula) 904 (ses-set-cell row col 'formula formula) 905 (and not-a-cell-ref-list 906 (error "Found in formula cells not in spreadsheet: %S" not-a-cell-ref-list))))) 907 908 909(defun ses-repair-cell-reference-all () 910 "Repair cell reference and warn if there was some reference corruption." 911 (interactive "*") 912 (let (errors) 913 ;; Step 1, reset :ses-repair-reference cell property in the whole sheet. 914 (dotimes (row ses--numrows) 915 (dotimes (col ses--numcols) 916 (let ((references (ses-cell-property-pop :ses-repair-reference 917 row col))) 918 (when references 919 (push (list (ses-cell-symbol row col) 920 :corrupt-property 921 references) 922 errors))))) 923 924 ;; Step 2, build new. 925 (dotimes (row ses--numrows) 926 (dotimes (col ses--numcols) 927 (let* ((cell (ses-get-cell row col)) 928 (sym (ses-cell-symbol cell)) 929 (formula (ses-cell-formula cell)) 930 (new-ref (ses-formula-references formula))) 931 (dolist (ref new-ref) 932 (let ((rowcol (ses-sym-rowcol ref))) 933 (cl-pushnew sym (ses-cell-property :ses-repair-reference 934 (car rowcol) 935 (cdr rowcol)))))))) 936 937 ;; Step 3, overwrite with check. 938 (dotimes (row ses--numrows) 939 (dotimes (col ses--numcols) 940 (let* ((cell (ses-get-cell row col)) 941 (irrelevant (ses-cell-references cell)) 942 (new-ref (ses-cell-property-pop :ses-repair-reference cell)) 943 missing) 944 (dolist (ref new-ref) 945 (if (memq ref irrelevant) 946 (setq irrelevant (delq ref irrelevant)) 947 (push ref missing))) 948 (ses-set-cell row col 'references new-ref) 949 (when (or missing irrelevant) 950 (push `( ,(ses-cell-symbol cell) 951 ,@(and missing (list :missing missing)) 952 ,@(and irrelevant (list :irrelevant irrelevant))) 953 errors))))) 954 (if errors 955 (warn "---------------------------------------------------------------- 956Some references were corrupted. 957 958The following is a list where each element ELT is such 959that (car ELT) is the reference of cell CELL with corruption, 960and (cdr ELT) is a property list where 961 962* property `:corrupt-property' means that 963 property `:ses-repair-reference' of cell CELL was initially non 964 nil, 965 966* property `:missing' is a list of missing references 967 968* property `:irrelevant' is a list of non needed references 969 970%S" errors) 971 (message "No reference corruption found")))) 972 973(defun ses-calculate-cell (row col force) 974 "Calculate and print the value for cell (ROW,COL) using the cell's formula 975function and print functions, if any. Result is nil for normal operation, or 976the error signal if the formula or print function failed. The old value is 977left unchanged if it was *skip* and the new value is nil. 978 Any cells that depend on this cell are queued for update after the end of 979processing for the current keystroke, unless the new value is the same as 980the old and FORCE is nil." 981 (let ((cell (ses-get-cell row col)) 982 cycle-error formula-error printer-error) 983 (let ((oldval (ses-cell-value cell)) 984 (formula (ses-cell-formula cell)) 985 newval 986 this-cell-Dijkstra-attempt+1) 987 (when (eq (car-safe formula) 'ses-safe-formula) 988 (setq formula (ses-safe-formula (cadr formula))) 989 (ses-set-cell row col 'formula formula)) 990 (condition-case sig 991 (setq newval (eval formula t)) 992 (error 993 ;; Variable `sig' can't be nil. 994 (nconc sig (list (ses-cell-symbol cell))) 995 (setq formula-error sig 996 newval '*error*))) 997 (if (and (not newval) (eq oldval '*skip*)) 998 ;; Don't lose the *skip* --- previous field spans this one. 999 (setq newval '*skip*)) 1000 (catch 'cycle 1001 (when (or force (not (eq newval oldval))) 1002 (cl-pushnew (cons row col) ses--deferred-write :test #'equal) ; In case force=t. 1003 (ses--letref (pget pset) 1004 (ses-cell-property :ses-Dijkstra-attempt cell) 1005 (let ((this-cell-Dijkstra-attempt (pget))) 1006 (if (null this-cell-Dijkstra-attempt) 1007 (pset 1008 (setq this-cell-Dijkstra-attempt 1009 (cons ses--Dijkstra-attempt-nb 0))) 1010 (unless (= ses--Dijkstra-attempt-nb 1011 (car this-cell-Dijkstra-attempt)) 1012 (setcar this-cell-Dijkstra-attempt ses--Dijkstra-attempt-nb) 1013 (setcdr this-cell-Dijkstra-attempt 0))) 1014 (setq this-cell-Dijkstra-attempt+1 1015 (1+ (cdr this-cell-Dijkstra-attempt))))) 1016 (ses-set-cell row col 'value newval) 1017 (dolist (ref (ses-cell-references cell)) 1018 (cl-pushnew ref ses--deferred-recalc) 1019 (ses--letref (pget pset) 1020 (let ((ref-rowcol (ses-sym-rowcol ref))) 1021 (ses-cell-property 1022 :ses-Dijkstra-attempt 1023 (car ref-rowcol) (cdr ref-rowcol))) 1024 (let ((ref-cell-Dijkstra-attempt (pget))) 1025 1026 (if (null ref-cell-Dijkstra-attempt) 1027 (pset 1028 (setq ref-cell-Dijkstra-attempt 1029 (cons ses--Dijkstra-attempt-nb 1030 this-cell-Dijkstra-attempt+1))) 1031 (if (= (car ref-cell-Dijkstra-attempt) ses--Dijkstra-attempt-nb) 1032 (setcdr ref-cell-Dijkstra-attempt 1033 (max (cdr ref-cell-Dijkstra-attempt) 1034 this-cell-Dijkstra-attempt+1)) 1035 (setcar ref-cell-Dijkstra-attempt ses--Dijkstra-attempt-nb) 1036 (setcdr ref-cell-Dijkstra-attempt 1037 this-cell-Dijkstra-attempt+1))))) 1038 1039 (when (> this-cell-Dijkstra-attempt+1 ses--Dijkstra-weight-bound) 1040 ;; Update print of this cell. 1041 (throw 'cycle (setq formula-error 1042 `(error ,(format "Found cycle on cells %S" 1043 (ses-cell-symbol cell))) 1044 cycle-error formula-error))))))) 1045 (setq printer-error (ses-print-cell row col)) 1046 (or 1047 (and cycle-error 1048 (error (error-message-string cycle-error))) 1049 formula-error printer-error))) 1050 1051(defun ses-clear-cell (row col) 1052 "Delete formula and printer for cell (ROW,COL)." 1053 (ses-set-cell row col 'printer nil) 1054 (ses-cell-set-formula row col nil)) 1055 1056(defcustom ses-self-reference-early-detection nil 1057 "Non-nil if cycle detection is early for cells that refer to themselves." 1058 :version "24.1" 1059 :type 'boolean 1060 :group 'ses) 1061 1062(defun ses-update-cells (list &optional force) 1063 "Recalculate cells in LIST, checking for dependency loops. 1064Print progress messages every second. Dependent cells are not 1065recalculated if the cell's value is unchanged and FORCE is nil." 1066 (let ((ses--deferred-recalc list) 1067 (nextlist list) 1068 (pos (point)) 1069 curlist prevlist this-sym this-rowcol formula) 1070 (with-temp-message " " 1071 (while ses--deferred-recalc 1072 ;; In each loop, recalculate cells that refer only to other cells that 1073 ;; have already been recalculated or aren't in the recalculation region. 1074 ;; Repeat until all cells have been processed or until the set of cells 1075 ;; being worked on stops changing. 1076 (if prevlist 1077 (message "Recalculating... (%d cells left)" 1078 (length ses--deferred-recalc))) 1079 (setq curlist ses--deferred-recalc 1080 ses--deferred-recalc nil 1081 prevlist nextlist) 1082 (while curlist 1083 ;; this-sym has to be popped from curlist *BEFORE* the check, and not 1084 ;; after because of the case of cells referring to themselves. 1085 (setq this-sym (pop curlist) 1086 this-rowcol (ses-sym-rowcol this-sym) 1087 formula (ses-cell-formula (car this-rowcol) 1088 (cdr this-rowcol))) 1089 (or (catch 'ref 1090 (dolist (ref (ses-formula-references formula)) 1091 (if (and ses-self-reference-early-detection (eq ref this-sym)) 1092 (error "Cycle found: cell %S is self-referring" this-sym) 1093 (when (or (memq ref curlist) 1094 (memq ref ses--deferred-recalc)) 1095 ;; This cell refers to another that isn't done yet 1096 (cl-pushnew this-sym ses--deferred-recalc :test #'equal) 1097 (throw 'ref t))))) 1098 ;; ses-update-cells is called from post-command-hook, so 1099 ;; inhibit-quit is implicitly bound to t. 1100 (when quit-flag 1101 ;; Abort the recalculation. User will probably undo now. 1102 (error "Quit")) 1103 (ses-calculate-cell (car this-rowcol) (cdr this-rowcol) force))) 1104 (dolist (ref ses--deferred-recalc) 1105 (cl-pushnew ref nextlist :test #'equal))) 1106 (when ses--deferred-recalc 1107 ;; Just couldn't finish these. 1108 (dolist (x ses--deferred-recalc) 1109 (let ((this-rowcol (ses-sym-rowcol x))) 1110 (ses-set-cell (car this-rowcol) (cdr this-rowcol) 'value '*error*) 1111 (1value (ses-print-cell (car this-rowcol) (cdr this-rowcol))))) 1112 (error "Circular references: %s" ses--deferred-recalc)) 1113 (message " ")) 1114 ;; Can't use save-excursion here: if the cell under point is updated, 1115 ;; save-excursion's marker will move past the cell. 1116 (goto-char pos))) 1117 1118 1119;;---------------------------------------------------------------------------- 1120;; The print area 1121;;---------------------------------------------------------------------------- 1122 1123(defun ses-in-print-area () 1124 "Return t if point is in print area of spreadsheet." 1125 (<= (point) ses--data-marker)) 1126 1127;; We turn off point-motion-hooks and explicitly position the cursor, in case 1128;; the intangible properties have gotten screwed up (e.g., when ses-goto-print 1129;; is called during a recursive ses-print-cell). 1130(defun ses-goto-print (row col) 1131 "Move point to print area for cell (ROW,COL)." 1132 (let ((n 0)) 1133 (goto-char (point-min)) 1134 (forward-line row) 1135 ;; Calculate column position. 1136 (dotimes (c col) 1137 (setq n (+ n (ses-col-width c) 1))) 1138 ;; Move to the position. 1139 (and (> n (move-to-column n)) 1140 (eolp) 1141 ;; Move point to the bol of next line (for TAB at the last cell). 1142 (forward-char)))) 1143 1144(defun ses--cell-at-pos (pos &optional object) 1145 (or (get-text-property pos 'cursor-intangible object) 1146 ;; (when (> pos (if object 0 (point-min))) 1147 ;; (get-text-property (1- pos) 'cursor-intangible object)) 1148 )) 1149 1150(defun ses--curcell (&optional pos) 1151 "Return the current cell symbol, or a cons (BEG,END) for a 1152region, or nil if cursor is not at a cell." 1153 (unless pos (setq pos (point))) 1154 (if (or (not mark-active) 1155 deactivate-mark 1156 (= pos (mark t))) 1157 ;; Single cell. 1158 (ses--cell-at-pos pos) 1159 ;; Range. 1160 (let* ((re (max pos (mark t))) 1161 (bcell (ses--cell-at-pos (min pos (mark t)))) 1162 (ecell (ses--cell-at-pos (1- re)))) 1163 (when (= re ses--data-marker) 1164 ;; Correct for overflow. 1165 (setq ecell (ses--cell-at-pos (- (region-end) 2)))) 1166 (if (and bcell ecell) 1167 (cons bcell ecell) 1168 nil)))) 1169 1170(defun ses-set-curcell () 1171 "Set `ses--curcell' to the current cell symbol, or a cons (BEG,END) for a 1172region, or nil if cursor is not at a cell." 1173 (setq ses--curcell (ses--curcell)) 1174 nil) 1175 1176(defun ses-check-curcell (&rest args) 1177 "Signal an error if `ses--curcell' is inappropriate. 1178The end marker is appropriate if some argument is `end'. 1179A range is appropriate if some argument is `range'. 1180A single cell is appropriate unless some argument is `needrange'." 1181 (ses-set-curcell); fix bug#21054 1182 (cond 1183 ((not ses--curcell) 1184 (or (memq 'end args) 1185 (error "Not at cell"))) 1186 ((consp ses--curcell) 1187 (or (memq 'range args) 1188 (memq 'needrange args) 1189 (error "Can't use a range"))) 1190 ((memq 'needrange args) 1191 (error "Need a range")))) 1192 1193(defvar ses--row) 1194(defvar ses--col) 1195 1196(defun ses-print-cell (row col) 1197 "Format and print the value of cell (ROW,COL) to the print area. 1198Use the cell's printer function. If the cell's new print form is too wide, 1199it will spill over into the following cell, but will not run off the end of the 1200row or overwrite the next non-nil field. Result is nil for normal operation, 1201or the error signal if the printer function failed and the cell was formatted 1202with \"%s\". If the cell's value is *skip*, nothing is printed because the 1203preceding cell has spilled over." 1204 (catch 'ses-print-cell 1205 (let* ((cell (ses-get-cell row col)) 1206 (value (ses-cell-value cell)) 1207 (printer (ses-cell-printer cell)) 1208 (maxcol (1+ col)) 1209 text sig startpos x) 1210 ;; Create the string to print. 1211 (cond 1212 ((eq value '*skip*) 1213 ;; Don't print anything. 1214 (throw 'ses-print-cell nil)) 1215 ((eq value '*error*) 1216 (setq text (make-string (ses-col-width col) ?#))) 1217 (t 1218 ;; Deferred safety-check on printer. 1219 (if (eq (car-safe printer) 'ses-safe-printer) 1220 (ses-set-cell row col 'printer 1221 (setq printer (ses-safe-printer (cadr printer))))) 1222 ;; Print the value. 1223 (setq text 1224 (let ((ses--row row) 1225 (ses--col col)) 1226 (ses-call-printer (or printer 1227 (ses-col-printer col) 1228 ses--default-printer) 1229 value))) 1230 (if (consp ses-call-printer-return) 1231 ;; Printer returned an error. 1232 (setq sig ses-call-printer-return)))) 1233 ;; Adjust print width to match column width. 1234 (let ((width (ses-col-width col)) 1235 (len (string-width text))) 1236 (cond 1237 ((< len width) 1238 ;; Fill field to length with spaces. 1239 (setq len (make-string (- width len) ?\s) 1240 text (if (eq ses-call-printer-return t) 1241 (concat text len) 1242 (concat len text)))) 1243 ((> len width) 1244 ;; Spill over into following cells, if possible. 1245 (let ((maxwidth width)) 1246 (while (and (> len maxwidth) 1247 (< maxcol ses--numcols) 1248 (or (not (setq x (ses-cell-value row maxcol))) 1249 (eq x '*skip*))) 1250 (unless x 1251 ;; Set this cell to '*skip* so it won't overwrite our spillover. 1252 (ses-set-cell row maxcol 'value '*skip*)) 1253 (setq maxwidth (+ maxwidth (ses-col-width maxcol) 1) 1254 maxcol (1+ maxcol))) 1255 (if (<= len maxwidth) 1256 ;; Fill to complete width of all the fields spanned. 1257 (setq text (concat text (make-string (- maxwidth len) ?\s))) 1258 ;; Not enough room to end of line or next non-nil field. Truncate 1259 ;; if string or decimal; otherwise fill with error indicator. 1260 (setq sig `(error "Too wide" ,text)) 1261 (cond 1262 ((stringp value) 1263 (setq text (truncate-string-to-width text maxwidth 0 ?\s))) 1264 ((and (numberp value) 1265 (string-match "\\.[0-9]+" text) 1266 (>= 0 (setq width 1267 (- len maxwidth 1268 (- (match-end 0) (match-beginning 0)))))) 1269 ;; Turn 6.6666666666e+49 into 6.66e+49. Rounding is too hard! 1270 (setq text (concat (substring text 1271 0 1272 (- (match-beginning 0) width)) 1273 (substring text (match-end 0))))) 1274 (t 1275 (setq text (make-string maxwidth ?#))))))))) 1276 ;; Substitute question marks for tabs and newlines. Newlines are used as 1277 ;; row-separators; tabs could confuse the reimport logic. 1278 (setq text (replace-regexp-in-string "[\t\n]" "?" text)) 1279 (ses-goto-print row col) 1280 (setq startpos (point)) 1281 ;; Install the printed result. This is not interruptible. 1282 (let ((inhibit-read-only t) 1283 (inhibit-quit t)) 1284 (delete-region (point) (progn 1285 (move-to-column (+ (current-column) 1286 (string-width text))) 1287 (1+ (point)))) 1288 ;; We use concat instead of inserting separate strings in order to 1289 ;; reduce the number of cells in the undo list. 1290 (setq x (concat text (if (< maxcol ses--numcols) " " "\n"))) 1291 ;; We use set-text-properties to prevent a wacky print function from 1292 ;; inserting rogue properties, and to ensure that the keymap property is 1293 ;; inherited (is it a bug that only unpropertized strings actually 1294 ;; inherit from surrounding text?) 1295 (set-text-properties 0 (length x) nil x) 1296 (insert-and-inherit x) 1297 (put-text-property startpos (point) 'cursor-intangible 1298 (ses-cell-symbol cell)) 1299 (when (and (zerop row) (zerop col)) 1300 ;; Reconstruct special beginning-of-buffer attributes. 1301 (put-text-property (point-min) (point) 'keymap 'ses-mode-print-map) 1302 (put-text-property (point-min) (point) 'read-only 'ses) 1303 (put-text-property (point-min) (1+ (point-min)) 1304 ;; `cursor-intangible' shouldn't be sticky at BOB. 1305 'front-sticky '(read-only keymap)))) 1306 (if (= row (1- ses--header-row)) 1307 ;; This line is part of the header --- force recalc. 1308 (ses-reset-header-string)) 1309 ;; If this cell (or a preceding one on the line) previously spilled over 1310 ;; and has gotten shorter, redraw following cells on line recursively. 1311 (when (and (< maxcol ses--numcols) 1312 (eq (ses-cell-value row maxcol) '*skip*)) 1313 (ses-set-cell row maxcol 'value nil) 1314 (ses-print-cell row maxcol)) 1315 ;; Return to start of cell. 1316 (goto-char startpos) 1317 sig))) 1318 1319(defun ses-call-printer (printer &optional value) 1320 "Invoke PRINTER (a string or parenthesized string or function-symbol or 1321lambda of one argument) on VALUE. Result is the printed cell as a string. 1322The variable `ses-call-printer-return' is set to t if the printer used 1323parenthesis to request left-justification, or the error-signal if the 1324printer signaled one (and \"%s\" is used as the default printer), else nil." 1325 (setq ses-call-printer-return nil) 1326 (condition-case signal 1327 (cond 1328 ((stringp printer) 1329 (if value 1330 (format printer value) 1331 "")) 1332 ((stringp (car-safe printer)) 1333 (setq ses-call-printer-return t) 1334 (if value 1335 (format (car printer) value) 1336 "")) 1337 (t 1338 (setq value 1339 (funcall 1340 (or (and (symbolp printer) 1341 (let ((locprn (gethash printer 1342 ses--local-printer-hashmap))) 1343 (and locprn 1344 (ses--locprn-compiled locprn)))) 1345 printer) 1346 value)) 1347 (if (stringp value) 1348 value 1349 (or (stringp (car-safe value)) 1350 (error "Printer should return \"string\" or (\"string\")")) 1351 (setq ses-call-printer-return t) 1352 (car value)))) 1353 (error 1354 (setq ses-call-printer-return signal) 1355 (ses-prin1 value)))) 1356 1357(defun ses-adjust-print-width (col change) 1358 "Insert CHANGE spaces in front of column COL, or at end of line if 1359COL=NUMCOLS. Deletes characters if CHANGE < 0. Caller should bind 1360`inhibit-quit' to t." 1361 (let ((inhibit-read-only t) 1362 (blank (if (> change 0) (make-string change ?\s))) 1363 (at-end (= col ses--numcols))) 1364 (ses-set-with-undo 'ses--linewidth (+ ses--linewidth change)) 1365 ;; ses-set-with-undo always returns t for strings. 1366 (1value (ses-set-with-undo 'ses--blank-line 1367 (concat (make-string ses--linewidth ?\s) "\n"))) 1368 (dotimes (row ses--numrows) 1369 (ses-goto-print row col) 1370 (when at-end 1371 ;; Insert new columns before newline. 1372 (backward-char 1)) 1373 (if blank 1374 (insert blank) 1375 (delete-char (- change)))))) 1376 1377(defun ses-print-cell-new-width (row col) 1378 "Same as `ses-print-cell', except if the cell's value is *skip*, 1379the preceding nonskipped cell is reprinted. This function is used 1380when the width of cell (ROW,COL) has changed." 1381 (if (not (eq (ses-cell-value row col) '*skip*)) 1382 (ses-print-cell row col) 1383 ;;Cell was skipped over - reprint previous 1384 (ses-goto-print row col) 1385 (backward-char 1) 1386 (let ((rowcol (ses-sym-rowcol (ses--cell-at-pos (point))))) 1387 (ses-print-cell (car rowcol) (cdr rowcol))))) 1388 1389 1390;;---------------------------------------------------------------------------- 1391;; The data area 1392;;---------------------------------------------------------------------------- 1393 1394(defun ses-widen () 1395 "Turn off narrowing, to be reenabled at end of command loop." 1396 (if (buffer-narrowed-p) 1397 (setq ses--deferred-narrow t)) 1398 (widen)) 1399 1400(defun ses-goto-data (def &optional col) 1401 "Move point to data area for (DEF,COL). If DEF is a row 1402number, COL is the column number for a data cell -- otherwise DEF 1403is one of the symbols ses--col-widths, ses--col-printers, 1404ses--default-printer, ses--numrows, or ses--numcols." 1405 (ses-widen) 1406 (if col 1407 ;; It's a cell. 1408 (progn 1409 (goto-char ses--data-marker) 1410 (forward-line (+ 1 (* def (1+ ses--numcols)) col))) 1411 ;; Convert def-symbol to offset. 1412 (setq def (plist-get ses-paramlines-plist def)) 1413 (or def (signal 'args-out-of-range nil)) 1414 (goto-char ses--params-marker) 1415 (forward-line def))) 1416 1417(defun ses-file-format-extend-parameter-list (new-file-format) 1418 "Extend the global parameters list when file format is updated 1419from 2 to 3. This happens when local printer function are added 1420to a sheet that was created with SES version 2. This is not 1421undoable. Return nil when there was no change, and non-nil otherwise." 1422 (save-excursion 1423 (cond 1424 ((and (= ses--file-format 2) (= 3 new-file-format)) 1425 (ses-set-parameter 'ses--file-format 3) 1426 (message "Upgrading from SES-2 to SES-3 file format") 1427 (ses-widen) 1428 (goto-char ses--params-marker) 1429 (forward-line (plist-get ses-paramlines-plist 'ses--numlocprn )) 1430 (insert (format (plist-get ses-paramfmt-plist 'ses--numlocprn) 1431 ses--numlocprn) 1432 ?\n) 1433 t) ))) 1434 1435(defun ses-set-parameter (def value &optional elem) 1436 "Set parameter DEF to VALUE (with undo) and write the value to the data area. 1437See `ses-goto-data' for meaning of DEF. Newlines in the data are escaped. 1438If ELEM is specified, it is the array subscript within DEF to be set to VALUE." 1439 (save-excursion 1440 ;; We call ses-goto-data early, using the old values of numrows and numcols 1441 ;; in case one of them is being changed. 1442 (ses-goto-data def) 1443 (let ((inhibit-read-only t) 1444 (fmt (plist-get ses-paramfmt-plist 1445 def)) 1446 oldval) 1447 (if elem 1448 (progn 1449 (setq oldval (aref (symbol-value def) elem)) 1450 (aset (symbol-value def) elem value)) 1451 (setq oldval (symbol-value def)) 1452 (set def value)) 1453 ;; Special undo since it's outside the narrowed buffer. 1454 (let (buffer-undo-list) 1455 (delete-region (point) (line-end-position)) 1456 (insert (format fmt (symbol-value def)))) 1457 (push `(apply ses-set-parameter ,def ,oldval ,elem) buffer-undo-list)))) 1458 1459 1460(defun ses-write-cells () 1461 "Write cells in `ses--deferred-write' from local variables to data area. 1462Newlines in the data are escaped." 1463 (let* ((inhibit-read-only t) 1464 (print-escape-newlines t) 1465 rowcol row col cell sym formula printer text) 1466 (setq ses-start-time (float-time)) 1467 (with-temp-message " " 1468 (save-excursion 1469 (while ses--deferred-write 1470 (ses--time-check "Writing... (%d cells left)" 1471 (length ses--deferred-write)) 1472 (setq rowcol (pop ses--deferred-write) 1473 row (car rowcol) 1474 col (cdr rowcol) 1475 cell (ses-get-cell row col) 1476 sym (ses-cell-symbol cell) 1477 formula (ses-cell-formula cell) 1478 printer (ses-cell-printer cell)) 1479 (if (eq (car-safe formula) 'ses-safe-formula) 1480 (setq formula (cadr formula))) 1481 (if (eq (car-safe printer) 'ses-safe-printer) 1482 (setq printer (cadr printer))) 1483 (setq text (prin1-to-string 1484 ;; We could shorten it to (ses-cell SYM VAL) when 1485 ;; the other parameters are nil, but in practice most 1486 ;; cells have non-nil `references', so it's 1487 ;; rather pointless. 1488 `(ses-cell ,sym 1489 ,(symbol-value sym) 1490 ,(unless (equal formula (symbol-value sym)) 1491 formula) 1492 ,printer 1493 ,(ses-cell-references cell)))) 1494 (ses-goto-data row col) 1495 (let ((inhibit-quit t)) 1496 (delete-region (point) (line-end-position)) 1497 (insert text)))) 1498 (message " ")))) 1499 1500 1501;;---------------------------------------------------------------------------- 1502;; Formula relocation 1503;;---------------------------------------------------------------------------- 1504 1505(defun ses-formula-references (formula &optional result-so-far) 1506 "Produce a list of symbols for cells that this FORMULA's value 1507refers to. For recursive calls, RESULT-SO-FAR is the list being 1508constructed, or t to get a wrong-type-argument error when the 1509first reference is found." 1510 (if (ses-sym-rowcol formula) 1511 ;; Entire formula is one symbol. 1512 (cl-pushnew formula result-so-far :test #'equal) 1513 (if (consp formula) 1514 (cond 1515 ((eq (car formula) 'ses-range) 1516 (dolist (cur 1517 (cdr (funcall 'macroexpand 1518 (list 'ses-range (nth 1 formula) 1519 (nth 2 formula))))) 1520 (cl-pushnew cur result-so-far :test #'equal))) 1521 ((null (eq (car formula) 'quote)) 1522 ;;Recursive call for subformulas 1523 (dolist (cur formula) 1524 (setq result-so-far (ses-formula-references cur result-so-far)))) 1525 (t 1526 ;;Ignore other stuff 1527 )) 1528 ;; other type of atom are ignored 1529 )) 1530 result-so-far) 1531 1532(defsubst ses-relocate-symbol (sym rowcol startrow startcol rowincr colincr) 1533 "Relocate one symbol SYM, which corresponds to ROWCOL (a cons of ROW and 1534COL). Cells starting at (STARTROW,STARTCOL) are being shifted 1535by (ROWINCR,COLINCR)." 1536 (let ((row (car rowcol)) 1537 (col (cdr rowcol))) 1538 (if (or (< row startrow) (< col startcol)) 1539 sym 1540 (setq row (+ row rowincr) 1541 col (+ col colincr)) 1542 (if (and (>= row startrow) (>= col startcol) 1543 (< row ses--numrows) (< col ses--numcols)) 1544 ;;Relocate this variable, unless it is a named cell 1545 (if (eq (get sym 'ses-cell) :ses-named) 1546 sym 1547 ;; otherwise, we create the relocated cell symbol because 1548 ;; ses-cell-symbol gives the old symbols, however since 1549 ;; renamed cell are not relocated we keep the relocated 1550 ;; cell old symbol in this case. 1551 (if (eq (get (setq sym (ses-cell-symbol row col)) 'ses-cell) :ses-named) 1552 sym 1553 (ses-create-cell-symbol row col))) 1554 ;;Delete reference to a deleted cell 1555 nil)))) 1556 1557(defun ses-relocate-formula (formula startrow startcol rowincr colincr) 1558 "Produce a copy of FORMULA where all symbols that refer to cells in row 1559STARTROW or above, and col STARTCOL or above, are altered by adding ROWINCR 1560and COLINCR. STARTROW and STARTCOL are 0-based. Example: 1561 (ses-relocate-formula \\='(+ A1 B2 D3) 1 2 1 -1) 1562 => (+ A1 B2 C4) 1563If ROWINCR or COLINCR is negative, references to cells being deleted are 1564removed. Example: 1565 (ses-relocate-formula \\='(+ A1 B2 D3) 0 1 0 -1) 1566 => (+ A1 C3) 1567Sets `ses-relocate-return' to `delete' if cell-references were removed." 1568 (let (rowcol result) 1569 (if (or (atom formula) (eq (car formula) 'quote)) 1570 (if (setq rowcol (ses-sym-rowcol formula)) 1571 (ses-relocate-symbol formula rowcol 1572 startrow startcol rowincr colincr) 1573 ;; Constants pass through as-is. 1574 formula) 1575 (dolist (cur formula) 1576 (setq rowcol (ses-sym-rowcol cur)) 1577 (cond 1578 (rowcol 1579 (setq cur (ses-relocate-symbol cur rowcol 1580 startrow startcol rowincr colincr)) 1581 (if cur 1582 (push cur result) 1583 ;; Reference to a deleted cell. Set a flag in ses-relocate-return. 1584 ;; don't change the flag if it's already 'range, since range implies 1585 ;; 'delete. 1586 (unless ses-relocate-return 1587 (setq ses-relocate-return 'delete)))) 1588 ((eq (car-safe cur) 'ses-range) 1589 (setq cur (ses-relocate-range cur startrow startcol rowincr colincr)) 1590 (if cur 1591 (push cur result))) 1592 ((or (atom cur) (eq (car cur) 'quote)) 1593 ;; Constants pass through unchanged. 1594 (push cur result)) 1595 (t 1596 ;; Recursively copy and alter subformulas. 1597 (push (ses-relocate-formula cur startrow startcol 1598 rowincr colincr) 1599 result)))) 1600 (nreverse result)))) 1601 1602(defun ses-relocate-range (range startrow startcol rowincr colincr) 1603 "Relocate one RANGE, of the form (ses-range MIN MAX). Cells starting 1604at (STARTROW,STARTCOL) are being shifted by (ROWINCR,COLINCR). Result is the 1605new range, or nil if the entire range is deleted. If new rows are being added 1606just beyond the end of a row range, or new columns just beyond a column range, 1607the new rows/columns will be added to the range. Sets `ses-relocate-return' 1608if the range was altered." 1609 (let* ((minorig (cadr range)) 1610 (minrowcol (ses-sym-rowcol minorig)) 1611 (min (ses-relocate-symbol minorig minrowcol 1612 startrow startcol 1613 rowincr colincr)) 1614 (maxorig (nth 2 range)) 1615 (maxrowcol (ses-sym-rowcol maxorig)) 1616 (max (ses-relocate-symbol maxorig maxrowcol 1617 startrow startcol 1618 rowincr colincr)) 1619 field) 1620 (cond 1621 ((and (not min) (not max)) 1622 (setq range nil)) ; The entire range is deleted. 1623 ((zerop colincr) 1624 ;; Inserting or deleting rows. 1625 (setq field 'car) 1626 (if (not min) 1627 ;; Chopped off beginning of range. 1628 (setq min (ses-create-cell-symbol startrow (cdr minrowcol)) 1629 ses-relocate-return 'range)) 1630 (if (not max) 1631 (if (> rowincr 0) 1632 ;; Trying to insert a nonexistent row. 1633 (setq max (ses-create-cell-symbol (1- ses--numrows) 1634 (cdr minrowcol))) 1635 ;; End of range is being deleted. 1636 (setq max (ses-create-cell-symbol (1- startrow) (cdr minrowcol)) 1637 ses-relocate-return 'range)) 1638 (and (> rowincr 0) 1639 (= (car maxrowcol) (1- startrow)) 1640 (= (cdr minrowcol) (cdr maxrowcol)) 1641 ;; Insert after ending row of vertical range --- include it. 1642 (setq max (ses-create-cell-symbol (+ startrow rowincr -1) 1643 (cdr maxrowcol)))))) 1644 (t 1645 ;; Inserting or deleting columns. 1646 (setq field 'cdr) 1647 (if (not min) 1648 ;; Chopped off beginning of range. 1649 (setq min (ses-create-cell-symbol (car minrowcol) startcol) 1650 ses-relocate-return 'range)) 1651 (if (not max) 1652 (if (> colincr 0) 1653 ;; Trying to insert a nonexistent column. 1654 (setq max (ses-create-cell-symbol (car maxrowcol) 1655 (1- ses--numcols))) 1656 ;; End of range is being deleted. 1657 (setq max (ses-create-cell-symbol (car maxrowcol) (1- startcol)) 1658 ses-relocate-return 'range)) 1659 (and (> colincr 0) 1660 (= (cdr maxrowcol) (1- startcol)) 1661 (= (car minrowcol) (car maxrowcol)) 1662 ;; Insert after ending column of horizontal range --- include it. 1663 (setq max (ses-create-cell-symbol (car maxrowcol) 1664 (+ startcol colincr -1))))))) 1665 (when range 1666 (if (/= (- (funcall field maxrowcol) 1667 (funcall field minrowcol)) 1668 (- (funcall field (ses-sym-rowcol max)) 1669 (funcall field (ses-sym-rowcol min)))) 1670 ;; This range has changed size. 1671 (setq ses-relocate-return 'range)) 1672 `(ses-range ,min ,max ,@(cdddr range))))) 1673 1674(defun ses-relocate-all (minrow mincol rowincr colincr) 1675 "Alter all cell values, symbols, formulas, and reference-lists to relocate 1676the rectangle (MINROW,MINCOL)..(NUMROWS,NUMCOLS) by adding ROWINCR and COLINCR 1677to each symbol." 1678 (let (reform) 1679 (let (mycell newval xrow) 1680 (dotimes-with-progress-reporter 1681 (row ses--numrows) "Relocating formulas..." 1682 (dotimes (col ses--numcols) 1683 (setq ses-relocate-return nil 1684 mycell (ses-get-cell row col) 1685 newval (ses-relocate-formula (ses-cell-formula mycell) 1686 minrow mincol rowincr colincr) 1687 xrow (- row rowincr)) 1688 (ses-set-cell row col 'formula newval) 1689 (if (eq ses-relocate-return 'range) 1690 ;; This cell contains a (ses-range X Y) where a cell has been 1691 ;; inserted or deleted in the middle of the range. 1692 (push (cons row col) reform)) 1693 (if ses-relocate-return 1694 ;; This cell referred to a cell that's been deleted or is no 1695 ;; longer part of the range. We can't fix that now because 1696 ;; reference lists cells have been partially updated. 1697 (cl-pushnew (ses-create-cell-symbol row col) 1698 ses--deferred-recalc :test #'equal)) 1699 (setq newval (ses-relocate-formula (ses-cell-references mycell) 1700 minrow mincol rowincr colincr)) 1701 (ses-set-cell row col 'references newval) 1702 (and (>= row minrow) (>= col mincol) 1703 (let ((sym (ses-cell-symbol row col)) 1704 (xcol (- col colincr))) 1705 (if (and 1706 sym 1707 (>= xrow 0) 1708 (>= xcol 0) 1709 ;; the following could also be tested as 1710 ;; (null (eq sym (ses-create-cell-symbol xrow xcol))) 1711 (eq (get sym 'ses-cell) :ses-named)) 1712 ;; This is a renamed cell, do not update the cell 1713 ;; name, but just update the coordinate property. 1714 (puthash sym (cons row col) ses--named-cell-hashmap) 1715 (ses-set-cell row col 'symbol 1716 (setq sym (ses-create-cell-symbol row col))) 1717 (unless (local-variable-if-set-p sym) 1718 (set (make-local-variable sym) nil) 1719 (put sym 'ses-cell (cons row col)))))) ))) 1720 ;; Relocate the cell values. 1721 (let (oldval myrow mycol xrow xcol sym) 1722 (cond 1723 ((and (<= rowincr 0) (<= colincr 0)) 1724 ;; Deletion of rows and/or columns. 1725 (dotimes-with-progress-reporter 1726 (row (- ses--numrows minrow)) "Relocating variables..." 1727 (setq myrow (+ row minrow)) 1728 (dotimes (col (- ses--numcols mincol)) 1729 (setq mycol (+ col mincol) 1730 xrow (- myrow rowincr) 1731 xcol (- mycol colincr) 1732 sym (ses-cell-symbol myrow mycol)) 1733 ;; We don't need to relocate value for renamed cells, as they keep the same 1734 ;; symbol. 1735 (unless (eq (get sym 'ses-cell) :ses-named) 1736 (ses-set-cell myrow mycol 'value 1737 (if (and (< xrow ses--numrows) (< xcol ses--numcols)) 1738 (ses-cell-value xrow xcol) 1739 ;; Cell is off the end of the array. 1740 (symbol-value (ses-create-cell-symbol xrow xcol))))))) 1741 (when ses--in-killing-named-cell-list 1742 (message "Unbinding killed named cell symbols...") 1743 (setq ses-start-time (float-time)) 1744 (while ses--in-killing-named-cell-list 1745 (ses--time-check "Unbinding killed named cell symbols... (%d left)" (length ses--in-killing-named-cell-list)) 1746 (ses--unbind-cell-name (pop ses--in-killing-named-cell-list)) ) 1747 (message nil)) ) 1748 1749 ((and (wholenump rowincr) (wholenump colincr)) 1750 ;; Insertion of rows and/or columns. Run the loop backwards. 1751 (let ((disty (1- ses--numrows)) 1752 (distx (1- ses--numcols)) 1753 myrow mycol) 1754 (dotimes-with-progress-reporter 1755 (row (- ses--numrows minrow)) "Relocating variables..." 1756 (setq myrow (- disty row)) 1757 (dotimes (col (- ses--numcols mincol)) 1758 (setq mycol (- distx col) 1759 xrow (- myrow rowincr) 1760 xcol (- mycol colincr) 1761 sym (ses-cell-symbol myrow mycol)) 1762 ;; We don't need to relocate value for renamed cells, as they keep the same 1763 ;; symbol. 1764 (unless (eq (get sym 'ses-cell) :ses-named) 1765 (if (or (< xrow minrow) (< xcol mincol)) 1766 ;; Newly-inserted value. 1767 (setq oldval nil) 1768 ;; Transfer old value. 1769 (setq oldval (ses-cell-value xrow xcol))) 1770 (ses-set-cell myrow mycol 'value oldval)))) 1771 t)) ; Make testcover happy by returning non-nil here. 1772 (t 1773 (error "ROWINCR and COLINCR must have the same sign")))) 1774 ;; Reconstruct reference lists for cells that contain ses-ranges that have 1775 ;; changed size. 1776 (when reform 1777 (message "Fixing ses-ranges...") 1778 (let (row col) 1779 (setq ses-start-time (float-time)) 1780 (while reform 1781 (ses--time-check "Fixing ses-ranges... (%d left)" (length reform)) 1782 (setq row (caar reform) 1783 col (cdar reform) 1784 reform (cdr reform)) 1785 (ses-cell-set-formula row col (ses-cell-formula row col)))) 1786 (message nil)))) 1787 1788 1789;;---------------------------------------------------------------------------- 1790;; Undo control 1791;;---------------------------------------------------------------------------- 1792 1793(defun ses-begin-change () 1794 "For undo, remember point before we start changing hidden stuff." 1795 (let ((inhibit-read-only t)) 1796 (insert-and-inherit "X") 1797 (delete-region (1- (point)) (point)))) 1798 1799(defun ses-setter-with-undo (accessors newval &rest args) 1800 "Set a field/variable and record it so it can be undone. 1801Result is non-nil if field/variable has changed." 1802 (let ((oldval (apply (car accessors) args))) 1803 (unless (equal-including-properties oldval newval) 1804 (push `(apply ses-setter-with-undo ,accessors ,oldval ,@args) 1805 buffer-undo-list) 1806 (apply (cdr accessors) newval args) 1807 t))) 1808 1809(defun ses-aset-with-undo (array idx newval) 1810 (ses-setter-with-undo (eval-when-compile 1811 (cons #'aref 1812 (lambda (newval array idx) (aset array idx newval)))) 1813 newval array idx)) 1814 1815(defun ses-set-with-undo (sym newval) 1816 (ses-setter-with-undo 1817 (eval-when-compile 1818 (cons (lambda (sym) (if (boundp sym) (symbol-value sym) :ses--unbound)) 1819 (lambda (newval sym) (if (eq newval :ses--unbound) 1820 (makunbound sym) 1821 (set sym newval))))) 1822 newval sym)) 1823 1824;;---------------------------------------------------------------------------- 1825;; Startup for major mode 1826;;---------------------------------------------------------------------------- 1827 1828(defun ses-load () 1829 "Parse the current buffer and set up buffer-local variables. 1830Does not execute cell formulas or print functions." 1831 (widen) 1832 ;; Read our global parameters, which should be a 3-element list. 1833 (goto-char (point-max)) 1834 (search-backward ";; Local Variables:\n" nil t) 1835 (backward-list 1) 1836 (setq ses--params-marker (point-marker)) 1837 (let* ((params (ignore-errors (read (current-buffer)))) 1838 (params-len (safe-length params))) 1839 (or (and (>= params-len 3) 1840 (<= params-len 4) 1841 (numberp (car params)) 1842 (numberp (cadr params)) 1843 (>= (cadr params) 0) 1844 (numberp (nth 2 params)) 1845 (> (nth 2 params) 0) 1846 (or (<= params-len 3) 1847 (let ((numlocprn (nth 3 params))) 1848 (and (integerp numlocprn) (>= numlocprn 0))))) 1849 (error "Invalid SES file")) 1850 (setq ses--file-format (car params) 1851 ses--numrows (cadr params) 1852 ses--numcols (nth 2 params) 1853 ses--numlocprn (or (nth 3 params) 0)) 1854 (when (= ses--file-format 1) 1855 (let (buffer-undo-list) ; This is not undoable. 1856 (ses-goto-data 'ses--header-row) 1857 (insert "(ses-header-row 0)\n") 1858 (ses-set-parameter 'ses--file-format 3) 1859 (message "Upgrading from SES-1 to SES-2 file format"))) 1860 (or (<= ses--file-format 3) 1861 (error "This file needs a newer version of the SES library code")) 1862 ;; Initialize cell array. 1863 (setq ses--cells (make-vector ses--numrows nil)) 1864 (dotimes (row ses--numrows) 1865 (aset ses--cells row (make-vector ses--numcols nil))) 1866 ;; initialize local printer map. 1867 (clrhash ses--local-printer-hashmap)) 1868 1869 ;; Skip over print area, which we assume is correct. 1870 (goto-char (point-min)) 1871 (forward-line ses--numrows) 1872 (or (looking-at-p ses-print-data-boundary) 1873 (error "Missing marker between print and data areas")) 1874 (forward-char 1) 1875 (setq ses--data-marker (point-marker)) 1876 (forward-char (1- (length ses-print-data-boundary))) 1877 ;; Initialize printer and symbol lists. 1878 (mapc #'ses-printer-record ses-standard-printer-functions) 1879 (setq ses--symbolic-formulas nil) 1880 1881 ;; Load local printer definitions. 1882 ;; This must be loaded *BEFORE* cells and column printers because the latter 1883 ;; may call them. 1884 (save-excursion 1885 (forward-line (* ses--numrows (1+ ses--numcols))) 1886 (let ((numlocprn ses--numlocprn)) 1887 (setq ses--numlocprn 0) 1888 (dotimes (_ numlocprn) 1889 (let ((x (read (current-buffer)))) 1890 (or (and (= (following-char) ?\n) 1891 (eq (car-safe x) 'ses-local-printer) 1892 (apply #'ses--local-printer (cdr x))) 1893 (error "Local printer-def error")) 1894 (setq ses--numlocprn (1+ ses--numlocprn)))))) 1895 ;; Load cell definitions. 1896 (dotimes (row ses--numrows) 1897 (dotimes (col ses--numcols) 1898 (let* ((x (read (current-buffer))) 1899 (sym (car-safe (cdr-safe x)))) 1900 (or (and (= (following-char) ?\n) 1901 (eq (car-safe x) 'ses-cell) 1902 (ses-create-cell-variable sym row col)) 1903 (error "Cell-def error")) 1904 (apply #'ses--cell (cdr x)))) 1905 (or (looking-at-p "\n\n") 1906 (error "Missing blank line between rows"))) 1907 ;; Skip local printer function declaration --- that were already loaded. 1908 (forward-line (+ 2 ses--numlocprn)) 1909 ;; Load global parameters. 1910 (let ((widths (read (current-buffer))) 1911 (n1 (char-after (point))) 1912 (printers (read (current-buffer))) 1913 (n2 (char-after (point))) 1914 (def-printer (read (current-buffer))) 1915 (n3 (char-after (point))) 1916 (head-row (read (current-buffer))) 1917 (n4 (char-after (point)))) 1918 (or (and (eq (car-safe widths) 'ses-column-widths) 1919 (= n1 ?\n) 1920 (eq (car-safe printers) 'ses-column-printers) 1921 (= n2 ?\n) 1922 (eq (car-safe def-printer) 'ses-default-printer) 1923 (= n3 ?\n) 1924 (eq (car-safe head-row) 'ses-header-row) 1925 (= n4 ?\n)) 1926 (error "Invalid SES global parameters")) 1927 (1value (eval widths t)) 1928 (1value (eval def-printer t)) 1929 (1value (eval printers t)) 1930 (1value (eval head-row t))) 1931 ;; Should be back at global-params. 1932 (forward-char 1) 1933 (or (looking-at-p ses-initial-global-parameters-re) 1934 (error "Problem with column-defs or global-params")) 1935 ;; Check for overall newline count in definitions area. 1936 (forward-line 3) 1937 (let ((start (point))) 1938 (ses-goto-data 'ses--numrows) 1939 (or (= (point) start) 1940 (error "Extraneous newlines someplace?")))) 1941 1942(defun ses-setup () 1943 "Set up for display of only the printed cell values. 1944 1945Narrows the buffer to show only the print area. Gives it `read-only' and 1946`intangible' properties. Sets up highlighting for current cell." 1947 (interactive) 1948 (let ((end (point-min)) 1949 pos sym) 1950 (with-silent-modifications 1951 (ses-goto-data 0 0) ; Include marker between print-area and data-area. 1952 (set-text-properties (point) (point-max) nil) ; Delete garbage props. 1953 (mapc #'delete-overlay (overlays-in (point-min) (point-max))) 1954 ;; The print area is read-only (except for our special commands) and 1955 ;; uses a special keymap. 1956 (put-text-property (point-min) (1- (point)) 'read-only 'ses) 1957 (put-text-property (point-min) (1- (point)) 'keymap 'ses-mode-print-map) 1958 ;; For the beginning of the buffer, we want the read-only and keymap 1959 ;; attributes to be inherited from the first character. 1960 (put-text-property (point-min) (1+ (point-min)) 1961 ;; `cursor-intangible' shouldn't be sticky at BOB. 1962 'front-sticky '(read-only keymap)) 1963 ;; Create intangible properties, which also indicate which cell the text 1964 ;; came from. 1965 (dotimes-with-progress-reporter (row ses--numrows) "Finding cells..." 1966 (dotimes (col ses--numcols) 1967 (setq pos end 1968 sym (ses-cell-symbol row col)) 1969 (unless (eq (symbol-value sym) '*skip*) 1970 ;; Include skipped cells following this one. 1971 (while (and (< col (1- ses--numcols)) 1972 (eq (ses-cell-value row (1+ col)) '*skip*)) 1973 (setq end (+ end (ses-col-width col) 1) 1974 ;; Beware: Modifying the iteration variable of `dotimes' 1975 ;; may or may not affect the iteration! 1976 col (1+ col))) 1977 (setq end (save-excursion 1978 (goto-char pos) 1979 (move-to-column (+ (current-column) (- end pos) 1980 (ses-col-width col))) 1981 (if (eolp) 1982 (+ end (ses-col-width col) 1) 1983 (forward-char) 1984 (point)))) 1985 (put-text-property pos end 'cursor-intangible sym)))))) 1986 ;; Create the underlining overlay. It's impossible for (point) to be 2, 1987 ;; because column A must be at least 1 column wide. 1988 (setq ses--curcell-overlay (make-overlay (1+ (point-min)) (1+ (point-min)))) 1989 (overlay-put ses--curcell-overlay 'face 'underline)) 1990 1991(defun ses-cleanup () 1992 "Cleanup when changing a buffer from SES mode to something else. 1993Delete overlays, remove special text properties." 1994 (widen) 1995 (let ((inhibit-read-only t) 1996 ;; When reverting, hide the buffer name, otherwise Emacs will ask the 1997 ;; user "the file is modified, do you really want to make modifications 1998 ;; to this buffer", where the "modifications" refer to the irrelevant 1999 ;; set-text-properties below. 2000 (buffer-file-name nil) 2001 (was-modified (buffer-modified-p))) 2002 ;; Delete read-only, keymap, and intangible properties. 2003 (set-text-properties (point-min) (point-max) nil) 2004 ;; Delete overlay. 2005 (mapc #'delete-overlay (overlays-in (point-min) (point-max))) 2006 (unless was-modified 2007 (restore-buffer-modified-p nil)))) 2008 2009(defun ses-killbuffer-hook () 2010 "Hook when the current buffer is killed." 2011 (setq ses--ses-buffer-list (delq (current-buffer) ses--ses-buffer-list))) 2012 2013 2014;;;###autoload 2015(defun ses-mode () 2016 "Major mode for Simple Emacs Spreadsheet. 2017 2018When you invoke SES in a new buffer, it is divided into cells 2019that you can enter data into. You can navigate the cells with 2020the arrow keys and add more cells with the tab key. The contents 2021of these cells can be numbers, text, or Lisp expressions. (To 2022enter text, enclose it in double quotes.) 2023 2024In an expression, you can use cell coordinates to refer to the 2025contents of another cell. For example, you can sum a range of 2026cells with `(+ A1 A2 A3)'. There are specialized functions like 2027`ses+' (addition for ranges with empty cells), `ses-average' (for 2028performing calculations on cells), and `ses-range' and `ses-select' 2029\(for extracting ranges of cells). 2030 2031Each cell also has a print function that controls how it is 2032displayed. 2033 2034Each SES buffer is divided into a print area and a data area. 2035Normally, you can simply use SES to look at and manipulate the print 2036area, and let SES manage the data area outside the visible region. 2037 2038See \"ses-example.ses\" (in `data-directory') for an example 2039spreadsheet, and the Info node `(ses)Top.' 2040 2041In the following, note the separate keymaps for cell editing mode 2042and print mode specifications. Key definitions: 2043 2044\\{ses-mode-map} 2045These key definitions are active only in the print area (the visible 2046part): 2047\\{ses-mode-print-map} 2048These are active only in the minibuffer, when entering or editing a 2049formula: 2050\\{ses-mode-edit-map}" 2051 (interactive) 2052 (unless (and (boundp 'ses--deferred-narrow) 2053 (eq ses--deferred-narrow 'ses-mode)) 2054 (kill-all-local-variables) 2055 (ses-set-localvars) 2056 (setq major-mode 'ses-mode 2057 mode-name "SES" 2058 next-line-add-newlines nil 2059 truncate-lines t 2060 ;; SES deliberately puts lots of trailing whitespace in its buffer. 2061 show-trailing-whitespace nil 2062 ;; Cell ranges do not work reasonably without this. 2063 transient-mark-mode t 2064 ;; Not to use tab characters for safe (tabs may do bad for column 2065 ;; calculation). 2066 indent-tabs-mode nil) 2067 (1value (add-hook 'change-major-mode-hook 'ses-cleanup nil t)) 2068 (1value (add-hook 'kill-buffer-hook 'ses-killbuffer-hook nil t)) 2069 (cl-pushnew (current-buffer) ses--ses-buffer-list :test 'eq) 2070 ;; This makes revert impossible if the buffer is read-only. 2071 ;; (1value (add-hook 'before-revert-hook 'ses-cleanup nil t)) 2072 (setq header-line-format '(:eval (progn 2073 (when (/= (window-hscroll) 2074 ses--header-hscroll) 2075 ;; Reset ses--header-hscroll first, 2076 ;; to avoid recursion problems when 2077 ;; debugging ses-create-header-string 2078 (setq ses--header-hscroll 2079 (window-hscroll)) 2080 (ses-create-header-string)) 2081 ses--header-string))) 2082 (setq-local mode-line-process '(:eval (ses--mode-line-process))) 2083 (add-hook 'pre-redisplay-functions #'ses--cursor-sensor-highlight 2084 ;; Highlight the cell after moving cursor out of intangible. 2085 'append t) 2086 (cursor-intangible-mode 1) 2087 (let ((was-empty (zerop (buffer-size))) 2088 (was-modified (buffer-modified-p))) 2089 (save-excursion 2090 (if was-empty 2091 ;; Initialize buffer to contain one cell, for now. 2092 (insert ses-initial-file-contents)) 2093 (ses-load) 2094 (ses-setup)) 2095 (when was-empty 2096 (unless (equal ses-initial-default-printer 2097 (1value ses--default-printer)) 2098 (1value (ses-read-default-printer ses-initial-default-printer))) 2099 (unless (= ses-initial-column-width (1value (ses-col-width 0))) 2100 (1value (ses-set-column-width 0 ses-initial-column-width))) 2101 (ses-set-curcell) 2102 (if (> (car ses-initial-size) (1value ses--numrows)) 2103 (1value (ses-insert-row (1- (car ses-initial-size))))) 2104 (if (> (cdr ses-initial-size) (1value ses--numcols)) 2105 (1value (ses-insert-column (1- (cdr ses-initial-size))))) 2106 (ses-write-cells) 2107 (restore-buffer-modified-p was-modified) 2108 (buffer-disable-undo) 2109 (buffer-enable-undo) 2110 (goto-char (point-min)))) 2111 (use-local-map ses-mode-map) 2112 ;; Set the deferred narrowing flag (we can't narrow until after 2113 ;; after-find-file completes). If .ses is on the auto-load alist and the 2114 ;; file has "mode: ses", our ses-mode function will be called twice! Use a 2115 ;; special flag to detect this (will be reset by ses-command-hook). For 2116 ;; find-alternate-file, post-command-hook doesn't get run for some reason, 2117 ;; so use an idle timer to make sure. 2118 (setq ses--deferred-narrow 'ses-mode) 2119 (1value (add-hook 'post-command-hook 'ses-command-hook nil t)) 2120 (run-with-idle-timer 0.01 nil 'ses-command-hook) 2121 (run-mode-hooks 'ses-mode-hook))) 2122 2123(put 'ses-mode 'mode-class 'special) 2124 2125(defun ses-command-hook () 2126 "Invoked from `post-command-hook'. If point has moved to a different cell, 2127move the underlining overlay. Perform any recalculations or cell-data 2128writes that have been deferred. If buffer-narrowing has been deferred, 2129narrow the buffer now." 2130 (condition-case err 2131 (when (eq major-mode 'ses-mode) ; Otherwise, not our buffer anymore. 2132 (when ses--deferred-recalc 2133 ;; We reset the deferred list before starting on the recalc --- in 2134 ;; case of error, we don't want to retry the recalc after every 2135 ;; keystroke! 2136 (ses-initialize-Dijkstra-attempt) 2137 (let ((old ses--deferred-recalc)) 2138 (setq ses--deferred-recalc nil) 2139 (ses-update-cells old))) 2140 (when ses--deferred-write 2141 ;; We don't reset the deferred list before starting --- the most 2142 ;; likely error is keyboard-quit, and we do want to keep trying these 2143 ;; writes after a quit. 2144 (ses-write-cells) 2145 (push '(apply ses-widen) buffer-undo-list)) 2146 (when ses--deferred-narrow 2147 ;; We're not allowed to narrow the buffer until after-find-file has 2148 ;; read the local variables at the end of the file. Now it's safe to 2149 ;; do the narrowing. 2150 (narrow-to-region (point-min) ses--data-marker) 2151 (setq ses--deferred-narrow nil))) 2152 ;; Prevent errors in this post-command-hook from silently erasing the hook! 2153 (error 2154 (unless executing-kbd-macro 2155 (ding)) 2156 (message "%s" (error-message-string err)))) 2157 nil) ; Make coverage-tester happy. 2158 2159(defun ses--mode-line-process () 2160 (let ((cmlp (window-parameter nil 'ses--mode-line-process)) 2161 (curcell (ses--curcell (window-point)))) 2162 (if (equal curcell (car cmlp)) 2163 (cdr cmlp) 2164 (let ((mlp 2165 (cond 2166 ((not curcell) nil) 2167 ((atom curcell) (list " cell " (symbol-name curcell))) 2168 (t 2169 (list " range " 2170 (symbol-name (car curcell)) 2171 "-" 2172 (symbol-name (cdr curcell))))))) 2173 (set-window-parameter nil 'ses--mode-line-process (cons curcell mlp)) 2174 mlp)))) 2175 2176(defun ses--cursor-sensor-highlight (window) 2177 (let ((curcell (ses--curcell)) 2178 (ol (window-parameter window 'ses--curcell-overlay))) 2179 (unless ol 2180 (setq ol (make-overlay (point) (point))) 2181 (overlay-put ol 'window window) 2182 (overlay-put ol 'face 'underline) 2183 (set-window-parameter window 'ses--curcell-overlay ol)) 2184 ;; Use underline overlay for single-cells only, turn off otherwise. 2185 (if (listp curcell) 2186 (delete-overlay ol) 2187 (let* ((pos (window-point window)) 2188 (next (next-single-property-change pos 'cursor-intangible))) 2189 (move-overlay ol pos (1- next)))))) 2190 2191(defun ses-create-header-string () 2192 "Set up `ses--header-string' as the buffer's header line. 2193Based on the current set of columns and `window-hscroll' position." 2194 (let ((totwidth (- (window-hscroll))) 2195 result width x) 2196 ;; Leave room for the left-side fringe and scrollbar. 2197 (push (propertize " " 'display '((space :align-to 0))) result) 2198 (dotimes (col ses--numcols) 2199 (setq width (ses-col-width col) 2200 totwidth (+ totwidth width 1)) 2201 (if (= totwidth 1) 2202 ;; Scrolled so intercolumn space is leftmost. 2203 (push " " result)) 2204 (when (> totwidth 1) 2205 (if (> ses--header-row 0) 2206 (save-excursion 2207 (ses-goto-print (1- ses--header-row) col) 2208 (setq x (buffer-substring-no-properties (point) 2209 (+ (point) width))) 2210 ;; Strip trailing space. 2211 (if (string-match "[ \t]+\\'" x) 2212 (setq x (substring x 0 (match-beginning 0)))) 2213 ;; Cut off excess text. 2214 (if (>= (length x) totwidth) 2215 (setq x (substring x 0 (- totwidth -1))))) 2216 (setq x (ses-column-letter col))) 2217 (push (propertize x 'face ses-box-prop) result) 2218 (push (propertize "." 2219 'display `((space :align-to ,(1- totwidth))) 2220 'face ses-box-prop) 2221 result) 2222 ;; Allow the following space to be squished to make room for the 3-D box 2223 ;; Coverage test ignores properties, thinks this is always a space! 2224 (push (1value (propertize " " 'display `((space :align-to ,totwidth)))) 2225 result))) 2226 (if (> ses--header-row 0) 2227 (push (propertize (format " [row %d]" ses--header-row) 2228 'display '((height (- 1)))) 2229 result)) 2230 (setq ses--header-string (apply #'concat (nreverse result))))) 2231 2232 2233;;---------------------------------------------------------------------------- 2234;; Redisplay and recalculation 2235;;---------------------------------------------------------------------------- 2236 2237(defun ses-jump (sym) 2238 "Move point to cell SYM." 2239 (interactive (let* (names 2240 (s (completing-read 2241 "Jump to cell: " 2242 (and ses--named-cell-hashmap 2243 (progn (maphash (lambda (key _val) 2244 (push (symbol-name key) names)) 2245 ses--named-cell-hashmap) 2246 names))))) 2247 (if (string= s "") 2248 (user-error "Invalid cell name") 2249 (list (intern s))))) 2250 (let ((rowcol (ses-sym-rowcol sym))) 2251 (or rowcol (error "Invalid cell name")) 2252 (if (eq (symbol-value sym) '*skip*) 2253 (error "Cell is covered by preceding cell")) 2254 (ses-goto-print (car rowcol) (cdr rowcol)))) 2255 2256(defun ses-jump-safe (cell) 2257 "Like `ses-jump', but no error if invalid cell." 2258 (ignore-errors 2259 (ses-jump cell))) 2260 2261(defun ses-reprint-all (&optional nonarrow) 2262 "Recreate the display area. Call all printer functions. 2263Narrow to print area if optional argument NONARROW is nil." 2264 (interactive "*P") 2265 (widen) 2266 (unless nonarrow 2267 (setq ses--deferred-narrow t)) 2268 (let ((startcell (ses--cell-at-pos (point))) 2269 (inhibit-read-only t)) 2270 (ses-begin-change) 2271 (goto-char (point-min)) 2272 (search-forward ses-print-data-boundary) 2273 (backward-char (length ses-print-data-boundary)) 2274 (delete-region (point-min) (point)) 2275 ;; Insert all blank lines before printing anything, so ses-print-cell can 2276 ;; find the data area when inserting or deleting *skip* values for cells. 2277 (dotimes (_ ses--numrows) 2278 (insert-and-inherit ses--blank-line)) 2279 (dotimes-with-progress-reporter (row ses--numrows) "Reprinting..." 2280 (if (eq (ses-cell-value row 0) '*skip*) 2281 ;; Column deletion left a dangling skip. 2282 (ses-set-cell row 0 'value nil)) 2283 (dotimes (col ses--numcols) 2284 (ses-print-cell row col)) 2285 (beginning-of-line 2)) 2286 (ses-jump-safe startcell))) 2287 2288(defun ses-initialize-Dijkstra-attempt () 2289 (setq ses--Dijkstra-attempt-nb (1+ ses--Dijkstra-attempt-nb) 2290 ses--Dijkstra-weight-bound (* ses--numrows ses--numcols))) 2291 2292;; These functions use the variables 'row' and 'col' that are dynamically bound 2293;; by ses-print-cell. We define these variables at compile-time to make the 2294;; compiler happy. 2295;; (defvar row) 2296;; (defvar col) 2297;; (defvar maxrow) 2298;; (defvar maxcol) 2299 2300(defun ses-recalculate-cell (&optional curcell) 2301 "Recalculate and reprint the current cell or range. 2302 2303If CURCELL is non nil use it as current cell or range 2304without any check, otherwise function (ses-check-curcell 'range) 2305is called. 2306 2307For an individual cell, shows the error if the formula or printer 2308signals one, or otherwise shows the cell's complete value. For a range, the 2309cells are recalculated in \"natural\" order, so cells that other cells refer 2310to are recalculated first." 2311 (interactive "*") 2312 (if curcell (setq ses--curcell curcell) 2313 (ses-check-curcell 'range)) 2314 (ses-begin-change) 2315 (ses-initialize-Dijkstra-attempt) 2316 (let (sig cur-rowcol) 2317 (setq ses-start-time (float-time)) 2318 (if (atom ses--curcell) 2319 (when 2320 (setq cur-rowcol (ses-sym-rowcol ses--curcell) 2321 sig (progn 2322 (setf (ses-cell-property :ses-Dijkstra-attempt 2323 (car cur-rowcol) 2324 (cdr cur-rowcol)) 2325 (cons ses--Dijkstra-attempt-nb 0)) 2326 (ses-calculate-cell (car cur-rowcol) (cdr cur-rowcol) t))) 2327 (nconc sig (list (ses-cell-symbol (car cur-rowcol) 2328 (cdr cur-rowcol))))) 2329 ;; First, recalculate all cells that don't refer to other cells and 2330 ;; produce a list of cells with references. 2331 (ses-dorange ses--curcell 2332 (ses--time-check "Recalculating... %s" (ses-cell-symbol row col)) 2333 (condition-case nil 2334 (progn 2335 ;; The t causes an error if the cell has references. If no 2336 ;; references, the t will be the result value. 2337 (1value (ses-formula-references (ses-cell-formula row col) t)) 2338 (setf (ses-cell-property :ses-Dijkstra-attempt row col) 2339 (cons ses--Dijkstra-attempt-nb 0)) 2340 (when (setq sig (ses-calculate-cell row col t)) 2341 (nconc sig (list (ses-cell-symbol row col))))) 2342 (wrong-type-argument 2343 ;; The formula contains a reference. 2344 (cl-pushnew (ses-cell-symbol row col) ses--deferred-recalc 2345 :test #'equal))))) 2346 ;; Do the update now, so we can force recalculation. 2347 (let ((x ses--deferred-recalc)) 2348 (setq ses--deferred-recalc nil) 2349 (condition-case hold 2350 (ses-update-cells x t) 2351 (error (setq sig hold)))) 2352 (cond 2353 (sig 2354 (message "%s" (error-message-string sig))) 2355 ((consp ses--curcell) 2356 (message " ")) 2357 (t 2358 (princ (symbol-value ses--curcell)))))) 2359 2360(defun ses-recalculate-all () 2361 "Recalculate and reprint all cells." 2362 (interactive "*") 2363 (let ((startcell (ses--cell-at-pos (point))) 2364 (ses--curcell (cons (ses-cell-symbol 0 0) 2365 (ses-cell-symbol (1- ses--numrows) 2366 (1- ses--numcols))))) 2367 (ses-recalculate-cell ses--curcell) 2368 (ses-jump-safe startcell))) 2369 2370(defun ses-truncate-cell () 2371 "Reprint current cell, but without spillover into any following blank cells." 2372 (interactive "*") 2373 (ses-check-curcell) 2374 (let* ((rowcol (ses-sym-rowcol ses--curcell)) 2375 (row (car rowcol)) 2376 (col (cdr rowcol))) 2377 (when (and (< col (1- ses--numcols)) ;;Last column can't spill over, anyway 2378 (eq (ses-cell-value row (1+ col)) '*skip*)) 2379 ;; This cell has spill-over. We'll momentarily pretend the following cell 2380 ;; has a t in it. 2381 (cl-progv 2382 (list (ses-cell-symbol row (1+ col))) 2383 '(t) 2384 (ses-print-cell row col)) 2385 ;; Now remove the *skip*. ses-print-cell is always nil here. 2386 (ses-set-cell row (1+ col) 'value nil) 2387 (1value (ses-print-cell row (1+ col)))))) 2388 2389(defun ses-reconstruct-all () 2390 "Reconstruct buffer based on cell data stored in Emacs variables." 2391 (interactive "*") 2392 (ses-begin-change) 2393 ;;Reconstruct reference lists. 2394 (let (x yrow ycol) 2395 ;;Delete old reference lists 2396 (dotimes-with-progress-reporter 2397 (row ses--numrows) "Deleting references..." 2398 (dotimes (col ses--numcols) 2399 (ses-set-cell row col 'references nil))) 2400 ;;Create new reference lists 2401 (dotimes-with-progress-reporter 2402 (row ses--numrows) "Computing references..." 2403 (dotimes (col ses--numcols) 2404 (dolist (ref (ses-formula-references (ses-cell-formula row col))) 2405 (setq x (ses-sym-rowcol ref) 2406 yrow (car x) 2407 ycol (cdr x)) 2408 (ses-set-cell yrow ycol 'references 2409 (cons (ses-cell-symbol row col) 2410 (ses-cell-references yrow ycol))))))) 2411 ;; Delete everything and reconstruct basic data area. 2412 (ses-widen) 2413 (let ((inhibit-read-only t)) 2414 (goto-char (point-max)) 2415 (if (search-backward ";; Local Variables:\n" nil t) 2416 (delete-region (point-min) (point)) 2417 ;; Buffer is quite screwed up --- can't even save the user-specified 2418 ;; locals. 2419 (delete-region (point-min) (point-max)) 2420 (insert ses-initial-file-trailer) 2421 (goto-char (point-min))) 2422 ;; Create a blank display area. 2423 (dotimes (_ ses--numrows) 2424 (insert ses--blank-line)) 2425 (insert ses-print-data-boundary) 2426 (backward-char (1- (length ses-print-data-boundary))) 2427 (setq ses--data-marker (point-marker)) 2428 (forward-char (1- (length ses-print-data-boundary))) 2429 ;; Placeholders for cell data. 2430 (insert (make-string (* ses--numrows (1+ ses--numcols)) ?\n)) 2431 ;; Placeholders for col-widths, col-printers, default-printer, header-row. 2432 (insert "\n\n\n\n") 2433 (insert ses-initial-global-parameters) 2434 (backward-char (1- (length ses-initial-global-parameters))) 2435 (setq ses--params-marker (point-marker)) 2436 (forward-char (1- (length ses-initial-global-parameters)))) 2437 (ses-set-parameter 'ses--col-widths ses--col-widths) 2438 (ses-set-parameter 'ses--col-printers ses--col-printers) 2439 (ses-set-parameter 'ses--default-printer ses--default-printer) 2440 (ses-set-parameter 'ses--header-row ses--header-row) 2441 (ses-set-parameter 'ses--numrows ses--numrows) 2442 (ses-set-parameter 'ses--numcols ses--numcols) 2443 ;;Keep our old narrowing 2444 (ses-setup) 2445 (ses-recalculate-all) 2446 (goto-char (point-min))) 2447 2448 2449;;---------------------------------------------------------------------------- 2450;; Input of cell formulas 2451;;---------------------------------------------------------------------------- 2452(defun ses-edit-cell-complete-symbol () 2453 (interactive) 2454 (let ((completion-at-point-functions (cons 'ses--edit-cell-completion-at-point-function 2455 completion-at-point-functions))) 2456 (completion-at-point))) 2457 2458(defun ses--edit-cell-completion-at-point-function () 2459 (and 2460 ses--completion-table 2461 (let* ((bol (save-excursion (move-beginning-of-line nil) (point))) 2462 start end collection 2463 (prefix 2464 (save-excursion 2465 (setq end (point)) 2466 (backward-sexp) 2467 (if (< (point) bol) 2468 (progn 2469 (setq start bol) 2470 (buffer-substring start end)) 2471 (setq start (point)) 2472 (forward-sexp) 2473 (if (>= (point) end) 2474 (progn 2475 (setq end (point)) 2476 (buffer-substring start end)) 2477 nil)))) 2478 prefix-length) 2479 (when (and prefix (null (string= prefix ""))) 2480 (setq prefix-length (length prefix)) 2481 (maphash (lambda (key _val) 2482 (let ((key-name (symbol-name key))) 2483 (when (and (>= (length key-name) prefix-length) 2484 (string= prefix (substring key-name 0 prefix-length))) 2485 (push key-name collection)))) 2486 ses--completion-table) 2487 (and collection (list start end collection)))))) 2488 2489(defun ses-edit-cell (row col newval) 2490 "Display current cell contents in minibuffer, for editing. 2491Return nil if cell formula was unsafe and user declined confirmation." 2492 (interactive 2493 (progn 2494 (barf-if-buffer-read-only) 2495 (ses-check-curcell) 2496 (let* ((rowcol (ses-sym-rowcol ses--curcell)) 2497 (row (car rowcol)) 2498 (col (cdr rowcol)) 2499 (formula (ses-cell-formula row col)) 2500 initial) 2501 (if (eq (car-safe formula) 'ses-safe-formula) 2502 (setq formula (cadr formula))) 2503 (if (eq (car-safe formula) 'quote) 2504 (setq initial (format "'%S" (cadr formula))) 2505 (setq initial (prin1-to-string formula))) 2506 (if (stringp formula) 2507 ;; Position cursor inside close-quote. 2508 (setq initial (cons initial (length initial)))) 2509 (dolist (key ses-completion-keys) 2510 (define-key ses-mode-edit-map key 'ses-edit-cell-complete-symbol)) 2511 ;; make it globally visible, so that it can be visible from the minibuffer. 2512 (setq ses--completion-table ses--named-cell-hashmap) 2513 (list row col 2514 (read-from-minibuffer (format "Cell %s: " ses--curcell) 2515 initial 2516 ses-mode-edit-map 2517 t ; Convert to Lisp object. 2518 'ses-read-cell-history))))) 2519 (when (ses-warn-unsafe newval 'unsafep) 2520 (ses-begin-change) 2521 (ses-cell-set-formula row col newval) 2522 t)) 2523 2524(defun ses-read-cell (row col newval) 2525 "Self-insert for initial character of cell function." 2526 (interactive 2527 (let* ((initial (this-command-keys)) 2528 (rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell))) 2529 (curval (ses-cell-formula (car rowcol) (cdr rowcol)))) 2530 (barf-if-buffer-read-only) 2531 (list (car rowcol) 2532 (cdr rowcol) 2533 (if (equal initial "\"") 2534 (progn 2535 (if (not (stringp curval)) (setq curval nil)) 2536 (read-string (format-prompt "String Cell %s" 2537 curval ses--curcell) 2538 nil 'ses-read-string-history curval)) 2539 (read-from-minibuffer 2540 (format "Cell %s: " ses--curcell) 2541 (cons (if (equal initial "(") "()" initial) 2) 2542 ses-mode-edit-map 2543 t ; Convert to Lisp object. 2544 'ses-read-cell-history 2545 (prin1-to-string (if (eq (car-safe curval) 'ses-safe-formula) 2546 (cadr curval) 2547 curval))))))) 2548 (when (ses-edit-cell row col newval) 2549 (ses-command-hook) ; Update cell widths before movement. 2550 (dolist (x ses-after-entry-functions) 2551 (funcall x 1)))) 2552 2553(defun ses-read-symbol (row col symb) 2554 "Self-insert for a symbol as a cell formula. 2555The set of all symbols that have been used as formulas in this 2556spreadsheet is available for completions." 2557 (interactive 2558 (let ((rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell))) 2559 newval) 2560 (barf-if-buffer-read-only) 2561 (setq newval (completing-read (format "Cell %s ': " ses--curcell) 2562 ses--symbolic-formulas)) 2563 (list (car rowcol) 2564 (cdr rowcol) 2565 (if (string= newval "") 2566 nil ; Don't create zero-length symbols! 2567 (list 'quote (intern newval)))))) 2568 (when (ses-edit-cell row col symb) 2569 (ses-command-hook) ; Update cell widths before movement. 2570 (dolist (x ses-after-entry-functions) 2571 (funcall x 1)))) 2572 2573(defun ses-clear-cell-forward (count) 2574 "Delete formula and printer for current cell and then move to next cell. 2575With prefix, deletes several cells." 2576 (interactive "*p") 2577 (if (< count 0) 2578 (1value (ses-clear-cell-backward (- count))) 2579 (ses-check-curcell) 2580 (ses-begin-change) 2581 (dotimes (_ count) 2582 (ses-set-curcell) 2583 (let ((rowcol (ses-sym-rowcol ses--curcell))) 2584 (or rowcol (signal 'end-of-buffer nil)) 2585 (ses-clear-cell (car rowcol) (cdr rowcol))) 2586 (forward-char 1)))) 2587 2588(defun ses-clear-cell-backward (count) 2589 "Move to previous cell and then delete it. With prefix, delete several cells." 2590 (interactive "*p") 2591 (if (< count 0) 2592 (1value (ses-clear-cell-forward (- count))) 2593 (ses-check-curcell 'end) 2594 (ses-begin-change) 2595 (dotimes (_ count) 2596 (backward-char 1) ; Will signal 'beginning-of-buffer if appropriate. 2597 (ses-set-curcell) 2598 (let ((rowcol (ses-sym-rowcol ses--curcell))) 2599 (ses-clear-cell (car rowcol) (cdr rowcol)))))) 2600 2601 2602;;---------------------------------------------------------------------------- 2603;; Input of cell-printer functions 2604;;---------------------------------------------------------------------------- 2605(defun ses-read-printer-complete-symbol () 2606 (interactive) 2607 (let ((completion-at-point-functions (cons 'ses--read-printer-completion-at-point-function 2608 completion-at-point-functions))) 2609 (completion-at-point))) 2610 2611(defun ses--read-printer-completion-at-point-function () 2612 (let* ((bol (save-excursion (move-beginning-of-line nil) (point))) 2613 start end collection 2614 (prefix 2615 (save-excursion 2616 (setq end (point)) 2617 (backward-sexp) 2618 (if (< (point) bol) 2619 (progn 2620 (setq start bol) 2621 (buffer-substring start end)) 2622 (setq start (point)) 2623 (forward-sexp) 2624 (if (>= (point) end) 2625 (progn 2626 (setq end (point)) 2627 (buffer-substring start end)) 2628 nil)))) 2629 prefix-length) 2630 (when prefix 2631 (setq prefix-length (length prefix)) 2632 (maphash (lambda (key _val) 2633 (let ((key-name (symbol-name key))) 2634 (when (and (>= (length key-name) prefix-length) 2635 (string= prefix (substring key-name 0 prefix-length))) 2636 (push key-name collection)))) 2637 ses--completion-table) 2638 (and collection (list start end collection))))) 2639 2640(defun ses-read-printer (prompt default) 2641 "Common code for functions `ses-read-cell-printer', `ses-read-column-printer', 2642`ses-read-default-printer' and `ses-define-local-printer'. 2643PROMPT should end with \": \". Result is t if operation was 2644canceled." 2645 (barf-if-buffer-read-only) 2646 (if (eq default t) 2647 (setq default "") 2648 (setq prompt (format-prompt prompt default))) 2649 (dolist (key ses-completion-keys) 2650 (define-key ses-mode-edit-map key 'ses-read-printer-complete-symbol)) 2651 ;; make it globally visible, so that it can be visible from the minibuffer. 2652 (setq ses--completion-table ses--local-printer-hashmap) 2653 (let ((new (read-from-minibuffer prompt 2654 nil ; Initial contents. 2655 ses-mode-edit-map 2656 t ; Evaluate the result. 2657 'ses-read-printer-history 2658 (prin1-to-string default)))) 2659 (if (equal new default) 2660 ;; User changed mind, decided not to change printer. 2661 (setq new t) 2662 (ses-printer-validate new) 2663 (or (not new) 2664 (stringp new) 2665 (stringp (car-safe new)) 2666 (and (symbolp new) (gethash new ses--local-printer-hashmap)) 2667 (ses-warn-unsafe new 'unsafep-function) 2668 (setq new t))) 2669 new)) 2670 2671(defun ses-read-cell-printer (newval) 2672 "Set the printer function for the current cell or range. 2673 2674A printer function is either a string (a format control-string with one 2675%-sequence -- result from format will be right-justified), or a list of one 2676string (result from format will be left-justified), or a lambda-expression of 2677one argument, or a symbol that names a function of one argument. In the 2678latter two cases, the function's result should be either a string (will be 2679right-justified) or a list of one string (will be left-justified)." 2680 (interactive 2681 (let ((default t)) 2682 (ses-check-curcell 'range) 2683 ;;Default is none if not all cells in range have same printer 2684 (catch 'ses-read-cell-printer 2685 (ses-dorange ses--curcell 2686 (let ((x (ses-cell-printer row col))) 2687 (if (eq (car-safe x) 'ses-safe-printer) 2688 (setq x (cadr x))) 2689 (if (eq default t) 2690 (setq default x) 2691 (unless (equal default x) 2692 ;;Range contains differing printer functions 2693 (setq default t) 2694 (throw 'ses-read-cell-printer t)))))) 2695 (list (ses-read-printer (format "Cell %S printer" ses--curcell) 2696 default)))) 2697 (unless (eq newval t) 2698 (ses-begin-change) 2699 (ses-dorange ses--curcell 2700 (ses-set-cell row col 'printer newval) 2701 (ses-print-cell row col)))) 2702 2703(defun ses-read-column-printer (col newval) 2704 "Set the printer function for the current column. 2705See `ses-read-cell-printer' for input forms." 2706 (interactive 2707 (let ((col (cdr (ses-sym-rowcol ses--curcell)))) 2708 (ses-check-curcell) 2709 (list col (ses-read-printer (format "Column %s printer" 2710 (ses-column-letter col)) 2711 (ses-col-printer col))))) 2712 2713 (unless (eq newval t) 2714 (ses-begin-change) 2715 (ses-set-parameter 'ses--col-printers newval col) 2716 (save-excursion 2717 (dotimes (row ses--numrows) 2718 (ses-print-cell row col))))) 2719 2720(defun ses-read-default-printer (newval) 2721 "Set the default printer function for cells that have no other. 2722See `ses-read-cell-printer' for input forms." 2723 (interactive 2724 (list (ses-read-printer "Default printer" ses--default-printer))) 2725 (unless (eq newval t) 2726 (ses-begin-change) 2727 (ses-set-parameter 'ses--default-printer newval) 2728 (ses-reprint-all t))) 2729 2730 2731;;---------------------------------------------------------------------------- 2732;; Spreadsheet size adjustments 2733;;---------------------------------------------------------------------------- 2734 2735(defun ses-insert-row (count) 2736 "Insert a new row before the current one. 2737With prefix, insert COUNT rows before current one." 2738 (interactive "*p") 2739 (ses-check-curcell 'end) 2740 (or (> count 0) (signal 'args-out-of-range nil)) 2741 (ses-begin-change) 2742 (let ((inhibit-quit t) 2743 (inhibit-read-only t) 2744 (row (or (car (ses-sym-rowcol ses--curcell)) ses--numrows)) 2745 newrow) 2746 ;;Create a new set of cell-variables 2747 (ses-create-cell-variable-range ses--numrows (+ ses--numrows count -1) 2748 0 (1- ses--numcols)) 2749 (ses-set-parameter 'ses--numrows (+ ses--numrows count)) 2750 ;;Insert each row 2751 (ses-goto-print row 0) 2752 (dotimes-with-progress-reporter (x count) "Inserting row..." 2753 ;;Create a row of empty cells. The `symbol' fields will be set by 2754 ;;the call to ses-relocate-all. 2755 (setq newrow (make-vector ses--numcols nil)) 2756 (dotimes (col ses--numcols) 2757 (aset newrow col (ses-make-cell))) 2758 (setq ses--cells (ses-vector-insert ses--cells row newrow)) 2759 (push `(apply ses-vector-delete ses--cells ,row 1) buffer-undo-list) 2760 (insert ses--blank-line)) 2761 ;;Insert empty lines in cell data area (will be replaced by 2762 ;;ses-relocate-all) 2763 (ses-goto-data row 0) 2764 (insert (make-string (* (1+ ses--numcols) count) ?\n)) 2765 (ses-relocate-all row 0 count 0) 2766 ;;If any cell printers insert constant text, insert that text 2767 ;;into the line. 2768 (let ((cols (mapconcat #'ses-call-printer ses--col-printers nil)) 2769 (global (ses-call-printer ses--default-printer))) 2770 (if (or (> (length cols) 0) (> (length global) 0)) 2771 (dotimes (x count) 2772 (dotimes (col ses--numcols) 2773 ;;These cells are always nil, only constant formatting printed 2774 (1value (ses-print-cell (+ x row) col)))))) 2775 (when (> ses--header-row row) 2776 ;;Inserting before header 2777 (ses-set-parameter 'ses--header-row (+ ses--header-row count)) 2778 (ses-reset-header-string))) 2779 ;;Reconstruct text attributes 2780 (ses-setup) 2781 ;;Prepare for undo 2782 (push '(apply ses-widen) buffer-undo-list) 2783 ;;Return to current cell 2784 (if ses--curcell 2785 (ses-jump-safe ses--curcell) 2786 (ses-goto-print (1- ses--numrows) 0))) 2787 2788(defun ses-delete-row (count) 2789 "Delete the current row. 2790With prefix, deletes COUNT rows starting from the current one." 2791 (interactive "*p") 2792 (ses-check-curcell) 2793 (or (> count 0) (signal 'args-out-of-range nil)) 2794 (let ((inhibit-quit t) 2795 (inhibit-read-only t) 2796 (row (car (ses-sym-rowcol ses--curcell)))) 2797 (setq count (min count (- ses--numrows row))) 2798 (ses-begin-change) 2799 (ses-set-parameter 'ses--numrows (- ses--numrows count)) 2800 ;;Delete lines from print area 2801 (ses-goto-print row 0) 2802 (ses-delete-line count) 2803 ;;Delete lines from cell data area 2804 (ses-goto-data row 0) 2805 (ses-delete-line (* count (1+ ses--numcols))) 2806 ;; Collect named cells in the deleted rows, in order to clean the 2807 ;; symbols out of the named cell hash map, once the deletion is 2808 ;; complete 2809 (unless (null ses--in-killing-named-cell-list) 2810 (warn "Internal error, `ses--in-killing-named-cell-list' should be nil, but is equal to %S" 2811 ses--in-killing-named-cell-list) 2812 (setq ses--in-killing-named-cell-list nil)) 2813 (dotimes-with-progress-reporter (nrow count) 2814 "Collecting named cell in deleted rows..." 2815 (dotimes (col ses--numcols) 2816 (let* ((row (+ row nrow)) 2817 (sym (ses-cell-symbol row col))) 2818 (and (eq (get sym 'ses-cell) :ses-named) 2819 (push sym ses--in-killing-named-cell-list))))) 2820 ;;Relocate variables and formulas 2821 (ses-set-with-undo 'ses--cells (ses-vector-delete ses--cells row count)) 2822 (ses-relocate-all row 0 (- count) 0) 2823 (ses-destroy-cell-variable-range ses--numrows (+ ses--numrows count -1) 2824 0 (1- ses--numcols)) 2825 (when (> ses--header-row row) 2826 (if (<= ses--header-row (+ row count)) 2827 ;;Deleting the header row 2828 (ses-set-parameter 'ses--header-row 0) 2829 (ses-set-parameter 'ses--header-row (- ses--header-row count))) 2830 (ses-reset-header-string))) 2831 ;;Reconstruct attributes 2832 (ses-setup) 2833 ;;Prepare for undo 2834 (push '(apply ses-widen) buffer-undo-list) 2835 (ses-jump-safe ses--curcell)) 2836 2837(defun ses-insert-column (count &optional col width printer) 2838 "Insert a new column before COL (default is the current one). 2839With prefix, insert COUNT columns before current one. 2840If COL is specified, the new column(s) get the specified WIDTH and PRINTER 2841\(otherwise they're taken from the current column)." 2842 (interactive "*p") 2843 (ses-check-curcell) 2844 (or (> count 0) (signal 'args-out-of-range nil)) 2845 (or col 2846 (setq col (cdr (ses-sym-rowcol ses--curcell)) 2847 width (ses-col-width col) 2848 printer (ses-col-printer col))) 2849 (ses-begin-change) 2850 (let ((inhibit-quit t) 2851 (inhibit-read-only t) 2852 (widths ses--col-widths) 2853 (printers ses--col-printers) 2854 has-skip) 2855 ;;Create a new set of cell-variables 2856 (ses-create-cell-variable-range 0 (1- ses--numrows) 2857 ses--numcols (+ ses--numcols count -1)) 2858 ;;Insert each column. 2859 (dotimes-with-progress-reporter (x count) "Inserting column..." 2860 ;;Create a column of empty cells. The `symbol' fields will be set by 2861 ;;the call to ses-relocate-all. 2862 (ses-adjust-print-width col (1+ width)) 2863 (ses-set-parameter 'ses--numcols (1+ ses--numcols)) 2864 (dotimes (row ses--numrows) 2865 (and (< (1+ col) ses--numcols) (eq (ses-cell-value row col) '*skip*) 2866 ;;Inserting in the middle of a spill-over 2867 (setq has-skip t)) 2868 (ses-aset-with-undo ses--cells row 2869 (ses-vector-insert (aref ses--cells row) 2870 col (ses-make-cell))) 2871 ;;Insert empty lines in cell data area (will be replaced by 2872 ;;ses-relocate-all) 2873 (ses-goto-data row col) 2874 (insert ?\n)) 2875 ;; Insert column width and printer. 2876 (setq widths (ses-vector-insert widths col width) 2877 printers (ses-vector-insert printers col printer))) 2878 (ses-set-parameter 'ses--col-widths widths) 2879 (ses-set-parameter 'ses--col-printers printers) 2880 (ses-reset-header-string) 2881 (ses-relocate-all 0 col 0 count) 2882 (if has-skip 2883 (ses-reprint-all t) 2884 (when (or (> (length (ses-call-printer printer)) 0) 2885 (> (length (ses-call-printer ses--default-printer)) 0)) 2886 ;; Either column printer or global printer inserts some constant text. 2887 ;; Reprint the new columns to insert that text. 2888 (dotimes (x ses--numrows) 2889 (dotimes (y count) 2890 ;; Always nil here --- this is a blank column. 2891 (1value (ses-print-cell-new-width x (+ y col)))))) 2892 (ses-setup))) 2893 (ses-jump-safe ses--curcell)) 2894 2895(defun ses-delete-column (count) 2896 "Delete the current column. 2897With prefix, deletes COUNT columns starting from the current one." 2898 (interactive "*p") 2899 (ses-check-curcell) 2900 (or (> count 0) (signal 'args-out-of-range nil)) 2901 (let ((inhibit-quit t) 2902 (inhibit-read-only t) 2903 (rowcol (ses-sym-rowcol ses--curcell)) 2904 (width 0) 2905 col origrow has-skip) 2906 (setq origrow (car rowcol) 2907 col (cdr rowcol) 2908 count (min count (- ses--numcols col))) 2909 (if (= count ses--numcols) 2910 (error "Can't delete all columns!")) 2911 ;;Determine width of column(s) being deleted 2912 (dotimes (x count) 2913 (setq width (+ width (ses-col-width (+ col x)) 1))) 2914 (ses-begin-change) 2915 (ses-set-parameter 'ses--numcols (- ses--numcols count)) 2916 (ses-adjust-print-width col (- width)) 2917 ;; Prepare collecting named cells in the deleted columns, in order 2918 ;; to clean the symbols out of the named cell hash map, once the 2919 ;; deletion is complete 2920 (unless (null ses--in-killing-named-cell-list) 2921 (warn "Internal error, `ses--in-killing-named-cell-list' should be nil, but is equal to %S" 2922 ses--in-killing-named-cell-list) 2923 (setq ses--in-killing-named-cell-list nil)) 2924 (dotimes-with-progress-reporter (row ses--numrows) "Deleting column..." 2925 ;;Delete lines from cell data area 2926 (ses-goto-data row col) 2927 (ses-delete-line count) 2928 ;; Collect named cells in the deleted columns within this row 2929 (dotimes (ncol count) 2930 (let ((sym (ses-cell-symbol row (+ col ncol)))) 2931 (and (eq (get sym 'ses-cell) :ses-named) 2932 (push sym ses--in-killing-named-cell-list)))) 2933 ;;Delete cells. Check if deletion area begins or ends with a skip. 2934 (if (or (eq (ses-cell-value row col) '*skip*) 2935 (and (< col ses--numcols) 2936 (eq (ses-cell-value row (+ col count)) '*skip*))) 2937 (setq has-skip t)) 2938 (ses-aset-with-undo ses--cells row 2939 (ses-vector-delete (aref ses--cells row) col count))) 2940 ;;Update globals 2941 (ses-set-parameter 'ses--col-widths 2942 (ses-vector-delete ses--col-widths col count)) 2943 (ses-set-parameter 'ses--col-printers 2944 (ses-vector-delete ses--col-printers col count)) 2945 (ses-reset-header-string) 2946 ;;Relocate variables and formulas 2947 (ses-relocate-all 0 col 0 (- count)) 2948 (ses-destroy-cell-variable-range 0 (1- ses--numrows) 2949 ses--numcols (+ ses--numcols count -1)) 2950 (if has-skip 2951 (ses-reprint-all t) 2952 (ses-setup)) 2953 (if (>= col ses--numcols) 2954 (setq col (1- col))) 2955 (ses-goto-print origrow col))) 2956 2957(defun ses-forward-or-insert (&optional count) 2958 "Move to next cell in row, or inserts a new cell if already in last one, or 2959inserts a new row if at bottom of print area. Repeat COUNT times." 2960 (interactive "p") 2961 (ses-check-curcell 'end) 2962 (setq deactivate-mark t) ; Doesn't combine well with ranges. 2963 (dotimes (x count) 2964 (ses-set-curcell) 2965 (if (not ses--curcell) 2966 (progn ; At bottom of print area. 2967 (barf-if-buffer-read-only) 2968 (ses-insert-row 1)) 2969 (let ((col (cdr (ses-sym-rowcol ses--curcell)))) 2970 (when (/= 32 2971 (char-before (next-single-property-change (point) 2972 'cursor-intangible))) 2973 ;; We're already in last nonskipped cell on line. Need to create a 2974 ;; new column. 2975 (barf-if-buffer-read-only) 2976 (ses-insert-column (- count x) 2977 ses--numcols 2978 (ses-col-width col) 2979 (ses-col-printer col))))) 2980 (forward-char))) 2981 2982(defun ses-append-row-jump-first-column () 2983 "Insert a new row after current one and jump to its first column." 2984 (interactive "*") 2985 (ses-check-curcell) 2986 (ses-begin-change) 2987 (beginning-of-line 2) 2988 (ses-set-curcell) 2989 (ses-insert-row 1)) 2990 2991(defun ses-set-column-width (col newwidth) 2992 "Set the width of the current column." 2993 (interactive 2994 (let ((col (cdr (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell))))) 2995 (barf-if-buffer-read-only) 2996 (list col 2997 (if current-prefix-arg 2998 (prefix-numeric-value current-prefix-arg) 2999 (read-from-minibuffer (format-prompt "Column %s width" 3000 (ses-col-width col) 3001 (ses-column-letter col)) 3002 nil ; No initial contents. 3003 nil ; No override keymap. 3004 t ; Convert to Lisp object. 3005 nil ; No history. 3006 (number-to-string 3007 (ses-col-width col))))))) ; Default value. 3008 (if (< newwidth 1) 3009 (error "Invalid column width")) 3010 (ses-begin-change) 3011 (ses-reset-header-string) 3012 (save-excursion 3013 (let ((inhibit-quit t)) 3014 (ses-adjust-print-width col (- newwidth (ses-col-width col))) 3015 (ses-set-parameter 'ses--col-widths newwidth col)) 3016 (dotimes (row ses--numrows) 3017 (ses-print-cell-new-width row col)))) 3018 3019 3020;;---------------------------------------------------------------------------- 3021;; Cut and paste, import and export 3022;;---------------------------------------------------------------------------- 3023 3024(defun ses--advice-copy-region-as-kill (crak-fun beg end &rest args) 3025 ;; FIXME: Why doesn't it make sense to copy read-only or 3026 ;; intangible attributes? They're removed upon yank! 3027 "It doesn't make sense to copy read-only or intangible attributes into the 3028kill ring. It probably doesn't make sense to copy keymap properties. 3029We'll assume copying front-sticky properties doesn't make sense, either. 3030 3031This advice also includes some SES-specific code because otherwise it's too 3032hard to override how mouse-1 works." 3033 (when (and beg end (> beg end)) 3034 (let ((temp beg)) 3035 (setq beg end 3036 end temp))) 3037 (if (not (and (derived-mode-p 'ses-mode) 3038 (eq (get-text-property beg 'read-only) 'ses) 3039 (eq (get-text-property (1- end) 'read-only) 'ses))) 3040 (apply crak-fun beg end args) ; Normal copy-region-as-kill. 3041 (kill-new (ses-copy-region beg end)) 3042 (if transient-mark-mode 3043 (setq deactivate-mark t)) 3044 nil)) 3045(advice-add 'copy-region-as-kill :around #'ses--advice-copy-region-as-kill) 3046 3047(defun ses-copy-region (beg end) 3048 "Treat the region as rectangular. 3049Convert the intangible attributes to SES attributes recording the 3050contents of the cell as of the time of copying." 3051 (when (= end ses--data-marker) 3052 ;;Avoid overflow situation 3053 (setq end (1- ses--data-marker))) 3054 (let* ((x (mapconcat #'ses-copy-region-helper 3055 (extract-rectangle beg (1- end)) "\n"))) 3056 (remove-text-properties 0 (length x) 3057 '(read-only t 3058 cursor-intangible t 3059 keymap t 3060 front-sticky t) 3061 x) 3062 x)) 3063 3064(defun ses-copy-region-helper (line) 3065 "Convert one line (of a rectangle being extracted from a spreadsheet) to 3066external form by attaching to each print cell a `ses' attribute that records 3067the corresponding data cell." 3068 (or (> (length line) 1) 3069 (error "Empty range")) 3070 (let ((inhibit-read-only t) 3071 (pos 0) 3072 mycell next sym rowcol) 3073 (while pos 3074 (setq sym (ses--cell-at-pos pos line) 3075 next (next-single-property-change pos 'cursor-intangible line) 3076 rowcol (ses-sym-rowcol sym) 3077 mycell (ses-get-cell (car rowcol) (cdr rowcol))) 3078 (put-text-property pos (or next (length line)) 3079 'ses 3080 (list (ses-cell-symbol mycell) 3081 (ses-cell-formula mycell) 3082 (ses-cell-printer mycell)) 3083 line) 3084 (setq pos next))) 3085 line) 3086 3087(defun ses-kill-override (beg end) 3088 "Generic override for any commands that kill text. 3089We clear the killed cells instead of deleting them." 3090 (interactive "r") 3091 (ses-check-curcell 'needrange) 3092 ;; For some reason, the text-read-only error is not caught by `delete-region', 3093 ;; so we have to use subterfuge. 3094 (let ((buffer-read-only t)) 3095 (1value (condition-case nil 3096 (noreturn (funcall (lookup-key (current-global-map) 3097 (this-command-keys)) 3098 beg end)) 3099 (buffer-read-only nil)))) ; The expected error. 3100 ;; Because the buffer was marked read-only, the kill command turned itself 3101 ;; into a copy. Now we clear the cells or signal the error. First we check 3102 ;; whether the buffer really is read-only. 3103 (barf-if-buffer-read-only) 3104 (ses-begin-change) 3105 (ses-dorange ses--curcell 3106 (ses-clear-cell row col)) 3107 (ses-jump (car ses--curcell))) 3108 3109(defun ses--advice-yank (yank-fun &optional arg &rest args) 3110 "In SES mode, the yanked text is inserted as cells. 3111 3112If the text contains `ses' attributes (meaning it went to the kill-ring from a 3113SES buffer), the formulas and print functions are restored for the cells. If 3114the text contains tabs, this is an insertion of tab-separated formulas. 3115Otherwise the text is inserted as the formula for the current cell. 3116 3117When inserting cells, the formulas are usually relocated to keep the same 3118relative references to neighboring cells. This is best if the formulas 3119generally refer to other cells within the yanked text. You can use the \\[universal-argument] 3120prefix to specify insertion without relocation, which is best when the 3121formulas refer to cells outside the yanked text. 3122 3123When inserting formulas, the text is treated as a string constant if it doesn't 3124make sense as a sexp or would otherwise be considered a symbol. Use `sym' to 3125explicitly insert a symbol, or use the \\[universal-argument] prefix to treat all unmarked words 3126as symbols." 3127 (if (not (and (derived-mode-p 'ses-mode) 3128 (eq (get-text-property (point) 'keymap) 'ses-mode-print-map))) 3129 (apply yank-fun arg args) ; Normal non-SES yank. 3130 (ses-check-curcell 'end) 3131 (push-mark) 3132 (let ((text (current-kill (cond 3133 ((listp arg) 0) 3134 ((eq arg '-) -1) 3135 (t (1- arg)))))) 3136 (or (ses-yank-cells text arg) 3137 (ses-yank-tsf text arg) 3138 (ses-yank-one (ses-yank-resize 1 1) 3139 text 3140 0 3141 (if (memq (aref text (1- (length text))) '(?\t ?\n)) 3142 ;; Just one cell --- delete final tab or newline. 3143 (1- (length text))) 3144 arg))) 3145 (if (consp arg) 3146 (exchange-point-and-mark)))) 3147(advice-add 'yank :around #'ses--advice-yank) 3148 3149(defun ses-yank-pop (arg) 3150 "Replace just-yanked stretch of killed text with a different stretch. 3151This command is allowed only immediately after a `yank' or a `yank-pop', 3152when the region contains a stretch of reinserted previously-killed text. 3153We replace it with a different stretch of killed text. 3154 Unlike standard `yank-pop', this function uses `undo' to delete the 3155previous insertion." 3156 (interactive "*p") 3157 (or (eq last-command 'yank) 3158 ;;Use noreturn here just to avoid a "poor-coverage" warning in its 3159 ;;macro definition. 3160 (noreturn (error "Previous command was not a yank"))) 3161 (undo) 3162 (ses-set-curcell) 3163 (yank (1+ (or arg 1))) 3164 (setq this-command 'yank)) 3165 3166(defun ses-yank-cells (text arg) 3167 "If TEXT has a proper set of `ses' attributes, insert it as cells. 3168Otherwise, return nil. The cells are reprinted--the supplied text is 3169ignored because the column widths, default printer, etc. at yank time might 3170be different from those at kill-time. ARG is a list to indicate that 3171formulas are to be inserted without relocation." 3172 (let ((first (get-text-property 0 'ses text)) 3173 (last (get-text-property (1- (length text)) 'ses text))) 3174 (when (and first last) ;;Otherwise not proper set of attributes 3175 (setq first (ses-sym-rowcol (car first)) 3176 last (ses-sym-rowcol (car last))) 3177 (let* ((needrows (- (car last) (car first) -1)) 3178 (needcols (- (cdr last) (cdr first) -1)) 3179 (rowcol (ses-yank-resize needrows needcols)) 3180 (rowincr (- (car rowcol) (car first))) 3181 (colincr (- (cdr rowcol) (cdr first))) 3182 (pos 0) 3183 myrow mycol x) 3184 (dotimes-with-progress-reporter (row needrows) "Yanking..." 3185 (setq myrow (+ row (car rowcol))) 3186 (dotimes (col needcols) 3187 (setq mycol (+ col (cdr rowcol)) 3188 last (get-text-property pos 'ses text) 3189 pos (next-single-property-change pos 'ses text) 3190 x (ses-sym-rowcol (car last))) 3191 (if (not last) 3192 ;; Newline --- all remaining cells on row are skipped. 3193 (setq x (cons (- myrow rowincr) (+ needcols colincr -1)) 3194 last (list nil nil nil) 3195 pos (1- pos))) 3196 (if (/= (car x) (- myrow rowincr)) 3197 (error "Cell row error")) 3198 (if (< (- mycol colincr) (cdr x)) 3199 ;; Some columns were skipped. 3200 (let ((oldcol mycol)) 3201 (while (< (- mycol colincr) (cdr x)) 3202 (ses-clear-cell myrow mycol) 3203 (setq col (1+ col) 3204 mycol (1+ mycol))) 3205 (ses-print-cell myrow (1- oldcol)))) ;; This inserts *skip*. 3206 (when (car last) ; Skip this for *skip* cells. 3207 (setq x (nth 2 last)) 3208 (unless (equal x (ses-cell-printer myrow mycol)) 3209 (or (not x) 3210 (stringp x) 3211 (eq (car-safe x) 'ses-safe-printer) 3212 (setq x `(ses-safe-printer ,x))) 3213 (ses-set-cell myrow mycol 'printer x)) 3214 (setq x (cadr last)) 3215 (if (atom arg) 3216 (setq x (ses-relocate-formula x 0 0 rowincr colincr))) 3217 (or (atom x) 3218 (eq (car-safe x) 'ses-safe-formula) 3219 (setq x `(ses-safe-formula ,x))) 3220 (ses-cell-set-formula myrow mycol x))) 3221 (when pos 3222 (if (get-text-property pos 'ses text) 3223 (error "Missing newline between rows")) 3224 (setq pos (next-single-property-change pos 'ses text)))) 3225 t)))) 3226 3227(defun ses-yank-one (rowcol text from to arg) 3228 "Insert the substring [FROM,TO] of TEXT as the formula for cell ROWCOL (a 3229cons of ROW and COL). Treat plain symbols as strings unless ARG is a list." 3230 (let ((val (condition-case nil 3231 (read-from-string text from to) 3232 (error (cons nil from))))) 3233 (cond 3234 ((< (cdr val) (or to (length text))) 3235 ;; Invalid sexp --- leave it as a string. 3236 (setq val (substring text from to))) 3237 ((and (car val) (symbolp (car val))) 3238 (setq val (if (consp arg) 3239 (list 'quote (car val)) ; Keep symbol. 3240 (substring text from to)))) ; Treat symbol as text. 3241 (t 3242 (setq val (car val)))) 3243 (let ((row (car rowcol)) 3244 (col (cdr rowcol))) 3245 (or (atom val) 3246 (setq val `(ses-safe-formula ,val))) 3247 (ses-cell-set-formula row col val)))) 3248 3249(defun ses-yank-tsf (text arg) 3250 "If TEXT contains tabs and/or newlines, treat the tabs as 3251column-separators and the newlines as row-separators and insert the text as 3252cell formulas--else return nil. Treat plain symbols as strings unless ARG 3253is a list. Ignore a final newline." 3254 (if (or (not (string-match "[\t\n]" text)) 3255 (= (match-end 0) (length text))) 3256 ;;Not TSF format 3257 nil 3258 (if (/= (aref text (1- (length text))) ?\n) 3259 (setq text (concat text "\n"))) 3260 (let ((pos -1) 3261 (spots (list -1)) 3262 (cols 0) 3263 (needrows 0) 3264 needcols rowcol) 3265 ;;Find all the tabs and newlines 3266 (while (setq pos (string-match "[\t\n]" text (1+ pos))) 3267 (push pos spots) 3268 (setq cols (1+ cols)) 3269 (when (eq (aref text pos) ?\n) 3270 (if (not needcols) 3271 (setq needcols cols) 3272 (or (= needcols cols) 3273 (error "Inconsistent row lengths"))) 3274 (setq cols 0 3275 needrows (1+ needrows)))) 3276 ;;Insert the formulas 3277 (setq rowcol (ses-yank-resize needrows needcols)) 3278 (dotimes (row needrows) 3279 (dotimes (col needcols) 3280 (ses-yank-one (cons (+ (car rowcol) needrows (- row) -1) 3281 (+ (cdr rowcol) needcols (- col) -1)) 3282 text (1+ (cadr spots)) (car spots) arg) 3283 (setq spots (cdr spots)))) 3284 (ses-goto-print (+ (car rowcol) needrows -1) 3285 (+ (cdr rowcol) needcols -1)) 3286 t))) 3287 3288(defun ses-yank-resize (needrows needcols) 3289 "If this yank will require inserting rows and/or columns, ask for 3290confirmation and then insert them. Result is (row,col) for top left of yank 3291spot, or error signal if user requests cancel." 3292 (ses-begin-change) 3293 (let ((rowcol (if ses--curcell 3294 (ses-sym-rowcol ses--curcell) 3295 (cons ses--numrows 0))) 3296 rowbool colbool) 3297 (setq needrows (- (+ (car rowcol) needrows) ses--numrows) 3298 needcols (- (+ (cdr rowcol) needcols) ses--numcols) 3299 rowbool (> needrows 0) 3300 colbool (> needcols 0)) 3301 (when (or rowbool colbool) 3302 ;;Need to insert. Get confirm 3303 (or (y-or-n-p (format "Yank will insert %s%s%s. Continue? " 3304 (if rowbool (format "%d rows" needrows) "") 3305 (if (and rowbool colbool) " and " "") 3306 (if colbool (format "%d columns" needcols) ""))) 3307 (error "Canceled")) 3308 (when rowbool 3309 (let (ses--curcell) 3310 (save-excursion 3311 (ses-goto-print ses--numrows 0) 3312 (ses-insert-row needrows)))) 3313 (when colbool 3314 (ses-insert-column needcols 3315 ses--numcols 3316 (ses-col-width (1- ses--numcols)) 3317 (ses-col-printer (1- ses--numcols))))) 3318 rowcol)) 3319 3320(defun ses-export-tsv (_beg _end) 3321 "Export values from the current range, with tabs between columns and 3322newlines between rows. Result is placed in kill ring." 3323 (interactive "r") 3324 (ses-export-tab nil)) 3325 3326(defun ses-export-tsf (_beg _end) 3327 "Export formulas from the current range, with tabs between columns and 3328newlines between rows. Result is placed in kill ring." 3329 (interactive "r") 3330 (ses-export-tab t)) 3331 3332(defun ses-export-tab (want-formulas) 3333 "Export the current range with tabs between columns and newlines between rows. 3334Result is placed in kill ring. The export is values unless WANT-FORMULAS 3335is non-nil. Newlines and tabs in the export text are escaped." 3336 (ses-check-curcell 'needrange) 3337 (let ((print-escape-newlines t) 3338 result item) 3339 (ses-dorange ses--curcell 3340 (setq item (if want-formulas 3341 (ses-cell-formula row col) 3342 (ses-cell-value row col))) 3343 (if (eq (car-safe item) 'ses-safe-formula) 3344 ;;Hide our deferred safety-check marker 3345 (setq item (cadr item))) 3346 (if (or (not item) (eq item '*skip*)) 3347 (setq item "")) 3348 (when (eq (car-safe item) 'quote) 3349 (push "'" result) 3350 (setq item (cadr item))) 3351 (setq item (ses-prin1 item)) 3352 (setq item (string-replace "\t" "\\t" item)) 3353 (push item result) 3354 (cond 3355 ((< col maxcol) 3356 (push "\t" result)) 3357 ((< row maxrow) 3358 (push "\n" result)))) 3359 (setq result (apply #'concat (nreverse result))) 3360 (kill-new result))) 3361 3362;;---------------------------------------------------------------------------- 3363;; Interactive help on symbols 3364;;---------------------------------------------------------------------------- 3365 3366(defun ses-list-local-printers (&optional local-printer-hashmap) 3367 "List local printers in a help buffer. 3368Can be called either during editing a printer or a formula, or 3369while in the SES buffer." 3370 (interactive 3371 (list (cond 3372 ((derived-mode-p 'ses-mode) ses--local-printer-hashmap) 3373 ((minibufferp) ses--completion-table) 3374 ((derived-mode-p 'help-mode) nil) 3375 (t (user-error "Not in a SES buffer"))))) 3376 (when local-printer-hashmap 3377 (let ((ses--list-orig-buffer (or ses--list-orig-buffer (current-buffer)))) 3378 (help-setup-xref 3379 (list (lambda (local-printer-hashmap buffer) 3380 (let ((ses--list-orig-buffer 3381 (if (buffer-live-p buffer) buffer))) 3382 (ses-list-local-printers local-printer-hashmap))) 3383 local-printer-hashmap ses--list-orig-buffer) 3384 (called-interactively-p 'interactive)) 3385 3386 (save-excursion 3387 (with-help-window (help-buffer) 3388 (if (= 0 (hash-table-count local-printer-hashmap)) 3389 (princ "No local printers defined.") 3390 (princ "List of local printers definitions:\n") 3391 (maphash (lambda (key val) 3392 (princ key) 3393 (princ " as ") 3394 (prin1 (ses--locprn-def val)) 3395 (princ "\n")) 3396 local-printer-hashmap)) 3397 (with-current-buffer standard-output 3398 (buffer-string))))))) 3399 3400(defun ses-list-named-cells (&optional named-cell-hashmap) 3401 "List named cells in a help buffer. 3402Can be called either during editing a printer or a formula, or 3403while in the SES buffer." 3404 (interactive 3405 (list (cond 3406 ((derived-mode-p 'ses-mode) ses--named-cell-hashmap) 3407 ((minibufferp) ses--completion-table) 3408 ((derived-mode-p 'help-mode) nil) 3409 (t (user-error "Not in a SES buffer"))))) 3410 (when named-cell-hashmap 3411 (let ((ses--list-orig-buffer (or ses--list-orig-buffer (current-buffer)))) 3412 (help-setup-xref 3413 (list (lambda (named-cell-hashmap buffer) 3414 (let ((ses--list-orig-buffer 3415 (if (buffer-live-p buffer) buffer))) 3416 (ses-list-named-cells named-cell-hashmap))) 3417 named-cell-hashmap ses--list-orig-buffer) 3418 (called-interactively-p 'interactive)) 3419 3420 (save-excursion 3421 (with-help-window (help-buffer) 3422 (if (= 0 (hash-table-count named-cell-hashmap)) 3423 (princ "No cell was renamed.") 3424 (princ "List of named cells definitions:\n") 3425 (maphash (lambda (key val) 3426 (princ key) 3427 (princ " for ") 3428 (prin1 (ses-create-cell-symbol (car val) (cdr val))) 3429 (princ "\n")) 3430 named-cell-hashmap)) 3431 (with-current-buffer standard-output 3432 (buffer-string))))))) 3433 3434 3435;;---------------------------------------------------------------------------- 3436;; Other user commands 3437;;---------------------------------------------------------------------------- 3438 3439(defun ses-unset-header-row () 3440 "Select the default header row." 3441 (interactive) 3442 (ses-set-header-row 0)) 3443 3444(defun ses-set-header-row (row) 3445 "Set the ROW to display in the header-line. 3446With a numerical prefix arg, use that row. 3447With no prefix arg, use the current row. 3448With a \\[universal-argument] prefix arg, prompt the user. 3449The top row is row 1. Selecting row 0 displays the default header row." 3450 (interactive 3451 (list (if (numberp current-prefix-arg) current-prefix-arg 3452 (let* ((curcell (or (ses--cell-at-pos (point)) 3453 (user-error "Invalid header-row"))) 3454 (currow (1+ (car (ses-sym-rowcol curcell))))) 3455 (if current-prefix-arg 3456 (read-number "Header row: " currow) 3457 currow))))) 3458 (if (or (< row 0) (> row ses--numrows)) 3459 (error "Invalid header-row")) 3460 (ses-begin-change) 3461 (let ((oldval ses--header-row)) 3462 (let (buffer-undo-list) 3463 (ses-set-parameter 'ses--header-row row)) 3464 (push `(apply ses-set-header-row ,oldval) buffer-undo-list)) 3465 (ses-reset-header-string)) 3466 3467(defun ses-mark-row () 3468 "Mark the entirety of current row as a range." 3469 (interactive) 3470 (ses-check-curcell 'range) 3471 (let ((row (car (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell))))) 3472 (push-mark) 3473 (ses-goto-print (1+ row) 0) 3474 (push-mark (point) nil t) 3475 (ses-goto-print row 0))) 3476 3477(defun ses-mark-column () 3478 "Mark the entirety of current column as a range." 3479 (interactive) 3480 (ses-check-curcell 'range) 3481 (let ((col (cdr (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell)))) 3482 (row 0)) 3483 (push-mark) 3484 (ses-goto-print (1- ses--numrows) col) 3485 (forward-char 1) 3486 (push-mark (point) nil t) 3487 (while (eq '*skip* (ses-cell-value row col)) 3488 ;;Skip over initial cells in column that can't be selected 3489 (setq row (1+ row))) 3490 (ses-goto-print row col))) 3491 3492(defun ses-end-of-line () 3493 "Move point to last cell on line." 3494 (interactive) 3495 (ses-check-curcell 'end 'range) 3496 (when ses--curcell ; Otherwise we're at the bottom row, which is empty 3497 ; anyway. 3498 (let ((col (1- ses--numcols)) 3499 row rowcol) 3500 (if (symbolp ses--curcell) 3501 ;; Single cell. 3502 (setq row (car (ses-sym-rowcol ses--curcell))) 3503 ;; Range --- use whichever end of the range the point is at. 3504 (setq rowcol (ses-sym-rowcol (if (< (point) (mark)) 3505 (car ses--curcell) 3506 (cdr ses--curcell)))) 3507 ;; If range already includes the last cell in a row, point is actually 3508 ;; in the following row. 3509 (if (<= (cdr rowcol) (1- col)) 3510 (setq row (car rowcol)) 3511 (setq row (1+ (car rowcol))) 3512 (if (= row ses--numrows) 3513 ;;Already at end - can't go anywhere 3514 (setq col 0)))) 3515 (when (< row ses--numrows) ; Otherwise it's a range that includes last cell. 3516 (while (eq (ses-cell-value row col) '*skip*) 3517 ;; Back to beginning of multi-column cell. 3518 (setq col (1- col))) 3519 (ses-goto-print row col))))) 3520 3521(defun ses-renarrow-buffer () 3522 "Narrow the buffer so only the print area is visible. 3523Use after \\[widen]." 3524 (interactive) 3525 (setq ses--deferred-narrow t)) 3526 3527(defun ses-sort-column (sorter &optional reverse) 3528 "Sort the range by a specified column. 3529With prefix, sorts in REVERSE order." 3530 (interactive "*sSort column: \nP") 3531 (ses-check-curcell 'needrange) 3532 (let ((min (ses-sym-rowcol (car ses--curcell))) 3533 (max (ses-sym-rowcol (cdr ses--curcell)))) 3534 (let ((minrow (car min)) 3535 (mincol (cdr min)) 3536 (maxrow (car max)) 3537 (maxcol (cdr max)) 3538 keys extracts end) 3539 (setq sorter (cdr (ses-sym-rowcol (intern (concat sorter "1"))))) 3540 (or (and sorter (>= sorter mincol) (<= sorter maxcol)) 3541 (error "Invalid sort column")) 3542 ;;Get key columns and sort them 3543 (dotimes (x (- maxrow minrow -1)) 3544 (ses-goto-print (+ minrow x) sorter) 3545 (setq end (next-single-property-change (point) 'cursor-intangible)) 3546 (push (cons (buffer-substring-no-properties (point) end) 3547 (+ minrow x)) 3548 keys)) 3549 (setq keys (sort keys (lambda (x y) (string< (car x) (car y))))) 3550 ;;Extract the lines in reverse sorted order 3551 (or reverse 3552 (setq keys (nreverse keys))) 3553 (dolist (x keys) 3554 (ses-goto-print (cdr x) (1+ maxcol)) 3555 (setq end (point)) 3556 (ses-goto-print (cdr x) mincol) 3557 (push (ses-copy-region (point) end) extracts)) 3558 (deactivate-mark) 3559 ;;Paste the lines sequentially 3560 (dotimes (x (- maxrow minrow -1)) 3561 (ses-goto-print (+ minrow x) mincol) 3562 (ses-set-curcell) 3563 (ses-yank-cells (pop extracts) nil))))) 3564 3565(defun ses-sort-column-click (event reverse) 3566 "Mouse version of `ses-sort-column'." 3567 (interactive "*e\nP") 3568 (setq event (event-end event)) 3569 (select-window (posn-window event)) 3570 (setq event (car (posn-col-row event))) ; Click column. 3571 (let ((col 0)) 3572 (while (and (< col ses--numcols) (> event (ses-col-width col))) 3573 (setq event (- event (ses-col-width col) 1) 3574 col (1+ col))) 3575 (if (>= col ses--numcols) 3576 (ding) 3577 (ses-sort-column (ses-column-letter col) reverse)))) 3578 3579(defun ses-insert-range () 3580 "Insert into minibuffer the list of cells currently highlighted in the 3581spreadsheet." 3582 (interactive "*") 3583 (let (x) 3584 (with-current-buffer (window-buffer minibuffer-scroll-window) 3585 (ses-command-hook) ; For ses-coverage. 3586 (ses-check-curcell 'needrange) 3587 (setq x (cdr (macroexpand `(ses-range ,(car ses--curcell) 3588 ,(cdr ses--curcell)))))) 3589 (insert (substring (prin1-to-string (nreverse x)) 1 -1)))) 3590 3591(defun ses-insert-ses-range () 3592 "Insert \"(ses-range x y)\" in the minibuffer to represent the currently 3593highlighted range in the spreadsheet." 3594 (interactive "*") 3595 (let (x) 3596 (with-current-buffer (window-buffer minibuffer-scroll-window) 3597 (ses-command-hook) ; For ses-coverage. 3598 (ses-check-curcell 'needrange) 3599 (setq x (format "(ses-range %S %S)" 3600 (car ses--curcell) 3601 (cdr ses--curcell)))) 3602 (insert x))) 3603 3604(defun ses-insert-range-click (event) 3605 "Mouse version of `ses-insert-range'." 3606 (interactive "*e") 3607 (mouse-set-point event) 3608 (ses-insert-range)) 3609 3610(defun ses-insert-ses-range-click (event) 3611 "Mouse version of `ses-insert-ses-range'." 3612 (interactive "*e") 3613 (mouse-set-point event) 3614 (ses-insert-ses-range)) 3615 3616(defun ses-replace-name-in-formula (formula old-name new-name) 3617 (let ((new-formula formula)) 3618 (cond 3619 ((eq (car-safe formula) 'quote)) 3620 ((symbolp formula) 3621 (if (eq formula old-name) 3622 (setq new-formula new-name))) 3623 ((consp formula) 3624 (while formula 3625 (let ((elt (car-safe formula))) 3626 (cond 3627 ((consp elt) 3628 (setcar formula (ses-replace-name-in-formula elt old-name new-name))) 3629 ((and (symbolp elt) 3630 (eq (car-safe formula) old-name)) 3631 (setcar formula new-name)))) 3632 (setq formula (cdr formula))))) 3633 new-formula)) 3634 3635(defun ses-rename-cell (new-name &optional cell) 3636 "Rename current cell." 3637 (interactive "*SEnter new name: ") 3638 (or 3639 (and (local-variable-p new-name) 3640 (ses-is-cell-sym-p new-name) 3641 (error "Already a cell name")) 3642 (and (boundp new-name) 3643 (null (yes-or-no-p 3644 (format-message 3645 "`%S' is already bound outside this buffer, continue? " 3646 new-name))) 3647 (error "Already a bound cell name"))) 3648 (let* (curcell 3649 (sym (if (ses-cell-p cell) 3650 (ses-cell-symbol cell) 3651 (setq cell nil 3652 curcell t) 3653 (ses-check-curcell) 3654 ses--curcell)) 3655 (rowcol (ses-sym-rowcol sym)) 3656 (row (car rowcol)) 3657 (col (cdr rowcol)) 3658 new-rowcol old-name old-value) 3659 (setq cell (or cell (ses-get-cell row col)) 3660 old-name (ses-cell-symbol cell) 3661 old-value (symbol-value old-name) 3662 new-rowcol (ses-decode-cell-symbol (symbol-name new-name))) 3663 ;; when ses-rename-cell is called interactively, then 'sym' is the 3664 ;; 'cursor-intangible' property of text at cursor position, while 3665 ;; 'old-name' is the symbol stored in array cell at coordinate 3666 ;; 'rowcol' corresponding to 'ses-cell' property of symbol 3667 ;; 'sym'. Both must be the same. 3668 (unless (eq sym old-name) 3669 (error "Spreadsheet is broken, both symbols %S and %S referring to cell (%d,%d)" sym old-name row col)) 3670 (if new-rowcol 3671 ;; the new name is of A1 type, so we test that the coordinate 3672 ;; inferred from new name 3673 (if (equal new-rowcol rowcol) 3674 (put new-name 'ses-cell rowcol) 3675 (error "Not a valid name for this cell location")) 3676 (setq ses--named-cell-hashmap 3677 (or ses--named-cell-hashmap (make-hash-table :test 'eq))) 3678 (put new-name 'ses-cell :ses-named) 3679 (puthash new-name rowcol ses--named-cell-hashmap)) 3680 (push `(ses-rename-cell ,old-name ,cell) buffer-undo-list) 3681 (cl-pushnew rowcol ses--deferred-write :test #'equal) 3682 ;; Replace name by new name in formula of cells referring to renamed cell. 3683 (dolist (ref (ses-cell-references cell)) 3684 (let* ((x (ses-sym-rowcol ref)) 3685 (xcell (ses-get-cell (car x) (cdr x)))) 3686 (cl-pushnew x ses--deferred-write :test #'equal) 3687 (setf (ses-cell-formula xcell) 3688 (ses-replace-name-in-formula 3689 (ses-cell-formula xcell) 3690 old-name 3691 new-name)))) 3692 ;; Replace name by new name in reference list of cells to which renamed 3693 ;; cell refers to. 3694 (dolist (ref (ses-formula-references (ses-cell-formula cell))) 3695 (let* ((x (ses-sym-rowcol ref)) 3696 (xcell (ses-get-cell (car x) (cdr x)))) 3697 (cl-pushnew x ses--deferred-write :test #'equal) 3698 (setf (ses-cell-references xcell) 3699 (cons new-name (delq old-name 3700 (ses-cell-references xcell)))))) 3701 (set (make-local-variable new-name) (symbol-value sym)) 3702 (setf (ses-cell--symbol cell) new-name) 3703 ;; set new name to value 3704 (set new-name old-value) 3705 ;; Unbind old name 3706 (if (eq (get old-name 'ses-cell) :ses-named) 3707 (ses--unbind-cell-name old-name) 3708 (kill-local-variable old-name)) 3709 (and curcell (setq ses--curcell new-name)) 3710 (save-excursion 3711 (or curcell (ses-goto-print row col)) 3712 (let* ((pos (point)) 3713 (inhibit-read-only t) 3714 (end (next-single-property-change pos 'cursor-intangible))) 3715 (put-text-property pos end 'cursor-intangible new-name))) 3716 ;; Update the cell name in the mode-line. 3717 (force-mode-line-update))) 3718 3719(defun ses-refresh-local-printer (name _compiled-value) ;FIXME: unused arg? 3720 "Refresh printout for all cells which use printer NAME. 3721NAME should be the name of a locally defined printer. 3722Uses the value COMPILED-VALUE for this printer." 3723 (message "Refreshing cells using printer %S" name) 3724 (let (new-print) 3725 (dotimes (row ses--numrows) 3726 (dotimes (col ses--numcols) 3727 (let ((cell-printer (ses-cell-printer row col))) 3728 (when (eq cell-printer name) 3729 (unless new-print 3730 (setq new-print t) 3731 (ses-begin-change)) 3732 (ses-print-cell row col))))))) 3733 3734 3735(defun ses-define-local-printer (name definition) 3736 "Define a local printer with name NAME and definition DEFINITION. 3737 3738NAME shall be a symbol. Use TAB to complete over existing local 3739printer names. 3740 3741DEFINITION shall be either a string formatter, e.g.: 3742 3743 \"%.2f\" or (\"%.2f\") for left alignment. 3744 3745or a lambda expression, e.g. for formatting in ISO format dates 3746created with a '(calcFunc-date YEAR MONTH DAY)' formula: 3747 3748 (lambda (x) 3749 (cond 3750 ((null val) \"\") 3751 ((eq (car-safe x) 'date) 3752 (let ((calc-format-date '(X YYYY \"-\" MM \"-\" DD))) 3753 (math-format-date x))) 3754 (t (ses-center-span val ?# 'ses-prin1)))) 3755 3756If NAME is already used to name a local printer function, then 3757the current definition is proposed as default value, and the 3758function is redefined." 3759 (interactive 3760 (let (name def already-defined-names) 3761 (maphash (lambda (key _val) (push (symbol-name key) already-defined-names)) 3762 ses--local-printer-hashmap) 3763 (setq name (completing-read "Enter printer name: " already-defined-names)) 3764 (when (string= name "") 3765 (error "Invalid printer name")) 3766 (setq name (intern name)) 3767 (let* ((cur-printer (gethash name ses--local-printer-hashmap)) 3768 (default (and cur-printer (ses--locprn-def cur-printer)))) 3769 (setq def (ses-read-printer (format-prompt 3770 "Enter definition of printer %S" 3771 default name) 3772 default))) 3773 (list name def))) 3774 3775 (let* ((cur-printer (gethash name ses--local-printer-hashmap)) 3776 (default (and cur-printer (ses--locprn-def cur-printer))) 3777 create-printer) 3778 (cond 3779 ;; cancelled operation => do nothing 3780 ((eq definition t)) 3781 ;; no change => do nothing 3782 ((and cur-printer (equal definition default))) 3783 ;; re-defined printer 3784 (cur-printer 3785 (setq create-printer 0) 3786 (setf (ses--locprn-def cur-printer) definition) 3787 (ses-refresh-local-printer 3788 name 3789 (setf (ses--locprn-compiled cur-printer) 3790 (ses-local-printer-compile definition)))) 3791 ;; new definition 3792 (t 3793 (setq create-printer 1) 3794 (puthash name 3795 (setq cur-printer 3796 (ses-make-local-printer-info definition)) 3797 ses--local-printer-hashmap))) 3798 (when create-printer 3799 (let ((printer-def-text 3800 (concat 3801 "(ses-local-printer " 3802 (symbol-name name) 3803 " " 3804 (prin1-to-string (ses--locprn-def cur-printer)) 3805 ")"))) 3806 (save-excursion 3807 (ses-goto-data ses--numrows 3808 (ses--locprn-number cur-printer)) 3809 (let ((inhibit-read-only t)) 3810 ;; Special undo since it's outside the narrowed buffer. 3811 (let (buffer-undo-list) 3812 (if (= create-printer 0) 3813 (delete-region (point) (line-end-position)) 3814 (insert ?\n) 3815 (backward-char)) 3816 (insert printer-def-text) 3817 (when (= create-printer 1) 3818 (ses-file-format-extend-parameter-list 3) 3819 (ses-set-parameter 'ses--numlocprn 3820 (1+ ses--numlocprn)))))))))) 3821 3822(defsubst ses-define-if-new-local-printer (name def) 3823 "Same as function `ses-define-if-new-local-printer', except 3824that the definition occurs only when the local printer does not 3825already exists. 3826 3827Function `ses-define-if-new-local-printer' is not interactive; it 3828is intended for mode hooks to add local printers automatically." 3829 (unless (gethash name ses--local-printer-hashmap) 3830 (ses-define-local-printer name def))) 3831 3832;;---------------------------------------------------------------------------- 3833;; Checking formulas for safety 3834;;---------------------------------------------------------------------------- 3835 3836(defun ses-safe-printer (printer) 3837 "Return PRINTER if safe, or the substitute printer `ses-unsafe' otherwise." 3838 (if (or (stringp printer) 3839 (stringp (car-safe printer)) 3840 (not printer) 3841 (and (symbolp printer) (gethash printer ses--local-printer-hashmap)) 3842 (ses-warn-unsafe printer 'unsafep-function)) 3843 printer 3844 'ses-unsafe)) 3845 3846(defun ses-safe-formula (formula) 3847 "Return FORMULA if safe, or the substitute formula *unsafe* otherwise." 3848 (if (ses-warn-unsafe formula 'unsafep) 3849 formula 3850 `(ses-unsafe ',formula))) 3851 3852(defun ses-warn-unsafe (formula checker) 3853 "Apply CHECKER to FORMULA. 3854If result is non-nil, asks user for confirmation about FORMULA, 3855which might be unsafe. Returns t if formula is safe or user allows 3856execution anyway. Always returns t if `safe-functions' is t." 3857 (if (eq safe-functions t) 3858 t 3859 (setq checker (funcall checker formula)) 3860 (if (not checker) 3861 t 3862 (y-or-n-p (format "Formula %S\nmight be unsafe %S. Process it? " 3863 formula checker))))) 3864 3865 3866;;---------------------------------------------------------------------------- 3867;; Standard formulas 3868;;---------------------------------------------------------------------------- 3869 3870(defun ses--clean-! (&rest x) 3871 "Clean by `delq' list X from any occurrence of nil or `*skip*'." 3872 (delq nil (delq '*skip* x))) 3873 3874(defun ses--clean-_ (x y) 3875 "Clean list X by replacing by Y any occurrence of nil or `*skip*'. 3876 3877This will change X by making `setcar' on its cons cells." 3878 (let ((ret x) ret-elt) 3879 (while ret 3880 (setq ret-elt (car ret)) 3881 (when (memq ret-elt '(nil *skip*)) 3882 (setcar ret y)) 3883 (setq ret (cdr ret)))) 3884 x) 3885 3886(defmacro ses-range (from to &rest rest) 3887 "Expand to a list of cell-symbols for the range going from 3888FROM up to TO. The range automatically expands to include any 3889new row or column inserted into its middle. The SES library code 3890specifically looks for the symbol `ses-range', so don't create an 3891alias for this macro! 3892 3893By passing in REST some flags one can configure the way the range 3894is read and how it is formatted. 3895 3896In the sequel we assume that cells A1, B1, A2 B2 have respective values 38971 2 3 and 4. 3898 3899Readout direction is specified by a `>v', `>^', `<v', `<^', 3900`v>', `v<', `^>', `^<' flag. For historical reasons, in absence 3901of such a flag, a default direction of `^<' is assumed. This 3902way `(ses-range A1 B2 ^>)' will evaluate to `(1 3 2 4)', 3903while `(ses-range A1 B2 >^)' will evaluate to (3 4 1 2). 3904 3905If the range is one row, then `>' can be used as a shorthand to 3906`>v' or `>^', and `<' to `<v' or `<^'. 3907 3908If the range is one column, then `v' can be used as a shorthand to 3909`v>' or `v<', and `^' to `^>' or `v<'. 3910 3911A `!' flag will remove all cells whose value is nil or `*skip*'. 3912 3913A `_' flag will replace nil or `*skip*' by the value following 3914the `_' flag. If the `_' flag is the last argument, then they are 3915replaced by integer 0. 3916 3917A `*', `*1' or `*2' flag will vectorize the range in the sense of 3918Calc. See info node `(Calc) Top'. Flag `*' will output either a 3919vector or a matrix depending on the number of rows, `*1' will 3920flatten the result to a one row vector, and `*2' will make a 3921matrix whatever the number of rows. 3922 3923Warning: interaction with Calc is experimental and may produce 3924confusing results if you are not aware of Calc data format. 3925Use `math-format-value' as a printer for Calc objects." 3926 (let (result-row 3927 result 3928 (prev-row -1) 3929 (reorient-x nil) 3930 (reorient-y nil) 3931 transpose vectorize 3932 (clean 'list)) 3933 (ses-dorange (cons from to) 3934 (when (/= prev-row row) 3935 (push result-row result) 3936 (setq result-row nil)) 3937 (push (ses-cell-symbol row col) result-row) 3938 (setq prev-row row)) 3939 (push result-row result) 3940 (while rest 3941 (let ((x (pop rest))) 3942 (pcase x 3943 ('>v (setq transpose nil reorient-x nil reorient-y nil)) 3944 ('>^ (setq transpose nil reorient-x nil reorient-y t)) 3945 ('<^ (setq transpose nil reorient-x t reorient-y t)) 3946 ('<v (setq transpose nil reorient-x t reorient-y nil)) 3947 ('v> (setq transpose t reorient-x nil reorient-y t)) 3948 ('^> (setq transpose t reorient-x nil reorient-y nil)) 3949 ('^< (setq transpose t reorient-x t reorient-y nil)) 3950 ('v< (setq transpose t reorient-x t reorient-y t)) 3951 ((or '* '*2 '*1) (setq vectorize x)) 3952 ('! (setq clean 'ses--clean-!)) 3953 ('_ (setq clean `(lambda (&rest x) 3954 (ses--clean-_ x ,(if rest (pop rest) 0))))) 3955 (_ 3956 (cond 3957 ; shorthands one row 3958 ((and (null (cddr result)) (memq x '(> <))) 3959 (push (intern (concat (symbol-name x) "v")) rest)) 3960 ; shorthands one col 3961 ((and (null (cdar result)) (memq x '(v ^))) 3962 (push (intern (concat (symbol-name x) ">")) rest)) 3963 (t (error "Unexpected flag `%S' in ses-range" x))))))) 3964 (if reorient-y 3965 (setcdr (last result 2) nil) 3966 (setq result (cdr (nreverse result)))) 3967 (unless reorient-x 3968 (setq result (mapcar #'nreverse result))) 3969 (when transpose 3970 (let ((ret (mapcar (lambda (x) (list x)) (pop result))) iter) 3971 (while result 3972 (setq iter ret) 3973 (dolist (elt (pop result)) 3974 (setcar iter (cons elt (car iter))) 3975 (setq iter (cdr iter)))) 3976 (setq result ret))) 3977 3978 (cl-flet ((vectorize-*1 3979 (clean result) 3980 (cons clean (cons (quote 'vec) (apply #'append result)))) 3981 (vectorize-*2 3982 (clean result) 3983 (cons clean (cons (quote 'vec) 3984 (mapcar (lambda (x) 3985 (cons clean (cons (quote 'vec) x))) 3986 result))))) 3987 (pcase vectorize 3988 ('nil (cons clean (apply #'append result))) 3989 ('*1 (vectorize-*1 clean result)) 3990 ('*2 (vectorize-*2 clean result)) 3991 ('* (funcall (if (cdr result) 3992 #'vectorize-*2 3993 #'vectorize-*1) 3994 clean result)))))) 3995 3996(defun ses-delete-blanks (&rest args) 3997 "Return ARGS reversed, with the blank elements (nil and *skip*) removed." 3998 (let (result) 3999 (dolist (cur args) 4000 (unless (memq cur '(nil *skip*)) 4001 (push cur result))) 4002 result)) 4003 4004(defun ses+ (&rest args) 4005 "Compute the sum of the arguments, ignoring blanks." 4006 (apply #'+ (apply #'ses-delete-blanks args))) 4007 4008(defun ses-average (list) 4009 "Calculate the sum of the numbers in LIST, divided by their length. 4010Blanks are ignored. Result is always floating-point, even if all 4011args are integers." 4012 (setq list (apply #'ses-delete-blanks list)) 4013 (/ (float (apply #'+ list)) (length list))) 4014 4015(defmacro ses-select (fromrange test torange) 4016 "Select cells in FROMRANGE that are `equal' to TEST. 4017For each match, return the corresponding cell from TORANGE. 4018The ranges are macroexpanded but not evaluated so they should be 4019either (ses-range BEG END) or (list ...). The TEST is evaluated." 4020 (setq fromrange (cdr (macroexpand fromrange)) 4021 torange (cdr (macroexpand torange)) 4022 test (eval test t)) 4023 (or (= (length fromrange) (length torange)) 4024 (error "ses-select: Ranges not same length")) 4025 (let (result) 4026 (dolist (x fromrange) 4027 (if (equal test (symbol-value x)) 4028 (push (car torange) result)) 4029 (setq torange (cdr torange))) 4030 (cons 'list result))) 4031 4032;;All standard formulas are safe 4033(dolist (x '(ses-cell-value ses-range ses-delete-blanks ses+ ses-average 4034 ses-select)) 4035 (put x 'side-effect-free t)) 4036 4037 4038;;---------------------------------------------------------------------------- 4039;; Standard print functions 4040;;---------------------------------------------------------------------------- 4041 4042(defun ses-center (value &optional span fill printer) 4043 "Print VALUE, centered within column. 4044FILL is the fill character for centering (default = space). 4045SPAN indicates how many additional rightward columns to include 4046in width (default = 0). 4047PRINTER is the printer to use for printing the value, default is the 4048column printer if any, or the spreadsheet the spreadsheet default 4049printer otherwise." 4050 (setq printer (or printer (ses-col-printer ses--col) ses--default-printer)) 4051 (let ((width (ses-col-width ses--col)) 4052 half) 4053 (or fill (setq fill ?\s)) 4054 (or span (setq span 0)) 4055 (setq value (ses-call-printer printer value)) 4056 (dotimes (x span) 4057 (setq width (+ width 1 (ses-col-width (+ ses--col span (- x)))))) 4058 ;; Set column width. 4059 (setq width (- width (string-width value))) 4060 (if (<= width 0) 4061 value ; Too large for field, anyway. 4062 (setq half (make-string (/ width 2) fill)) 4063 (concat half value half 4064 (if (> (% width 2) 0) (char-to-string fill)))))) 4065 4066(defun ses-center-span (value &optional fill printer) 4067 "Print VALUE, centered within the span that starts in the current column 4068and continues until the next nonblank column. 4069FILL specifies the fill character (default = space)." 4070 (let ((end (1+ ses--col))) 4071 (while (and (< end ses--numcols) 4072 (memq (ses-cell-value ses--row end) '(nil *skip*))) 4073 (setq end (1+ end))) 4074 (ses-center value (- end ses--col 1) fill printer))) 4075 4076(defun ses-dashfill (value &optional span printer) 4077 "Print VALUE centered using dashes. 4078SPAN indicates how many rightward columns to include in width (default = 0)." 4079 (ses-center value span ?- printer)) 4080 4081(defun ses-dashfill-span (value &optional printer) 4082 "Print VALUE, centered using dashes within the span that starts in the 4083current column and continues until the next nonblank column." 4084 (ses-center-span value ?- printer)) 4085 4086(defun ses-tildefill-span (value &optional printer) 4087 "Print VALUE, centered using tildes within the span that starts in the 4088current column and continues until the next nonblank column." 4089 (ses-center-span value ?~ printer)) 4090 4091(defun ses-prin1 (value) 4092 "Shorthand for '(prin1-to-string VALUE t)'. 4093Useful to handle the default behavior in custom lambda based 4094printer functions." 4095 (prin1-to-string value t)) 4096 4097(defun ses-unsafe (_value) 4098 "Substitute for an unsafe formula or printer." 4099 (error "Unsafe formula or printer")) 4100 4101;;All standard printers are safe, including ses-unsafe! 4102(dolist (x (cons 'ses-unsafe ses-standard-printer-functions)) 4103 (put x 'side-effect-free t)) 4104 4105(defun ses-unload-function () 4106 "Unload the Simple Emacs Spreadsheet." 4107 (advice-remove 'yank #'ses--advice-yank) 4108 (advice-remove 'copy-region-as-kill #'ses--advice-copy-region-as-kill) 4109 ;; Continue standard unloading. 4110 nil) 4111 4112(provide 'ses) 4113 4114;;; ses.el ends here 4115