You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1908 lines
71 KiB
1908 lines
71 KiB
;;; 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
|
|
|