Eagles Nest BBS 8/Eagles_Nest_Mac_Collection_Disc_8.TOAST/Developer Environments/AllegroCL11/Examples/Cosell.Lisp

Text File | 1987-10-27 | 32.2 KB | 941 lines | [TEXT/CCL ]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Cosell, a Common Lisp spread-sheet
;;
;;copyright 1987, Coral Software Corp
;;
;;  Cosell just like a normal spread-sheet, except that you enter Lisp
;;  expressions the cells.  It is written in Allegro CL version 1.1.
;;
;;  To run Cosell, just evaluate this file.  The code will add a new menu
;;  which provides the Cosell functionality.  In addition, the Save, Save As…,
;;  and Close menu-items from the File menu can be used, and also Cut, Copy,
;;  Paste, and Clear from the Edit menu.
;;
;;  Each cell in a Cosell window can contain a Lisp expression.  A cell can
;;  can access the value of another cell through an absolute or relative
;;  reference.  The expression (C 5 3) would return the value of cell #@(5 5).
;;  The expression (R 5 3) would return the value of the cell 5 rows to the
;;  right and 3 rows down from the cell containing the expression.  Relative
;;  references may contain negative numbers.
;;
;;  Cosell calculates the value of cells using a depth-first, demand-driven
;;  evaluation.  It starts in the upper left corner, and begins calculating
;;  the values of of cell.  If a cell contains a forward reference to another
;;  cell, the value of the other cell is calculated.  This may in turn trigger
;;  the calculation of other cells.  Cells are marked when they are calculated,
;;  so each calculation occurs only once during a sweep through a spreadsheet.
;;
;;  The only restriction on the action performed by cells is that they cannot
;;  side-effect the value of another cell.  Allowing this would introduce
;;  order dependencies and make forward references impossible.
;;
;;
;;  The object variable declarations are only used to suppress compiler
;;  warnings.  They don't improve the speed of the code.
;;

