(require 'unsafep)
(defgroup ses nil
"Simple Emacs Spreadsheet."
:group 'applications
:prefix "ses-"
:version "21.1")
(defcustom ses-initial-size '(1 . 1)
"Initial size of a new spreadsheet, as a cons (NUMROWS . NUMCOLS)."
:group 'ses
:type '(cons (integer :tag "numrows") (integer :tag "numcols")))
(defcustom ses-initial-column-width 7
"Initial width of columns in a new spreadsheet."
:group 'ses
:type '(integer :match (lambda (widget value) (> value 0))))
(defcustom ses-initial-default-printer "%.7g"
"Initial default printer for a new spreadsheet."
:group 'ses
:type '(choice string
(list :tag "Parenthesized string" string)
function))
(defcustom ses-after-entry-functions '(forward-char)
"Things to do after entering a value into a cell.
An abnormal hook that usually runs a cursor-movement function.
Each function is called with ARG=1."
:group 'ses
:type 'hook
:options '(forward-char backward-char next-line previous-line))
(defcustom ses-mode-hook nil
"Hook functions to be run upon entering SES mode."
:group 'ses
:type 'hook)
(defvar ses-read-cell-history nil
"List of formulas that have been typed in.")
(defvar ses-read-printer-history nil
"List of printer functions that have been typed in.")
(easy-menu-define ses-header-line-menu nil
"Context menu when mouse-3 is used on the header-line in an SES buffer."
'("SES header row"
["Set current row" ses-set-header-row t]
["Unset row" ses-unset-header-row (> ses--header-row 0)]))
(defconst ses-mode-map
(let ((keys `("\C-c\M-\C-l" ses-reconstruct-all
"\C-c\C-l" ses-recalculate-all
"\C-c\C-n" ses-renarrow-buffer
"\C-c\C-c" ses-recalculate-cell
"\C-c\M-\C-s" ses-sort-column
"\C-c\M-\C-h" ses-set-header-row
"\C-c\C-t" ses-truncate-cell
"\C-c\C-j" ses-jump
"\C-c\C-p" ses-read-default-printer
"\M-\C-l" ses-reprint-all
[?\S-\C-l] ses-reprint-all
[header-line down-mouse-3] ,ses-header-line-menu
[header-line mouse-2] ses-sort-column-click))
(newmap (make-sparse-keymap)))
(while keys
(define-key (1value newmap) (car keys) (cadr keys))
(setq keys (cddr keys)))
newmap)
"Local keymap for Simple Emacs Spreadsheet.")
(easy-menu-define ses-menu ses-mode-map
"Menu bar menu for SES."
'("SES"
["Insert row" ses-insert-row (ses-in-print-area)]
["Delete row" ses-delete-row (ses-in-print-area)]
["Insert column" ses-insert-column (ses-in-print-area)]
["Delete column" ses-delete-column (ses-in-print-area)]
["Set column printer" ses-read-column-printer t]
["Set column width" ses-set-column-width t]
["Set default printer" ses-read-default-printer t]
["Jump to cell" ses-jump t]
["Set cell printer" ses-read-cell-printer t]
["Recalculate cell" ses-recalculate-cell t]
["Truncate cell display" ses-truncate-cell t]
["Export values" ses-export-tsv t]
["Export formulas" ses-export-tsf t]))
(defconst ses-mode-edit-map
(let ((keys '("\C-c\C-r" ses-insert-range
"\C-c\C-s" ses-insert-ses-range
[S-mouse-3] ses-insert-range-click
[C-S-mouse-3] ses-insert-ses-range-click
"\M-\C-i" lisp-complete-symbol))
(newmap (make-sparse-keymap)))
(set-keymap-parent newmap minibuffer-local-map)
(while keys
(define-key newmap (pop keys) (pop keys)))
newmap)
"Local keymap for SES minibuffer cell-editing.")
(defalias 'ses-mode-print-map
(let ((keys '([backtab] backward-char
[tab] ses-forward-or-insert
"\C-i" ses-forward-or-insert "\M-o" ses-insert-column
"\C-o" ses-insert-row
"\C-m" ses-edit-cell
"\M-k" ses-delete-column
"\M-y" ses-yank-pop
"\C-k" ses-delete-row
"\C-j" ses-append-row-jump-first-column
"\M-h" ses-mark-row
"\M-H" ses-mark-column
"\C-d" ses-clear-cell-forward
"\C-?" ses-clear-cell-backward
"(" ses-read-cell
"\"" ses-read-cell
"'" ses-read-symbol
"=" ses-edit-cell
"j" ses-jump
"p" ses-read-cell-printer
"w" ses-set-column-width
"x" ses-export-keymap
"\M-p" ses-read-column-printer))
(repl '( clipboard-kill-region ses-kill-override
end-of-line ses-end-of-line
kill-line ses-delete-row
kill-region ses-kill-override
open-line ses-insert-row))
(numeric "0123456789.-")
(newmap (make-keymap)))
(suppress-keymap newmap t)
(dotimes (x (length numeric))
(define-key newmap (substring numeric x (1+ x)) 'ses-read-cell))
(while repl
(substitute-key-definition (car repl) (cadr repl) newmap
(current-global-map))
(setq repl (cddr repl)))
(define-key newmap [(menu-bar) edit cut] 'ses-kill-override)
(while keys
(define-key newmap (car keys) (cadr keys))
(setq keys (cddr keys)))
newmap))
(defconst ses-mode-print-map (symbol-function 'ses-mode-print-map))
(defalias 'ses-export-keymap
(let ((map (make-sparse-keymap "SES export")))
(define-key map "T" (cons " tab-formulas" 'ses-export-tsf))
(define-key map "t" (cons " tab-values" 'ses-export-tsv))
map))
(defconst ses-print-data-boundary "\n\014\n"
"Marker string denoting the boundary between print area and data area.")
(defconst ses-initial-global-parameters
"\n( ;Global parameters (these are read first)\n 2 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n"
"Initial contents for the three-element list at the bottom of the data area.")
(defconst ses-initial-file-trailer
";; Local Variables:\n;; mode: ses\n;; End:\n"
"Initial contents for the file-trailer area at the bottom of the file.")
(defconst ses-initial-file-contents
(concat " \n" ses-print-data-boundary
"(ses-cell A1 nil nil nil nil)\n" "\n" "(ses-column-widths [7])\n"
"(ses-column-printers [nil])\n"
"(ses-default-printer \"%.7g\")\n"
"(ses-header-row 0)\n"
ses-initial-global-parameters
ses-initial-file-trailer)
"The initial contents of an empty spreadsheet.")
(defconst ses-box-prop '(:box (:line-width 2 :style released-button))
"Display properties to create a raised box for cells in the header line.")
(defconst ses-standard-printer-functions
'(ses-center ses-center-span ses-dashfill ses-dashfill-span
ses-tildefill-span)
"List of print functions to be included in initial history of printer
functions. None of these standard-printer functions is suitable for use as a
column printer or a global-default printer because they invoke the column or
default printer and then modify its output.")
(eval-and-compile
(defconst ses-localvars
'(ses--blank-line ses--cells ses--col-printers ses--col-widths ses--curcell
ses--curcell-overlay ses--default-printer ses--deferred-narrow
ses--deferred-recalc ses--deferred-write ses--file-format
ses--header-hscroll ses--header-row ses--header-string ses--linewidth
ses--numcols ses--numrows ses--symbolic-formulas ses--data-marker
ses--params-marker
mode-line-process next-line-add-newlines transient-mark-mode)
"Buffer-local variables used by SES."))
(eval-when-compile
(dolist (x ses-localvars)
(make-local-variable x)
(set x nil)))
(defconst ses-paramlines-plist
'(ses--col-widths -5 ses--col-printers -4 ses--default-printer -3
ses--header-row -2 ses--file-format 1 ses--numrows 2
ses--numcols 3)
"Offsets from 'Global parameters' line to various parameter lines in the
data area of a spreadsheet.")
(defvar ses-relocate-return nil
"Set by `ses-relocate-formula' and `ses-relocate-range', read by
`ses-relocate-all'. Set to 'delete if a cell-reference was deleted from a
formula--so the formula needs recalculation. Set to 'range if the size of a
`ses-range' was changed--so both the formula's value and list of dependents
need to be recalculated.")
(defvar ses-call-printer-return nil
"Set to t if last cell printer invoked by `ses-call-printer' requested
left-justification of the result. Set to error-signal if ses-call-printer
encountered an error during printing. Otherwise nil.")
(defvar ses-start-time nil
"Time when current operation started. Used by `ses-time-check' to decide
when to emit a progress message.")
(defmacro ses-get-cell (row col)
"Return the cell structure that stores information about cell (ROW,COL)."
`(aref (aref ses--cells ,row) ,col))
(defsubst ses-make-cell (&optional symbol formula printer references)
(vector symbol formula printer references))
(defmacro ses-cell-symbol (row &optional col)
"From a CELL or a pair (ROW,COL), get the symbol that names the local-variable holding its value. (0,0) => A1."
`(aref ,(if col `(ses-get-cell ,row ,col) row) 0))
(defmacro ses-cell-formula (row &optional col)
"From a CELL or a pair (ROW,COL), get the function that computes its value."
`(aref ,(if col `(ses-get-cell ,row ,col) row) 1))
(defmacro ses-cell-printer (row &optional col)
"From a CELL or a pair (ROW,COL), get the function that prints its value."
`(aref ,(if col `(ses-get-cell ,row ,col) row) 2))
(defmacro ses-cell-references (row &optional col)
"From a CELL or a pair (ROW,COL), get the list of symbols for cells whose
functions refer to its value."
`(aref ,(if col `(ses-get-cell ,row ,col) row) 3))
(defmacro ses-cell-value (row &optional col)
"From a CELL or a pair (ROW,COL), get the current value for that cell."
`(symbol-value (ses-cell-symbol ,row ,col)))
(defmacro ses-col-width (col)
"Return the width for column COL."
`(aref ses--col-widths ,col))
(defmacro ses-col-printer (col)
"Return the default printer for column COL."
`(aref ses--col-printers ,col))
(defmacro ses-sym-rowcol (sym)
"From a cell-symbol SYM, gets the cons (row . col). A1 => (0 . 0). Result
is nil if SYM is not a symbol that names a cell."
`(and (symbolp ,sym) (get ,sym 'ses-cell)))
(defmacro ses-cell (sym value formula printer references)
"Load a cell SYM from the spreadsheet file. Does not recompute VALUE from
FORMULA, does not reprint using PRINTER, does not check REFERENCES. This is a
macro to prevent propagate-on-load viruses. Safety-checking for FORMULA and
PRINTER are deferred until first use."
(let ((rowcol (ses-sym-rowcol sym)))
(ses-formula-record formula)
(ses-printer-record printer)
(or (atom formula)
(eq safe-functions t)
(setq formula `(ses-safe-formula ,formula)))
(or (not printer)
(stringp printer)
(eq safe-functions t)
(setq printer `(ses-safe-printer ,printer)))
(aset (aref ses--cells (car rowcol))
(cdr rowcol)
(ses-make-cell sym formula printer references)))
(set sym value)
sym)
(defmacro ses-column-widths (widths)
"Load the vector of column widths from the spreadsheet file. This is a
macro to prevent propagate-on-load viruses."
(or (and (vectorp widths) (= (length widths) ses--numcols))
(error "Bad column-width vector"))
(setq ses--col-widths widths
ses--linewidth (apply '+ -1 (mapcar '1+ widths))
ses--blank-line (concat (make-string ses--linewidth ?\s) "\n"))
t)
(defmacro ses-column-printers (printers)
"Load the vector of column printers from the spreadsheet file and checks
them for safety. This is a macro to prevent propagate-on-load viruses."
(or (and (vectorp printers) (= (length printers) ses--numcols))
(error "Bad column-printers vector"))
(dotimes (x ses--numcols)
(aset printers x (ses-safe-printer (aref printers x))))
(setq ses--col-printers printers)
(mapc 'ses-printer-record printers)
t)
(defmacro ses-default-printer (def)
"Load the global default printer from the spreadsheet file and checks it
for safety. This is a macro to prevent propagate-on-load viruses."
(setq ses--default-printer (ses-safe-printer def))
(ses-printer-record def)
t)
(defmacro ses-header-row (row)
"Load the header row from the spreadsheet file and checks it
for safety. This is a macro to prevent propagate-on-load viruses."
(or (and (wholenump row) (or (zerop ses--numrows) (< row ses--numrows)))
(error "Bad header-row"))
(setq ses--header-row row)
t)
(defmacro ses-dorange (curcell &rest body)
"Execute BODY repeatedly, with the variables `row' and `col' set to each
cell in the range specified by CURCELL. The range is available in the
variables `minrow', `maxrow', `mincol', and `maxcol'."
(declare (indent defun) (debug (form body)))
(let ((cur (make-symbol "cur"))
(min (make-symbol "min"))
(max (make-symbol "max"))
(r (make-symbol "r"))
(c (make-symbol "c")))
`(let* ((,cur ,curcell)
(,min (ses-sym-rowcol (if (consp ,cur) (car ,cur) ,cur)))
(,max (ses-sym-rowcol (if (consp ,cur) (cdr ,cur) ,cur))))
(let ((minrow (car ,min))
(maxrow (car ,max))
(mincol (cdr ,min))
(maxcol (cdr ,max))
row col)
(if (or (> minrow maxrow) (> mincol maxcol))
(error "Empty range"))
(dotimes (,r (- maxrow minrow -1))
(setq row (+ ,r minrow))
(dotimes (,c (- maxcol mincol -1))
(setq col (+ ,c mincol))
,@body))))))
(defmacro 1value (form)
"For code-coverage testing, indicate that FORM is expected to always have
the same value."
form)
(defmacro noreturn (form)
"For code-coverage testing, indicate that FORM will always signal an error."
form)
(defun ses-vector-insert (array idx new)
"Create a new vector which is one larger than ARRAY and has NEW inserted
before element IDX."
(let* ((len (length array))
(result (make-vector (1+ len) new)))
(dotimes (x len)
(aset result
(if (< x idx) x (1+ x))
(aref array x)))
result))
(defun ses-vector-delete (array idx count)
"Create a new vector which is a copy of ARRAY with COUNT objects removed
starting at element IDX. ARRAY is either a vector or a symbol whose value
is a vector--if a symbol, the new vector is assigned as the symbol's value."
(let* ((a (if (arrayp array) array (symbol-value array)))
(len (- (length a) count))
(result (make-vector len nil)))
(dotimes (x len)
(aset result x (aref a (if (< x idx) x (+ x count)))))
(if (symbolp array)
(set array result))
result))
(defun ses-delete-line (count)
"Like `kill-line', but no kill ring."
(let ((pos (point)))
(forward-line count)
(delete-region pos (point))))
(defun ses-printer-validate (printer)
"Signals an error if PRINTER is not a valid SES cell printer."
(or (not printer)
(stringp printer)
(functionp printer)
(and (stringp (car-safe printer)) (not (cdr printer)))
(error "Invalid printer function"))
printer)
(defun ses-printer-record (printer)
"Add PRINTER to `ses-read-printer-history' if not already there, after first
checking that it is a valid printer function."
(ses-printer-validate printer)
(if printer
(add-to-list 'ses-read-printer-history (prin1-to-string printer))))
(defun ses-formula-record (formula)
"If FORMULA is of the form 'symbol, adds it to the list of symbolic formulas
for this spreadsheet."
(when (and (eq (car-safe formula) 'quote)
(symbolp (cadr formula)))
(add-to-list 'ses--symbolic-formulas
(list (symbol-name (cadr formula))))))
(defun ses-column-letter (col)
"Converts a column number to A..Z or AA..ZZ"
(if (< col 26)
(char-to-string (+ ?A col))
(string (+ ?@ (/ col 26)) (+ ?A (% col 26)))))
(defun ses-create-cell-symbol (row col)
"Produce a symbol that names the cell (ROW,COL). (0,0) => 'A1."
(intern (concat (ses-column-letter col) (number-to-string (1+ row)))))
(defun ses-create-cell-variable-range (minrow maxrow mincol maxcol)
"Create buffer-local variables for cells. This is undoable."
(push `(apply ses-destroy-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol)
buffer-undo-list)
(let (sym xrow xcol)
(dotimes (row (1+ (- maxrow minrow)))
(dotimes (col (1+ (- maxcol mincol)))
(setq xrow (+ row minrow)
xcol (+ col mincol)
sym (ses-create-cell-symbol xrow xcol))
(put sym 'ses-cell (cons xrow xcol))
(make-local-variable sym)))))
(defun ses-destroy-cell-variable-range (minrow maxrow mincol maxcol)
"Destroy buffer-local variables for cells. This is undoable."
(let (sym)
(dotimes (row (1+ (- maxrow minrow)))
(dotimes (col (1+ (- maxcol mincol)))
(setq sym (ses-create-cell-symbol (+ row minrow) (+ col mincol)))
(if (boundp sym)
(push `(apply ses-set-with-undo ,sym ,(symbol-value sym))
buffer-undo-list))
(kill-local-variable sym))))
(push `(apply ses-create-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol)
buffer-undo-list))
(defun ses-reset-header-string ()
"Flags the header string for update. Upon undo, the header string will be
updated again."
(push '(apply ses-reset-header-string) buffer-undo-list)
(setq ses--header-hscroll -1))
(defun ses-time-check (format arg)
"If `ses-start-time' is more than a second ago, call `message' with FORMAT
and (eval ARG) and reset `ses-start-time' to the current time."
(when (> (- (float-time) ses-start-time) 1.0)
(message format (eval arg))
(setq ses-start-time (float-time)))
nil)
(defun ses-set-cell (row col field val)
"Install VAL as the contents for field FIELD (named by a quoted symbol) of
cell (ROW,COL). This is undoable. The cell's data will be updated through
`post-command-hook'."
(let ((cell (ses-get-cell row col))
(elt (plist-get '(value t symbol 0 formula 1 printer 2 references 3)
field))
change)
(or elt (signal 'args-out-of-range nil))
(setq change (if (eq elt t)
(ses-set-with-undo (ses-cell-symbol cell) val)
(ses-aset-with-undo cell elt val)))
(if change
(add-to-list 'ses--deferred-write (cons row col))))
nil)
(defun ses-cell-set-formula (row col formula)
"Store a new formula for (ROW . COL) and enqueues the cell for
recalculation via `post-command-hook'. Updates the reference lists for the
cells that this cell refers to. Does not update cell value or reprint the
cell. To avoid inconsistencies, this function is not interruptible, which
means Emacs will crash if FORMULA contains a circular list."
(let* ((cell (ses-get-cell row col))
(old (ses-cell-formula cell)))
(let ((sym (ses-cell-symbol cell))
(oldref (ses-formula-references old))
(newref (ses-formula-references formula))
(inhibit-quit t)
x xrow xcol)
(add-to-list 'ses--deferred-recalc sym)
(dolist (ref oldref)
(unless (memq ref newref)
(setq x (ses-sym-rowcol ref)
xrow (car x)
xcol (cdr x))
(ses-set-cell xrow xcol 'references
(delq sym (ses-cell-references xrow xcol)))))
(dolist (ref newref)
(setq x (ses-sym-rowcol ref)
xrow (car x)
xcol (cdr x)
x (ses-cell-references xrow xcol))
(or (memq sym x)
(ses-set-cell xrow xcol 'references (cons sym x))))
(ses-formula-record formula)
(ses-set-cell row col 'formula formula))))
(defun ses-calculate-cell (row col force)
"Calculate and print the value for cell (ROW,COL) using the cell's formula
function and print functions, if any. Result is nil for normal operation, or
the error signal if the formula or print function failed. The old value is
left unchanged if it was *skip* and the new value is nil.
Any cells that depend on this cell are queued for update after the end of
processing for the current keystroke, unless the new value is the same as
the old and FORCE is nil."
(let ((cell (ses-get-cell row col))
formula-error printer-error)
(let ((oldval (ses-cell-value cell))
(formula (ses-cell-formula cell))
newval)
(if (eq (car-safe formula) 'ses-safe-formula)
(ses-set-cell row col 'formula (ses-safe-formula (cadr formula))))
(condition-case sig
(setq newval (eval formula))
(error
(setq formula-error sig
newval '*error*)))
(if (and (not newval) (eq oldval '*skip*))
(setq newval '*skip*))
(when (or force (not (eq newval oldval)))
(add-to-list 'ses--deferred-write (cons row col)) (ses-set-cell row col 'value newval)
(dolist (ref (ses-cell-references cell))
(add-to-list 'ses--deferred-recalc ref))))
(setq printer-error (ses-print-cell row col))
(or formula-error printer-error)))
(defun ses-clear-cell (row col)
"Delete formula and printer for cell (ROW,COL)."
(ses-set-cell row col 'printer nil)
(ses-cell-set-formula row col nil))
(defun ses-update-cells (list &optional force)
"Recalculate cells in LIST, checking for dependency loops. Prints
progress messages every second. Dependent cells are not recalculated
if the cell's value is unchanged and FORCE is nil."
(let ((ses--deferred-recalc list)
(nextlist list)
(pos (point))
curlist prevlist rowcol formula)
(with-temp-message " "
(while (and ses--deferred-recalc (not (equal nextlist prevlist)))
(if prevlist
(message "Recalculating... (%d cells left)"
(length ses--deferred-recalc)))
(setq curlist ses--deferred-recalc
ses--deferred-recalc nil
prevlist nextlist)
(while curlist
(setq rowcol (ses-sym-rowcol (car curlist))
formula (ses-cell-formula (car rowcol) (cdr rowcol)))
(or (catch 'ref
(dolist (ref (ses-formula-references formula))
(when (or (memq ref curlist)
(memq ref ses--deferred-recalc))
(add-to-list 'ses--deferred-recalc (car curlist))
(throw 'ref t))))
(when quit-flag
(error "Quit"))
(ses-calculate-cell (car rowcol) (cdr rowcol) force))
(setq curlist (cdr curlist)))
(dolist (ref ses--deferred-recalc)
(add-to-list 'nextlist ref))
(setq nextlist (sort (copy-sequence nextlist) 'string<))
(if (equal nextlist prevlist)
(add-to-list 'nextlist t)))
(when ses--deferred-recalc
(dolist (x ses--deferred-recalc)
(let ((rowcol (ses-sym-rowcol x)))
(ses-set-cell (car rowcol) (cdr rowcol) 'value '*error*)
(1value (ses-print-cell (car rowcol) (cdr rowcol)))))
(error "Circular references: %s" ses--deferred-recalc))
(message " "))
(goto-char pos)))
(defun ses-in-print-area ()
"Returns t if point is in print area of spreadsheet."
(<= (point) ses--data-marker))
(defun ses-goto-print (row col)
"Move point to print area for cell (ROW,COL)."
(let ((inhibit-point-motion-hooks t))
(goto-char (point-min))
(forward-line row)
(dotimes (c col)
(forward-char (1+ (ses-col-width c))))))
(defun ses-set-curcell ()
"Sets `ses--curcell' to the current cell symbol, or a cons (BEG,END) for a
region, or nil if cursor is not at a cell."
(if (or (not mark-active)
deactivate-mark
(= (region-beginning) (region-end)))
(setq ses--curcell (get-text-property (point) 'intangible))
(let ((bcell (get-text-property (region-beginning) 'intangible))
(ecell (get-text-property (1- (region-end)) 'intangible)))
(setq ses--curcell (if (and bcell ecell)
(cons bcell ecell)
nil))))
nil)
(defun ses-check-curcell (&rest args)
"Signal an error if ses--curcell is inappropriate. The end marker is
appropriate if some argument is 'end. A range is appropriate if some
argument is 'range. A single cell is appropriate unless some argument is
'needrange."
(if (eq ses--curcell t)
(ses-set-curcell))
(cond
((not ses--curcell)
(or (memq 'end args)
(error "Not at cell")))
((consp ses--curcell)
(or (memq 'range args)
(memq 'needrange args)
(error "Can't use a range")))
((memq 'needrange args)
(error "Need a range"))))
(defun ses-print-cell (row col)
"Format and print the value of cell (ROW,COL) to the print area.
Use the cell's printer function. If the cell's new print form is too wide,
it will spill over into the following cell, but will not run off the end of the
row or overwrite the next non-nil field. Result is nil for normal operation,
or the error signal if the printer function failed and the cell was formatted
with \"%s\". If the cell's value is *skip*, nothing is printed because the
preceding cell has spilled over."
(catch 'ses-print-cell
(let* ((cell (ses-get-cell row col))
(value (ses-cell-value cell))
(printer (ses-cell-printer cell))
(maxcol (1+ col))
text sig startpos x)
(cond
((eq value '*skip*)
(throw 'ses-print-cell nil))
((eq value '*error*)
(setq text (make-string (ses-col-width col) ?#)))
(t
(if (eq (car-safe printer) 'ses-safe-printer)
(ses-set-cell row col 'printer
(setq printer (ses-safe-printer (cadr printer)))))
(setq text (ses-call-printer (or printer
(ses-col-printer col)
ses--default-printer)
value))
(if (consp ses-call-printer-return)
(setq sig ses-call-printer-return))))
(let ((width (ses-col-width col))
(len (length text)))
(cond
((< len width)
(setq len (make-string (- width len) ?\s)
text (if (eq ses-call-printer-return t)
(concat text len)
(concat len text))))
((> len width)
(let ((maxwidth width))
(while (and (> len maxwidth)
(< maxcol ses--numcols)
(or (not (setq x (ses-cell-value row maxcol)))
(eq x '*skip*)))
(unless x
(ses-set-cell row maxcol 'value '*skip*))
(setq maxwidth (+ maxwidth (ses-col-width maxcol) 1)
maxcol (1+ maxcol)))
(if (<= len maxwidth)
(setq text (concat text (make-string (- maxwidth len) ?\s)))
(setq sig `(error "Too wide" ,text))
(cond
((stringp value)
(setq text (substring text 0 maxwidth)))
((and (numberp value)
(string-match "\\.[0-9]+" text)
(>= 0 (setq width
(- len maxwidth
(- (match-end 0) (match-beginning 0))))))
(setq text (concat (substring text
0
(- (match-beginning 0) width))
(substring text (match-end 0)))))
(t
(setq text (make-string maxwidth ?#)))))))))
(setq text (replace-regexp-in-string "[\t\n]" "?" text))
(ses-goto-print row col)
(setq startpos (point))
(let ((inhibit-read-only t)
(inhibit-quit t))
(delete-char (1+ (length text)))
(setq x (concat text (if (< maxcol ses--numcols) " " "\n")))
(set-text-properties 0 (length x) nil x)
(insert-and-inherit x)
(put-text-property startpos (point) 'intangible
(ses-cell-symbol cell))
(when (and (zerop row) (zerop col))
(put-text-property (point-min) (point) 'keymap 'ses-mode-print-map)
(put-text-property (point-min) (point) 'read-only 'ses)
(put-text-property (point-min) (1+ (point-min)) 'front-sticky t)))
(if (= row (1- ses--header-row))
(ses-reset-header-string))
(when (and (< maxcol ses--numcols)
(eq (ses-cell-value row maxcol) '*skip*))
(ses-set-cell row maxcol 'value nil)
(ses-print-cell row maxcol))
(goto-char startpos)
sig)))
(defun ses-call-printer (printer &optional value)
"Invokes PRINTER (a string or parenthesized string or function-symbol or
lambda of one argument) on VALUE. Result is the the printed cell as a
string. The variable `ses-call-printer-return' is set to t if the printer
used parenthesis to request left-justification, or the error-signal if the
printer signaled one (and \"%s\" is used as the default printer), else nil."
(setq ses-call-printer-return nil)
(unless value
(setq value ""))
(condition-case signal
(cond
((stringp printer)
(format printer value))
((stringp (car-safe printer))
(setq ses-call-printer-return t)
(format (car printer) value))
(t
(setq value (funcall printer value))
(if (stringp value)
value
(or (stringp (car-safe value))
(error "Printer should return \"string\" or (\"string\")"))
(setq ses-call-printer-return t)
(car value))))
(error
(setq ses-call-printer-return signal)
(prin1-to-string value t))))
(defun ses-adjust-print-width (col change)
"Insert CHANGE spaces in front of column COL, or at end of line if
COL=NUMCOLS. Deletes characters if CHANGE < 0. Caller should bind
inhibit-quit to t."
(let ((inhibit-read-only t)
(blank (if (> change 0) (make-string change ?\s)))
(at-end (= col ses--numcols)))
(ses-set-with-undo 'ses--linewidth (+ ses--linewidth change))
(1value (ses-set-with-undo 'ses--blank-line
(concat (make-string ses--linewidth ?\s) "\n")))
(dotimes (row ses--numrows)
(ses-goto-print row col)
(when at-end
(let ((inhibit-point-motion-hooks t))
(backward-char 1)))
(if blank
(insert blank)
(delete-char (- change))))))
(defun ses-print-cell-new-width (row col)
"Same as ses-print-cell, except if the cell's value is *skip*, the preceding
nonskipped cell is reprinted. This function is used when the width of
cell (ROW,COL) has changed."
(if (not (eq (ses-cell-value row col) '*skip*))
(ses-print-cell row col)
(ses-goto-print row col)
(backward-char 1)
(let ((rowcol (ses-sym-rowcol (get-text-property (point) 'intangible))))
(ses-print-cell (car rowcol) (cdr rowcol)))))
(defun ses-narrowed-p () (/= (- (point-max) (point-min)) (buffer-size)))
(defun ses-widen ()
"Turn off narrowing, to be reenabled at end of command loop."
(if (ses-narrowed-p)
(setq ses--deferred-narrow t))
(widen))
(defun ses-goto-data (def &optional col)
"Move point to data area for (DEF,COL). If DEF is a row
number, COL is the column number for a data cell -- otherwise DEF
is one of the symbols ses--col-widths, ses--col-printers,
ses--default-printer, ses--numrows, or ses--numcols."
(ses-widen)
(let ((inhibit-point-motion-hooks t)) (if col
(progn
(goto-char ses--data-marker)
(forward-line (+ 1 (* def (1+ ses--numcols)) col)))
(setq def (plist-get ses-paramlines-plist def))
(or def (signal 'args-out-of-range nil))
(goto-char ses--params-marker)
(forward-line def))))
(defun ses-set-parameter (def value &optional elem)
"Set parameter DEF to VALUE (with undo) and write the value to the data area.
See `ses-goto-data' for meaning of DEF. Newlines in the data are escaped.
If ELEM is specified, it is the array subscript within DEF to be set to VALUE."
(save-excursion
(ses-goto-data def)
(let ((inhibit-read-only t)
(fmt (plist-get '(ses--col-widths "(ses-column-widths %S)"
ses--col-printers "(ses-column-printers %S)"
ses--default-printer "(ses-default-printer %S)"
ses--header-row "(ses-header-row %S)"
ses--file-format " %S ;SES file-format"
ses--numrows " %S ;numrows"
ses--numcols " %S ;numcols")
def))
oldval)
(if elem
(progn
(setq oldval (aref (symbol-value def) elem))
(aset (symbol-value def) elem value))
(setq oldval (symbol-value def))
(set def value))
(let (buffer-undo-list)
(delete-region (point) (line-end-position))
(insert (format fmt (symbol-value def))))
(push `(apply ses-set-parameter ,def ,oldval ,elem) buffer-undo-list))))
(defun ses-write-cells ()
"Write cells in `ses--deferred-write' from local variables to data area.
Newlines in the data are escaped."
(let* ((inhibit-read-only t)
(print-escape-newlines t)
rowcol row col cell sym formula printer text)
(setq ses-start-time (float-time))
(with-temp-message " "
(save-excursion
(while ses--deferred-write
(ses-time-check "Writing... (%d cells left)"
'(length ses--deferred-write))
(setq rowcol (pop ses--deferred-write)
row (car rowcol)
col (cdr rowcol)
cell (ses-get-cell row col)
sym (ses-cell-symbol cell)
formula (ses-cell-formula cell)
printer (ses-cell-printer cell))
(if (eq (car-safe formula) 'ses-safe-formula)
(setq formula (cadr formula)))
(if (eq (car-safe printer) 'ses-safe-printer)
(setq printer (cadr printer)))
(setq text (concat "(ses-cell "
(symbol-name sym)
" "
(prin1-to-string (symbol-value sym))
" "
(prin1-to-string formula)
" "
(prin1-to-string printer)
" "
(if (atom (ses-cell-references cell))
"nil"
(concat "("
(mapconcat 'symbol-name
(ses-cell-references cell)
" ")
")"))
")"))
(ses-goto-data row col)
(delete-region (point) (line-end-position))
(insert text)))
(message " "))))
(defun ses-formula-references (formula &optional result-so-far)
"Produce a list of symbols for cells that this formula's value
refers to. For recursive calls, RESULT-SO-FAR is the list being constructed,
or t to get a wrong-type-argument error when the first reference is found."
(if (atom formula)
(if (ses-sym-rowcol formula)
(add-to-list 'result-so-far formula)
) (dolist (cur formula)
(cond
((ses-sym-rowcol cur)
(add-to-list 'result-so-far cur))
((eq (car-safe cur) 'ses-range)
(dolist (x (cdr (macroexpand cur)))
(add-to-list 'result-so-far x)))
((and (consp cur) (not (eq (car cur) 'quote)))
(setq result-so-far (ses-formula-references cur result-so-far)))
(t
))))
result-so-far)
(defsubst ses-relocate-symbol (sym rowcol startrow startcol rowincr colincr)
"Relocate one symbol SYM, whichs corresponds to ROWCOL (a cons of ROW and
COL). Cells starting at (STARTROW,STARTCOL) are being shifted
by (ROWINCR,COLINCR)."
(let ((row (car rowcol))
(col (cdr rowcol)))
(if (or (< row startrow) (< col startcol))
sym
(setq row (+ row rowincr)
col (+ col colincr))
(if (and (>= row startrow) (>= col startcol)
(< row ses--numrows) (< col ses--numcols))
(ses-create-cell-symbol row col)
nil))))
(defun ses-relocate-formula (formula startrow startcol rowincr colincr)
"Produce a copy of FORMULA where all symbols that refer to cells in row
STARTROW or above and col STARTCOL or above are altered by adding ROWINCR
and COLINCR. STARTROW and STARTCOL are 0-based. Example:
(ses-relocate-formula '(+ A1 B2 D3) 1 2 1 -1)
=> (+ A1 B2 C4)
If ROWINCR or COLINCR is negative, references to cells being deleted are
removed. Example:
(ses-relocate-formula '(+ A1 B2 D3) 0 1 0 -1)
=> (+ A1 C3)
Sets `ses-relocate-return' to 'delete if cell-references were removed."
(let (rowcol result)
(if (or (atom formula) (eq (car formula) 'quote))
(if (setq rowcol (ses-sym-rowcol formula))
(ses-relocate-symbol formula rowcol
startrow startcol rowincr colincr)
formula) (dolist (cur formula)
(setq rowcol (ses-sym-rowcol cur))
(cond
(rowcol
(setq cur (ses-relocate-symbol cur rowcol
startrow startcol rowincr colincr))
(if cur
(push cur result)
(unless ses-relocate-return
(setq ses-relocate-return 'delete))))
((eq (car-safe cur) 'ses-range)
(setq cur (ses-relocate-range cur startrow startcol rowincr colincr))
(if cur
(push cur result)))
((or (atom cur) (eq (car cur) 'quote))
(push cur result))
(t
(push (ses-relocate-formula cur startrow startcol
rowincr colincr)
result))))
(nreverse result))))
(defun ses-relocate-range (range startrow startcol rowincr colincr)
"Relocate one RANGE, of the form '(ses-range min max). Cells starting
at (STARTROW,STARTCOL) are being shifted by (ROWINCR,COLINCR). Result is the
new range, or nil if the entire range is deleted. If new rows are being added
just beyond the end of a row range, or new columns just beyond a column range,
the new rows/columns will be added to the range. Sets `ses-relocate-return'
if the range was altered."
(let* ((minorig (cadr range))
(minrowcol (ses-sym-rowcol minorig))
(min (ses-relocate-symbol minorig minrowcol
startrow startcol
rowincr colincr))
(maxorig (nth 2 range))
(maxrowcol (ses-sym-rowcol maxorig))
(max (ses-relocate-symbol maxorig maxrowcol
startrow startcol
rowincr colincr))
field)
(cond
((and (not min) (not max))
(setq range nil)) ((zerop colincr)
(setq field 'car)
(if (not min)
(setq min (ses-create-cell-symbol startrow (cdr minrowcol))
ses-relocate-return 'range))
(if (not max)
(if (> rowincr 0)
(setq max (ses-create-cell-symbol (1- ses--numrows)
(cdr minrowcol)))
(setq max (ses-create-cell-symbol (1- startrow) (cdr minrowcol))
ses-relocate-return 'range))
(and (> rowincr 0)
(= (car maxrowcol) (1- startrow))
(= (cdr minrowcol) (cdr maxrowcol))
(setq max (ses-create-cell-symbol (+ startrow rowincr -1)
(cdr maxrowcol))))))
(t
(setq field 'cdr)
(if (not min)
(setq min (ses-create-cell-symbol (car minrowcol) startcol)
ses-relocate-return 'range))
(if (not max)
(if (> colincr 0)
(setq max (ses-create-cell-symbol (car maxrowcol)
(1- ses--numcols)))
(setq max (ses-create-cell-symbol (car maxrowcol) (1- startcol))
ses-relocate-return 'range))
(and (> colincr 0)
(= (cdr maxrowcol) (1- startcol))
(= (car minrowcol) (car maxrowcol))
(setq max (ses-create-cell-symbol (car maxrowcol)
(+ startcol colincr -1)))))))
(when range
(if (/= (- (funcall field maxrowcol)
(funcall field minrowcol))
(- (funcall field (ses-sym-rowcol max))
(funcall field (ses-sym-rowcol min))))
(setq ses-relocate-return 'range))
(list 'ses-range min max))))
(defun ses-relocate-all (minrow mincol rowincr colincr)
"Alter all cell values, symbols, formulas, and reference-lists to relocate
the rectangle (MINROW,MINCOL)..(NUMROWS,NUMCOLS) by adding ROWINCR and COLINCR
to each symbol."
(let (reform)
(let (mycell newval)
(dotimes-with-progress-reporter
(row ses--numrows) "Relocating formulas..."
(dotimes (col ses--numcols)
(setq ses-relocate-return nil
mycell (ses-get-cell row col)
newval (ses-relocate-formula (ses-cell-formula mycell)
minrow mincol rowincr colincr))
(ses-set-cell row col 'formula newval)
(if (eq ses-relocate-return 'range)
(push (cons row col) reform))
(if ses-relocate-return
(add-to-list 'ses--deferred-recalc
(ses-create-cell-symbol row col)))
(setq newval (ses-relocate-formula (ses-cell-references mycell)
minrow mincol rowincr colincr))
(ses-set-cell row col 'references newval)
(and (>= row minrow) (>= col mincol)
(ses-set-cell row col 'symbol
(ses-create-cell-symbol row col))))))
(let (oldval myrow mycol xrow xcol)
(cond
((and (<= rowincr 0) (<= colincr 0))
(dotimes-with-progress-reporter
(row (- ses--numrows minrow)) "Relocating variables..."
(setq myrow (+ row minrow))
(dotimes (col (- ses--numcols mincol))
(setq mycol (+ col mincol)
xrow (- myrow rowincr)
xcol (- mycol colincr))
(if (and (< xrow ses--numrows) (< xcol ses--numcols))
(setq oldval (ses-cell-value xrow xcol))
(setq oldval (symbol-value (ses-create-cell-symbol xrow xcol))))
(ses-set-cell myrow mycol 'value oldval))))
((and (wholenump rowincr) (wholenump colincr))
(let ((disty (1- ses--numrows))
(distx (1- ses--numcols))
myrow mycol)
(dotimes-with-progress-reporter
(row (- ses--numrows minrow)) "Relocating variables..."
(setq myrow (- disty row))
(dotimes (col (- ses--numcols mincol))
(setq mycol (- distx col)
xrow (- myrow rowincr)
xcol (- mycol colincr))
(if (or (< xrow minrow) (< xcol mincol))
(setq oldval nil)
(setq oldval (ses-cell-value xrow xcol)))
(ses-set-cell myrow mycol 'value oldval)))
t)) (t
(error "ROWINCR and COLINCR must have the same sign"))))
(when reform
(message "Fixing ses-ranges...")
(let (row col)
(setq ses-start-time (float-time))
(while reform
(ses-time-check "Fixing ses-ranges... (%d left)" '(length reform))
(setq row (caar reform)
col (cdar reform)
reform (cdr reform))
(ses-cell-set-formula row col (ses-cell-formula row col))))
(message nil))))
(defun ses-begin-change ()
"For undo, remember point before we start changing hidden stuff."
(let ((inhibit-read-only t))
(insert-and-inherit "X")
(delete-region (1- (point)) (point))))
(defun ses-set-with-undo (sym newval)
"Like set, but undoable. Result is t if value has changed."
(unless (and (boundp sym)
(equal (symbol-value sym) newval)
(not (stringp newval)))
(push (if (boundp sym)
`(apply ses-set-with-undo ,sym ,(symbol-value sym))
`(apply ses-unset-with-undo ,sym))
buffer-undo-list)
(set sym newval)
t))
(defun ses-unset-with-undo (sym)
"Set SYM to be unbound. This is undoable."
(when (1value (boundp sym)) (push `(apply ses-set-with-undo ,sym ,(symbol-value sym)) buffer-undo-list)
(makunbound sym)))
(defun ses-aset-with-undo (array idx newval)
"Like aset, but undoable. Result is t if element has changed"
(unless (equal (aref array idx) newval)
(push `(apply ses-aset-with-undo ,array ,idx ,(aref array idx)) buffer-undo-list)
(aset array idx newval)
t))
(defun ses-load ()
"Parse the current buffer and sets up buffer-local variables. Does not
execute cell formulas or print functions."
(widen)
(goto-char (point-max))
(search-backward ";; Local Variables:\n" nil t)
(backward-list 1)
(setq ses--params-marker (point-marker))
(let ((params (condition-case nil (read (current-buffer)) (error nil))))
(or (and (= (safe-length params) 3)
(numberp (car params))
(numberp (cadr params))
(>= (cadr params) 0)
(numberp (nth 2 params))
(> (nth 2 params) 0))
(error "Invalid SES file"))
(setq ses--file-format (car params)
ses--numrows (cadr params)
ses--numcols (nth 2 params))
(when (= ses--file-format 1)
(let (buffer-undo-list) (ses-goto-data 'ses--header-row)
(insert "(ses-header-row 0)\n")
(ses-set-parameter 'ses--file-format 2)
(message "Upgrading from SES-1 file format")))
(or (= ses--file-format 2)
(error "This file needs a newer version of the SES library code"))
(ses-create-cell-variable-range 0 (1- ses--numrows) 0 (1- ses--numcols))
(setq ses--cells (make-vector ses--numrows nil))
(dotimes (row ses--numrows)
(aset ses--cells row (make-vector ses--numcols nil))))
(goto-char (point-min))
(forward-line ses--numrows)
(or (looking-at ses-print-data-boundary)
(error "Missing marker between print and data areas"))
(forward-char 1)
(setq ses--data-marker (point-marker))
(forward-char (1- (length ses-print-data-boundary)))
(mapc 'ses-printer-record ses-standard-printer-functions)
(setq ses--symbolic-formulas nil)
(dotimes (row ses--numrows)
(dotimes (col ses--numcols)
(let* ((x (read (current-buffer)))
(rowcol (ses-sym-rowcol (car-safe (cdr-safe x)))))
(or (and (looking-at "\n")
(eq (car-safe x) 'ses-cell)
(eq row (car rowcol))
(eq col (cdr rowcol)))
(error "Cell-def error"))
(eval x)))
(or (looking-at "\n\n")
(error "Missing blank line between rows")))
(let ((widths (read (current-buffer)))
(n1 (char-after (point)))
(printers (read (current-buffer)))
(n2 (char-after (point)))
(def-printer (read (current-buffer)))
(n3 (char-after (point)))
(head-row (read (current-buffer)))
(n4 (char-after (point))))
(or (and (eq (car-safe widths) 'ses-column-widths)
(= n1 ?\n)
(eq (car-safe printers) 'ses-column-printers)
(= n2 ?\n)
(eq (car-safe def-printer) 'ses-default-printer)
(= n3 ?\n)
(eq (car-safe head-row) 'ses-header-row)
(= n4 ?\n))
(error "Invalid SES global parameters"))
(1value (eval widths))
(1value (eval def-printer))
(1value (eval printers))
(1value (eval head-row)))
(forward-char 1)
(or (looking-at (replace-regexp-in-string "1" "[0-9]+"
ses-initial-global-parameters))
(error "Problem with column-defs or global-params"))
(forward-line 3)
(let ((start (point)))
(ses-goto-data 'ses--numrows)
(or (= (point) start)
(error "Extraneous newlines someplace?"))))
(defun ses-setup ()
"Set up for display of only the printed cell values.
Narrows the buffer to show only the print area. Gives it `read-only' and
`intangible' properties. Sets up highlighting for current cell."
(interactive)
(let ((end (point-min))
(inhibit-read-only t)
(was-modified (buffer-modified-p))
pos sym)
(ses-goto-data 0 0) (set-text-properties (point) (point-max) nil) (mapc 'delete-overlay (overlays-in (point-min) (point-max)))
(put-text-property (point-min) (1- (point)) 'read-only 'ses)
(put-text-property (point-min) (1- (point)) 'keymap 'ses-mode-print-map)
(put-text-property (point-min) (1+ (point-min)) 'front-sticky t)
(dotimes-with-progress-reporter (row ses--numrows) "Finding cells..."
(dotimes (col ses--numcols)
(setq pos end
sym (ses-cell-symbol row col))
(while (and (< col (1- ses--numcols))
(eq (ses-cell-value row (1+ col)) '*skip*))
(setq end (+ end (ses-col-width col) 1)
col (1+ col)))
(setq end (+ end (ses-col-width col) 1))
(put-text-property pos end 'intangible sym)))
(unless was-modified
(restore-buffer-modified-p nil)
(buffer-disable-undo)
(buffer-enable-undo)))
(setq ses--curcell-overlay (make-overlay (1+ (point-min)) (1+ (point-min))))
(overlay-put ses--curcell-overlay 'face 'underline))
(defun ses-cleanup ()
"Cleanup when changing a buffer from SES mode to something else. Delete
overlay, remove special text properties."
(widen)
(let ((inhibit-read-only t)
(was-modified (buffer-modified-p)))
(set-text-properties (point-min) (point-max) nil)
(mapc 'delete-overlay (overlays-in (point-min) (point-max)))
(unless was-modified
(set-buffer-modified-p nil))))
(defun ses-mode ()
"Major mode for Simple Emacs Spreadsheet.
See \"ses-example.ses\" (in `data-directory') for more info.
Key definitions:
\\{ses-mode-map}
These key definitions are active only in the print area (the visible part):
\\{ses-mode-print-map}
These are active only in the minibuffer, when entering or editing a formula:
\\{ses-mode-edit-map}"
(interactive)
(unless (and (boundp 'ses--deferred-narrow)
(eq ses--deferred-narrow 'ses-mode))
(kill-all-local-variables)
(mapc 'make-local-variable ses-localvars)
(setq major-mode 'ses-mode
mode-name "SES"
next-line-add-newlines nil
truncate-lines t
show-trailing-whitespace nil
transient-mark-mode t)
(1value (add-hook 'change-major-mode-hook 'ses-cleanup nil t))
(1value (add-hook 'before-revert-hook 'ses-cleanup nil t))
(setq ses--curcell nil
ses--deferred-recalc nil
ses--deferred-write nil
ses--header-hscroll -1 header-line-format '(:eval (progn
(when (/= (window-hscroll)
ses--header-hscroll)
(setq ses--header-hscroll
(window-hscroll))
(ses-create-header-string))
ses--header-string)))
(let ((was-empty (zerop (buffer-size)))
(was-modified (buffer-modified-p)))
(save-excursion
(if was-empty
(insert ses-initial-file-contents))
(ses-load)
(ses-setup))
(when was-empty
(unless (equal ses-initial-default-printer (1value ses--default-printer))
(1value (ses-read-default-printer ses-initial-default-printer)))
(unless (= ses-initial-column-width (1value (ses-col-width 0)))
(1value (ses-set-column-width 0 ses-initial-column-width)))
(ses-set-curcell)
(if (> (car ses-initial-size) (1value ses--numrows))
(1value (ses-insert-row (1- (car ses-initial-size)))))
(if (> (cdr ses-initial-size) (1value ses--numcols))
(1value (ses-insert-column (1- (cdr ses-initial-size)))))
(ses-write-cells)
(restore-buffer-modified-p was-modified)
(buffer-disable-undo)
(buffer-enable-undo)
(goto-char (point-min))))
(use-local-map ses-mode-map)
(setq ses--deferred-narrow 'ses-mode)
(1value (add-hook 'post-command-hook 'ses-command-hook nil t))
(run-with-idle-timer 0.01 nil 'ses-command-hook)
(run-mode-hooks 'ses-mode-hook)))
(put 'ses-mode 'mode-class 'special)
(defun ses-command-hook ()
"Invoked from `post-command-hook'. If point has moved to a different cell,
moves the underlining overlay. Performs any recalculations or cell-data
writes that have been deferred. If buffer-narrowing has been deferred,
narrows the buffer now."
(condition-case err
(when (eq major-mode 'ses-mode) (when ses--deferred-recalc
(let ((old ses--deferred-recalc))
(setq ses--deferred-recalc nil)
(ses-update-cells old)))
(when ses--deferred-write
(ses-write-cells)
(push '(apply ses-widen) buffer-undo-list))
(when ses--deferred-narrow
(narrow-to-region (point-min) ses--data-marker)
(setq ses--deferred-narrow nil))
(let ((oldcell ses--curcell))
(ses-set-curcell)
(unless (eq ses--curcell oldcell)
(cond
((not ses--curcell)
(setq mode-line-process nil))
((atom ses--curcell)
(setq mode-line-process (list " cell "
(symbol-name ses--curcell))))
(t
(setq mode-line-process (list " range "
(symbol-name (car ses--curcell))
"-"
(symbol-name (cdr ses--curcell))))))
(force-mode-line-update)))
(if (listp ses--curcell)
(move-overlay ses--curcell-overlay 2 2)
(let ((next (next-single-property-change (point) 'intangible)))
(move-overlay ses--curcell-overlay (point) (1- next))))
(when (not (pos-visible-in-window-p))
(run-with-idle-timer 0.01 nil 'ses-command-hook)
(setq ses--curcell t)))
(error
(unless executing-kbd-macro
(ding))
(message "%s" (error-message-string err))))
nil)
(defun ses-create-header-string ()
"Set up `ses--header-string' as the buffer's header line.
Based on the current set of columns and `window-hscroll' position."
(let ((totwidth (- (window-hscroll)))
result width x)
(push (propertize " " 'display '((space :align-to 0))) result)
(dotimes (col ses--numcols)
(setq width (ses-col-width col)
totwidth (+ totwidth width 1))
(if (= totwidth 1)
(push " " result))
(when (> totwidth 1)
(if (> ses--header-row 0)
(save-excursion
(ses-goto-print (1- ses--header-row) col)
(setq x (buffer-substring-no-properties (point)
(+ (point) width)))
(if (string-match "[ \t]+\\'" x)
(setq x (substring x 0 (match-beginning 0))))
(if (>= (length x) totwidth)
(setq x (substring x 0 (- totwidth -1)))))
(setq x (ses-column-letter col)))
(push (propertize x 'face ses-box-prop) result)
(push (propertize "."
'display `((space :align-to ,(1- totwidth)))
'face ses-box-prop)
result)
(push (1value (propertize " " 'display `((space :align-to ,totwidth))))
result)))
(if (> ses--header-row 0)
(push (propertize (format " [row %d]" ses--header-row)
'display '((height (- 1))))
result))
(setq ses--header-string (apply 'concat (nreverse result)))))
(defun ses-jump (sym)
"Move point to cell SYM."
(interactive "SJump to cell: ")
(let ((rowcol (ses-sym-rowcol sym)))
(or rowcol (error "Invalid cell name"))
(if (eq (symbol-value sym) '*skip*)
(error "Cell is covered by preceding cell"))
(ses-goto-print (car rowcol) (cdr rowcol))))
(defun ses-jump-safe (cell)
"Like `ses-jump', but no error if invalid cell."
(condition-case nil
(ses-jump cell)
(error)))
(defun ses-reprint-all (&optional nonarrow)
"Recreate the display area. Calls all printer functions. Narrows to
print area if NONARROW is nil."
(interactive "*P")
(widen)
(unless nonarrow
(setq ses--deferred-narrow t))
(let ((startcell (get-text-property (point) 'intangible))
(inhibit-read-only t))
(ses-begin-change)
(goto-char (point-min))
(search-forward ses-print-data-boundary)
(backward-char (length ses-print-data-boundary))
(delete-region (point-min) (point))
(dotimes (row ses--numrows)
(insert-and-inherit ses--blank-line))
(dotimes-with-progress-reporter (row ses--numrows) "Reprinting..."
(if (eq (ses-cell-value row 0) '*skip*)
(ses-set-cell row 0 'value nil))
(dotimes (col ses--numcols)
(ses-print-cell row col))
(beginning-of-line 2))
(ses-jump-safe startcell)))
(defun ses-recalculate-cell ()
"Recalculate and reprint the current cell or range.
For an individual cell, shows the error if the formula or printer
signals one, or otherwise shows the cell's complete value. For a range, the
cells are recalculated in \"natural\" order, so cells that other cells refer
to are recalculated first."
(interactive "*")
(ses-check-curcell 'range)
(ses-begin-change)
(let (sig)
(setq ses-start-time (float-time))
(if (atom ses--curcell)
(setq sig (ses-sym-rowcol ses--curcell)
sig (ses-calculate-cell (car sig) (cdr sig) t))
(ses-dorange ses--curcell
(ses-time-check "Recalculating... %s" '(ses-cell-symbol row col))
(condition-case nil
(progn
(1value (ses-formula-references (ses-cell-formula row col) t))
(setq sig (ses-calculate-cell row col t)))
(wrong-type-argument
(add-to-list 'ses--deferred-recalc (ses-cell-symbol row col))))))
(let ((x ses--deferred-recalc))
(setq ses--deferred-recalc nil)
(condition-case hold
(ses-update-cells x t)
(error (setq sig hold))))
(cond
(sig
(message "%s" (error-message-string sig)))
((consp ses--curcell)
(message " "))
(t
(princ (symbol-value ses--curcell))))))
(defun ses-recalculate-all ()
"Recalculate and reprint all cells."
(interactive "*")
(let ((startcell (get-text-property (point) 'intangible))
(ses--curcell (cons 'A1 (ses-cell-symbol (1- ses--numrows)
(1- ses--numcols)))))
(ses-recalculate-cell)
(ses-jump-safe startcell)))
(defun ses-truncate-cell ()
"Reprint current cell, but without spillover into any following blank
cells."
(interactive "*")
(ses-check-curcell)
(let* ((rowcol (ses-sym-rowcol ses--curcell))
(row (car rowcol))
(col (cdr rowcol)))
(when (and (< col (1- ses--numcols)) (eq (ses-cell-value row (1+ col)) '*skip*))
(eval `(let ((,(ses-cell-symbol row (1+ col)) t))
(ses-print-cell row col)))
(ses-set-cell row (1+ col) 'value nil)
(1value (ses-print-cell row (1+ col))))))
(defun ses-reconstruct-all ()
"Reconstruct buffer based on cell data stored in Emacs variables."
(interactive "*")
(ses-begin-change)
(let (x yrow ycol)
(dotimes-with-progress-reporter
(row ses--numrows) "Deleting references..."
(dotimes (col ses--numcols)
(ses-set-cell row col 'references nil)))
(dotimes-with-progress-reporter
(row ses--numrows) "Computing references..."
(dotimes (col ses--numcols)
(dolist (ref (ses-formula-references (ses-cell-formula row col)))
(setq x (ses-sym-rowcol ref)
yrow (car x)
ycol (cdr x))
(ses-set-cell yrow ycol 'references
(cons (ses-cell-symbol row col)
(ses-cell-references yrow ycol)))))))
(ses-widen)
(let ((inhibit-read-only t))
(goto-char (point-max))
(if (search-backward ";; Local Variables:\n" nil t)
(delete-region (point-min) (point))
(delete-region (point-min) (point-max))
(insert ses-initial-file-trailer)
(goto-char (point-min)))
(dotimes (row ses--numrows)
(insert ses--blank-line))
(insert ses-print-data-boundary)
(backward-char (1- (length ses-print-data-boundary)))
(setq ses--data-marker (point-marker))
(forward-char (1- (length ses-print-data-boundary)))
(insert (make-string (* ses--numrows (1+ ses--numcols)) ?\n))
(insert "\n\n\n\n")
(insert ses-initial-global-parameters)
(backward-char (1- (length ses-initial-global-parameters)))
(setq ses--params-marker (point-marker))
(forward-char (1- (length ses-initial-global-parameters))))
(ses-set-parameter 'ses--col-widths ses--col-widths)
(ses-set-parameter 'ses--col-printers ses--col-printers)
(ses-set-parameter 'ses--default-printer ses--default-printer)
(ses-set-parameter 'ses--header-row ses--header-row)
(ses-set-parameter 'ses--numrows ses--numrows)
(ses-set-parameter 'ses--numcols ses--numcols)
(ses-setup)
(ses-recalculate-all)
(goto-char (point-min)))
(defun ses-edit-cell (row col newval)
"Display current cell contents in minibuffer, for editing. Returns nil if
cell formula was unsafe and user declined confirmation."
(interactive
(progn
(barf-if-buffer-read-only)
(ses-check-curcell)
(let* ((rowcol (ses-sym-rowcol ses--curcell))
(row (car rowcol))
(col (cdr rowcol))
(formula (ses-cell-formula row col))
initial)
(if (eq (car-safe formula) 'ses-safe-formula)
(setq formula (cadr formula)))
(if (eq (car-safe formula) 'quote)
(setq initial (format "'%S" (cadr formula)))
(setq initial (prin1-to-string formula)))
(if (stringp formula)
(setq initial (cons initial (length initial))))
(list row col
(read-from-minibuffer (format "Cell %s: " ses--curcell)
initial
ses-mode-edit-map
t 'ses-read-cell-history)))))
(when (ses-warn-unsafe newval 'unsafep)
(ses-begin-change)
(ses-cell-set-formula row col newval)
t))
(defun ses-read-cell (row col newval)
"Self-insert for initial character of cell function."
(interactive
(let* ((initial (this-command-keys))
(rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))
(curval (ses-cell-formula (car rowcol) (cdr rowcol))))
(barf-if-buffer-read-only)
(list (car rowcol)
(cdr rowcol)
(read-from-minibuffer
(format "Cell %s: " ses--curcell)
(cons (if (equal initial "\"") "\"\""
(if (equal initial "(") "()" initial)) 2)
ses-mode-edit-map
t 'ses-read-cell-history
(prin1-to-string (if (eq (car-safe curval) 'ses-safe-formula)
(cadr curval)
curval))))))
(when (ses-edit-cell row col newval)
(ses-command-hook) (dolist (x ses-after-entry-functions)
(funcall x 1))))
(defun ses-read-symbol (row col symb)
"Self-insert for a symbol as a cell formula. The set of all symbols that
have been used as formulas in this spreadsheet is available for completions."
(interactive
(let ((rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))
newval)
(barf-if-buffer-read-only)
(setq newval (completing-read (format "Cell %s ': " ses--curcell)
ses--symbolic-formulas))
(list (car rowcol)
(cdr rowcol)
(if (string= newval "")
nil (list 'quote (intern newval))))))
(when (ses-edit-cell row col symb)
(ses-command-hook) (dolist (x ses-after-entry-functions)
(funcall x 1))))
(defun ses-clear-cell-forward (count)
"Delete formula and printer for current cell and then move to next cell.
With prefix, deletes several cells."
(interactive "*p")
(if (< count 0)
(1value (ses-clear-cell-backward (- count)))
(ses-check-curcell)
(ses-begin-change)
(dotimes (x count)
(ses-set-curcell)
(let ((rowcol (ses-sym-rowcol ses--curcell)))
(or rowcol (signal 'end-of-buffer nil))
(ses-clear-cell (car rowcol) (cdr rowcol)))
(forward-char 1))))
(defun ses-clear-cell-backward (count)
"Move to previous cell and then delete it. With prefix, deletes several
cells."
(interactive "*p")
(if (< count 0)
(1value (ses-clear-cell-forward (- count)))
(ses-check-curcell 'end)
(ses-begin-change)
(dotimes (x count)
(backward-char 1) (ses-set-curcell)
(let ((rowcol (ses-sym-rowcol ses--curcell)))
(ses-clear-cell (car rowcol) (cdr rowcol))))))
(defun ses-read-printer (prompt default)
"Common code for `ses-read-cell-printer', `ses-read-column-printer', and `ses-read-default-printer'.
PROMPT should end with \": \". Result is t if operation was cancelled."
(barf-if-buffer-read-only)
(if (eq default t)
(setq default "")
(setq prompt (format "%s [currently %S]: "
(substring prompt 0 -2)
default)))
(let ((new (read-from-minibuffer prompt
nil ses-mode-edit-map
t 'ses-read-printer-history
(prin1-to-string default))))
(if (equal new default)
(setq new t)
(ses-printer-validate new)
(or (not new)
(stringp new)
(stringp (car-safe new))
(ses-warn-unsafe new 'unsafep-function)
(setq new t)))
new))
(defun ses-read-cell-printer (newval)
"Set the printer function for the current cell or range.
A printer function is either a string (a format control-string with one
%-sequence -- result from format will be right-justified), or a list of one
string (result from format will be left-justified), or a lambda-expression of
one argument, or a symbol that names a function of one argument. In the
latter two cases, the function's result should be either a string (will be
right-justified) or a list of one string (will be left-justified)."
(interactive
(let ((default t)
x)
(ses-check-curcell 'range)
(catch 'ses-read-cell-printer
(ses-dorange ses--curcell
(setq x (ses-cell-printer row col))
(if (eq (car-safe x) 'ses-safe-printer)
(setq x (cadr x)))
(if (eq default t)
(setq default x)
(unless (equal default x)
(setq default t)
(throw 'ses-read-cell-printer t)))))
(list (ses-read-printer (format "Cell %S printer: " ses--curcell)
default))))
(unless (eq newval t)
(ses-begin-change)
(ses-dorange ses--curcell
(ses-set-cell row col 'printer newval)
(ses-print-cell row col))))
(defun ses-read-column-printer (col newval)
"Set the printer function for the current column. See
`ses-read-cell-printer' for input forms."
(interactive
(let ((col (cdr (ses-sym-rowcol ses--curcell))))
(ses-check-curcell)
(list col (ses-read-printer (format "Column %s printer: "
(ses-column-letter col))
(ses-col-printer col)))))
(unless (eq newval t)
(ses-begin-change)
(ses-set-parameter 'ses--col-printers newval col)
(save-excursion
(dotimes (row ses--numrows)
(ses-print-cell row col)))))
(defun ses-read-default-printer (newval)
"Set the default printer function for cells that have no other. See
`ses-read-cell-printer' for input forms."
(interactive
(list (ses-read-printer "Default printer: " ses--default-printer)))
(unless (eq newval t)
(ses-begin-change)
(ses-set-parameter 'ses--default-printer newval)
(ses-reprint-all t)))
(defun ses-insert-row (count)
"Insert a new row before the current one. With prefix, insert COUNT rows
before current one."
(interactive "*p")
(ses-check-curcell 'end)
(or (> count 0) (signal 'args-out-of-range nil))
(ses-begin-change)
(let ((inhibit-quit t)
(inhibit-read-only t)
(row (or (car (ses-sym-rowcol ses--curcell)) ses--numrows))
newrow)
(ses-create-cell-variable-range ses--numrows (+ ses--numrows count -1)
0 (1- ses--numcols))
(ses-set-parameter 'ses--numrows (+ ses--numrows count))
(ses-goto-print row 0)
(dotimes-with-progress-reporter (x count) "Inserting row..."
(setq newrow (make-vector ses--numcols nil))
(dotimes (col ses--numcols)
(aset newrow col (ses-make-cell)))
(setq ses--cells (ses-vector-insert ses--cells row newrow))
(push `(apply ses-vector-delete ses--cells ,row 1) buffer-undo-list)
(insert ses--blank-line))
(ses-goto-data row 0)
(insert (make-string (* (1+ ses--numcols) count) ?\n))
(ses-relocate-all row 0 count 0)
(let ((cols (mapconcat #'ses-call-printer ses--col-printers nil))
(global (ses-call-printer ses--default-printer)))
(if (or (> (length cols) 0) (> (length global) 0))
(dotimes (x count)
(dotimes (col ses--numcols)
(1value (ses-print-cell (+ x row) col))))))
(when (> ses--header-row row)
(ses-set-parameter 'ses--header-row (+ ses--header-row count))
(ses-reset-header-string)))
(ses-setup)
(push '(apply ses-widen) buffer-undo-list)
(if ses--curcell
(ses-jump-safe ses--curcell)
(ses-goto-print (1- ses--numrows) 0)))
(defun ses-delete-row (count)
"Delete the current row. With prefix, Deletes COUNT rows starting from the
current one."
(interactive "*p")
(ses-check-curcell)
(or (> count 0) (signal 'args-out-of-range nil))
(let ((inhibit-quit t)
(inhibit-read-only t)
(row (car (ses-sym-rowcol ses--curcell))))
(setq count (min count (- ses--numrows row)))
(ses-begin-change)
(ses-set-parameter 'ses--numrows (- ses--numrows count))
(ses-goto-print row 0)
(ses-delete-line count)
(ses-goto-data row 0)
(ses-delete-line (* count (1+ ses--numcols)))
(ses-set-with-undo 'ses--cells (ses-vector-delete ses--cells row count))
(ses-relocate-all row 0 (- count) 0)
(ses-destroy-cell-variable-range ses--numrows (+ ses--numrows count -1)
0 (1- ses--numcols))
(when (> ses--header-row row)
(if (<= ses--header-row (+ row count))
(ses-set-parameter 'ses--header-row 0)
(ses-set-parameter 'ses--header-row (- ses--header-row count)))
(ses-reset-header-string)))
(ses-setup)
(push '(apply ses-widen) buffer-undo-list)
(ses-jump-safe ses--curcell))
(defun ses-insert-column (count &optional col width printer)
"Insert a new column before COL (default is the current one).
With prefix, insert COUNT columns before current one.
If COL is specified, the new column(s) get the specified WIDTH and PRINTER
\(otherwise they're taken from the current column)."
(interactive "*p")
(ses-check-curcell)
(or (> count 0) (signal 'args-out-of-range nil))
(or col
(setq col (cdr (ses-sym-rowcol ses--curcell))
width (ses-col-width col)
printer (ses-col-printer col)))
(ses-begin-change)
(let ((inhibit-quit t)
(inhibit-read-only t)
(widths ses--col-widths)
(printers ses--col-printers)
has-skip)
(ses-create-cell-variable-range 0 (1- ses--numrows)
ses--numcols (+ ses--numcols count -1))
(dotimes-with-progress-reporter (x count) "Inserting column..."
(ses-adjust-print-width col (1+ width))
(ses-set-parameter 'ses--numcols (1+ ses--numcols))
(dotimes (row ses--numrows)
(and (< (1+ col) ses--numcols) (eq (ses-cell-value row col) '*skip*)
(setq has-skip t))
(ses-aset-with-undo ses--cells row
(ses-vector-insert (aref ses--cells row)
col (ses-make-cell)))
(ses-goto-data row col)
(insert ?\n))
(setq widths (ses-vector-insert widths col width)
printers (ses-vector-insert printers col printer)))
(ses-set-parameter 'ses--col-widths widths)
(ses-set-parameter 'ses--col-printers printers)
(ses-reset-header-string)
(ses-relocate-all 0 col 0 count)
(if has-skip
(ses-reprint-all t)
(when (or (> (length (ses-call-printer printer)) 0)
(> (length (ses-call-printer ses--default-printer)) 0))
(dotimes (x ses--numrows)
(dotimes (y count)
(1value (ses-print-cell-new-width x (+ y col))))))
(ses-setup)))
(ses-jump-safe ses--curcell))
(defun ses-delete-column (count)
"Delete the current column. With prefix, Deletes COUNT columns starting
from the current one."
(interactive "*p")
(ses-check-curcell)
(or (> count 0) (signal 'args-out-of-range nil))
(let ((inhibit-quit t)
(inhibit-read-only t)
(rowcol (ses-sym-rowcol ses--curcell))
(width 0)
col origrow has-skip)
(setq origrow (car rowcol)
col (cdr rowcol)
count (min count (- ses--numcols col)))
(if (= count ses--numcols)
(error "Can't delete all columns!"))
(dotimes (x count)
(setq width (+ width (ses-col-width (+ col x)) 1)))
(ses-begin-change)
(ses-set-parameter 'ses--numcols (- ses--numcols count))
(ses-adjust-print-width col (- width))
(dotimes-with-progress-reporter (row ses--numrows) "Deleting column..."
(ses-goto-data row col)
(ses-delete-line count)
(if (or (eq (ses-cell-value row col) '*skip*)
(and (< col ses--numcols)
(eq (ses-cell-value row (+ col count)) '*skip*)))
(setq has-skip t))
(ses-aset-with-undo ses--cells row
(ses-vector-delete (aref ses--cells row) col count)))
(ses-set-parameter 'ses--col-widths
(ses-vector-delete ses--col-widths col count))
(ses-set-parameter 'ses--col-printers
(ses-vector-delete ses--col-printers col count))
(ses-reset-header-string)
(ses-relocate-all 0 col 0 (- count))
(ses-destroy-cell-variable-range 0 (1- ses--numrows)
ses--numcols (+ ses--numcols count -1))
(if has-skip
(ses-reprint-all t)
(ses-setup))
(if (>= col ses--numcols)
(setq col (1- col)))
(ses-goto-print origrow col)))
(defun ses-forward-or-insert (&optional count)
"Move to next cell in row, or inserts a new cell if already in last one, or
inserts a new row if at bottom of print area. Repeat COUNT times."
(interactive "p")
(ses-check-curcell 'end)
(setq deactivate-mark t) (dotimes (x count)
(ses-set-curcell)
(if (not ses--curcell)
(progn (barf-if-buffer-read-only)
(ses-insert-row 1))
(let ((col (cdr (ses-sym-rowcol ses--curcell))))
(when (/= 32
(char-before (next-single-property-change (point)
'intangible)))
(barf-if-buffer-read-only)
(ses-insert-column (- count x)
ses--numcols
(ses-col-width col)
(ses-col-printer col)))))
(forward-char)))
(defun ses-append-row-jump-first-column ()
"Insert a new row after current one and jumps to its first column."
(interactive "*")
(ses-check-curcell)
(ses-begin-change)
(beginning-of-line 2)
(ses-set-curcell)
(ses-insert-row 1))
(defun ses-set-column-width (col newwidth)
"Set the width of the current column."
(interactive
(let ((col (cdr (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))))
(barf-if-buffer-read-only)
(list col
(if current-prefix-arg
(prefix-numeric-value current-prefix-arg)
(read-from-minibuffer (format "Column %s width [currently %d]: "
(ses-column-letter col)
(ses-col-width col))
nil nil t nil (number-to-string
(ses-col-width col))))))) (if (< newwidth 1)
(error "Invalid column width"))
(ses-begin-change)
(ses-reset-header-string)
(save-excursion
(let ((inhibit-quit t))
(ses-adjust-print-width col (- newwidth (ses-col-width col)))
(ses-set-parameter 'ses--col-widths newwidth col))
(dotimes (row ses--numrows)
(ses-print-cell-new-width row col))))
(defadvice copy-region-as-kill (around ses-copy-region-as-kill
activate preactivate)
"It doesn't make sense to copy read-only or intangible attributes into the
kill ring. It probably doesn't make sense to copy keymap properties.
We'll assume copying front-sticky properties doesn't make sense, either.
This advice also includes some SES-specific code because otherwise it's too
hard to override how mouse-1 works."
(when (> beg end)
(let ((temp beg))
(setq beg end
end temp)))
(if (not (and (eq major-mode 'ses-mode)
(eq (get-text-property beg 'read-only) 'ses)
(eq (get-text-property (1- end) 'read-only) 'ses)))
ad-do-it (kill-new (ses-copy-region beg end))
(if transient-mark-mode
(setq deactivate-mark t))
nil))
(defun ses-copy-region (beg end)
"Treat the region as rectangular. Convert the intangible attributes to
SES attributes recording the contents of the cell as of the time of copying."
(let* ((inhibit-point-motion-hooks t)
(x (mapconcat 'ses-copy-region-helper
(extract-rectangle beg (1- end)) "\n")))
(remove-text-properties 0 (length x)
'(read-only t
intangible t
keymap t
front-sticky t)
x)
x))
(defun ses-copy-region-helper (line)
"Converts one line (of a rectangle being extracted from a spreadsheet) to
external form by attaching to each print cell a 'ses attribute that records
the corresponding data cell."
(or (> (length line) 1)
(error "Empty range"))
(let ((inhibit-read-only t)
(pos 0)
mycell next sym rowcol)
(while pos
(setq sym (get-text-property pos 'intangible line)
next (next-single-property-change pos 'intangible line)
rowcol (ses-sym-rowcol sym)
mycell (ses-get-cell (car rowcol) (cdr rowcol)))
(put-text-property pos (or next (length line))
'ses
(list (ses-cell-symbol mycell)
(ses-cell-formula mycell)
(ses-cell-printer mycell))
line)
(setq pos next)))
line)
(defun ses-kill-override (beg end)
"Generic override for any commands that kill text. We clear the killed
cells instead of deleting them."
(interactive "r")
(ses-check-curcell 'needrange)
(let ((buffer-read-only t))
(1value (condition-case x
(noreturn (funcall (lookup-key (current-global-map)
(this-command-keys))
beg end))
(buffer-read-only nil)))) (barf-if-buffer-read-only)
(ses-begin-change)
(ses-dorange ses--curcell
(ses-clear-cell row col))
(ses-jump (car ses--curcell)))
(defadvice yank (around ses-yank activate preactivate)
"In SES mode, the yanked text is inserted as cells.
If the text contains 'ses attributes (meaning it went to the kill-ring from a
SES buffer), the formulas and print functions are restored for the cells. If
the text contains tabs, this is an insertion of tab-separated formulas.
Otherwise the text is inserted as the formula for the current cell.
When inserting cells, the formulas are usually relocated to keep the same
relative references to neighboring cells. This is best if the formulas
generally refer to other cells within the yanked text. You can use the C-u
prefix to specify insertion without relocation, which is best when the
formulas refer to cells outsite the yanked text.
When inserting formulas, the text is treated as a string constant if it doesn't
make sense as a sexp or would otherwise be considered a symbol. Use 'sym to
explicitly insert a symbol, or use the C-u prefix to treat all unmarked words
as symbols."
(if (not (and (eq major-mode 'ses-mode)
(eq (get-text-property (point) 'keymap) 'ses-mode-print-map)))
ad-do-it (ses-check-curcell 'end)
(push-mark (point))
(let ((text (current-kill (cond
((listp arg) 0)
((eq arg '-) -1)
(t (1- arg))))))
(or (ses-yank-cells text arg)
(ses-yank-tsf text arg)
(ses-yank-one (ses-yank-resize 1 1)
text
0
(if (memq (aref text (1- (length text))) '(?\t ?\n))
(1- (length text)))
arg)))
(if (consp arg)
(exchange-point-and-mark))))
(defun ses-yank-pop (arg)
"Replace just-yanked stretch of killed text with a different stretch.
This command is allowed only immediately after a `yank' or a `yank-pop', when
the region contains a stretch of reinserted previously-killed text. We
replace it with a different stretch of killed text.
Unlike standard `yank-pop', this function uses `undo' to delete the
previous insertion."
(interactive "*p")
(or (eq last-command 'yank)
(noreturn (error "Previous command was not a yank")))
(undo)
(ses-set-curcell)
(yank (1+ (or arg 1)))
(setq this-command 'yank))
(defun ses-yank-cells (text arg)
"If the TEXT has a proper set of 'ses attributes, inserts the text as
cells, else return nil. The cells are reprinted--the supplied text is
ignored because the column widths, default printer, etc. at yank time might
be different from those at kill-time. ARG is a list to indicate that
formulas are to be inserted without relocation."
(let ((first (get-text-property 0 'ses text))
(last (get-text-property (1- (length text)) 'ses text)))
(when (and first last) (setq first (ses-sym-rowcol (car first))
last (ses-sym-rowcol (car last)))
(let* ((needrows (- (car last) (car first) -1))
(needcols (- (cdr last) (cdr first) -1))
(rowcol (ses-yank-resize needrows needcols))
(rowincr (- (car rowcol) (car first)))
(colincr (- (cdr rowcol) (cdr first)))
(pos 0)
myrow mycol x)
(dotimes-with-progress-reporter (row needrows) "Yanking..."
(setq myrow (+ row (car rowcol)))
(dotimes (col needcols)
(setq mycol (+ col (cdr rowcol))
last (get-text-property pos 'ses text)
pos (next-single-property-change pos 'ses text)
x (ses-sym-rowcol (car last)))
(if (not last)
(setq x (cons (- myrow rowincr) (+ needcols colincr -1))
last (list nil nil nil)
pos (1- pos)))
(if (/= (car x) (- myrow rowincr))
(error "Cell row error"))
(if (< (- mycol colincr) (cdr x))
(let ((oldcol mycol))
(while (< (- mycol colincr) (cdr x))
(ses-clear-cell myrow mycol)
(setq col (1+ col)
mycol (1+ mycol)))
(ses-print-cell myrow (1- oldcol)))) (when (car last) (setq x (nth 2 last))
(unless (equal x (ses-cell-printer myrow mycol))
(or (not x)
(stringp x)
(eq (car-safe x) 'ses-safe-printer)
(setq x `(ses-safe-printer ,x)))
(ses-set-cell myrow mycol 'printer x))
(setq x (cadr last))
(if (atom arg)
(setq x (ses-relocate-formula x 0 0 rowincr colincr)))
(or (atom x)
(eq (car-safe x) 'ses-safe-formula)
(setq x `(ses-safe-formula ,x)))
(ses-cell-set-formula myrow mycol x)))
(when pos
(if (get-text-property pos 'ses text)
(error "Missing newline between rows"))
(setq pos (next-single-property-change pos 'ses text))))
t))))
(defun ses-yank-one (rowcol text from to arg)
"Insert the substring [FROM,TO] of TEXT as the formula for cell ROWCOL (a
cons of ROW and COL). Treat plain symbols as strings unless ARG is a list."
(let ((val (condition-case nil
(read-from-string text from to)
(error (cons nil from)))))
(cond
((< (cdr val) (or to (length text)))
(setq val (substring text from to)))
((and (car val) (symbolp (car val)))
(if (consp arg)
(setq val (list 'quote (car val))) (setq val (substring text from to)))) (t
(setq val (car val))))
(let ((row (car rowcol))
(col (cdr rowcol)))
(or (atom val)
(setq val `(ses-safe-formula ,val)))
(ses-cell-set-formula row col val))))
(defun ses-yank-tsf (text arg)
"If TEXT contains tabs and/or newlines, treats the tabs as
column-separators and the newlines as row-separators and inserts the text as
cell formulas--else return nil. Treat plain symbols as strings unless ARG
is a list. Ignore a final newline."
(if (or (not (string-match "[\t\n]" text))
(= (match-end 0) (length text)))
nil
(if (/= (aref text (1- (length text))) ?\n)
(setq text (concat text "\n")))
(let ((pos -1)
(spots (list -1))
(cols 0)
(needrows 0)
needcols rowcol)
(while (setq pos (string-match "[\t\n]" text (1+ pos)))
(push pos spots)
(setq cols (1+ cols))
(when (eq (aref text pos) ?\n)
(if (not needcols)
(setq needcols cols)
(or (= needcols cols)
(error "Inconsistent row lengths")))
(setq cols 0
needrows (1+ needrows))))
(setq rowcol (ses-yank-resize needrows needcols))
(dotimes (row needrows)
(dotimes (col needcols)
(ses-yank-one (cons (+ (car rowcol) needrows (- row) -1)
(+ (cdr rowcol) needcols (- col) -1))
text (1+ (cadr spots)) (car spots) arg)
(setq spots (cdr spots))))
(ses-goto-print (+ (car rowcol) needrows -1)
(+ (cdr rowcol) needcols -1))
t)))
(defun ses-yank-resize (needrows needcols)
"If this yank will require inserting rows and/or columns, asks for
confirmation and then inserts them. Result is (row,col) for top left of yank
spot, or error signal if user requests cancel."
(ses-begin-change)
(let ((rowcol (if ses--curcell
(ses-sym-rowcol ses--curcell)
(cons ses--numrows 0)))
rowbool colbool)
(setq needrows (- (+ (car rowcol) needrows) ses--numrows)
needcols (- (+ (cdr rowcol) needcols) ses--numcols)
rowbool (> needrows 0)
colbool (> needcols 0))
(when (or rowbool colbool)
(or (y-or-n-p (format "Yank will insert %s%s%s. Continue? "
(if rowbool (format "%d rows" needrows) "")
(if (and rowbool colbool) " and " "")
(if colbool (format "%d columns" needcols) "")))
(error "Cancelled"))
(when rowbool
(let (ses--curcell)
(save-excursion
(ses-goto-print ses--numrows 0)
(ses-insert-row needrows))))
(when colbool
(ses-insert-column needcols
ses--numcols
(ses-col-width (1- ses--numcols))
(ses-col-printer (1- ses--numcols)))))
rowcol))
(defun ses-export-tsv (beg end)
"Export values from the current range, with tabs between columns and
newlines between rows. Result is placed in kill ring."
(interactive "r")
(ses-export-tab nil))
(defun ses-export-tsf (beg end)
"Export formulas from the current range, with tabs between columns and
newlines between rows. Result is placed in kill ring."
(interactive "r")
(ses-export-tab t))
(defun ses-export-tab (want-formulas)
"Export the current range with tabs between columns and newlines between
rows. Result is placed in kill ring. The export is values unless
WANT-FORMULAS is non-nil. Newlines and tabs in the export text are escaped."
(ses-check-curcell 'needrange)
(let ((print-escape-newlines t)
result item)
(ses-dorange ses--curcell
(setq item (if want-formulas
(ses-cell-formula row col)
(ses-cell-value row col)))
(if (eq (car-safe item) 'ses-safe-formula)
(setq item (cadr item)))
(if (or (not item) (eq item '*skip*))
(setq item ""))
(when (eq (car-safe item) 'quote)
(push "'" result)
(setq item (cadr item)))
(setq item (prin1-to-string item t))
(setq item (replace-regexp-in-string "\t" "\\\\t" item))
(push item result)
(cond
((< col maxcol)
(push "\t" result))
((< row maxrow)
(push "\n" result))))
(setq result (apply 'concat (nreverse result)))
(kill-new result)))
(defun ses-unset-header-row ()
"Select the default header row."
(interactive)
(ses-set-header-row 0))
(defun ses-set-header-row (row)
"Set the ROW to display in the header-line.
With a numerical prefix arg, use that row.
With no prefix arg, use the current row.
With a \\[universal-argument] prefix arg, prompt the user.
The top row is row 1. Selecting row 0 displays the default header row."
(interactive
(list (if (numberp current-prefix-arg) current-prefix-arg
(let ((currow (1+ (car (ses-sym-rowcol ses--curcell)))))
(if current-prefix-arg
(read-number "Header row: " currow)
currow)))))
(if (or (< row 0) (> row ses--numrows))
(error "Invalid header-row"))
(ses-begin-change)
(let ((oldval ses--header-row))
(let (buffer-undo-list)
(ses-set-parameter 'ses--header-row row))
(push `(apply ses-set-header-row ,oldval) buffer-undo-list))
(ses-reset-header-string))
(defun ses-mark-row ()
"Marks the entirety of current row as a range."
(interactive)
(ses-check-curcell 'range)
(let ((row (car (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell)))))
(push-mark (point))
(ses-goto-print (1+ row) 0)
(push-mark (point) nil t)
(ses-goto-print row 0)))
(defun ses-mark-column ()
"Marks the entirety of current column as a range."
(interactive)
(ses-check-curcell 'range)
(let ((col (cdr (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell))))
(row 0))
(push-mark (point))
(ses-goto-print (1- ses--numrows) col)
(forward-char 1)
(push-mark (point) nil t)
(while (eq '*skip* (ses-cell-value row col))
(setq row (1+ row)))
(ses-goto-print row col)))
(defun ses-end-of-line ()
"Move point to last cell on line."
(interactive)
(ses-check-curcell 'end 'range)
(when ses--curcell (let ((col (1- ses--numcols))
row rowcol)
(if (symbolp ses--curcell)
(setq row (car (ses-sym-rowcol ses--curcell)))
(setq rowcol (ses-sym-rowcol (if (< (point) (mark))
(car ses--curcell)
(cdr ses--curcell))))
(if (<= (cdr rowcol) (1- col))
(setq row (car rowcol))
(setq row (1+ (car rowcol)))
(if (= row ses--numrows)
(setq col 0))))
(when (< row ses--numrows) (while (eq (ses-cell-value row col) '*skip*)
(setq col (1- col)))
(ses-goto-print row col)))))
(defun ses-renarrow-buffer ()
"Narrow the buffer so only the print area is visible. Use after \\[widen]."
(interactive)
(setq ses--deferred-narrow t))
(defun ses-sort-column (sorter &optional reverse)
"Sorts the range by a specified column. With prefix, sorts in
REVERSE order."
(interactive "*sSort column: \nP")
(ses-check-curcell 'needrange)
(let ((min (ses-sym-rowcol (car ses--curcell)))
(max (ses-sym-rowcol (cdr ses--curcell))))
(let ((minrow (car min))
(mincol (cdr min))
(maxrow (car max))
(maxcol (cdr max))
keys extracts end)
(setq sorter (cdr (ses-sym-rowcol (intern (concat sorter "1")))))
(or (and sorter (>= sorter mincol) (<= sorter maxcol))
(error "Invalid sort column"))
(dotimes (x (- maxrow minrow -1))
(ses-goto-print (+ minrow x) sorter)
(setq end (next-single-property-change (point) 'intangible))
(push (cons (buffer-substring-no-properties (point) end)
(+ minrow x))
keys))
(setq keys (sort keys #'(lambda (x y) (string< (car x) (car y)))))
(or reverse
(setq keys (nreverse keys)))
(dolist (x keys)
(ses-goto-print (cdr x) (1+ maxcol))
(setq end (point))
(ses-goto-print (cdr x) mincol)
(push (ses-copy-region (point) end) extracts))
(deactivate-mark)
(dotimes (x (- maxrow minrow -1))
(ses-goto-print (+ minrow x) mincol)
(ses-set-curcell)
(ses-yank-cells (pop extracts) nil)))))
(defun ses-sort-column-click (event reverse)
"Mouse version of `ses-sort-column'."
(interactive "*e\nP")
(setq event (event-end event))
(select-window (posn-window event))
(setq event (car (posn-col-row event))) (let ((col 0))
(while (and (< col ses--numcols) (> event (ses-col-width col)))
(setq event (- event (ses-col-width col) 1)
col (1+ col)))
(if (>= col ses--numcols)
(ding)
(ses-sort-column (ses-column-letter col) reverse))))
(defun ses-insert-range ()
"Inserts into minibuffer the list of cells currently highlighted in the
spreadsheet."
(interactive "*")
(let (x)
(with-current-buffer (window-buffer minibuffer-scroll-window)
(ses-command-hook) (ses-check-curcell 'needrange)
(setq x (cdr (macroexpand `(ses-range ,(car ses--curcell)
,(cdr ses--curcell))))))
(insert (substring (prin1-to-string (nreverse x)) 1 -1))))
(defun ses-insert-ses-range ()
"Inserts \"(ses-range x y)\" in the minibuffer to represent the currently
highlighted range in the spreadsheet."
(interactive "*")
(let (x)
(with-current-buffer (window-buffer minibuffer-scroll-window)
(ses-command-hook) (ses-check-curcell 'needrange)
(setq x (format "(ses-range %S %S)"
(car ses--curcell)
(cdr ses--curcell))))
(insert x)))
(defun ses-insert-range-click (event)
"Mouse version of `ses-insert-range'."
(interactive "*e")
(mouse-set-point event)
(ses-insert-range))
(defun ses-insert-ses-range-click (event)
"Mouse version of `ses-insert-ses-range'."
(interactive "*e")
(mouse-set-point event)
(ses-insert-ses-range))
(defun ses-safe-printer (printer)
"Returns PRINTER if safe, or the substitute printer `ses-unsafe' otherwise."
(if (or (stringp printer)
(stringp (car-safe printer))
(not printer)
(ses-warn-unsafe printer 'unsafep-function))
printer
'ses-unsafe))
(defun ses-safe-formula (formula)
"Returns FORMULA if safe, or the substitute formula *unsafe* otherwise."
(if (ses-warn-unsafe formula 'unsafep)
formula
`(ses-unsafe ',formula)))
(defun ses-warn-unsafe (formula checker)
"Applies CHECKER to FORMULA. If result is non-nil, asks user for
confirmation about FORMULA, which might be unsafe. Returns t if formula
is safe or user allows execution anyway. Always returns t if
`safe-functions' is t."
(if (eq safe-functions t)
t
(setq checker (funcall checker formula))
(if (not checker)
t
(y-or-n-p (format "Formula %S\nmight be unsafe %S. Process it? "
formula checker)))))
(defmacro ses-range (from to)
"Expands to a list of cell-symbols for the range. The range automatically
expands to include any new row or column inserted into its middle. The SES
library code specifically looks for the symbol `ses-range', so don't create an
alias for this macro!"
(let (result)
(ses-dorange (cons from to)
(push (ses-cell-symbol row col) result))
(cons 'list result)))
(defun ses-delete-blanks (&rest args)
"Return ARGS reversed, with the blank elements (nil and *skip*) removed."
(let (result)
(dolist (cur args)
(unless (memq cur '(nil *skip*))
(push cur result)))
result))
(defun ses+ (&rest args)
"Compute the sum of the arguments, ignoring blanks."
(apply '+ (apply 'ses-delete-blanks args)))
(defun ses-average (list)
"Computes the sum of the numbers in LIST, divided by their length. Blanks
are ignored. Result is always floating-point, even if all args are integers."
(setq list (apply 'ses-delete-blanks list))
(/ (float (apply '+ list)) (length list)))
(defmacro ses-select (fromrange test torange)
"Select cells in FROMRANGE that are `equal' to TEST. For each match, return
the corresponding cell from TORANGE. The ranges are macroexpanded but not
evaluated so they should be either (ses-range BEG END) or (list ...). The
TEST is evaluated."
(setq fromrange (cdr (macroexpand fromrange))
torange (cdr (macroexpand torange))
test (eval test))
(or (= (length fromrange) (length torange))
(error "ses-select: Ranges not same length"))
(let (result)
(dolist (x fromrange)
(if (equal test (symbol-value x))
(push (car torange) result))
(setq torange (cdr torange)))
(cons 'list result)))
(dolist (x '(ses-cell-value ses-range ses-delete-blanks ses+ ses-average
ses-select))
(put x 'side-effect-free t))
(eval-when-compile
(dolist (x '(row col))
(make-local-variable x)
(set x nil)))
(defun ses-center (value &optional span fill)
"Print VALUE, centered within column. FILL is the fill character for
centering (default = space). SPAN indicates how many additional rightward
columns to include in width (default = 0)."
(let ((printer (or (ses-col-printer col) ses--default-printer))
(width (ses-col-width col))
half)
(or fill (setq fill ?\s))
(or span (setq span 0))
(setq value (ses-call-printer printer value))
(dotimes (x span)
(setq width (+ width 1 (ses-col-width (+ col span (- x))))))
(setq width (- width (length value)))
(if (<= width 0)
value (setq half (make-string (/ width 2) fill))
(concat half value half
(if (> (% width 2) 0) (char-to-string fill))))))
(defun ses-center-span (value &optional fill)
"Print VALUE, centered within the span that starts in the current column
and continues until the next nonblank column. FILL specifies the fill
character (default = space)."
(let ((end (1+ col)))
(while (and (< end ses--numcols)
(memq (ses-cell-value row end) '(nil *skip*)))
(setq end (1+ end)))
(ses-center value (- end col 1) fill)))
(defun ses-dashfill (value &optional span)
"Print VALUE centered using dashes. SPAN indicates how many rightward
columns to include in width (default = 0)."
(ses-center value span ?-))
(defun ses-dashfill-span (value)
"Print VALUE, centered using dashes within the span that starts in the
current column and continues until the next nonblank column."
(ses-center-span value ?-))
(defun ses-tildefill-span (value)
"Print VALUE, centered using tildes within the span that starts in the
current column and continues until the next nonblank column."
(ses-center-span value ?~))
(defun ses-unsafe (value)
"Substitute for an unsafe formula or printer"
(error "Unsafe formula or printer"))
(dolist (x (cons 'ses-unsafe ses-standard-printer-functions))
(put x 'side-effect-free t))
(provide 'ses)