You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1909 lines
71 KiB
EmacsLisp
1909 lines
71 KiB
EmacsLisp
;;; cell.el --- EIEIO spreadsheet mode -*- lexical-binding: nil; -*-
|
|
|
|
;; Copyright (C) 2006-2007, 2019 by David O'Toole
|
|
|
|
;; Author: David O'Toole <dto@xelf.me> <deeteeoh1138@gmail.com>
|
|
;; Maintainer: David O'Toole <dto@xelf.me> <deeteeoh1138@gmail.com>
|
|
;; URL: http://xelf.me/cell-mode.html
|
|
;; Package-Requires: ((emacs "24.4"))
|
|
;; License: GPLv3
|
|
|
|
;; This program is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU General Public License
|
|
;; (Version 3) as published by the Free Software Foundation.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program, in a text file called LICENSE. If not, see
|
|
;; <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Summary:
|
|
|
|
;; Cell-mode implements an abstract spreadsheet control in an Emacs
|
|
;; buffer. The purpose of Cell-mode is to provide a major mode for
|
|
;; spreadsheet-based user interfaces; it can be further extended by
|
|
;; defining application-specific Emacs Lisp minor modes which supply
|
|
;; new cell and spreadsheet classes via Emacs' included object system,
|
|
;; EIEIO. The website for Cell-mode is http://xelf.me/cell.html.
|
|
|
|
;; Features:
|
|
|
|
;; - Uses a simple file format based on Lisp property lists. Cell-mode
|
|
;; files can be visited, saved, loaded, and so on just like any other
|
|
;; text file. Works with Emacs' existing autosave, VC, and backup
|
|
;; features.
|
|
;; - You can cut, copy, and paste cells between sheets using typical
|
|
;; Emacs shortcuts, as well as insert and delete rows and
|
|
;; columns.
|
|
;; - Undo/redo support.
|
|
;; - Execute sexps in cells, and other user defined actions.
|
|
;; - Rectangle selection via keyboard and mouse-drag are available.
|
|
;; - Object-orientation through the use of Emacs' included object
|
|
;; system, EIEIO. Cells can contain any Lisp value and respond
|
|
;; polymorphically to events.
|
|
;; - Contents can be collected and processed however you want.
|
|
;; - Images, Unicode text, and variable-width fonts can be displayed
|
|
;; - in cells.
|
|
|
|
;; Issues:
|
|
|
|
;; - Columns are sometimes misaligned; restart Cell-mode with "M-x
|
|
;; cell-mode RET" to restore proper formatting.
|
|
;; - Needs more optimization.
|
|
|
|
;; Notes:
|
|
|
|
;; - It is highly recommended to byte-compile this file so that
|
|
;; commands execute quickly.
|
|
;; - Cell-mode source dates originally to 2006 and thus uses dynamic
|
|
;; binding by default. Two warnings each about free variables named
|
|
;; "row" and "col" are to be expected during byte-compilation.
|
|
|
|
;; Getting started:
|
|
|
|
;; Download cell.el and place it in your Emacs load-path. Then:
|
|
|
|
;; (require 'cell)
|
|
;; (add-to-list 'auto-mode-alist (cons "\\.cell" 'cell-mode))
|
|
|
|
;; Then use M-x CELL-SHEET-CREATE, or visit a new file with the
|
|
;; extension ".cell". Press "Control-H m" to get help on the
|
|
;; keybindings.
|
|
|
|
;; To byte-compile and load cell-mode in one step, use:
|
|
|
|
;; (byte-compile-file "/path/to/cell.el" t)
|
|
|
|
;; How to extend Cell-mode:
|
|
|
|
;; - Use EIEIO's DEFCLASS to derive new subclasses from the included
|
|
;; CELL and CELL-SHEET classes in order to implement the new
|
|
;; behaviors you want; use DEFINE-DERIVED-MODE or DEFINE-MINOR-MODE
|
|
;; to extend the Emacs mode if necessary. Available CELL methods
|
|
;; are:
|
|
|
|
;; (INITIALIZE-INSTANCE :AFTER (C CELL) &KEY)
|
|
;; Define this :AFTER method for any initialization you need.
|
|
|
|
;; (CELL-EXECUTE (C CELL))
|
|
;; Perform a cell's action. S-Expression cells are evaluated.
|
|
|
|
;; (CELL-COLLECT-VALUE-P (C CELL))
|
|
;; Return non-nil if CELL-COLLECT-CELLS and related functions should
|
|
;; include this cell in their output.
|
|
|
|
;; (CELL-GET-VALUE (C CELL))
|
|
;; Return the stored value.
|
|
|
|
;; (CELL-SET-VALUE (C CELL) VALUE)
|
|
;; Set the value. You can define :BEFORE, :AFTER methods here
|
|
;; etc.
|
|
|
|
;; (CELL-FIND-VALUE (C CELL))
|
|
;; Lazily find the value. Just returns the value by default;
|
|
;; subclasses can use this for cache-on-demand behavior.
|
|
|
|
;; (CELL-TAP (C CELL))
|
|
;; Primary (left-click) action for cells. By default this just
|
|
;; selects the cell.
|
|
|
|
;; (CELL-ALTERNATE-TAP (C CELL))
|
|
;; Secondary click action for cells. By default this calls
|
|
;; CELL-EXECUTE.
|
|
|
|
;; (CELL-ACCEPT-STRING-VALUE (C CELL) STRING)
|
|
;; Accept a string representing the value, instead of the value.
|
|
;; Normally you will not have to modify this.
|
|
|
|
;; Other functions include:
|
|
|
|
;; (CELL-SHEET-CREATE &OPTIONAL ROWS COLS CLASS)
|
|
;; Create a new cell sheet in a new buffer with ROWS rows and
|
|
;; COLS columns. Optionally use CLASS instead of the default
|
|
;; cell sheet class.
|
|
|
|
;; (CELL-COLLECT-CELLS SHEET)
|
|
;; Return a flat list of all cells in the spreadsheet, in
|
|
;; left-to-right then top-to-bottom order.
|
|
|
|
;; (CELL-COLLECT-CELLS-BY-ROW SHEET)
|
|
;; Return a list of rows of cells from the spreadsheet.
|
|
|
|
;; The buffer-local variable CELL-CURRENT-SHEET is always set to the
|
|
;; current CELL-CURRENT-SHEET object in Cell-mode buffers.
|
|
|
|
;; Documentation for the CELL-SHEET class is forthcoming. Read on
|
|
;; and check the docstrings below if you wish to learn more.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl)
|
|
(require 'eieio)
|
|
(require 'eieio-base)
|
|
(require 'eieio-custom)
|
|
(require 'eieio-speedbar)
|
|
|
|
;;; Memoization facility.
|
|
|
|
;; The `defun-memo' facility is based on code by Peter Norvig
|
|
;; for his book "Paradigms of Artificial Intelligence
|
|
;; Programming". The modified versions are redistributed here under
|
|
;; the terms of the General Public License as given above.
|
|
|
|
;; You can find more information on Norvig's book at his website:
|
|
;; http://www.norvig.com/paip.html
|
|
;; http://www.norvig.com/license.html
|
|
|
|
(cl-defmacro defun-memo (name args memo-args &body body)
|
|
"Define a memoized function named NAME.
|
|
ARGS is the lambda list giving the memoized function's arguments.
|
|
MEMO-ARGS is a list with optional keyword arguments for the
|
|
memoization process: :KEY, :VALIDATOR, and :TEST."
|
|
`(memoize (cl-defun ,name ,args . ,body) ,@memo-args))
|
|
|
|
(cl-defun memo (fn &key (key #'first) (test #'eql) validator name)
|
|
"Return a memo-function of fn."
|
|
(let ((table (make-hash-table :test test)))
|
|
(setf (get name 'memo) table)
|
|
(lexical-let ((key* key)
|
|
(table* table)
|
|
(validator* validator)
|
|
(fn* fn))
|
|
#'(lambda (&rest args)
|
|
(let ((k (funcall key* args)))
|
|
(let* ((val (gethash k table* :default-|-value))
|
|
(found-p (not (eq val :default-|-value))))
|
|
(if found-p
|
|
val
|
|
;; only cache if value is valid
|
|
(let ((candidate-value (apply fn* args)))
|
|
(prog1 candidate-value
|
|
(when (or (null validator*)
|
|
(funcall validator* candidate-value))
|
|
(setf (gethash k table*) candidate-value)))))))))))
|
|
|
|
(cl-defun memoize (fn-name &key (key #'first) (test #'eql) validator)
|
|
"Replace fn-name's global definition with a memoized version."
|
|
(clear-memoize fn-name)
|
|
(setf (symbol-function fn-name)
|
|
(memo (symbol-function fn-name)
|
|
:name fn-name :key key :test test :validator validator)))
|
|
|
|
(cl-defun clear-memoize (fn-name)
|
|
"Clear the hash table from a memo function."
|
|
(let ((table (get fn-name 'memo)))
|
|
(when table (clrhash table))))
|
|
|
|
(cl-defun get-memo-table (fn-name)
|
|
(get fn-name 'memo))
|
|
|
|
;;; EIEIO compatibility macros
|
|
|
|
;; The following compatibility macros transform code using the old
|
|
;; DEFSTRUCT-style class definitions and slot accessors (which is
|
|
;; still perfectly readable and useful) into the modern way of doing
|
|
;; object orientation in Emacs, namely EIEIO. This is transparent to
|
|
;; the cell and sheet subclasses you define, which can just use the
|
|
;; normal EIEIO slot accessors.
|
|
|
|
;; Also, for compatibility with the original code, this file does not
|
|
;; use Emacs Lisp LEXICAL-BINDING (see local variable on first line.)
|
|
|
|
(cl-defmacro cell-defslot (class slot)
|
|
(let ((instance (cl-gensym))
|
|
(value (cl-gensym))
|
|
(getter (intern (concat (symbol-name class) "-" (symbol-name slot))))
|
|
(setter (intern (concat "cell-set-value/"
|
|
(symbol-name class) "-" (symbol-name slot)))))
|
|
`(progn
|
|
(defun ,getter (,instance)
|
|
(slot-value ,instance ',slot))
|
|
(defun ,setter (,instance ,value)
|
|
(setf (slot-value ,instance ',slot)
|
|
,value))
|
|
(defsetf ,getter ,setter))))
|
|
|
|
(cl-defmacro cell-defclass (name superclasses &rest specs)
|
|
`(defclass ,name ,superclasses
|
|
,(mapcar #'(lambda (spec)
|
|
(if (listp spec)
|
|
spec
|
|
(list
|
|
spec
|
|
:initform nil
|
|
:initarg (intern (concat ":" (symbol-name spec))))))
|
|
specs)))
|
|
|
|
;;; Customization
|
|
|
|
(defcustom cell-cursor-blink-interval 0.5
|
|
"How many seconds to wait between cursor blinks."
|
|
:tag "Cursor blink interval"
|
|
:group 'cell
|
|
:type 'number)
|
|
|
|
(defcustom cell-cursor-blink-p t
|
|
"When non-nil, blink active cursor."
|
|
:group 'cell
|
|
:type 'boolean)
|
|
|
|
(defcustom cell-blank-width 4 "Default width of blank cells, in spaces."
|
|
:group 'cell
|
|
:type 'integer)
|
|
|
|
(defcustom cell-no-label-string "no label"
|
|
"Default string for when a cell has no label."
|
|
:group 'cell
|
|
:type 'string)
|
|
|
|
;;; Utilities
|
|
|
|
(defun cell-char-width-pixels (char)
|
|
(with-temp-buffer
|
|
(set-window-buffer (selected-window) (current-buffer))
|
|
(insert-char char)
|
|
(aref (aref (font-get-glyphs (font-at 1) 1 2) 0) 4)))
|
|
|
|
(defun cell-string-width (str)
|
|
(/ (float (apply #'+ (map 'list #'cell-char-width-pixels str)))
|
|
(float (window-font-width))))
|
|
|
|
;;; Variables
|
|
|
|
(defvar cell-timer nil "Timer object for periodic updates.")
|
|
|
|
(defvar cell-current-sheet nil "This buffer's cell-sheet object.")
|
|
(make-variable-buffer-local 'cell-sheet)
|
|
|
|
(defvar cell-clipboard nil "List of cell rows on the clipboard.")
|
|
|
|
(defvar cell-cached-buffer-positions nil)
|
|
(make-variable-buffer-local 'cell-cached-buffer-positions)
|
|
|
|
(cell-defclass cell ()
|
|
label ; label to be displayed on the cell
|
|
label-width ; width of label (when not integral; used for images)
|
|
value ; can be any lisp object the cell requires.
|
|
face ; face to display cell label with,
|
|
; or use propertized text for label)
|
|
)
|
|
|
|
(cell-defslot cell label)
|
|
(cell-defslot cell label-width)
|
|
(cell-defslot cell value)
|
|
(cell-defslot cell face)
|
|
|
|
(cl-defmethod initialize-instance :after ((c cell) &rest slots)
|
|
"Initialize the cell C."
|
|
nil)
|
|
|
|
(cl-defmethod cell-execute ((c cell))
|
|
"Perform action when cell is executed."
|
|
nil)
|
|
|
|
(cl-defmethod cell-collect-value-p ((c cell))
|
|
"When non-nil, collect the value of this cell during
|
|
CELL-COLLECT-CELLS and related calls."
|
|
t)
|
|
|
|
(cl-defmethod cell-get-value ((c cell))
|
|
"Return the value of the cell C."
|
|
(slot-value c 'value))
|
|
|
|
(cl-defmethod cell-set-value ((c cell) value)
|
|
"Set the value of cell C to VALUE."
|
|
(setf (slot-value c 'value) value))
|
|
|
|
(cl-defmethod cell-find-value ((c cell))
|
|
"Lazily find the value. Subclasses can use this for caching."
|
|
(cell-get-value c))
|
|
|
|
(cl-defmethod cell-accept-string-value ((c cell) string)
|
|
"Accept a string instead of a value."
|
|
(cell-set-value c string))
|
|
|
|
(cl-defmethod cell-tap ((c cell))
|
|
"Primary click action for cell C." nil)
|
|
|
|
(cl-defmethod cell-alternate-tap ((c cell))
|
|
"Secondary click action for cell C. By default this executes the
|
|
cell."
|
|
(cell-execute c))
|
|
|
|
(cl-defmethod cell-contains-image-p ((c cell)) nil)
|
|
|
|
;;; Blinking the cursor and other periodic updates
|
|
|
|
(defun cell-update-cursor-blink ()
|
|
(when (and cell-cursor-blink-p
|
|
(eq major-mode 'cell-mode)
|
|
(eq (current-buffer) (window-buffer)))
|
|
(cell-sheet-display-cursors (overlays-in (point-min) (point-max)))))
|
|
|
|
(defun cell-start-timer ()
|
|
(when (timerp cell-timer)
|
|
(cancel-timer cell-timer))
|
|
(setf cell-timer (run-with-timer
|
|
0 cell-cursor-blink-interval
|
|
'cell-update-cursor-blink)))
|
|
|
|
(defun cell-stop-timer ()
|
|
(when (timerp cell-timer)
|
|
(cancel-timer cell-timer)))
|
|
|
|
(cl-defmethod cell-fill-space ((cell cell) face) nil)
|
|
|
|
;;; Lisp expression cells
|
|
|
|
(cell-defclass cell-expression (cell))
|
|
|
|
(cl-defmethod cell-set-value :after ((c cell-expression) value)
|
|
(setf (cell-label-width c)
|
|
(cell-string-width value))
|
|
(setf (cell-label c) value))
|
|
|
|
(cl-defmethod cell-find-value ((exp cell-expression))
|
|
(when (stringp (cell-value exp))
|
|
(car (read-from-string (cell-value exp)))))
|
|
|
|
(cl-defmethod cell-execute ((exp cell-expression))
|
|
(eval (cell-find-value exp)))
|
|
|
|
(cl-defmethod cell-fill-space ((exp cell-expression) face)
|
|
(let ((width (cell-label-width exp)))
|
|
(when width
|
|
(cell-insert-spacer (ceiling width) face))))
|
|
|
|
;;; Comment cells
|
|
|
|
(cell-defclass cell-comment-cell (cell-expression))
|
|
|
|
(cl-defmethod cell-collect-value-p ((c cell-comment-cell)) nil)
|
|
|
|
(cl-defmethod cell-set-value :after ((c cell-comment-cell) value)
|
|
(setf (cell-face c) 'cell-comment-2-face))
|
|
|
|
;;; Image cells
|
|
|
|
(cell-defclass cell-image-cell (cell) image)
|
|
(cell-defslot cell image)
|
|
|
|
(cl-defmethod cell-set-value :after ((i cell-image-cell) image-name)
|
|
(setf (cell-image i)
|
|
(create-image (car (read-from-string image-name))))
|
|
(setf (cell-label-width i)
|
|
(car (image-size (cell-image i))))
|
|
(setf (cell-label i)
|
|
(propertize " " 'display (cell-image i))))
|
|
|
|
(cl-defmethod cell-contains-image-p ((c cell-image-cell)) t)
|
|
|
|
;;; Internal grid data structure
|
|
|
|
(defun cell-make-grid (rows cols)
|
|
"Make a new grid with ROWS rows and COLS columns."
|
|
(let ((grid (make-vector rows nil)))
|
|
(dotimes (row rows)
|
|
(setf (aref grid row) (make-vector cols nil)))
|
|
grid))
|
|
|
|
(defun cell-grid-get (grid row col)
|
|
"Return the object in GRID at row ROW and column COL."
|
|
(when (and (< row (length grid))
|
|
(< col (length (aref grid 0))))
|
|
(aref (aref grid row) col)))
|
|
|
|
(defun cell-grid-set (grid row col value)
|
|
"Set the object at GRID location ROW,COL to VALUE."
|
|
(when (and (< row (length grid))
|
|
(< col (length (aref grid 0))))
|
|
(let ((row (aref grid row)))
|
|
(setf (aref row col) value))))
|
|
|
|
(defun cell-grid-columns (grid)
|
|
"Return the number of columns in the GRID."
|
|
(length (aref grid 0)))
|
|
|
|
(defun cell-grid-rows (grid)
|
|
"Return the number of rows in the GRID."
|
|
(length grid))
|
|
|
|
(defun cell-vector-insert (oldvec pos elt)
|
|
"Insert into OLDVEC at position POS the element ELT."
|
|
(let* ((len (length oldvec))
|
|
(newvec (make-vector (+ len 1) nil)))
|
|
(dotimes (i (+ 1 len))
|
|
(setf (aref newvec i) (cond
|
|
(( < i pos)
|
|
(aref oldvec i))
|
|
(( equal i pos)
|
|
elt)
|
|
(( > i pos)
|
|
(aref oldvec (- i 1))))))
|
|
newvec))
|
|
|
|
(defun cell-vector-delete (oldvec pos)
|
|
"Remove from vector OLDVEC the position POS."
|
|
(let* ((len (length oldvec))
|
|
(newvec (make-vector (- len 1) nil)))
|
|
(dotimes (i (- len 1))
|
|
(setf (aref newvec i) (cond
|
|
(( < i pos)
|
|
(aref oldvec i))
|
|
(( >= i pos)
|
|
(aref oldvec (+ i 1))))))
|
|
newvec))
|
|
|
|
(defun cell-grid-insert-row (grid row)
|
|
"Return a copy of GRID with a row inserted at row ROW."
|
|
(let* ((newrow (make-vector (cell-grid-columns grid) nil)))
|
|
(cell-vector-insert grid row newrow)))
|
|
|
|
(defun cell-grid-insert-column (grid col)
|
|
"Return a copy of GRID with a column inserted at column COL."
|
|
(dotimes (i (cell-grid-rows grid))
|
|
(setf (aref grid i) (cell-vector-insert (aref grid i) col nil)))
|
|
grid)
|
|
|
|
(defun cell-grid-delete-row (grid row)
|
|
"Return a copy of GRID with the row ROW removed."
|
|
(cell-vector-delete grid row))
|
|
|
|
(defun cell-grid-delete-column (grid col)
|
|
"Return a copy of GRID with the column COL removed."
|
|
(dotimes (i (cell-grid-rows grid))
|
|
(setf (aref grid i) (cell-vector-delete (aref grid i) col)))
|
|
grid)
|
|
|
|
;;; Sheets
|
|
|
|
(cell-defclass cell-sheet ()
|
|
name ; string title, currently ignored
|
|
rows ; initial requested number of rows
|
|
cols ; initial requested number of columns
|
|
mark ; nil when there is no mark, or (LIST ROW COL)
|
|
rendering ; cached buffer text of spreadsheet
|
|
widths ; column widths
|
|
row-header-width ; width of leftmost column
|
|
buffer ; what buffer is this sheet in?
|
|
cursor ; what cell is the user pointing at? (LIST ROW COL)
|
|
selection ; rectangle in this form: (row-1 col-1 row-2 col-2)
|
|
grid ; two-dimensional array of spreadsheet cells
|
|
column-stops ; vector of integers where v[x] is first column number of column x
|
|
buffer ; associated buffer where user interface is displayed
|
|
borders-p ; whether to display borders
|
|
headers-p ; whether to display headers
|
|
raw-display-p ; whether we are doing raw display
|
|
properties) ; general-purpose plist for extensions
|
|
|
|
(cell-defslot cell-sheet name)
|
|
(cell-defslot cell-sheet rendering)
|
|
(cell-defslot cell-sheet mark)
|
|
(cell-defslot cell-sheet widths)
|
|
(cell-defslot cell-sheet row-header-width)
|
|
(cell-defslot cell-sheet rows)
|
|
(cell-defslot cell-sheet cols)
|
|
(cell-defslot cell-sheet buffer)
|
|
(cell-defslot cell-sheet cursor)
|
|
(cell-defslot cell-sheet selection)
|
|
(cell-defslot cell-sheet grid)
|
|
(cell-defslot cell-sheet column-stops)
|
|
(cell-defslot cell-sheet borders-p)
|
|
(cell-defslot cell-sheet headers-p)
|
|
(cell-defslot cell-sheet raw-display-p)
|
|
(cell-defslot cell-sheet properties)
|
|
|
|
(defmacro cell-with-current-cell-sheet (&rest body)
|
|
"Evaluate BODY forms with cell-sheet variables bound."
|
|
(declare (debug t))
|
|
`(let* ((inhibit-read-only t)
|
|
(rendering (cell-sheet-rendering cell-current-sheet))
|
|
(grid (cell-sheet-grid cell-current-sheet))
|
|
(cursor (cell-sheet-cursor cell-current-sheet))
|
|
(cursor-row (cl-first cursor))
|
|
(cursor-column (cl-second cursor))
|
|
(selection (cell-sheet-selection cell-current-sheet))
|
|
(cell^ (cell-grid-get grid cursor-row cursor-column))
|
|
(stops (cell-sheet-column-stops cell-current-sheet)))
|
|
,@body))
|
|
|
|
;;; Undo/redo support
|
|
|
|
(defvar cell-undo-history nil "Undo history for current cell sheet.")
|
|
(make-variable-buffer-local 'cell-undo-history)
|
|
|
|
(defvar cell-redo-history nil "Redo history for current cell sheet.")
|
|
(make-variable-buffer-local 'cell-redo-history)
|
|
|
|
(defun cell-push-undo-history ()
|
|
"Push a serialized copy of the cell sheet onto the undo history."
|
|
(push (cell-sheet-serialize cell-current-sheet)
|
|
cell-undo-history))
|
|
|
|
(defun cell-push-redo-history ()
|
|
"Push a serialized copy of the cell sheet onto the redo history."
|
|
(push (cell-sheet-serialize cell-current-sheet)
|
|
cell-redo-history))
|
|
|
|
(defun cell-pop-undo-history ()
|
|
"Undo the last action."
|
|
(let ((inhibit-read-only t)
|
|
(cursor (cell-sheet-cursor cell-current-sheet))
|
|
(class (or (cell-sheet-setting-value cell-current-sheet 'cell-sheet-class)
|
|
'cell-sheet)))
|
|
(if (null cell-undo-history)
|
|
(progn (beep) (message "Cell-mode: undo history is empty."))
|
|
(progn
|
|
(setf cell-current-sheet
|
|
(cell-sheet-from-plist (cdr (car (read-from-string (pop cell-undo-history))))
|
|
class
|
|
))
|
|
(cell-sheet-update)
|
|
(setf (cell-sheet-cursor cell-current-sheet) cursor)
|
|
(cell-sheet-after-open-hook cell-current-sheet)
|
|
(setf (buffer-modified-p (current-buffer)) t)
|
|
(message "Undo! %d change(s) remaining." (length cell-undo-history))))))
|
|
|
|
(defun cell-sheet-undo ()
|
|
"Undo the last edit."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(let ((inhibit-read-only t))
|
|
(cell-push-redo-history)
|
|
(cell-pop-undo-history)
|
|
(cell-sheet-update))))
|
|
|
|
(defun cell-sheet-redo ()
|
|
"Redo the last undo operation."
|
|
(interactive)
|
|
(let ((inhibit-read-only t)
|
|
(cursor (cell-sheet-cursor cell-current-sheet)))
|
|
(if (null cell-redo-history)
|
|
(progn (beep) (message "Cell-mode: redo history is empty."))
|
|
(progn
|
|
(push (pop cell-redo-history)
|
|
cell-undo-history)
|
|
(cell-pop-undo-history)
|
|
(setf (cell-sheet-cursor cell-current-sheet) cursor)
|
|
(cell-sheet-update)
|
|
(message "Redo! %d redo(s) remaining." (length cell-redo-history))))))
|
|
|
|
;;; Major mode declaration
|
|
|
|
(defvar cell-mode-map nil "Keymap for Cell-mode.")
|
|
|
|
(defun cell-find-cell-mode-map ()
|
|
"Return the cell-mode keymap."
|
|
(or cell-mode-map
|
|
(setf cell-mode-map
|
|
(make-sparse-keymap))))
|
|
|
|
(defun cell-mode-insinuate ()
|
|
"Install local keybindings for Cell-mode."
|
|
(interactive)
|
|
(mapcar (lambda (mapping)
|
|
(define-key (cell-find-cell-mode-map) (car mapping) (cdr mapping)))
|
|
`(([(control c)(control e)] . cell-sheet-execute)
|
|
([(return)] . cell-sheet-create-cell)
|
|
([(next)] . cell-sheet-page-down)
|
|
([(prior)] . cell-sheet-page-up)
|
|
([(control ? )] . cell-sheet-set-mark)
|
|
([(escape)] . cell-sheet-clear-mark)
|
|
([(shift return)] . cell-sheet-execute)
|
|
([(control c)(control c)] . cell-sheet-create-comment)
|
|
([(control c) ?i] . cell-sheet-create-image)
|
|
([(control d)] . cell-sheet-delete-cell)
|
|
([(control z)] . cell-sheet-undo)
|
|
([(control /)] . cell-sheet-undo)
|
|
([(control shift z)] . cell-sheet-redo)
|
|
([(control ??)] . cell-sheet-redo)
|
|
(,(kbd ":") . cell-sheet-create-comment)
|
|
(,(kbd ";") . cell-sheet-create-comment)
|
|
;; navigating to corners
|
|
([(meta ?<)] . cell-sheet-move-bob)
|
|
([(meta ?>)] . cell-sheet-move-eob)
|
|
;; adding and removing rows
|
|
(,(kbd "\C-c\C-n\C-r") . cell-sheet-insert-row)
|
|
(,(kbd "\C-c\C-n\C-c") . cell-sheet-insert-column)
|
|
(,(kbd "\C-c\C-d\C-r") . cell-sheet-delete-row)
|
|
(,(kbd "\C-c\C-d\C-c") . cell-sheet-delete-column)
|
|
;; arrow keys
|
|
([(up)] . cell-sheet-move-cursor-up)
|
|
([(down)] . cell-sheet-move-cursor-down)
|
|
([(left)] . cell-sheet-move-cursor-left)
|
|
([(right)] . cell-sheet-move-cursor-right)
|
|
;; traditional cursor-motion keys
|
|
([(control a)] . cell-sheet-move-bol)
|
|
([(control e)] . cell-sheet-move-eol)
|
|
([(home)] . cell-sheet-move-bol)
|
|
([(end)] . cell-sheet-move-eol)
|
|
([(control f)] . cell-sheet-move-cursor-right)
|
|
([(control b)] . cell-sheet-move-cursor-left)
|
|
([(control n)] . cell-sheet-move-cursor-down)
|
|
([(control p)] . cell-sheet-move-cursor-up)
|
|
;; the mouse
|
|
([(mouse-1)] . cell-sheet-mouse-move-cursor)
|
|
([(mouse-3)] . mouse-major-mode-menu)
|
|
([(mouse-5)] . cell-sheet-page-down)
|
|
([(mouse-4)] . cell-sheet-page-up)
|
|
([(drag-mouse-1)] . cell-sheet-mouse-select)
|
|
;; cut and paste
|
|
([(meta w)] . cell-sheet-copy-to-clipboard)
|
|
([(control w)] . cell-sheet-cut-to-clipboard)
|
|
([(control y)] . cell-sheet-paste))))
|
|
|
|
(cell-mode-insinuate)
|
|
|
|
(define-derived-mode cell-mode nil "Cell"
|
|
"Abstract spreadsheet display mode."
|
|
(let ((inhibit-read-only t))
|
|
(make-local-variable 'cell-sheet)
|
|
(make-local-variable 'tool-bar-map)
|
|
(setf tool-bar-map (cell-enable-tool-bar-map))
|
|
(if (zerop (length (buffer-substring-no-properties (point-min) (point-max))))
|
|
;; new blank sheet
|
|
(setf cell-current-sheet
|
|
(make-instance 'cell-sheet :name (buffer-file-name (current-buffer))))
|
|
;; recover serialized sheet
|
|
(setf cell-current-sheet
|
|
(cell-sheet-from-plist
|
|
(cdr (car (read-from-string
|
|
(buffer-substring-no-properties
|
|
(point-min) (point-max))))))))
|
|
;; finish initializing cell mode in new buffer
|
|
(setf cell-cached-buffer-positions (make-hash-table :test 'equal))
|
|
(delete-region (point-min) (point-max))
|
|
(add-hook 'before-save-hook 'cell-remove-rendering)
|
|
(add-hook 'after-save-hook 'cell-sheet-update*)
|
|
(cell-mode-insinuate)
|
|
(cell-sheet-update)
|
|
(cell-sheet-after-open-hook cell-current-sheet)
|
|
(setf (buffer-modified-p (current-buffer)) nil)))
|
|
|
|
;;; Initializing sheets
|
|
|
|
(cl-defmethod initialize-instance :after ((sheet^ cell-sheet) &rest slots)
|
|
"Initialize SHEET and its buffer for Cell-mode."
|
|
(setf cell-current-sheet sheet^)
|
|
(let* ((new-buffer (current-buffer))
|
|
(inhibit-read-only t)
|
|
(rows (or (slot-value sheet^ 'rows) 15))
|
|
(cols (or (slot-value sheet^ 'cols) 10)))
|
|
(with-slots (buffer grid cursor column-stops
|
|
borders-p headers-p)
|
|
cell-current-sheet
|
|
(setf buffer new-buffer)
|
|
(setf grid (or grid (cell-make-grid rows cols)))
|
|
(setf column-stops (make-vector (+ cols 1) 0))
|
|
(setf cursor '(0 0))
|
|
(setf borders-p t)
|
|
(setf headers-p t)
|
|
;; set up the buffer to act the right way
|
|
(with-current-buffer buffer
|
|
(setf cursor-type nil)
|
|
;; next line changed from (toggle-truncate-lines 1) for
|
|
;; emacs-21 compatibility.
|
|
(setf truncate-lines t)
|
|
(buffer-disable-undo buffer)
|
|
(make-local-variable 'cell-current-sheet)
|
|
(setf buffer-read-only t)
|
|
(cell-mode-insinuate)
|
|
(cell-sheet-after-open-hook sheet^)
|
|
(setf (buffer-modified-p buffer) nil))
|
|
sheet^)))
|
|
|
|
;;; The mark and the selection
|
|
|
|
(defun cell-sheet-set-mark ()
|
|
"Begin defining a region by putting the mark here."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(setf (cell-sheet-mark cell-current-sheet) (list cursor-row cursor-column))
|
|
(cell-sheet-update-selection-from-mark)
|
|
(cell-sheet-update)))
|
|
|
|
(defun cell-sheet-update-selection-from-mark ()
|
|
"Update the selection based on mark and cursor."
|
|
(cell-with-current-cell-sheet
|
|
(let ((mark (cell-sheet-mark cell-current-sheet)))
|
|
(when mark
|
|
(when (not (and (= (car mark) cursor-row)
|
|
(= (cadr mark) cursor-column)))
|
|
(setf (cell-sheet-selection cell-current-sheet)
|
|
(list cursor-row cursor-column
|
|
(car mark) (cadr mark))))))))
|
|
|
|
(defun cell-sheet-clear-mark* ()
|
|
"Clear the mark and selection without updating the sheet."
|
|
(cell-with-current-cell-sheet
|
|
(setf (cell-sheet-mark cell-current-sheet) nil)
|
|
(setf (cell-sheet-selection cell-current-sheet) nil)))
|
|
|
|
(defun cell-sheet-clear-mark ()
|
|
"Stop defining a region by clearing the mark."
|
|
(interactive)
|
|
(cell-sheet-clear-mark*)
|
|
(cell-sheet-update))
|
|
|
|
;;; Cut, copy, paste
|
|
|
|
(defun cell-copy-cell (c)
|
|
(when c
|
|
(let ((class (eieio-object-class c)))
|
|
(with-slots (label value face) c
|
|
(let ((label* (copy-tree label :vec))
|
|
(value* (copy-tree value :vec))
|
|
(face* (copy-tree face :vec)))
|
|
(make-instance class :label label* :value value* :face face*))))))
|
|
|
|
(defun cell-sheet-copy-to-clipboard ()
|
|
"Copy the currently selected region to the clipboard."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(if (null selection)
|
|
(progn (setf cell-clipboard (list (list (cell-copy-cell (cell-grid-get grid cursor-row cursor-column)))))
|
|
(message "The cell at the cursor was copied to the clipboard."))
|
|
(let* ((inhibit-read-only t))
|
|
(cl-destructuring-bind (r1 c1 r2 c2) selection
|
|
(let* ((dr (abs (- r2 r1)))
|
|
(dc (abs (- c2 c1)))
|
|
(start-row (min r1 r2))
|
|
(start-col (min c1 c2))
|
|
(out-rows ())
|
|
(out-column ()))
|
|
(cl-do ((r start-row (+ 1 r)))
|
|
((> r (+ dr start-row)))
|
|
(cl-do ((c start-col (+ 1 c)))
|
|
((> c (+ dc start-col)))
|
|
(push (cell-copy-cell (cell-grid-get grid r c))
|
|
out-column))
|
|
(push (reverse out-column) out-rows)
|
|
(setf out-column nil))
|
|
(setf cell-clipboard (reverse out-rows))))
|
|
(cell-sheet-clear-mark*)
|
|
(cell-sheet-update)
|
|
(message "The selection was copied to the clipboard.")))))
|
|
|
|
(defun cell-sheet-blank-selection (&optional sel)
|
|
"Remove all cells within the current selection."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(when (or sel selection)
|
|
(let* ((inhibit-read-only t))
|
|
(cell-push-undo-history)
|
|
(cl-destructuring-bind (r1 c1 r2 c2) (or sel (slot-value cell-current-sheet 'selection))
|
|
(let* ((dr (abs (- r2 r1)))
|
|
(dc (abs (- c2 c1)))
|
|
(start-row (min r1 r2))
|
|
(start-col (min c1 c2))
|
|
(out-rows ())
|
|
(out-column ()))
|
|
(cl-do ((r start-row (+ 1 r)))
|
|
((> r (+ dr start-row)))
|
|
(cl-do ((c start-col (+ 1 c)))
|
|
((> c (+ dc start-col)))
|
|
(cell-grid-set grid r c nil)))))))))
|
|
|
|
(defun cell-sheet-cut-to-clipboard ()
|
|
"Cut the selected cells to the clipboard."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(cell-push-undo-history)
|
|
(if (null (cell-sheet-selection cell-current-sheet))
|
|
(cell-grid-set grid cursor-row cursor-column nil)
|
|
(progn
|
|
(let ((sel (cell-sheet-selection cell-current-sheet)))
|
|
(cell-sheet-copy-to-clipboard)
|
|
(cell-sheet-blank-selection sel))))
|
|
(cell-sheet-clear-mark*)
|
|
(cell-sheet-update)
|
|
(message "The selection was cut to the clipboard.")))
|
|
|
|
(defun cell-sheet-paste ()
|
|
"Paste the current contents of the clipboard at the cursor."
|
|
(interactive)
|
|
(let ((inhibit-read-only t))
|
|
(cell-push-undo-history)
|
|
(cell-with-current-cell-sheet
|
|
(let ((rows cell-clipboard))
|
|
(cl-do ((r cursor-row (1+ r)))
|
|
((null rows))
|
|
(let ((col (pop rows)))
|
|
(cl-do ((c cursor-column (1+ c)))
|
|
((null col))
|
|
(cell-grid-set grid r c (cell-copy-cell (pop col)))))))
|
|
(cell-sheet-clear-mark*)
|
|
(cell-sheet-update))))
|
|
|
|
;;; Blanking a cell sheet
|
|
|
|
(cl-defmethod cell-sheet-blank ((sheet^ cell-sheet) rows cols)
|
|
;; don't use this function interactively; it doesn't save undo history!
|
|
(let ((inhibit-read-only t))
|
|
(setf (cell-sheet-grid sheet^)
|
|
(cell-make-grid rows cols))
|
|
(setf (cell-sheet-cursor sheet^) (list 0 0))))
|
|
|
|
;;; The cursor and the selection
|
|
|
|
(defun cell-move-point-to-rendering ()
|
|
"Move point to the place where the sheet will be rendered."
|
|
(goto-char (point-min))
|
|
(while (and (not (eobp))
|
|
(not (get-text-property (point) 'rendering)))
|
|
(forward-char 1))
|
|
(when (not (get-text-property (point) 'rendering))
|
|
(error "Cell-mode: could not find rendering text property"))
|
|
(forward-char 1)
|
|
(point))
|
|
|
|
(defun cell-sheet-display-cursor (row column &optional face)
|
|
"Display a cursor using overlays at the give ROW and COLUMN.
|
|
The argument FACE specifies the face to use for the overlay."
|
|
(cell-with-current-cell-sheet
|
|
(let* ((inhibit-read-only t)
|
|
(face (or face 'cell-cursor-face))
|
|
(cursor-width (if (and cell^ (cell-label-width cell^))
|
|
(ceiling (cell-label-width cell^))
|
|
(- (aref stops (+ column 1))
|
|
(aref stops column)))))
|
|
(let ((p (gethash (list row column) cell-cached-buffer-positions)))
|
|
(let ((cl (cell-grid-get grid row column))
|
|
(p0 0))
|
|
(when cl
|
|
(when (cell-label-width cl)
|
|
(setf cursor-width (ceiling (max cell-blank-width (cell-label-width cl))))))
|
|
(let ((ov (make-overlay (+ p0 (- p cursor-width)) p)))
|
|
(overlay-put ov 'face face)
|
|
(goto-char p)))))))
|
|
|
|
(defun cell-sheet-highlight-cell (row column &optional face)
|
|
"Highlight a cell by adding face properties at ROW and COLUMN.
|
|
The argument FACE specifies which face to use."
|
|
(cell-with-current-cell-sheet
|
|
(let* ((inhibit-read-only t)
|
|
(cursor-width (if (and cell^ (cell-label-width cell^))
|
|
(ceiling (cell-label-width cell^))
|
|
(- (aref stops (+ column 1))
|
|
(aref stops column))))
|
|
(face (or face 'cell-cursor-face)))
|
|
(cell-move-point-to-rendering)
|
|
;; move to right place
|
|
(forward-line (+ 1 row))
|
|
(forward-char (aref stops column))
|
|
;; adjust cursor when images are present in any cells to left
|
|
(let ((n 0))
|
|
(dotimes (c column)
|
|
(let ((cl (cell-grid-get grid row c)))
|
|
(when cl
|
|
(when (cell-label-width cl)
|
|
(cl-incf n)
|
|
(backward-char 1)))))
|
|
;; (when (plusp n)
|
|
;; (goto-char (+ (point-at-bol) (aref stops column)))
|
|
;; (forward-char (+ n 1))))
|
|
(add-text-properties (point) (+ (point) cursor-width)
|
|
(list 'face face))))))
|
|
|
|
(defun cell-sheet-display-selection ()
|
|
"Display the selection using text properties."
|
|
(cell-with-current-cell-sheet
|
|
(when selection
|
|
(let* ((inhibit-read-only t))
|
|
(cl-destructuring-bind (r1 c1 r2 c2) selection
|
|
(let* ((dr (abs (- r2 r1)))
|
|
(dc (abs (- c2 c1)))
|
|
(start-row (min r1 r2))
|
|
(start-col (min c1 c2))
|
|
(current-cell nil))
|
|
(goto-char (point-min))
|
|
(forward-line (1+ start-row))
|
|
(cl-do ((r start-row (+ r 1)))
|
|
((> r (+ start-row dr)))
|
|
(beginning-of-line)
|
|
(let* ((pos (+ (point-at-bol) (aref stops start-col)))
|
|
(end pos))
|
|
(cl-do ((c start-col (+ c 1)))
|
|
((> c (+ start-col dc)))
|
|
(setf current-cell (cell-grid-get grid r c))
|
|
(let ((cursor-width (if (and current-cell (cell-label-width current-cell))
|
|
(ceiling (cell-label-width current-cell))
|
|
(- (aref stops (+ c 1))
|
|
(aref stops c)))))
|
|
(cl-incf end cursor-width)))
|
|
(add-text-properties pos end
|
|
(list 'face 'cell-selection-face)))
|
|
(forward-line))))))))
|
|
|
|
(defun cell-sheet-in-selection (rxx cxx)
|
|
"Return non-nil if row RXX, column CXX is within the selection."
|
|
(let ((selection (cell-sheet-selection cell-current-sheet)))
|
|
(when selection
|
|
(let ((r1 (pop selection))
|
|
(c1 (pop selection))
|
|
(r2 (pop selection))
|
|
(c2 (pop selection)))
|
|
(and (<= (min r1 r2) rxx (max r1 r2))
|
|
(<= (min c1 c2) cxx (max c1 c2)))))))
|
|
|
|
(defun cell-sheet-display-cursors (&optional just-delete)
|
|
"Display all the cursors."
|
|
(cell-with-current-cell-sheet
|
|
;; remove overlays. there is a fix for emacs-21 here, which does
|
|
;; not have the function (remove-overlays)
|
|
(if (fboundp 'remove-overlays)
|
|
(remove-overlays)
|
|
(mapc #'delete-overlay (overlays-in (point-min) (point-max))))
|
|
;; The commented out code below is sometimes used during testing.
|
|
;;
|
|
;; (when selection
|
|
;; (cell-sheet-display-selection))
|
|
(unless just-delete
|
|
(let ((c (cell-grid-get grid cursor-row cursor-column)))
|
|
(if c
|
|
;;(if (null (cell-label-width c))
|
|
(cell-sheet-display-cursor cursor-row cursor-column)
|
|
;;(cell-sheet-highlight-cell cursor-row cursor-column 'cell-cursor-face)
|
|
)
|
|
(cell-sheet-display-cursor cursor-row cursor-column)))))
|
|
;;(cell-sheet-highlight-cell cursor-row cursor-column 'cell-cursor-face)
|
|
;; (let ((m (cell-sheet-mark sheet)))
|
|
;; (when m (cell-sheet-display-cursor (first m) (second m) 'cell-mark-face)))))
|
|
|
|
(defun cell-sheet-move-bol ()
|
|
"Move to the beginning of the line."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(with-slots (cursor) cell-current-sheet
|
|
(setf cursor
|
|
(list (cl-first cursor) 0)))
|
|
(cell-sheet-update)))
|
|
|
|
(defun cell-sheet-move-eol ()
|
|
"Move to the end of the line."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(with-slots (cursor grid) cell-current-sheet
|
|
(setf cursor
|
|
(list (cl-first cursor)
|
|
(1- (length (aref grid 0))))))
|
|
(cell-sheet-update)))
|
|
|
|
(defun cell-sheet-move-bob ()
|
|
"Move to the top left corner of the cell sheet."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(with-slots (cursor) cell-current-sheet
|
|
(setf cursor (list 0 0))
|
|
(cell-sheet-update))))
|
|
|
|
(defun cell-sheet-move-eob ()
|
|
"Move to the bottom right corner of the cell sheet."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(with-slots (cursor grid) cell-current-sheet
|
|
(setf cursor
|
|
(list (1- (length grid))
|
|
(1- (length (aref grid 0))))))
|
|
(cell-sheet-update)))
|
|
|
|
(cl-defun cell-sheet-move-cursor (direction &optional (distance 1))
|
|
"Move the cursor one cell in DIRECTION."
|
|
(cell-with-current-cell-sheet
|
|
;; clear selection
|
|
(setf (cell-sheet-selection cell-current-sheet) nil)
|
|
;; calculate new cursor location
|
|
(let* ((rows (cell-grid-rows grid))
|
|
(cols (cell-grid-columns grid))
|
|
(new-cursor
|
|
(cl-case direction
|
|
(:up (if (not (minusp (- cursor-row distance)))
|
|
(list (- cursor-row distance) cursor-column)
|
|
cursor))
|
|
(:left (if (not (minusp (- cursor-column distance)))
|
|
(list cursor-row (- cursor-column distance))
|
|
cursor))
|
|
(:down (if (< cursor-row (- rows distance))
|
|
(list (+ cursor-row distance) cursor-column)
|
|
cursor))
|
|
(:right (if (< cursor-column (- cols distance))
|
|
(list cursor-row (+ cursor-column distance))
|
|
cursor)))))
|
|
(setf (cell-sheet-cursor cell-current-sheet) new-cursor)
|
|
;; choose technique for display
|
|
(if (cell-sheet-raw-display-p cell-current-sheet)
|
|
;; just move point to where cursor should go
|
|
(progn
|
|
(let ((buffer-position (+ 1 (cl-second new-cursor)
|
|
(* (cl-first new-cursor)
|
|
(+ 1 (cell-grid-columns grid))))))
|
|
(goto-char buffer-position)
|
|
))
|
|
;; display cell-mode cursor with overlay
|
|
(if (cell-sheet-mark cell-current-sheet)
|
|
(progn (cell-remove-rendering*)
|
|
(cell-sheet-update-selection-from-mark)
|
|
(cell-sheet-update :lazy)
|
|
(cell-sheet-display-cursors))
|
|
(progn
|
|
(cell-sheet-display-cursors)))))))
|
|
;; (cell-remove-rendering)
|
|
;; (cell-sheet-update :lazy)))))))
|
|
|
|
(defun cell-sheet-move-cursor-up ()
|
|
"Move the cursor one cell upward."
|
|
(interactive)
|
|
(cell-sheet-move-cursor :up))
|
|
|
|
(defun cell-sheet-move-cursor-left ()
|
|
"Move the cursor one cell leftward."
|
|
(interactive)
|
|
(cell-sheet-move-cursor :left))
|
|
|
|
(defun cell-sheet-move-cursor-down ()
|
|
"Move the cursor one cell downward."
|
|
(interactive)
|
|
(cell-sheet-move-cursor :down))
|
|
|
|
(defun cell-sheet-move-cursor-right ()
|
|
"Move the cursor one cell rightward."
|
|
(interactive)
|
|
(cell-sheet-move-cursor :right))
|
|
|
|
(defun cell-sheet-page-up ()
|
|
(interactive)
|
|
;; check for correct major mode, in case mouse is over a cell-mode
|
|
;; buffer that isn't the current buffer.
|
|
(when (eq major-mode 'cell-mode)
|
|
(cell-sheet-move-cursor :up 10)))
|
|
|
|
(defun cell-sheet-page-down ()
|
|
(interactive)
|
|
(when (eq major-mode 'cell-mode)
|
|
(cell-sheet-move-cursor :down 10)))
|
|
|
|
;;; Executing cells
|
|
|
|
(defun cell-sheet-execute ()
|
|
"Execute the current cell."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet (cell-execute cell^)))
|
|
|
|
;;; Deleting cells
|
|
|
|
(defun cell-sheet-delete-cell ()
|
|
"Delete the current cell."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(cell-push-undo-history)
|
|
(cell-grid-set grid cursor-row cursor-column nil)
|
|
(cell-sheet-update)))
|
|
|
|
;;; Interactively creating and editing cells
|
|
|
|
(cl-defmethod cell-sheet-after-update-hook ((sheet cell-sheet))
|
|
nil)
|
|
|
|
(cl-defmethod cell-sheet-after-open-hook ((sheet cell-sheet))
|
|
(setf (buffer-modified-p (current-buffer)) nil))
|
|
|
|
(defun cell-sheet-create-cell (&optional no-change)
|
|
"Create or edit a cell at the cursor."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(cell-push-undo-history)
|
|
(let* ((the-cell (cell-grid-get grid cursor-row cursor-column))
|
|
(value (when the-cell (cell-value the-cell))))
|
|
(let* ((instance (or the-cell (make-instance 'cell-expression)))
|
|
(default (cell-value instance))
|
|
(val (if no-change default (read-from-minibuffer "Enter value: "
|
|
(when the-cell default)))))
|
|
(when (and (stringp val)
|
|
(> (length val) 0))
|
|
(cell-grid-set grid cursor-row cursor-column (copy-tree instance :copy-vectors))
|
|
(cell-accept-string-value instance (copy-tree val :copy-vectors)))))
|
|
(cell-sheet-after-update-hook cell-current-sheet)
|
|
(cell-sheet-update)))
|
|
|
|
(defun cell-sheet-create-comment ()
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(cell-push-undo-history)
|
|
(let ((i (make-instance 'cell-comment-cell))
|
|
(val (read-from-minibuffer "Comment expression: ")))
|
|
(cell-set-value i val)
|
|
(cell-grid-set grid cursor-row cursor-column i)
|
|
(cell-sheet-update))))
|
|
|
|
(defun cell-sheet-create-image ()
|
|
"Create an image cell at the cursor."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(cell-push-undo-history)
|
|
(let ((i (make-instance 'cell-image-cell))
|
|
(val (read-file-name "Image file name: ")))
|
|
(cell-set-value i val)
|
|
(cell-grid-set grid cursor-row cursor-column i)
|
|
(cell-sheet-update))))
|
|
|
|
;;; Inserting rows and columns
|
|
|
|
(defun cell-sheet-insert-row ()
|
|
"Insert a row at the cursor."
|
|
(interactive)
|
|
(cell-push-undo-history)
|
|
(cell-with-current-cell-sheet
|
|
(setf (cell-sheet-grid cell-current-sheet) (cell-grid-insert-row grid cursor-row))
|
|
(cell-sheet-update)))
|
|
|
|
(defun cell-sheet-insert-column ()
|
|
"Insert a column at the cursor."
|
|
(interactive)
|
|
(cell-push-undo-history)
|
|
(cell-with-current-cell-sheet
|
|
(let ((columns (+ 1 (cell-grid-columns (cell-sheet-grid cell-current-sheet)))))
|
|
(setf (cell-sheet-grid cell-current-sheet) (cell-grid-insert-column grid cursor-column))
|
|
(setf (cell-sheet-column-stops cell-current-sheet) (make-vector (+ 1 columns) 0))))
|
|
(cell-sheet-update))
|
|
|
|
;;; Deleting rows and columns
|
|
|
|
(defun cell-sheet-delete-row ()
|
|
"Delete a row at the cursor."
|
|
(interactive)
|
|
(cell-push-undo-history)
|
|
(cell-with-current-cell-sheet
|
|
(setf (cell-sheet-grid cell-current-sheet) (cell-grid-delete-row grid cursor-row))
|
|
(cell-sheet-update)))
|
|
|
|
(defun cell-sheet-delete-column ()
|
|
"Delete a column at the cursor."
|
|
(interactive)
|
|
(cell-push-undo-history)
|
|
(cell-with-current-cell-sheet
|
|
(setf (cell-sheet-grid cell-current-sheet) (cell-grid-delete-column grid cursor-column))
|
|
(cell-sheet-update)))
|
|
|
|
;;; Collecting cells
|
|
|
|
;; This is useful when you want to process the contents of a sheet.
|
|
|
|
(defun cell-collect-cells (sheet &optional collect-all-p)
|
|
"Return a flat list of all the cells in the SHEET."
|
|
(let ((grid (cell-sheet-grid cell-current-sheet))
|
|
(cell^ nil)
|
|
(cells nil))
|
|
(dotimes (r (cell-grid-rows grid))
|
|
(dotimes (c (cell-grid-columns grid))
|
|
(when (setf cell^ (cell-grid-get grid r c))
|
|
(when (and cell^ (or collect-all-p (cell-collect-value-p cell^)))
|
|
(push cell^ cells)))))
|
|
(nreverse cells)))
|
|
|
|
(defun cell-collect-cells-by-row (sheet &optional collect-all-p)
|
|
"Return a list of rows of all the cells in the SHEET."
|
|
(let ((grid (cell-sheet-grid cell-current-sheet))
|
|
(rows nil))
|
|
(dotimes (r (cell-grid-rows grid))
|
|
(let ((cell^ nil)
|
|
(cells nil))
|
|
(dotimes (c (cell-grid-columns grid))
|
|
(when (setf cell^ (cell-grid-get grid r c))
|
|
(when (and cell^ (or collect-all-p (cell-collect-value-p cell^)))
|
|
(push cell^ cells))))
|
|
(when cells (push (nreverse cells) rows))))
|
|
(nreverse rows)))
|
|
|
|
(defun cell-collect-cells-by-row-include-blanks (sheet)
|
|
"Return a list of rows of all the cells in the SHEET, with blanks."
|
|
(let ((grid (cell-sheet-grid cell-current-sheet))
|
|
(rows nil))
|
|
(dotimes (r (cell-grid-rows grid))
|
|
(let ((cell^ nil)
|
|
(cells nil))
|
|
(dotimes (c (cell-grid-columns grid))
|
|
(setf cell^ (cell-grid-get grid r c))
|
|
(push cell^ cells))
|
|
(when cells (push (nreverse cells) rows))))
|
|
(nreverse rows)))
|
|
|
|
(defun cell-collect-cells-by-row-no-settings (sheet)
|
|
(let ((rows (cell-collect-cells-by-row sheet))
|
|
(results ()))
|
|
(dolist (row rows)
|
|
(when (not (some #'vectorp (mapcar #'cell-find-value row)))
|
|
(push row results)))
|
|
(nreverse results)))
|
|
|
|
;;; Drawing
|
|
|
|
(defun cell-sheet-do-layout ()
|
|
"Compute layout information for the cell sheet."
|
|
(let ((widths (make-vector (cell-grid-columns (cell-sheet-grid cell-current-sheet)) 0))
|
|
(column-width 0))
|
|
(cell-with-current-cell-sheet
|
|
(let ((rows (cell-grid-rows grid))
|
|
(columns (cell-grid-columns grid)))
|
|
;; Find column widths and stops before rendering.
|
|
;; how many digits in longest row number?
|
|
(setf (cell-sheet-row-header-width cell-current-sheet)
|
|
(max 2 (length (format "%d" rows))))
|
|
;; factor in headers if needed
|
|
(setf (aref (cell-sheet-column-stops cell-current-sheet) 0)
|
|
(if (cell-sheet-headers-p cell-current-sheet)
|
|
(cell-sheet-row-header-width cell-current-sheet)
|
|
0))
|
|
(dotimes (col columns)
|
|
(setf column-width 0)
|
|
(dotimes (row rows)
|
|
(setf cell^ (cell-grid-get grid row col))
|
|
(setf column-width (max column-width (if cell^
|
|
(+ 1
|
|
(if (cell-label-width cell^)
|
|
(ceiling (cell-label-width cell^))
|
|
(length
|
|
(if (cell-label cell^)
|
|
(cell-label cell^)
|
|
cell-no-label-string))))
|
|
cell-blank-width))))
|
|
(setf (aref widths col) column-width)
|
|
(when (< col columns)
|
|
(setf (aref (cell-sheet-column-stops cell-current-sheet) (+ 1 col))
|
|
(+ column-width (aref (cell-sheet-column-stops cell-current-sheet) col)))))
|
|
;; save layout data
|
|
(setf (cell-sheet-widths cell-current-sheet) widths)))))
|
|
|
|
(defun cell-sheet-do-redraw ()
|
|
"Redraw the cell sheet."
|
|
(interactive)
|
|
(let* ((inhibit-read-only t)
|
|
(selection-now-p nil)
|
|
(rendering-point nil)
|
|
(grid (cell-sheet-grid cell-current-sheet))
|
|
(rows (cell-grid-rows grid))
|
|
(cursor (cell-sheet-cursor cell-current-sheet))
|
|
(mark (cell-sheet-mark cell-current-sheet))
|
|
(cursor-row (cl-first cursor))
|
|
(cursor-column (cl-second cursor))
|
|
(mark-row (cl-first mark))
|
|
(mark-column (cl-second mark))
|
|
(columns (cell-grid-columns grid))
|
|
(column-stops (cell-sheet-column-stops cell-current-sheet))
|
|
(widths (cell-sheet-widths cell-current-sheet))
|
|
(cell^ nil)
|
|
(headers-p (cell-sheet-headers-p cell-current-sheet))
|
|
(raw-display-p (cell-sheet-raw-display-p cell-current-sheet))
|
|
(column-width 0)
|
|
(cell-width 0)
|
|
(row-header-width (cell-sheet-row-header-width cell-current-sheet))
|
|
(face nil))
|
|
(if raw-display-p
|
|
;; just insert all the labels with \n between lines
|
|
(progn
|
|
(setf cursor-type 'hollow)
|
|
;; (when *serialization-marker*
|
|
;; (delete-region (point-min) (- (marker-position *serialization-marker*)
|
|
;; 1)))
|
|
(goto-char (point-min))
|
|
(dotimes (row rows)
|
|
(dotimes (col columns)
|
|
(setf cell^ (cell-grid-get grid row col))
|
|
(when (and cell^ (cell-label cell^))
|
|
(insert (cell-label cell^))))
|
|
(insert "\n"))
|
|
;; move cursor to right place
|
|
(goto-char (+ 1 cursor-column
|
|
(* cursor-row
|
|
(+ 1 (cell-grid-columns grid)))))
|
|
)
|
|
;; otherwise render everything all nice with borders and cell backgrounds.
|
|
;;
|
|
;; Render the cell sheet into the buffer
|
|
;; (if cell-rendering-marker
|
|
;; (delete-region (marker-position cell-rendering-marker) (point-max))
|
|
;; (error "Cell-mode: No rendering marker."))
|
|
(goto-char (point-max))
|
|
(setf rendering-point (point))
|
|
;; draw headers if needed
|
|
(when headers-p
|
|
(cell-insert-header (cell-sheet-row-header-width cell-current-sheet) 0 :empty)
|
|
(dotimes (col columns)
|
|
(cell-insert-header (- (aref column-stops (+ col 1)) (aref column-stops col)) col)))
|
|
(insert "\n")
|
|
(dotimes (row rows)
|
|
;; draw headers if needed
|
|
(when headers-p
|
|
(cell-insert-header row-header-width row))
|
|
;; render
|
|
(dotimes (col columns)
|
|
(setf column-width (aref widths col))
|
|
(setf cell^ (cell-grid-get grid row col))
|
|
(when cell^
|
|
(setf face `(,(or (cell-face cell^) 'cell-default-face)
|
|
,(if (cl-evenp col) 'cell-blank-face
|
|
'cell-blank-odd-face))))
|
|
;; draw selection face if needed
|
|
(if (cell-sheet-in-selection row col)
|
|
(progn (setf face 'cell-selection-face)
|
|
(setf selection-now-p t))
|
|
(setf selection-now-p nil))
|
|
;; ;; or cursor face
|
|
;; (when (and (= cursor-row row)
|
|
;; (= cursor-column col))
|
|
;; (setf face 'cell-cursor-face))
|
|
;; or mark face
|
|
(when (and mark
|
|
(= mark-row row)
|
|
(= mark-column col))
|
|
(setf face 'cell-mark-face))
|
|
;;
|
|
(if cell^
|
|
(progn
|
|
(setf cell-width
|
|
(cell-insert cell^ face))
|
|
;; fill column if needed
|
|
(if (cell-label-width cell^)
|
|
(progn
|
|
(cell-insert-spacer (+ 1.0 (- (ceiling (cell-label-width cell^))
|
|
(cell-label-width cell^)))
|
|
face)
|
|
;;(cell-fill-space cell^ face)
|
|
(cell-insert-blank (- column-width (ceiling (cell-label-width cell^)) 1) face)
|
|
)
|
|
(cell-insert-blank (- column-width cell-width) face)))
|
|
;; blank cell
|
|
(progn (setf face (if selection-now-p face (if (cl-evenp col) 'cell-blank-face
|
|
'cell-blank-odd-face)))
|
|
(setf cell-width (cell-insert-blank column-width face))))
|
|
;; add text properties to store row, col for mouse click
|
|
(let* ((end (point))
|
|
(beg (- end column-width)))
|
|
(put-text-property beg end 'cell-mode-position (list row col))))
|
|
(insert "\n"))
|
|
;;
|
|
(setf (cell-sheet-rendering cell-current-sheet)
|
|
(buffer-substring rendering-point (point-max)))
|
|
(goto-char (point-min))
|
|
(cell-sheet-update-selection-from-mark)
|
|
(cell-sheet-display-cursors))))
|
|
|
|
(defun cell-sheet-set-raw-display (sheet bool)
|
|
"Enable raw display on SHEET if BOOL is non-nil."
|
|
(setf (cell-sheet-raw-display-p cell-current-sheet) bool))
|
|
|
|
;;;; Rendering individual elements of the spreadsheet
|
|
|
|
(defun cell-insert (c &optional face)
|
|
"Make a clickable text cell from C and insert it at point.
|
|
Returns length of inserted string. FACE is the optional face to
|
|
use."
|
|
(let* ((label (or (cell-label c) cell-no-label-string))
|
|
(face (or face 'cell-default-face))
|
|
(action `(lambda ()
|
|
(interactive)
|
|
nil)))
|
|
(let ((str label))
|
|
(insert str)
|
|
;; the variables ROW and COL are free in the next line.
|
|
(setf (gethash (list row col)
|
|
cell-cached-buffer-positions)
|
|
(point))
|
|
(add-text-properties (point) (- (point) (length str))
|
|
`(face ,face))
|
|
(length label))))
|
|
|
|
(defun-memo cell-cached-blank-string (width face) (:test 'equal :key 'identity)
|
|
(propertize (make-string width ? ) 'face face))
|
|
|
|
(defun cell-insert-blank (width &optional face)
|
|
"Insert a blank cell WIDTH characters wide in face FACE."
|
|
(when (> width 0)
|
|
(insert (cell-cached-blank-string width face))
|
|
;; the variables ROW and COL are free in the next line.
|
|
(setf (gethash (list row col)
|
|
cell-cached-buffer-positions)
|
|
(point))
|
|
width))
|
|
|
|
(defun cell-insert-spacer (width &optional face)
|
|
"Insert an arbitrary WIDTH spacer with face FACE."
|
|
(insert "Q")
|
|
(backward-char)
|
|
(put-text-property (point) (1+ (point)) 'display
|
|
`(space . (:width ,width)))
|
|
(when face
|
|
(put-text-property (point) (1+ (point)) 'face face))
|
|
;;
|
|
(forward-char))
|
|
|
|
(defun cell-insert-header (width number &optional empty)
|
|
"Insert a header cell of width WIDTH displaying NUMBER.
|
|
If EMPTY is non-nil, don't display the number."
|
|
(let ((blank "")
|
|
(label (if empty " "(format "%d" number)))
|
|
(face (if (cl-evenp number)
|
|
'cell-axis-face
|
|
'cell-axis-odd-face)))
|
|
(dotimes (i (- width (length label)))
|
|
(setf blank (concat blank " ")))
|
|
(insert (propertize (concat blank label)
|
|
'face face))))
|
|
|
|
(defun cell-make-clickable (text action &optional face)
|
|
"Make TEXT clickable calling function ACTION.
|
|
The optional argument FACE is the face to use."
|
|
(let ((keymap (make-sparse-keymap))
|
|
(face (or face 'cell-face-red)))
|
|
(define-key keymap [mouse-2] action)
|
|
(propertize text
|
|
'face face
|
|
'keymap keymap)))
|
|
|
|
;;; Serialization
|
|
|
|
(defun cell-remove-rendering* ()
|
|
"Remove the cell sheet's rendering without updating."
|
|
(let ((inhibit-read-only t))
|
|
(when (eq major-mode 'cell-mode)
|
|
(delete-region (point-min) (point-max)))))
|
|
|
|
(defun cell-remove-rendering ()
|
|
"Remove the cell sheet's rendering and update."
|
|
(when (eq major-mode 'cell-mode)
|
|
(cell-remove-rendering*)
|
|
(cell-sheet-update-serialization)))
|
|
|
|
(defun cell-sheet-update* ()
|
|
"Update the cell sheet and mark the buffer non-modified."
|
|
(when (eq major-mode 'cell-mode)
|
|
(let ((inhibit-read-only t))
|
|
(cell-sheet-update)
|
|
(setf (buffer-modified-p (current-buffer)) nil))))
|
|
|
|
(defun cell-sheet-update-serialization ()
|
|
"Rewrite the buffer contents to reflect the current data."
|
|
(interactive)
|
|
(let ((inhibit-read-only t))
|
|
(cell-with-current-cell-sheet
|
|
(save-excursion
|
|
(delete-region (point-min) (point-max))
|
|
(goto-char (point-min))
|
|
;; (setf cell-rendering-marker (point-marker))
|
|
;; (set-marker-insertion-type cell-rendering-marker t)
|
|
(insert " ")
|
|
(goto-char (point-max))
|
|
(goto-char (point-min))
|
|
(insert (cell-sheet-serialize cell-current-sheet))
|
|
(goto-char (point-max))
|
|
(insert (propertize " " 'rendering t 'display ""))
|
|
;;
|
|
(goto-char (point-min))
|
|
(let ((x (progn
|
|
(while (and (not (eobp))
|
|
(not (get-text-property (point) 'rendering)))
|
|
(forward-char 1))
|
|
(if (not (get-text-property (point) 'rendering))
|
|
(error "Cell-mode: could not find rendering text property")
|
|
(point)))))
|
|
(add-text-properties (point-min)
|
|
x
|
|
(list 'display "")))
|
|
(setf (buffer-modified-p (current-buffer)) nil)))))
|
|
|
|
(defun cell-sheet-update (&optional lazy)
|
|
"Update the entire cell sheet.
|
|
If LAZY is non-nil, just redraw without updating."
|
|
(interactive)
|
|
(cell-with-current-cell-sheet
|
|
(unless lazy
|
|
(cell-sheet-update-serialization)
|
|
(cell-sheet-do-layout))
|
|
(cell-sheet-do-redraw)))
|
|
|
|
(defun cell-sheet-serialize (sheet)
|
|
"Return a string version of SHEET."
|
|
(lexical-let* ((grid (cell-sheet-grid cell-current-sheet))
|
|
(sheet^ cell-current-sheet)
|
|
(rows (cell-grid-rows grid))
|
|
(cols (cell-grid-columns grid))
|
|
(cell^ nil))
|
|
(cl-labels ((serialize-cell (cell^ row col)
|
|
(format "(:cell :row %d :col %d :class %S :label %S :value %S)"
|
|
row col (eieio-object-class cell^) (when (cell-label cell^)
|
|
(substring-no-properties (cell-label cell^)))
|
|
(cell-value cell^))))
|
|
(with-temp-buffer
|
|
(insert (format "(:sheet :name %S :rows %d :cols %d :raw-display-p %S :grid ("
|
|
(cell-sheet-name sheet^) rows cols (cell-sheet-raw-display-p sheet^)))
|
|
(dotimes (row rows)
|
|
(dotimes (col cols)
|
|
(when (setf cell^ (cell-grid-get grid row col))
|
|
(insert (serialize-cell cell^ row col))
|
|
(insert "\n"))))
|
|
(insert "\n))")
|
|
(buffer-substring-no-properties (point-min) (point-max))))))
|
|
|
|
(defun cell-sheet-from-plist (plist &optional class)
|
|
"Return a new cell-sheet object constructed from the data in PLIST."
|
|
(let* ((name (cl-getf plist :name))
|
|
(rows (cl-getf plist :rows))
|
|
(cols (cl-getf plist :cols))
|
|
(cells (cl-getf plist :grid))
|
|
(raw-display-p (cl-getf plist :raw-display-p))
|
|
(sheet^ (make-instance (or class 'cell-sheet) :name name :rows rows :cols cols))
|
|
(grid (cell-sheet-grid cell-current-sheet))
|
|
(cell-ob nil)
|
|
(cell-plist nil)
|
|
(cell^ nil))
|
|
;; keep raw-display-p the same
|
|
(setf cell-current-sheet sheet^)
|
|
(setf (cell-sheet-raw-display-p cell-current-sheet) raw-display-p)
|
|
;; store cells
|
|
(while (setf cell-ob (pop cells))
|
|
(setf cell-plist (cdr cell-ob))
|
|
(setf cell^ (make-instance
|
|
(cl-getf cell-plist :class)
|
|
:label (cl-getf cell-plist :label)
|
|
:value (cl-getf cell-plist :value)
|
|
:face (cl-getf cell-plist :face)))
|
|
(cell-grid-set grid
|
|
(cl-getf cell-plist :row)
|
|
(cl-getf cell-plist :col)
|
|
cell^))
|
|
cell-current-sheet))
|
|
|
|
;;; Mouse support
|
|
|
|
(defun cell-sheet-mouse-move-cursor (event)
|
|
"Move the mouse cursor to the clicked cell.
|
|
EVENT is the mouse event data."
|
|
(interactive "e")
|
|
(cell-with-current-cell-sheet
|
|
(when event
|
|
(cl-destructuring-bind (event-type position &optional ignore) event
|
|
(let* ((clicked-position (posn-point position))
|
|
(clicked-cell (get-text-property clicked-position 'cell-mode-position)))
|
|
;;
|
|
;; whether we are in raw display mode
|
|
(when (cell-sheet-raw-display-p cell-current-sheet)
|
|
(goto-char clicked-position)
|
|
;;
|
|
;; bounds check
|
|
(let ((clicked-row (/ clicked-position (+ 1 (cell-grid-columns grid))))
|
|
(clicked-column (+ -1 (% clicked-position (+ 1 (cell-grid-columns grid))))))
|
|
(when (and (<= 0 clicked-row)
|
|
(<= 0 clicked-column)
|
|
(< clicked-row (cell-grid-rows grid))
|
|
(< clicked-column (cell-grid-columns grid)))
|
|
(setf (cell-sheet-cursor cell-current-sheet)
|
|
(list clicked-row clicked-column)))))
|
|
;;
|
|
;; not in raw display
|
|
(when clicked-cell
|
|
(cl-destructuring-bind (clicked-row clicked-column) clicked-cell
|
|
(setf (cell-sheet-cursor cell-current-sheet) clicked-cell)
|
|
(when (cell-sheet-selection cell-current-sheet)
|
|
(cell-sheet-update-selection-from-mark))
|
|
(cell-sheet-update))))))))
|
|
|
|
(defun cell-sheet-mouse-execute (event)
|
|
"Execute the clicked cell. EVENT is the mouse event data."
|
|
(interactive "e")
|
|
(cell-with-current-cell-sheet
|
|
(when event
|
|
(cl-destructuring-bind (event-type position &optional ignore) event
|
|
(let* ((clicked-position (posn-point position))
|
|
(clicked-cell (get-text-property clicked-position 'cell-mode-position)))
|
|
(when clicked-cell
|
|
(cl-destructuring-bind (clicked-row clicked-column) clicked-cell
|
|
(setf (cell-sheet-cursor cell-current-sheet) clicked-cell)
|
|
(let ((c (cell-grid-get (cell-sheet-grid cell-current-sheet)
|
|
clicked-row clicked-column)))
|
|
(when c
|
|
(cell-tap c)
|
|
(cell-sheet-update))))))))))
|
|
|
|
(defun cell-sheet-mouse-select (event)
|
|
"Select a cell with the mouse. EVENT is the mouse event data."
|
|
(interactive "e")
|
|
(cell-with-current-cell-sheet
|
|
(cell-sheet-clear-mark*)
|
|
(cl-destructuring-bind (event-type position1 position2 &rest ignore) event
|
|
(let* ((pt1 (get-text-property (posn-point position1) 'cell-mode-position))
|
|
(pt2 (get-text-property (posn-point position2) 'cell-mode-position))
|
|
(sel `(,@pt1 ,@pt2)))
|
|
(setf (cell-sheet-selection cell-current-sheet) sel))
|
|
(cell-sheet-update))))
|
|
|
|
;;; Additional commands
|
|
|
|
(defun* cell-sheet-create (&optional r0 c0 (class 'cell-sheet))
|
|
"Create a new cell sheet with R0 rows and C0 columns."
|
|
(interactive)
|
|
(let ((r (or r0 (read-from-minibuffer "Create cell-sheet with how many rows? " "24")))
|
|
(c (or c0 (read-from-minibuffer "...with how many columns? " "40"))))
|
|
(let ((rs (car (read-from-string r)))
|
|
(cs (car (read-from-string c))))
|
|
(let ((buffer (generate-new-buffer "*cell sheet*")))
|
|
(switch-to-buffer buffer)
|
|
(cell-mode)
|
|
(setf cell-current-sheet (make-instance class :rows rs :cols cs))
|
|
(cell-sheet-update)))))
|
|
|
|
;;; Sheet settings are a form of local variable.
|
|
|
|
(defvar cell-sheet-class nil "Local mode class for interpreting cell sheets.")
|
|
(make-variable-buffer-local 'cell-sheet-class)
|
|
|
|
(cl-defmethod cell-sheet-collect-settings ((sheet cell-sheet))
|
|
(let ((values (mapcar #'cell-find-value (cell-collect-cells sheet)))
|
|
(results ()))
|
|
(dolist (value values)
|
|
(when (vectorp value)
|
|
(push value results)))
|
|
(nreverse results)))
|
|
|
|
(cl-defmethod cell-sheet-collect-settings-cells ((sheet cell-sheet))
|
|
(let ((cells (cell-collect-cells sheet :collect-all-p))
|
|
(results ()))
|
|
(dolist (c cells)
|
|
(when (vectorp (cell-find-value c))
|
|
(push c results)))
|
|
results))
|
|
|
|
(cl-defmethod cell-sheet-change-setting ((sheet cell-sheet) setting-name value)
|
|
(let ((cells (cell-sheet-collect-settings-cells sheet)))
|
|
(dolist (c cells)
|
|
(let ((vec (cell-find-value c)))
|
|
(when (eq setting-name (aref vec 0))
|
|
(cell-accept-string-value c (prin1-to-string (vector setting-name value))))))))
|
|
|
|
;; (cl-defmethod cell-sheet-change-setting :after ((sheet cell-sheet) setting-name value)
|
|
;; (cell-sheet-update sheet)
|
|
;; (setf (buffer-modified-p (cell-sheet-buffer sheet)) t))
|
|
|
|
(cl-defmethod cell-sheet-setting-value ((sheet cell-sheet) setting-name)
|
|
(let ((settings (cell-sheet-collect-settings sheet)))
|
|
(block finding
|
|
(dolist (setting settings)
|
|
(when (eq setting-name (aref setting 0))
|
|
(return-from finding (aref setting 1)))))))
|
|
|
|
(defun cell-apply-settings (settings)
|
|
(dolist (binding settings)
|
|
(set (aref binding 0)
|
|
(aref binding 1))))
|
|
|
|
(cl-defmethod cell-sheet-apply-settings ((sheet cell-sheet))
|
|
(with-current-buffer (slot-value sheet 'buffer)
|
|
(cell-apply-settings (cell-sheet-collect-settings sheet))))
|
|
|
|
(defun cell-sheet-class (sheet)
|
|
(cell-sheet-setting-value sheet 'cell-sheet-class))
|
|
|
|
(defun cell-subclass-sheet (sheet)
|
|
(let ((class (cell-sheet-class sheet)))
|
|
(when (null class)
|
|
(error "Cell-mode: no CELL-SHEET-CLASS setting in this sheet."))
|
|
(let* ((new-sheet (make-instance class))
|
|
(slots '(name mark rendering widths row-header-width
|
|
buffer cursor selection grid
|
|
column-stops buffer borders-p headers-p
|
|
raw-display-p properties)))
|
|
(dolist (slot slots)
|
|
(setf (slot-value new-sheet slot)
|
|
(slot-value sheet slot)))
|
|
new-sheet)))
|
|
|
|
(defun cell-replace-sheet (sheet)
|
|
(with-current-buffer (slot-value sheet 'buffer)
|
|
(setf cell-current-sheet
|
|
(cell-subclass-sheet sheet))))
|
|
|
|
(defun cell-replace-sheet-maybe ()
|
|
(cell-with-current-cell-sheet
|
|
(when (cell-sheet-class cell-current-sheet)
|
|
(cell-replace-sheet cell-current-sheet)
|
|
(cell-sheet-after-open-hook cell-current-sheet)
|
|
(cell-sheet-update)
|
|
(setf (buffer-modified-p (current-buffer)) nil))))
|
|
|
|
(defun cell-insinuate ()
|
|
(interactive)
|
|
(add-hook 'cell-mode-hook 'cell-replace-sheet-maybe)
|
|
(cell-start-timer))
|
|
|
|
(defun cell-sexp->cell (sexp)
|
|
(let (cell)
|
|
(when (and (consp sexp)
|
|
(symbolp (first sexp))
|
|
(ignore-errors (eieio--class-p (eieio--class-object (first sexp)))))
|
|
(setf cell (apply #'make-instance (first sexp) (rest sexp))))
|
|
(when (null cell)
|
|
(setf cell (make-instance 'cell-expression
|
|
:value sexp
|
|
:label (if (stringp sexp) sexp (prin1-to-string sexp))))
|
|
(cell-set-value cell sexp))
|
|
cell))
|
|
|
|
(defun cell-copy-cells-from-sexps (sexps)
|
|
(let ((rows (mapcar (lambda (row)
|
|
(mapcar #'cell-sexp->cell row))
|
|
sexps)))
|
|
(setf cell-clipboard rows)))
|
|
|
|
;;; Customization
|
|
|
|
(defgroup cell nil
|
|
"Options for cell-mode."
|
|
:group 'applications)
|
|
|
|
;;; Font locking
|
|
|
|
(defface cell-default-face '((t (:foreground "black")))
|
|
"Face for cells." :group 'cell)
|
|
|
|
(defface cell-action-face '((t (:foreground "yellow" :background "red" :bold t :weight bold)))
|
|
"Face for cells that perform an action." :group 'cell)
|
|
|
|
(defface cell-comment-face '((t (:foreground "dodger blue")))
|
|
"Face for cells that simply label stuff." :group 'cell)
|
|
|
|
(defface cell-comment-2-face '((t (:foreground "hot pink" :slant italic :italic t)))
|
|
"Face for cells that simply label stuff." :group 'cell)
|
|
|
|
(defface cell-file-face '((t (:foreground "yellowgreen")))
|
|
"Face for simple links to files." :group 'cell)
|
|
|
|
(defface cell-cursor-face '((t (:background "hot pink" :foreground "yellow"
|
|
:box (:line-width 1 :color "magenta"))))
|
|
"Face for selected cell." :group 'cell)
|
|
|
|
(defface cell-mark-face '((t (:background "yellow" :foreground "red")))
|
|
"Face for marked cell." :group 'cell)
|
|
|
|
(defface cell-selection-face '((t (:background "pale green" :foreground "gray20"
|
|
:box (:line-width 1 :color "pale green"))))
|
|
"Face for multi-cell selection." :group 'cell)
|
|
|
|
(defface cell-text-face '((t (:foreground "yellow")))
|
|
"Face for text entry cells." :group 'cell)
|
|
|
|
(defface cell-blank-face '((t (:background
|
|
"wheat"
|
|
:box
|
|
(:line-width 1 :color "dark khaki"))))
|
|
"Face for blank cells." :group 'cell)
|
|
|
|
(defface cell-blank-odd-face '((t (:background
|
|
"cornsilk"
|
|
:box
|
|
(:line-width 1 :color "dark khaki"))))
|
|
"Face for blank cells in odd columns" :group 'cell)
|
|
|
|
(defface cell-axis-face '((t :foreground "gray50"
|
|
:background "gray80"
|
|
:box (:line-width 1 :color "grey70")))
|
|
"Face for numbered axes." :group 'cell)
|
|
|
|
(defface cell-axis-odd-face '((t :foreground "gray50"
|
|
:background "gray90"
|
|
:box (:line-width 1 :color "grey70")))
|
|
"Face for numbered axes in odd columns." :group 'cell)
|
|
|
|
(easy-menu-define cell-menu global-map
|
|
"Menu for Cell-mode commands."
|
|
'("Sheet"
|
|
["Create or edit cell" cell-sheet-create-cell]
|
|
["Create comment" cell-sheet-create-comment]
|
|
["Undo" cell-sheet-undo]
|
|
["Redo" cell-sheet-redo]
|
|
["Set mark" cell-sheet-set-mark]
|
|
["Clear mark" cell-sheet-clear-mark]
|
|
["Delete cell at cursor" cell-sheet-delete-cell]
|
|
["Cut selection" cell-sheet-cut-to-clipboard]
|
|
["Copy selection" cell-sheet-copy-to-clipboard]
|
|
["Paste at cursor" cell-sheet-paste]
|
|
["Insert row" cell-sheet-insert-row]
|
|
["Insert column" cell-sheet-insert-column]
|
|
["Delete row" cell-sheet-delete-row]
|
|
["Delete column" cell-sheet-delete-column]
|
|
["Move cursor left" cell-sheet-move-cursor-left]
|
|
["Move cursor right" cell-sheet-move-cursor-right]
|
|
["Move cursor up" cell-sheet-move-cursor-up]
|
|
["Move cursor down" cell-sheet-move-cursor-down]
|
|
["Move to beginning of row" cell-sheet-move-bol]
|
|
["Move to end of row" cell-sheet-move-eol]
|
|
["Page up" cell-sheet-page-up]
|
|
["Page down" cell-sheet-page-down]
|
|
["Move to top left corner" cell-sheet-move-bob]
|
|
["Move to bottom right corner" cell-sheet-move-eob]
|
|
["Re-initialize buffer (fix columns)" cell-mode]))
|
|
|
|
(defvar cell-mode-tool-bar-map ())
|
|
|
|
(defun cell-enable-tool-bar-map ()
|
|
(setf cell-mode-tool-bar-map
|
|
(when (keymapp tool-bar-map)
|
|
(let ((tool-bar-map (make-sparse-keymap)))
|
|
(tool-bar-add-item
|
|
"left-arrow" 'winner-undo 'winner-undo
|
|
:label "Back"
|
|
:help "Back to previous window configuration."
|
|
:enable t)
|
|
(tool-bar-add-item
|
|
"right-arrow"
|
|
'winner-redo 'winner-redo
|
|
:label "Forward"
|
|
:help "Forward to next window configuration."
|
|
:enable t)
|
|
(define-key-after tool-bar-map [cell-separator-1]
|
|
(list 'menu-item "--") 'winner-redo)
|
|
(tool-bar-add-item
|
|
"save" 'save-buffer 'save-buffer
|
|
:label "Save"
|
|
:help "Save the current sheet."
|
|
:enable t)
|
|
(define-key-after tool-bar-map [cell-separator-2]
|
|
(list 'menu-item "--") 'save-buffer)
|
|
(tool-bar-add-item
|
|
"undo" 'cell-sheet-undo 'cell-sheet-undo
|
|
:label "Undo"
|
|
:help "Undo."
|
|
:enable t)
|
|
(tool-bar-add-item
|
|
"cut" 'cell-sheet-redo 'cell-sheet-redo
|
|
:label "Redo"
|
|
:help "Redo."
|
|
:enable t)
|
|
(define-key-after tool-bar-map [cell-separator-3]
|
|
(list 'menu-item "--") 'cell-sheet-redo)
|
|
(tool-bar-add-item
|
|
"cut" 'cell-sheet-cut-to-clipboard 'cell-sheet-cut-to-clipboard
|
|
:label "Cut"
|
|
:help "Cut the cells to the clipbboard."
|
|
:enable t)
|
|
(tool-bar-add-item
|
|
"copy" 'cell-sheet-copy-to-clipboard 'cell-sheet-copy-to-clipboard
|
|
:label "Copy"
|
|
:help "Copy the cells to the clipbboard."
|
|
:enable t)
|
|
(tool-bar-add-item
|
|
"paste" 'cell-sheet-paste 'cell-sheet-paste
|
|
:label "Paste"
|
|
:help "Paste cells from the clipboard."
|
|
:enable t)
|
|
tool-bar-map))))
|
|
|
|
(provide 'cell)
|
|
;; Local Variables:
|
|
;; indent-tabs-mode: nil
|
|
;; End:
|
|
;;; cell.el ends here
|