(eval-when (eval compile)
  (require 'records)
  (require 'traps))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;A few little utilities.


;;;;;;;;;
;;
;;*40-space-string*
;;
;;  this is used for formatting in the trace feature
;;
(defvar *40-space-string* "                                        ")

;;;;;;;;;
;;
;;point-to-list
;;
;;  converts a point to a list of h-coordinate and v-coordinate
;;
(defun point-to-list (point)
  (list (point-h point) (point-v point)))

;;;;;;;;;
;;
;;draw-cell
;;
;;  an extension to table-dialog-items.
;;  this function used to redraw a single cell
;;
;;  looks much prettier than redrawing the entire table.
;;
(defobfun (draw-cell *table-dialog-item*) (cell)
  (declare (object-variable my-dialog wptr))
  (let* ((cell-pos (cell-position cell)))
    (when cell-pos
      (with-port (ask my-dialog wptr)
        (rlet ((cell-rect rect))
          (rset cell-rect rect.topleft cell-pos)
          (rset cell-rect rect.bottomright (add-points cell-pos
                                                       (cell-size)))
          (ccl::draw-table-cell cell
                                cell-rect
                                (cell-selected-p cell)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  The Cosell window and it's components
;;
;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;*cosell-table*
;;
;;  Every Cosell window contains a cosell table.
;;  The Cosell table is what actually displays the spreadsheet
;;
;;  Because the Macintosh List Manager is used, large tables don't perform
;;  wonderfully.  This file creates spreadsheets with seven by 10 cells
;;  (though more can certainly be done, it will take longer to create
;;  a window).
;;

(defobject *cosell-table* *array-dialog-item*)

(defobfun (exist *cosell-table*) (init-list)
  (usual-exist init-list)
  (have 'evaled-cell-array                   ;cells in this array are non-nil
        (make-array (array-dimensions        ;when the corresponding cell in
                     (table-array))))        ;the table has been evaluated.
  (have 'undo-cell #@(0 0))                  ;the last cell which was changed
  (have 'undo-text "")                       ;the old text of the last changed
                                             ;  cell
  (have 'table-trace-p nil)                  ;true of trace is turned on for
                                             ;  the table
  (have 'trace-indent 0)                     ;the current depth of the trace
  (have 'current-cell-list ())               ;a stack of cells whose evaluation
                                             ;  is pending.
;these last three are initialized to their proper values by the exist
;  procedure of the tables owning window.
  (have 'entry-text nil)                     ;editable text for entering
                                             ;  formulas
  (have 'auto-calc-p nil))                   ;true if the spreadsheet should
                                             ;  recalculate automatically
                                             ;  every time a cell is changed


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;Accessor functions for getting and setting the values of cells
;;
;;  Each cell potentially has three components:
;;     1.  The value (result) from the last time the cell was calculated.
;;     2.  A compiled expression to be funcalled whenever their is a need
;;         to recalculate the value of the cell.
;;     3.  The text of the expression entered by the user.
;;
;;  These three components are stored in a list of length 3.
;;
;;  If the contents of a cell is NIL, it means that it hasn't been given
;;  an expression, so it never needs to be recalculated.
;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;;  Accessors
  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;
;;
;;full-cell-contents
;;
;;  returns the entire contents of the cell.  This will either be NIL, or
;;  a list of three components.
;;
(defobfun (full-cell-contents *cosell-table*) (cell &aux subscript)
  (if (setq subscript (cell-to-subscript cell))
    (apply #'aref (table-array) subscript)))

;;;;;;;;;;;;;;
;;
;;result-cell-contents
;;
;;  returns the result from the last time the cell was calculated, or NIL
;;    if the cell has no contents
;;
(defobfun (result-cell-contents *cosell-table*) (cell)
  "first item in the list is the calculated value"
   (first (full-cell-contents cell)))

;;;;;;;;;;;;;;
;;
;;action-cell-contents
;;
;;  returns a function to be funcalled to get the value of the cell, or NIL
;;    if the cell has no contents.
;;
(defobfun (action-cell-contents *cosell-table*) (cell)
  "second item in the list is the compiled definition"
  (second (full-cell-contents cell)))

;;;;;;;;;;;;;;
;;
;;text-cell-contents
;;
;;  returns the text of the formula entered into the cell by the user, or
;;    an empty string if the cell is empty.
;;
(defobfun (text-cell-contents *cosell-table*) (cell)
  "third item in the list is the text of the body of the definition"
  (or
   (third (full-cell-contents cell))
   ""))

;;;;;;;;;;;;;;
;;
;;cell-contents
;;
;;  This function is used by the system calls which print the contents of
;;    the cell of a table.  We set it up so that the result-cell-contents
;;    are printed.
;;
(defobfun (cell-contents *cosell-table*) (cell)
  "this function is called to print the cell"
  (result-cell-contents cell))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;;  Modifiers
  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;
;;
;;set-full-cell-contents
;;
;;  Sets the contents of the cell.  The new-contents argument should be
;;    a list of three components, or NIL.
;;
(defobfun (set-full-cell-contents *cosell-table*) (cell new-contents)
  (setf
     (apply #'aref (table-array) (cell-to-subscript cell))
     new-contents)
  (draw-cell cell))

;;;;;;;;;;;;;;
;;
;;set-result-contents
;;
;;  sets the result part of the cell, and redraws the cell.  This will be
;;   the value returned by funcalling the cell's formula, or it will be the
;;   the text of the formula if calculation hasn't happened yet.
;;
(defobfun (set-result-contents *cosell-table*) (cell new-contents)
  (let ((old-full-contents (full-cell-contents cell)))
    (setf (first old-full-contents) new-contents))
  (draw-cell cell))

;;;;;;;;;;;;;;
;;
;;set-action-contents
;;
;;  sets the action part of the cell.  The new-contents argument should be
;;  a compiled function, which is funcalled to get the value of the cell.
;;
(defobfun (set-action-contents *cosell-table*) (cell new-contents)
  (let ((old-full-contents (full-cell-contents cell)))
    (setf (second old-full-contents) new-contents)))

;;;;;;;;;;;;;;
;;
;;set-text-contents
;;
;;  sets the text part of the cell.  The new-contents argument should be the
;;  the text of the formula which was entered by the user.
;;
(defobfun (set-text-contents *cosell-table*) (cell new-contents)
  (let ((old-full-contents (full-cell-contents cell)))
    (setf (third old-full-contents) new-contents)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;;  Mungers
  ;;     procedures which manipulate the contents of cells
  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;
;;
;;update-value
;;
;;  calculates the value of the cell.
;;
;;  this involves printing trace information and various other hair.
;;
;;  The cell will only be calculated if it hasn't already been calculated this
;;  time around.  It can tell, because if it _has_ been calculated, then the
;;  corresponding position in evaled-cell-arry will be non-nil.
;;
;;  Of course, no calculation occurs if the cell is empty.
;;
(defobfun (update-value *cosell-table*) (cell)
  (declare (object-variable evaled-cell-array table-trace-p
                            trace-indent current-cell-list))
  (let* ((the-fun (action-cell-contents cell))
         (h-dim (point-h cell))
         (v-dim (point-v cell))
         (cell-string (point-string cell)))
    (when                                    ;recalculate when
      (and the-fun                           ;  there is a function
           (not                              ;  and the cell hasn't been
            (aref evaled-cell-array h-dim v-dim)))     ;  calculated yet.
      (when table-trace-p                    ;print trace info if necessary
        (format t "~%~aStarting cell ~a."
                (subseq *40-space-string* 0 (min trace-indent 40))
                cell-string)
        (incf trace-indent))
      (when                                  ;if the cell is already on the
                                             ;  of cells pending calculation
                                             ;  it means we're circular, so
                                             ;  we just punt.
        (member cell current-cell-list :test #'eq)
        (setq current-cell-list ())          ;zero pending cells first
        (error "circularity detected in cell ~a.  Recalculation aborted."
               cell-string))
      (push cell current-cell-list)          ;mark the cell as pending
      (set-result-contents cell              ;recalc the cell
                           (funcall the-fun))
      (setf                                  ;note that the cell is calculated
       (aref evaled-cell-array h-dim v-dim) t)
      (pop current-cell-list)                ;remove it from the pending list
      (when table-trace-p                    ;print trace info if necessary
        (decf trace-indent)
        (format t "~%~aFinished cell ~a."
                (subseq *40-space-string* 0 (min trace-indent 40))
                cell-string)))))

;;;;;;;;;;;;;;
;;
;;new-contents-from-text
;;
;;  given text newly entered by the user, it resets the full contents of the
;;  cell.
;;
;;  The value is set to the text with a prepended asterix (this is immediately
;;      recalculated if auto-calculation is turned on).
;;  The action is set to a function compiled from the text
;;  The text is just the text
;;
(defobfun (new-contents-from-text *cosell-table*) (cell text)
  (if (equal text "")
    (set-full-cell-contents cell nil)
    (let* ((new-function (progn
                           (compile nil
                                    `(lambda ()
                                         ,(read-from-string text nil nil)))))
           (new-value (concatenate 'string "*" text)))
      (set-full-cell-contents cell
                              (list new-value new-function text)))))

;;;;;;;;;;;;;;
;;
;;change-cell
;;
;;  moves from one cell to another, depending on the character typed by the
;;  user.  The character is passed to change-cell as an argument.
;;
;;  The old-cell is unhighlighted, and the new cell is highlighted.
;;  In addition, the text of the new cell is displayed in the text area.
;;
;;  The four arrow-keys move right, left, up, and down.
;;  Tab moves to the right and shift-tab left.
;;  Return moves down and shift-return moves up.
;;
(defobfun (change-cell *cosell-table*) (cell char)
  "shifts the selected cell according to the typed character, and updates
   the display.  Does not perform any recalculation."
  (declare (object-variable entry-text))
  (let* ((next-cell (case char
                      (#\downarrow
                       (add-points cell #@(0 1)))
                      (#\forwardarrow
                       (add-points cell #@(1 0)))
                      (#\uparrow
                       (subtract-points cell #@(0 1)))
                      (#\backarrow
                       (subtract-points cell #@(1 0)))
                      (#\tab
                       (if (shift-key-p)
                           (subtract-points cell #@(1 0))
                           (add-points cell #@(1 0))))
                      (#\return
                       (if (shift-key-p)
                           (subtract-points cell #@(0 1))
                           (add-points cell #@(0 1)))))))
    (when (cell-to-subscript next-cell)
      (cell-deselect cell)
      (cell-select next-cell)
      (let* ((next-text (text-cell-contents next-cell)))
        (ask entry-text
          (set-dialog-item-text next-text)
          (dialog-item-draw))))))


;;;;;;;;;;;;;;
;;
;;dialog-item-action
;;
;;  This function is sometimes called when the user clicks in a cell in the
;;  table.  It is called by window-click-event-handler
;;
;;  window-click-event-handler _won't_ call this function if the user is in
;;  the midst of entering a formula.  In those cases, window-click-event-handler
;;  uses the click to insert a cell reference into the formula.
;;
;;  On single clicks, it selects the cell and displays the cell's text in the
;;  the text area.
;;
;;  On double clicks, it prints the cell's value to the listener.  This is
;;  useful for cell's whose value has a long print representation.
;;
;;
(defobfun (dialog-item-action *cosell-table*) ()
  (declare (object-variable entry-text))
  (let* ((the-cell (car (selected-cells)))
         (the-text (text-cell-contents the-cell)))
    (if (double-click-p)
      (print (result-cell-contents the-cell))
      (ask entry-text
        (set-dialog-item-text the-text)))))


;;;;;;;;;;;;;;
;;
;;calculate
;;
;;  recalculates the entire spreadsheet.
;;
;;  first it zeroes the array, indicating that no cells have been calculated.
;;  then it goes through and calculates the values of each cell row by row
;;  and column by column.  Note that the calculation of some cells will by
;;  forced in advance.  Each cell is calculated as soon as its value is needed
;;  by another cell.  This way forward references work.  Marking calculated
;;  cells in the evaled-cell-array insures that no cell is calculated twice.
;;
;;  this function returns T.
;;
(defobfun (calculate *cosell-table*) ()
  (declare (object-variable evaled-cell-array table-trace-p trace-indent))
  (let ((dim (array-dimensions (table-array))))
    (dotimes (column (car dim))
      (dotimes (row (cadr dim))
        (setf (aref evaled-cell-array column row) nil)))
    (when table-trace-p
      (terpri)
      (setq trace-indent 0))
    (dotimes (column (car dim))
      (dotimes (row (cadr dim))
        (update-value (make-point column row)))))
  t)

;;;;;;;;;;;;;;
;;
;;c
;;
;;  this function takes two arguments, vertical and horizontal coordinates
;;  of a cell.  It forces the evaluation of the cell (the cell will
;;  recalculate only if it has to), and returns the cell's value.
;;
;;  the name of this function is intentionally brief, so that it can fit
;;  comfortably inside formulas.
;;
(defobfun (c *cosell-table*) (h v &aux (cell (make-point h v)))
  "for referring to other cells with absolute coordinates"
  (update-value cell)
  (result-cell-contents cell))

;;;;;;;;;;;;;;
;;
;;r
;;
;;  this function is analogous to c, except the numbers it receives as
;;  arguments are taken as relative offsets from the cell containing
;;  the formula.  These offsets may be positive or negative.
;;
;;  The function knows which cell's formula contains it, because that cell
;;  will be on the top of the stack of cells pending evaluation.
;;
(defobfun (r *cosell-table*) (h v)
  "for referring to cells with relative coordinates"
  (declare (object-variable current-cell-list))
  (let* ((cell (add-points (car current-cell-list)
                           (make-point h v))))
    (update-value cell)
    (result-cell-contents cell)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;*cosell-window*
;;
;;  The spreadsheet window class.
;;

(defobject *cosell-window* *dialog*)

;;;;;;;;;;;;;;
;;
;;exist
;;
;;  First create a window, and then add items to it.
;;
;;  Because we shadow window-update to look at the state of the window, we
;;  have to make sure window-update doesn't get called before the window
;;  has the proper state (i.e. instance variables and items).  This means
;;  we create the window hidden, set it up, and then do a window-show.
;;
;;  Setting up involves adding two dialog-items and then setting the state of
;;  some instance variables.
;;
(defobfun (exist *cosell-window*) (init-list)
  (declare (object-variable entry-text spread-table
                            table-trace-p auto-calc-p))
  (setq init-list
        (init-list-default init-list
                           :window-type :document-with-zoom
                           :window-show nil
                           :window-font '("monaco" 9)
                           :window-size #@(492 185)
                           :window-position #@(6 40)
                           :window-title "Untitled Spreadsheet"))
  (usual-exist init-list)
  (add-dialog-items
   (have 'entry-text
         (oneof *editable-text-dialog-item*
                :dialog-item-position #@(2 2)
                :dialog-item-size #@(10 10)  ;size will be reset
                :allow-returns t))
   (have 'spread-table
         (oneof *cosell-table*
                :dialog-item-position #@(0 56)
                :dialog-item-size #@(10 10)  ;size will be reset
                :table-array (make-array
                              (point-to-list
                               (getf init-list :table-dimensions #@(7 10)))))))
  (let* ((temp entry-text))
    (ask spread-table
      (setq entry-text temp
            table-trace-p (getf init-list :table-trace-p nil)
            auto-calc-p (getf init-list :auto-calc-p t))))
  (have 'previous-size (window-size))
  (have 'text-changed-p nil)
  (have 'my-file-name nil)
  (ask spread-table (cell-select #@(0 0)))
  (window-size-items)
  (window-show))

;;;;;;;;;;;;;;
;;
;;cut, paste, and clear
;;
;;  these need to do the usual version, and then set a flag showing that the
;;  window has been changed.
;;
(defobfun (cut *cosell-window*) ()
  (declare (object-variable text-changed-p))
  (setq text-changed-p t)
  (usual-cut))

(defobfun (paste *cosell-window*) ()
  (declare (object-variable text-changed-p))
  (setq text-changed-p t)
  (usual-paste))

(defobfun (clear *cosell-window*) ()
  (declare (object-variable text-changed-p))
  (setq text-changed-p t)
  (usual-clear))


;;;;;;;;;;;;;;
;;
;;set-window-size
;;
;;  Does a usual-set-window-size and then resizes the items in the window.
;;
(defobfun (set-window-size *cosell-window*) (new-size)
  (without-interrupts
   (usual-set-window-size new-size)
   (window-size-items)))


;;;;;;;;;;;;;;
;;
;;window-zoom-event-handler
;;
;;  Does a usual-set-window-zoom-event-handler and then resizes the items
;;  in the window.
;;
(defobfun (window-zoom-event-handler *cosell-window*) (message)
  (without-interrupts
   (usual-window-zoom-event-handler message)
   (window-size-items)))

;;;;;;;;;;;;;;
;;
;;window-size-items
;;
;;  This is called when the window is resized or zoomed.
;;  First it resizes the dialog items in the window to fit the new size of
;;  the window.
;;  Then it invalidates the entire contents of the window to force redrawing
;;  of the whole thing.
;;  All this is done before the window is redrawn.
;;
(defobfun (window-size-items *cosell-window*) ()
  (declare (object-variable spread-table entry-text wptr))
  (without-interrupts
   (let ((new-size (window-size)))
     (ask spread-table
       (set-dialog-item-size (subtract-points new-size
                                              #@(0 56))))
     (ask entry-text
       (set-dialog-item-size (make-point (- (point-h new-size)
                                            4)
                                         49))))
   (when (window-shown-p)
     (with-port wptr
       (_invalrect :ptr (rref wptr window.portrect))))))

;;;;;;;;;;;;;;
;;
;;window-click-event-handler
;;
;;  This does one of two things:
;;
;;  If the click was in a cell, and if the user was currently editing the
;;  formula of a cell, then a reference to the clicked cell is inserted into
;;  the formula.
;;
;;  If the click wasn't in a cell, or if a formula wasn't being edited, then
;;  the usual click is done.  This lets the user edit the editable-text, scroll
;;  the table, or move between cells.
;;
(defobfun (window-click-event-handler *cosell-window*) (where)
  (declare (object-variable spread-table text-changed-p))
  (let ((cell-clicked (ask spread-table (point-to-cell where))))
    (unless (and text-changed-p
                 cell-clicked
                 (insert-clicked-cell cell-clicked))
      (usual-window-click-event-handler where))))

;;;;;;;;;;;;;;
;;
;;insert-clicked-cell
;;
;;  Inserts a reference to a cell into the formula currently being edited.
;;  It receives the cell as an argument.
;;
;;  This always inserts an absolute cell reference, but it could be changed to
;;  insert an absolute or a relative reference, depending on the value of a
;;  global or object variable, or on the state of various modifier keys.
;;
(defobfun (insert-clicked-cell *cosell-window*) (cell)
  (push (concatenate 'string " (c "
                     (subseq (point-string cell) 3))
        *killed-strings*)
  (paste)
  (pop *killed-strings*))


;;;;;;;;;;;;;;
;;
;;window-key-event-handler
;;
;;  window-key-event-handler usually just passes keystrokes to the editable
;;  text item.  However, it first filters for the keys which are used to
;;  move from one cell to another.  These are the arrow keys, return, and tab.
;;
;;  If it gets one of these special keys, it does several things:
;;     If the formula has been changed, it sets up undo, gets the new
;;     formula, changes the cell's contents, and recalculates if auto-calc-p
;;     is true.
;;     In any case, it calls change-cell to move to a new cell.
;;
;;  To insert a carriage return into a formula, hold down the option key when
;;  typing return.
;;
(defobfun (window-key-event-handler *cosell-window*) (char)
  (declare (object-variable spread-table text-changed-p
                            undo-cell undo-text entry-text auto-calc-p))
  (let* ((current-cell (ask spread-table
                         (car (selected-cells)))))
    (if (and (member char
                     '(#\return #\tab #\backarrow
                       #\forwardarrow #\uparrow #\downarrow)
                     :test #'eq)
             (not (option-key-p)))
      (progn
        (when text-changed-p
          (setq text-changed-p nil)
          (ask spread-table
            (setq undo-cell current-cell)
            (setq undo-text (text-cell-contents current-cell))
            (let* ((new-text (ask entry-text (dialog-item-text))))
              (new-contents-from-text current-cell new-text)
              (if auto-calc-p
                (calculate)))))
        (ask spread-table
          (change-cell current-cell char)))
      (progn
        (setq text-changed-p t)
        (usual-window-key-event-handler char)))))

;;;;;;;;;;;;;;
;;
;;undo
;;
;;  this function is called from the undo menu-item.  When a cell has been
;;  changed, it lets the user revert to the old version of the cell.
;;
;;  Once the user starts entering a new formula, undo is disabled.
;;
(defobfun (undo *cosell-window*) ()
  (declare (object-variable spread-table undo-cell undo-text
                            entry-text auto-calc-p))
  (ask spread-table
    (let* ((now-selected (car (selected-cells)))
           (removed-text (text-cell-contents undo-cell))
           (added-text undo-text))
      (cell-deselect now-selected)
      (cell-select undo-cell)
      (new-contents-from-text undo-cell undo-text)
      (ask entry-text
        (set-dialog-item-text added-text))
      (setq undo-text removed-text)         ;sets up for redo
      (if auto-calc-p
        (calculate)
        (draw-cell undo-cell)))))

;;;;;;;;;;;;;;
;;
;;window-can-undo-p
;;
;;  determines whether the undo menu-item is enabled, and sets the text of the
;;  undo menu-item.
;;
;;  the item will be enabled when the user has just changed a cell, but hasn't
;;  yet started editing a new formula.
;;
(defobfun (window-can-undo-p *cosell-window*) ()
  (declare (object-variable text-changed-p))
  (let* ((enabled text-changed-p))
    (ask *undo-menu-item*
      (if enabled
        (progn
          (set-menu-item-title "Undo")
          ())
        (set-menu-item-title "Undo Cell Change")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  A set of functions for saving and reading in spreadsheets
;;


;;;;;;;;;;;;;;
;;
;;spread-to-list
;;
;;  converts the contents of a spreadsheet to a list.  This list can then be
;;  printed or stored in a file.
;;  The list includes the size of the spreadsheet (because they can actually
;;  be made with varying numbers of cells), whether it traces and/or
;;  autocalculates, and it stores the text of the formulas in each cell.
;;
(defobfun (spread-to-list *cosell-window*) ()
  (declare (object-variable spread-table table-trace-p auto-calc-p))
  (ask spread-table
    (let* ((the-list ())
           (the-array (table-array))
           (dimensions (array-dimensions the-array)))
      (dotimes (h (car dimensions))
        (dotimes (v (cadr dimensions))
          (push (text-cell-contents (make-point h v))
                the-list)))
      (setq the-list (nreverse the-list))
      (push table-trace-p the-list)
      (push auto-calc-p the-list)
      (push dimensions the-list))))


;;;;;;;;;;;;;;
;;
;;list-to-spread
;;
;;  Does the inverse of spread-to-list.  It creates a new spreadsheet window
;;  from a list of data.
;;
;;  This function is used by the open command.
;;
(defun list-to-spread (the-list)
  (declare (object-variable spread-table auto-calc-p))
  (let* ((dimensions (pop the-list))
         (h (car dimensions))
         (v (cadr dimensions))
         (new-spread (oneof *cosell-window*
                            :table-dimensions (make-point h v)
                            :auto-calc-p (pop the-list)
                            :table-trace-p (pop the-list))))
    (ask new-spread
      (ask spread-table
        (dotimes (hn h)
          (dotimes (vn v)
            (new-contents-from-text (make-point hn vn) (pop the-list))))
        (when auto-calc-p
          (calculate))))
    new-spread))


;;;;;;;;;;;;;;
;;
;;window-save
;;
;;  This function is called by the standard Save menu-item from the File
;;  menu.  If the window has a file, it stores the spreadsheet in the file.
;;  If the window doesn't have a file, it calls window-save-as.
;;
(defobfun (window-save *cosell-window*) ()
  (declare (object-variable my-file-name))
  (if my-file-name
    (with-open-file (the-file my-file-name
                              :direction :output
                              :if-exists :supersede)
      (print (spread-to-list) the-file))
    (window-save-as)))

;;;;;;;;;;;;;;
;;
;;window-save-as
;;
;;  This function is called by the standard Save As… menu item.  It prompts the
;;  user for the name of a new file, stores the spreadsheet in the window, and
;;  sets the window's filename and title appropriately.
;;
(defobfun (window-save-as *cosell-window*) ()
  (declare (object-variable my-file-name))
  (let* ((new-name (choose-new-file-dialog
                    :prompt "Save Spreadsheet As…"
                    :directory (or my-file-name
                                   "Untitled Spreadsheet"))))
    (with-open-file (the-file new-name
                              :direction :output
                              :if-exists :supersede)
      (print (spread-to-list) the-file))
    (setq my-file-name new-name)
    (set-window-title (mac-filename new-name))))


;;;;;;;;;;;;;;
;;
;;cosell-open
;;
;;  this command is called from the Open menu-item on the Cosell menu.  It
;;  opens a text file, and creates a spreadsheet from the list read in from
;;  the file.
;;
;;  This function will let you open any text file.  If you choose a file that
;;  doesn't hold a cosell spreadsheet, it will lose.
;;
(defun cosell-open ()
  (declare (object-variable my-file-name))
  (let* ((the-file-name (choose-file-dialog))
         (the-window (with-open-file
                       (the-stream the-file-name :direction :input)
                       (list-to-spread (read the-stream)))))
    (ask the-window
      (setq my-file-name the-file-name)
      (set-window-title (mac-filename the-file-name)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  code to set up the cosell menu.
;;
(defun init-cosell-menu (&aux old-menu)
  (when (setq old-menu (find-menu "cosell"))
        (ask old-menu (menu-deinstall)))
    (let ((men (oneof *menu* :menu-title "Cosell"))
          (new
           (oneof *menu-item*
                  :menu-item-title "New"
                  :menu-item-action #'(lambda ()
                                        (oneof *cosell-window*))))
          (open
           (oneof *menu-item*
                  :menu-item-title "Open…"
                  :menu-item-action 'cosell-open))
          (auto
           (oneof *menu-item*
                  :menu-item-title "Auto Calculate"
                  :menu-item-action
                  #'(lambda ()
                      (ask (front-window)
                        (ask spread-table
                          (if auto-calc-p
                            (setq auto-calc-p nil)
                            (progn (setq auto-calc-p t)
                                   (calculate))))))))
          (calc
           (oneof *menu-item*
                  :menu-item-title "Calculate Now"
                  :menu-item-action
                  #'(lambda ()
                      (ask (front-window)
                        (ask spread-table (calculate))))))
          (trace
           (oneof *menu-item*
                  :menu-item-title "Trace"
                  :menu-item-action
                  #'(lambda ()
                      (ask (front-window)
                        (ask spread-table
                          (setq table-trace-p (not table-trace-p))))))))
      (defobfun (menu-update men) ()
        (let* ((cosell-on-top-p (typep (front-window)
                                       *cosell-window*)))
          (dolist (the-item (cddr (menu-items)))   ;do all but the first two
            (ask the-item
              (if cosell-on-top-p
                (menu-item-enable)
                (menu-item-disable)))))
        (usual-menu-update))
      (defobfun (menu-item-update auto) ()
        (when (menu-item-enabled-p)
          (set-menu-item-check-mark
           (ask (front-window)
             (ask spread-table auto-calc-p)))))
      (defobfun (menu-item-update calc) ()
        (and (menu-item-enabled-p)
             (ask (front-window)
               (ask spread-table auto-calc-p))
             (menu-item-disable)))
      (defobfun (menu-item-update trace) ()
        (when (menu-item-enabled-p)
          (set-menu-item-check-mark
           (ask (front-window)
             (ask spread-table table-trace-p)))))
      (ask men
        (add-menu-items new open auto calc trace)
        (menu-install))))

(init-cosell-menu)