;;;;; Code to adapt Forrest Young's ViSta data spreadsheets to Cook and
;;;;; Weisberg's ARC 

;; last modified: 16 Dec 1998

;; Most of the following code is slightly modified from Forrest Young's ViSta
;; (used with his permission -- Copyright (c) 1994-6 by Forrest W. Young):

;;########################################################################
;; datasheet menu functions, datasheet constructor function,
;; code to define the datasheet prototype and its slot accessor methods,
;; and a few additional methods.
;; 


(defun show-datasheet (&optional data-object &key new-data)
"Args: &optional DATA-OBJECT &key NEW-DATA
Shows a datasheet for DATA-OBJECT (or current-data if not specified). NEW-DATA is t for new data, nil otherwise" 
  (when (not data-object) (setf data-object current-data)) 
  (let ((dsob (send data-object :datasheet-object))) 
    (cond 
      ((not dsob)
           (setf dsob (datasheet data-object :editable t)))
      (t 
       (send dsob :editable t)
       (send dsob :hot-cell nil)
       (send dsob :hot-cell-ready nil)
       (send dsob :hot-cell-string nil)
       (send dsob :scroll 0 0)
       (send dsob :set-window-size 
             (send dsob :field-width)
             (send dsob :field-height)
             (send dsob :label-width)
             (send dsob :nvar)
             (send dsob :nobs))
       (send dsob :redraw)
       (send dsob :show-window)))
    (when dsob
          (send dsob :enable-vista-menus&tools nil)
          (send (send data-object :datasheet-object) :enable-menu-items t)
          (send dsob :new-data new-data)
          (send dsob :edited nil))
    t))

(defun browse-data (&optional data-object) 
"Args: DATA-OBJECT
Function to show a non-editable datasheet for browsing DATA-OBJECT"
  (when (not data-object) (setf data-object current-data)) 
  (cond 
    ((not (send data-object :datasheet-object))
     (datasheet data-object :editable nil)
     )
    (t
     (send (send data-object :datasheet-object) :editable nil)
     (send (send data-object :datasheet-object) :show-window)))
  (send (send data-object :datasheet-object) :enable-menu-items nil)
  t)


(defun datasheet (data-object &key editable)
"Args: DATA-OBJECT &KEY EDITABLE
Constructor function for constructing datasheet for editing or browsing DATA-OBJECT"
  (let* ((object (send datasheet-proto :new 2
                       :title (send data-object :name)
                       :size '(475 280) ;full-graph-size ;'(590 380)
                       :location (+ (list 24 20) location11) ;'(22 22)
                       :show nil)) 
         (nvar   (send data-object :nvar))
         (nobs   (send data-object :nobs))
         (dsmenu (send menu-proto :new "DataSheet"))
         (setfw  (send menu-item-proto :new "Width of Columns"
                       :action #'(lambda ()
                                   (send object :set-fw-dialog))))
         (setdec (send menu-item-proto :new "Number of Decimals"
                       :action #'(lambda ()
                                   (send object :set-dec-dialog))))
         (new1st (send menu-item-proto :new "New Observations"
                          :action 'new-observations))
         (new2nd (send menu-item-proto :new "New Variables"
                       :action 'new-variables))
         (save (send menu-item-proto :new "Save Datasheet"
                     :action #'(lambda () (send object :save))))
         (save-as (send menu-item-proto :new "Save Datasheet as"
                     :action #'(lambda () (send object :save-as))))
         (tw     (send object :text-width "9"))
         (data   (send data-object :active-data '(:variate)))
         (nonil  (remove nil (remove "?" data :test #'equal) :test #'equal))
         (ndigit (cond
                   (nonil (ceiling (log (max (abs nonil)) 10)))
                   (t 6))) 
         (ndciml 2)
         (ncols  (max 6 (+ ndigit ndciml)))
         (dcimlw (send object :text-width "."))
         (signw  (send object :text-width "-"))
         (fw     (+ (* tw ncols) dcimlw signw 6))
         (fh     (+ (send object :text-ascent) 
                    (send object :text-descent) 3))
         (lw     nil)) 
    (send object :nvar nvar)
    (send object :variable-strings 
          (copy-list (send data-object :variables)))
    (send object :type-strings (copy-list (send data-object :Vtypes))) 
    (send object :create-label-strings data-object)
    (setf lw (max (* 10 tw) fw (+ 6 (max 
             (map-elements #'send object :text-width 
                           (send object :label-strings))))))
    (send dsmenu :append-items setfw setdec (send dash-item-proto :new)
          new1st new2nd (send dash-item-proto :new) save save-as)
    (send object :data-object data-object)
    (send object :nobs nobs) 
    (send object :newvar 0)
    (send object :newobs 0)
    (send object :field-width fw) 
    (send object :field-height fh)
    (send object :label-width  lw)
    (send object :number-of-decimals ndciml)
    (send object :number-of-columns ncols)
    (send object :create-data-matrix-strings)
    (send object :editable editable)
    (send object :redraw-now t)
    (send object :menu dsmenu)
    (send object :show-window)
    (send object :set-window-size fw fh lw nvar nobs)
    (send object :h-scroll-incs fw (* 4 fw))
    (send object :v-scroll-incs fh (* 10 fh))
    (setf *datasheet* object)
    (send data-object :datasheet-object object)
    (send data-object :datasheet-open t)
    object))
   
(defproto datasheet-proto '(data-object 
   data-matrix-strings variable-strings label-strings type-strings 
   editable edited nvar nobs field-width field-height label-width 
   hot-cell hot-cell-ready hot-cell-string menu-states new-data
   number-of-columns number-of-decimals newvar newobs 
   redraw-now) nil graph-proto)

(defmeth datasheet-proto :isnew (&rest args) 
  (apply #'call-next-method args))

(defmeth datasheet-proto :data-object (&optional (obj-id nil set))
"Message args: (&optional obj-id)
 Sets or retrieves the object-id of the data object for this datasheet."
  (if set (setf (slot-value 'data-object) obj-id))
  (slot-value 'data-object))

(defmeth datasheet-proto :data-matrix-strings (&optional (matrix nil set))
"Message args: (&optional matrix)
 Sets or retrieves the data matrix with data as strings."
  (if set (setf (slot-value 'data-matrix-strings) matrix))
  (slot-value 'data-matrix-strings))

(defmeth datasheet-proto :variable-strings (&optional (list nil set))
"Message args: (&optional list)
 Sets or retrieves the list of variable strings."
  (if set (setf (slot-value 'variable-strings) list))
  (slot-value 'variable-strings))

(defmeth datasheet-proto :label-strings (&optional (list nil set))
"Message args: (&optional list)
 Sets or retrieves the list of label strings."
  (if set (setf (slot-value 'label-strings) list))
  (slot-value 'label-strings))

(defmeth datasheet-proto :type-strings (&optional (list nil set))
"Message args: (&optional list)
 Sets or retrieves the list of type strings."
  (if set (setf (slot-value 'type-strings) list))
  (slot-value 'type-strings))

(defmeth datasheet-proto :editable (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the datasheet is editable."
  (if set (setf (slot-value 'editable) logical))
  (slot-value 'editable))

(defmeth datasheet-proto :edited (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the datasheet is editable."
  (if set (setf (slot-value 'edited) logical))
  (slot-value 'edited))

(defmeth datasheet-proto :nobs (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of observations in the datasheet."
  (if set (setf (slot-value 'nobs) number))
  (slot-value 'nobs))

(defmeth datasheet-proto :nvar (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of variables in the datasheet."
  (if set (setf (slot-value 'nvar) number))
  (slot-value 'nvar))

(defmeth datasheet-proto :newobs (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of observations in the datasheet."
  (if set (setf (slot-value 'newobs) number))
  (slot-value 'newobs))

(defmeth datasheet-proto :newvar (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of variables in the datasheet."
  (if set (setf (slot-value 'newvar) number))
  (slot-value 'newvar))

(defmeth datasheet-proto :field-width (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the field width of the datasheet."
  (if set (setf (slot-value 'field-width) number))
  (slot-value 'field-width))

(defmeth datasheet-proto :field-height (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the field height of the datasheet."
  (if set (setf (slot-value 'field-height) number))
  (slot-value 'field-height))

(defmeth datasheet-proto :label-width (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the label width of the datasheet."
  (if set (setf (slot-value 'label-width) number))
  (slot-value 'label-width))

(defmeth datasheet-proto :hot-cell (&optional (number-list nil set))
"Message args: (&optional number-list)
 Sets or retrieves a list of the row and column of the highlighted cell."
  (if set (setf (slot-value 'hot-cell) number-list))
  (slot-value 'hot-cell))

(defmeth datasheet-proto :hot-cell-ready (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the hot cell is ready for typing."
  (if set (setf (slot-value 'hot-cell-ready) logical))
  (slot-value 'hot-cell-ready))

(defmeth datasheet-proto :hot-cell-string (&optional (string nil set))
"Message args: (&optional string)
 Sets or retrieves the hot cell string."
  (if set (setf (slot-value 'hot-cell-string) string))
  (slot-value 'hot-cell-string))

(defmeth datasheet-proto :menu-states (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the hot cell is ready for typing."
  (if set (setf (slot-value 'menu-states) logical))
  (slot-value 'menu-states))

(defmeth datasheet-proto :new-data (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the hot cell is ready for typing."
  (if set (setf (slot-value 'new-data) logical))
  (slot-value 'new-data))

(defmeth datasheet-proto :number-of-decimals (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of decimals displayed in the datasheet."
  (if set (setf (slot-value 'number-of-decimals) number))
  (slot-value 'number-of-decimals))

(defmeth datasheet-proto :number-of-columns (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of columns displayed in the datasheet."
  (if set (setf (slot-value 'number-of-columns) number))
  (slot-value 'number-of-columns))

(defmeth datasheet-proto :redraw-now (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether redraw should be done (t) or delayed (nil)."
  (if set (setf (slot-value 'redraw-now) logical))
  (slot-value 'redraw-now))

(defmeth datasheet-proto :set-window-size (fw fh lw nv no)
  (send self :has-h-scroll 
        (max (select (screen-size) 0) (+ 1 lw (* fw (+ 1 nv)))))
  (send self :has-v-scroll
        (max (select (screen-size) 1) (+ 1 (* fh (+ 3 no))))))

(defmeth datasheet-proto :enable-vista-menus&tools 
  (&optional (logical nil set)) 
  (when set 
        (cond 
          (logical ;enable appropriate menus and tools
             (send current-data :set-menu&tool-states "MV"))
          (t       ;disable all menus and tools
             (send current-data :set-menu&tool-states "Disabled")))))

(defmeth datasheet-proto :create-data-matrix-strings ()
"Message args: nil
 Creates and stores the string version of the data matrix." 
  (let* ((mat (send (send self :data-object) :data-matrix))
         (numobs (send self :nobs))
         (numvar (send self :nvar))
         (ndec (send self :number-of-decimals))
         (ncol (send self :number-of-columns))
         (matst (make-array (list numobs numvar)))
         (k 0)) 
    (dotimes (i numobs)
          (dotimes (j numvar)
             (setf (aref matst i j) (string-trim " " ;was string-right-trim
                   (format nil "~v,vf" ncol ndec (aref mat i j))))))
    (send self :data-matrix-strings matst))) 

(defmeth datasheet-proto :create-label-strings (data-object)
  (send self :label-strings (copy-list (send data-object :Vlabels))))


;;  methods to draw and manipulate a datasheet

#|
The following method works on the Mac and under MS-WIN. Maybe not for Unix. I feel squeamish about mucking around with activate! See do-click below for another way to do this.|#

(defmeth datasheet-proto :activate (logical) 
  (call-next-method logical)
  (when logical 
        (when (equal self (front-window))
              (let ((dob (send self :data-object)))
                (when (not (eq current-data dob)) 
                      (setcd dob)
                      (setf *datasheet* self))))))

(defmeth datasheet-proto :do-click (x y m1 m2)
  (let ((dob (send self :data-object))
        (fw  (send self :field-width))
        (fh  (send self :field-height))
        (lw  (send self :label-width))
        (old-hot-cell (send self :hot-cell))
        (ready (send self :hot-cell-ready))
        (nobs (send self :nobs))
        (nvar (send self :nvar))
        (new-var nil)
        (new-obs nil)
        (body nil)
        (row nil)
        (col nil)) 
    (send self :edited t)
    (when (send self :editable)
          (setf row (- (ceiling y fh) 2))
          (setf col (ceiling (- x lw) fw))
          (when (and (not (and (< row 1) (< col 1)))
                     (and (<= row nobs) (<= col nvar)))
                (setf body t)
                (send self :hot-cell (list row col))
                (send self :reverse-cell-color row col lw fw fh))
          (when (not body)
                (if (and (= row -1) (= col (+ 1 nvar))) 
                    (setf new-var t) (setf new-var nil))
                (if (and (= row (+ 1 nobs)) (< col 1))
                    (setf new-obs t) (setf new-obs nil)))
          (when old-hot-cell
                (setf row (first  old-hot-cell))
                (setf col (second old-hot-cell))
                (send self :reverse-cell-color row col lw fw fh ready))
          (when (not body)
                (send self :hot-cell nil)
                (when (or new-var new-obs)
                      (send self :expand-mv-datasheet new-var new-obs 1)))
                      
          (when ready (send self :hot-cell-ready nil)))))

(defmeth datasheet-proto :set-window-scroll-size (new-obs new-var)
  (let ((fw  (send self :field-width))
        (fh  (send self :field-height))
        (lw  (send self :label-width))
        (nobs (send self :nobs))
        (nvar (send self :nvar))
        )
    (send self :set-window-size fw fh lw nvar nobs)
 ;   (send self :set-window-scroll new-obs new-var fh fw lw nvar nobs)
    ))

(defmeth datasheet-proto :set-window-scroll 
                         (new-obs new-var fh fw lw nvar nobs)
  (let ((table-size  (list (+ lw (* nvar fw)) (* (+ 2 nobs) fh)))
        (window-size (send self :size))
        (scroll (send self :scroll)))
    (when (and new-obs (> (+ (second table-size) fh) 
                          (+ (second window-size) (second scroll))))
          (setf (second scroll) (+ (second scroll) fh))
          (apply #'send self :scroll scroll))
    (when (and new-var (> (+ (first table-size) fw) 
                          (+ (first window-size) (first scroll))))
          (setf (first  scroll) (+ (first  scroll) fw))
          (apply #'send self :scroll scroll))))

(defun new-observation ()
  (send *datasheet* :expand-mv-datasheet nil t 1))

(defun new-observations (&optional (n 0))
  (when (= n 0) 
        (send *datasheet* :redraw-now nil)
        (setf n (first (get-value-dialog 
                        "Number of New Observations" :initial 1))))
  (when n 
        (when (< n 1) (error "You Must Add at Least 1 New Observation."))
        (send *datasheet* :expand-mv-datasheet nil t n)))

(defun new-variable ()
  (send *datasheet* :expand-mv-datasheet t nil 1))

(defun new-variables (&optional (n 0))
  (when (= n 0) 
        (send *datasheet* :redraw-now nil)
        (setf n (first (get-value-dialog 
                        "Number of New Variables" :initial 1))))
  (when n
        (when (< n 1) (error "You Must Add at Least 1 New Variable."))
        (send *datasheet* :expand-mv-datasheet t nil n)))

(defmeth datasheet-proto :expand-labels (n)
  (let ((nobs (length (send self :label-strings))))
    (send self :label-strings 
          (append (send self :label-strings)
                  (mapcar #'(lambda (i) (format nil "~a~d" "" (+ nobs i)))
                          (iseq n))))))

(defmeth datasheet-proto :expand-names (n name)
  (let ((nvar (length (send self :variable-strings))))
    (send self :variable-strings 
          (append (send self :variable-strings)
                  (mapcar #'(lambda (i) (format nil "~a~d" name (+ nvar i)))
                          (iseq n))))))     

(defmeth datasheet-proto :expand-mv-datasheet (new-var new-obs n)
"Args: new-var new-obs n
Method to add N new variables (when NEW-VAR is t) and/or observations (when NEW-OBS is t) to a multivariate datasheet."
  (let ((varname "Var")
        (vartype "variate")
        (vars (send self :variable-strings))
        (newstrs nil)
        (types (send self :type-strings))
        (labels (send self :label-strings))
        (nvar (send self :nvar))
        (nobs (send self :nobs)))
    (when new-var   
          (send self :nvar (+ nvar n))
          (send self :newvar (+ (send self :newvar) n))
          (send self :expand-names n varname)
          (send self :type-strings (append types (repeat vartype n)))
          (send self :data-matrix-strings
                (bind-columns (send self :data-matrix-strings)
                              (matrix (list nobs n)
                                      (repeat "?" (* nobs n))))))
    (when new-obs
          (send self :nobs (+ nobs n))
          (send self :newobs (+ (send self :newobs) n))
          (send self :expand-labels n)
          (send self :data-matrix-strings 
                (bind-rows (send self :data-matrix-strings) 
                           (matrix (list n nvar)
                                   (repeat "?" (* n nvar)))))))
  (send self :edited t)
  (send self :set-window-scroll-size new-obs new-var)
  (send self :redraw-now t)
  (send self :redraw))

(defmeth datasheet-proto :reverse-cell-color (row col lw fw fh &optional ready)
"Args: row col lw fw fh & optional ready
Reverses color of cell at intersection of col and row, where (in pixels) lw is label width, fw is field (cell) width, fh is field height. Ready indicates if cell ready for typing."
  (let ((x nil) (y nil) (w nil) (h nil) (xf 0) (yf 0)
        (nrow (send self :nobs)) (ncol (send self :nvar)))
#+macintosh(when (= 1 row) (setf yf 1))
#+macintosh(when (= 1 col) (setf xf 1))
    (when (< col 1) (setf xf (- fw lw)))
    (setf x (+ lw 1 xf (* (- col 1) fw)))
    (when (< x 1) (setf x 1))
    (setf y (+ 1 yf (* (+ row 1) fh)))
    (setf w (- fw 1 xf))
    (setf h (- fh 1 yf))
#-macintosh(when (or (= col 0) (= col ncol)) (setf w (1- w)))
#-macintosh(when (or (= row 0) (= row nrow)) (setf h (1- h)))
    (send self :draw-mode 'xor) 
#+macintosh(if ready
           (send self :frame-rect x y w h)
           (send self :paint-rect x y w h))
#-macintosh(send self :frame-rect x y w h)
    (send self :draw-mode 'normal)))

(defmeth datasheet-proto :cell-size-location (row col lw fw fh)
  (let ((x nil) (y nil) (w nil) (h nil) (xf nil) (yf nil)
        )
    (if (= 1 row) (setf yf 1) (setf yf 0))
    (if (= 1 col) (setf xf 1) (setf xf 0))
    (when (< col 1) (setf xf (- fw lw)))
    (setf x (+ lw 1 xf (* (- col 1) fw)))
    (when (< x 1) (setf x 1))
    (setf y (+ 1 yf (* (+ row 1) fh)))
    (setf w (- fw 1 xf))
    (setf h (- fh 1 yf))
    (list x y w h)))

(defmeth datasheet-proto :do-key (c m1 m2)
"Method Args: c m1 m2
Senses character c and shift (m1=t) or option (m2=t)"
  (let ((editable (send self :editable))
        (hot (send self :hot-cell))
        (fw  (send self :field-width))
        (fh  (send self :field-height))
        (lw  (send self :label-width))
        (nobs (send self :nobs))
        (nvar (send self :nvar))
        (x   nil)
        (y   nil)
        ) 
;DISPLAYS CHARACTER TYPED
;(format t "~%~s" c)
    (when 
     editable 
     (when 
      hot
      (setf row (first hot))
      (setf col (second hot))
      (setf x (+ lw 1 (* fw (1- col))))
      (setf y (+ 1 (* fh (+ 1 row))))
#+macintosh      (case c
        ( (#\C-\ #\C-] #\C-M #\Newline #\Tab #\C-C #\C-^ #\C-_ #\C-A #\C-D)
;            left right return? return   tab  enter  up   down  home  end    
         (send self :move-cell c row col nvar nobs x y lw fw fh m1))
        (t
         (send self :store-and-show-char c row col lw fw fh)))
#+msdos    (case c
        ( (  #\;   #\C-M #\[ #\'  #\Tab)
;            left  right up  down   tab
         (send self :move-cell c row col nvar nobs x y lw fw fh m1))
        (t
         (send self :store-and-show-char c row col lw fw fh)))
#+X11   (case c
        ( (  #\;   #\Newline #\[ #\'  #\Tab) ;temp same as msdos
;            left  right up  down   tab
         (send self :move-cell c row col nvar nobs x y lw fw fh m1))
        (t
         (send self :store-and-show-char c row col lw fw fh)))
      ))))

(defmeth datasheet-proto :store-and-show-char (c row col lw fw fh)
"Method Args: c row col lw fw fh
Method to store and show a non cursor moving character c when in row and col of datasheet with lw label width, fw and fh field width and height."
  (let* ((hot-cell-ready (send self :hot-cell-ready))
         (xywh (send self :cell-size-location row col lw fw fh))
         (data-strings (send self :data-matrix-strings))
         (x (first  xywh))
         (y (second xywh))
         (w (third  xywh))
         (h (fourth xywh))
         ) 
    (cond 
      ((not hot-cell-ready) 
       (send self :hot-cell-ready t)
       (send self :erase-rect (1+ x) (1+ y) (- w 2) (- h 2))
       (if (eq c #\C-H) ;if delete
           (send self :hot-cell-string "")
           (send self :hot-cell-string (coerce (list c) 'string))))
      (t
       (if (eq c #\C-H)
           (when (> (length (send self :hot-cell-string)) 0)
                 (send self :hot-cell-string
                       (subseq (send self :hot-cell-string) 0 
                               (1- (length (send self :hot-cell-string))))))
           (send self :hot-cell-string (strcat (send self :hot-cell-string)
                                               (coerce (list c) 'string))))))
    (cond 
      ((and (> row 0) (> col 0)) ;when in main body of table
       (send self :draw-cell-text self ':data-matrix-strings
             row col x y w h fw fh lw 2 (1- row) (1- col))      
;The following statement updates data-object's data after every key-stroke. 
;This is fast enough on my machine, but isnt necessary unless code is 
;changed to update objects dependent on the current-data on the fly. 
;Currently, the close method updates the data.
;      (send (send self :data-object) :Vdata (mapcar #'number-from-string 
;              (combine (send self :data-matrix-strings)))))
       )
      ((< col 1) ;when in labels
       (send self :draw-cell-text self ':label-strings 
             row col x y w h fw fh lw 0 (1- row)))
      ((= row -1) ;when in variable names
       (send self :draw-cell-text self ':variable-strings 
             row col x y w h fw fh lw 1 (1- col)))
      ((= row 0) ;when in variable types
       (send self :draw-cell-text self ':type-strings
             row col x y w h fw fh lw 1 (1- col)))
      )))
    

(defmeth datasheet-proto :draw-cell-text 
  (object message row col x y w h fw fh lw justify element1 &optional element2)
"Args: Object - dataobj; message - message sent to data-object;
row col - of data sheet; x y w h - position and size of cell; fw fh lw field sizes of sheet; justify - 0 1 2 left center right; element1 element2 row and col of dataobj"
  (let ((string nil)
        (maxstring 0))
    (if element2 
        (setf (select (send object message) element1 element2)
              (send self :hot-cell-string))
        (setf (select (send object message) element1)
              (send self :hot-cell-string)))
    (send self :erase-rect (+ x 2) (+ y 2) (- w 3) (- h 3))
    (if element2
        (setf string (select (send object message) element1 element2))
        (setf string (select (send object message) element1))) 
    (if (< col 1) (setf maxstring lw) (setf maxstring fw))
    (when (> (send self :text-width string) (- maxstring 6)) 
          (setf string "*****"))
    (case justify
      (2 (send self :draw-text string (- (+ lw (* col fw)) 3) 
               (- (* fh (+ 2 row)) 3) 2 0))
      (1 (send self :draw-text string (- (+ lw (* col fw)) (floor (/ fw 2))) 
               (- (* fh (+ 2 row)) 3) 1 0))
      (0 (send self :draw-text string 3 
               (- (* fh (+ 2 row)) 3) 0 0)))
    ))

(defmeth datasheet-proto :move-cell (c row col nvar nobs x y lw fw fh m1)
"Method Args: c row col nvar nobs x y lw fw fh m1
Method to move to another cell by simulating a do-click.  Movement character is c.  In row and col. There are nvar and nobs cols and rows.  Simulated click will be at x and y. Fields are fw and fh wide and high. Lables are lw wide. M1 t for shift."
  (when (< col 1) ;when in labels column
     (case c 
       (
#+macintosh(#\C-\ #\C-^) ;left,up
#+msdos    (#\;   #\[)
#+X11    (#\;   #\[)
        (when (> row 1) (send self :do-click x (- y fh) nil nil))) ;up
       (#\Tab
        (if m1 
            (when (> row 1)
                  (send self :do-click 3 (- y fh) nil nil))
            (when (< row nobs)
                  (send self :do-click 3 (+ y fh) nil nil))))
       (#\C-A (send self :do-click (+ lw 3) (+ (* 2 fh) 3) nil nil)) ;home
       (#\C-D (send self :do-click (+ lw -3 (* nvar fw)) 
                    (+ 3 fh (* nobs fh)) nil nil)) ;end
       (t ;down
        (when (< row nobs)
              (send self :do-click x (+ y fh) nil nil)))
       ))
  (when (> col 0) ;when in datasheet columns
     (case c
       (
#+macintosh #\C-\ ;left
#+msdos     #\;
#+X11     #\;
         (when (and (not (and (= col 1) (= row 1)))
                    (not (and (= col 1) (= row -1))))
         (if (> col 1) 
             (send self :do-click (- x fw) y nil nil)
             (send self :do-click (+ lw -3 (* nvar fw)) (- y fh) nil nil))))

       ((#\C-] #\C-M #\C-C #\Newline)  ;right
         (when (not (and (= col nvar) (= row nobs)))
         (if (< col nvar)
             (send self :do-click (+ x fw) y nil nil)
             (send self :do-click (+ lw 3) (+ y fh) nil nil))))
       (#\Tab ; first in next (previous if shift-tab) row
         (cond 
           ((and (> row 1) (< row nobs))
            (if m1
                (send self :do-click (+ lw 3) (- y fh) nil nil)
                (send self :do-click (+ lw 3) (+ y fh) nil nil)))
           ((and (= row 1) (not m1))
            (send self :do-click (+ lw 3) (+ y fh) nil nil))
           ((and (= row nobs) m1)
            (send self :do-click (+ lw 3) (- y fh) nil nil))))
       (
#+macintosh #\C-^ ;up
#+msdos     #\[
#+X11     #\[
         (when (or (> row 1) (= row 0))
               (send self :do-click x (- y fh) nil nil)))
       (
#+macintosh #\C-_ ;down
#+msdos     #\'
#+X11     #\'
         (when (< row nobs)
         (send self :do-click x (+ y fh) nil nil)))
        (#\C-A (send self :do-click (+ lw 3) (+ (* 2 fh) 3) nil nil)) ;home
        (#\C-D (send self :do-click (+ lw -3 (* nvar fw)) 
                    (+ 3 fh (* nobs fh)) nil nil)) ;end
        )))




;;  code to manipulate and close datasheet.

(defmeth datasheet-proto :enable-menu-items (nilt)
"Args: nilt
If nilt is t, enable items that permit changes to datasheet."
  (let ((menu (send self :menu)))
    (send (select (send menu :items) 3) :enabled nilt)
    (send (select (send menu :items) 4) :enabled nilt)
    (send (select (send menu :items) 6) :enabled nilt)
    (send (select (send menu :items) 7) :enabled nilt)))    

(defmeth datasheet-proto :close-dialog ()
"Args: ()
Dialog Box for Closing Datasheets. Returns nil if cancelled, or a list of one item: 0 for update; 1 for discard; 2 for create."
  (let* ((title (send text-item-proto :new 
                      "Options for Saving DataSheet:"))
         (choice (send choice-item-proto :new (list
                            "Update Current Dataset"
                            "Discard All DataSheet Changes"
                            "Create New Dataset")
                            :value 2))
         (ok (send modal-button-proto :new "OK"
                   :action #'(lambda ()
                               (send choice :value))))
         (cancel (send modal-button-proto :new "Cancel"))
         (dialog (send modal-dialog-proto :new
                       (list title choice (list ok cancel))
                       :default-button ok)))
    (send dialog :modal-dialog)))
           
(defmeth datasheet-proto :matrix-from-strings-matrix () 
  (let* ((dob  current-data)
         (dms  (send self :data-matrix-strings))
         (type (send self :type-strings))
         (nvar (send self :nvar))
         (nobs (send self :nobs))
         (dm   nil))
     (dotimes (i nvar)
              (cond 
                ((equal (select type i) "text")
                 (setf dm (combine dm (col dms i))))
                (t
                 (setf dm (combine dm
                     (map-elements #'number-from-string (col dms i)))))))
    (transpose (matrix (list nvar nobs) (rest dm)))))

(defmeth datasheet-proto :show-window () 
  (send (send self :data-object) :datasheet-open t)
  (call-next-method))

(defmeth datasheet-proto :set-fw-dialog () 
  (let* ((min-ncols 1)
         (tw        (send self :text-width "9"))
         (signw     (send self :text-width "-"))
         (dcimlw    (send self :text-width "."))
         (ndecimals (send self :number-of-decimals))
         (old-ncols (send self :number-of-columns))
         (new-ncols (get-value-dialog "Width of Columns:" 
                                      :initial old-ncols))
         )
    (when new-ncols 
          (when (not new-ncols) (setf new-ncols (list min-ncols)))
          (when (not (first new-ncols)) (setf new-ncols (list min-ncols)))
          (when (< (first new-ncols) min-ncols) 
                (setf new-ncols (list min-ncols)))
          (send self :field-width (+ (* tw (first new-ncols)) dcimlw signw 6))
          (send self :number-of-columns (first new-ncols))
          (send self :scroll 0 0)
          (send self :has-h-scroll 
                (max (select (screen-size) 0)
                     (+ 1 (send self :label-width) (* (send self :field-width) 
                                           (+ 1 (send self :nvar))))))
          (send self :redraw))))

(defmeth datasheet-proto :set-dec-dialog ()
  (let* ((odec (send self :number-of-decimals))
         (ndec (get-value-dialog "Number of Decimals:" 
                                 :initial odec))) 
    (when ndec
          (setf ndec (first ndec))
          (when (not ndec) (setf ndec odec))
          (when (< ndec 0) (setf ndec odec))
          (send self :number-of-decimals ndec)
          (send self :create-data-matrix-strings)
          (send self :redraw))))

(defun convert-number-from-string (str)
    (let ((result (ignore-errors (number-from-string str))))
      (when (not result) 
            (when (not (equal "?" (string-downcase str)))
                  (message-dialog 
          "A variate has non-numeric data.")
                  (error "Bad Numeric Data")))
      result))

(defmeth datasheet-proto :close ()
"Method args: ()
Closes datasheet, offering to save it, if modified."
  (when (and (send self :editable)(send self :edited))
        (let ((response (send self :close-dialog)))
          (when (not response) (return-from :close))
          (case response
            (0 (send self :save))
            (1 nil)
            (2 (send self :save-as)))))
  (let* ((data (send self :data-object))
         (graphs (send data :graphs)))
    (send data :slot-value 'graphs (remove self graphs))
    (send data :datasheet-object nil)
    (send data :datasheet-open nil))
  (call-next-method))

(defmeth datasheet-proto :enable-vista-menus&tools (args) 
"Method args: args
This is a dummy method, for compatibility with ViSta."
         nil)

(defmeth datasheet-proto :redraw ()
  (when (send self :redraw-now)
  (send self :start-buffering)
  (send self :erase-window)
  (let* ((dob (send self :data-object))
        (numvar (send self :nvar))
        (numobs (send self :nobs))
        (fw (send self :field-width))  ;datum field width
        (fh (send self :field-height)) ;datum field height
        (lw (send self :label-width))  ;label field width
        (hh nil)                       ;header field height
#+macintosh (cw-default 6)              ;character width
#-macintosh (cw-default 8)              ;character width
        (cw (if *graphics-font-size* 
                (/ (* *graphics-font-size* 2) 3)
                cw-default))
        (nchars (floor (/ fw cw)))
        (yloc nil)
        (xloc nil)
        (text nil)
        (matst (send self :data-matrix-strings))
        (types (send self :type-strings))
        (editable (send self :editable))
        (hot-cell (send self :hot-cell))
        ) 
    (setf hh (* 2 fh))
    (send self :line-type 'solid)
    (send self :draw-line  0  0 (+ lw (* numvar fw))  0)
    (send self :draw-line  0  0 0 (* (+ 2 numobs) fh))
    (send self :draw-line lw fh (+ lw (* numvar fw)) fh)
    (dotimes (i numvar)
             (send self :draw-line (+ lw (* (+ i 1) fw)) 0
                   (+ lw (* (+ i 1) fw)) hh))
    (send self :draw-line 0 0 lw hh)
    (send self :line-width 2)
    (send self :draw-line  0 hh (+ lw (* numvar fw))  hh)
    (send self :draw-line lw  0    lw (* (+ 2 numobs) fh))
    (send self :draw-line 0 (* (+ 2 numobs) fh)
          (+ lw (* numvar fw)) (* (+ 2 numobs) fh) )
    (send self :draw-line (+ lw (* numvar fw)) 0
          (+ lw (* numvar fw)) (* (+ 2 numobs) fh))
    (send self :line-width 1)
    (send self :line-type 'dashed)
    (send self :draw-text (format nil "~d Vars" numvar)
          (- lw 4) (- fh 3) 2 0)
    (send self :draw-text (format nil "~d Obs" numobs) 3 (- (* 2 fh) 3) 0 0)
    (dotimes (i (- numobs 1))
             (send self :draw-line 0 (* (+ i 3) fh) 
                   (+ lw (* numvar fw)) (* (+ i 3) fh)))
    (dotimes (i (- numvar 1))
             (send self :draw-line (+ lw (* (+ i 1) fw)) hh 
                   (+ lw (* (+ i 1) fw)) (* (+ 2 numobs) fh)))
;draw variable names and types
    (dotimes (i numvar) 
             (send self :draw-text 
                   (subseq 
                    (select (send self :variable-strings) i) 0 
                    (min (floor (/ fw cw));6
                         (length (select (send self :variable-strings) i))))
                   (+ lw (* fw i) (floor (/ fw 2))) (- fh 3) 1 0)
             (send self :draw-text 
                   (subseq 
                    (select (send self :type-strings) i) 0
                    (min (floor (/ fw cw));6
                         (length (select (send self :type-strings) i))))
                   (+ lw (* fw i) (floor (/ fw 2))) (- (* 2 fh) 3) 1 0))
;draw labels and data
    (dotimes (i numobs)
             (setf yloc (+ (* 3 fh) (- (* i fh) 3))) 
             (send self :draw-text (select (send self :label-strings) i)
                   3 yloc 0 0)
#|The following code seems to strip off characters when we don't need to
                   (subseq 
                    (select (send self :label-strings) i) 0
                    (min (floor (/ lw 6))
                         (length (select (send self :label-strings) i))))
                   3 yloc 0 0)|#
             (dotimes (j numvar)  
              (setf xloc (- (+ lw (* (+ 1 j) fw)) 3))
              (if (> (- fw cw) (send self :text-width (aref matst i j)));6
                  (send self :draw-text (aref matst i j) xloc yloc 2 0)
                  (if (equal (select types j) "variate")
                      (send self :draw-text "*****" xloc yloc 2 0)
                      (let* ((string (aref matst i j))
                             (len (length string))
                             (sel (min len nchars))
                             (substr (select string (iseq sel))))
                        (send self :draw-text substr xloc yloc 2 0))))))
    (when editable
          (send self :line-type 'solid)
          (send self :draw-line (+ lw (* fw (+ numvar 1)))  0 
                (+ lw (* fw (+ numvar 1))) fh)
          (send self :draw-line (+ lw (* fw    numvar   )) fh 
                (+ lw (* fw (+ numvar 1))) fh)
          (setf text "New Var")
          (send self :draw-text text 
                (floor (+ lw (* fw (+ numvar 0.5)))) (- fh 3) 1 0)
          (send self :draw-line 0  (* fh (+ numobs 3))
                                lw (* fh (+ numobs 3)) )
          (send self :line-width 2)
          (send self :draw-line lw (* fh (+ numobs 2)) 
                                lw (- (* fh (+ numobs 3)) 1))
          (send self :line-width 1)
          (setf text "New Obs")
          (send self :draw-text text 3 (- (* fh (+ numobs 3)) 3) 0 0)
          (when hot-cell (send self :reverse-cell-color 
                      (first hot-cell) (second hot-cell) lw fw fh 
                               (send self :hot-cell-ready)))
          )
    (send self :buffer-to-screen)
        )))


;;; the following two functions are copied from other ViSta files:

(defun column-list2 (matrix &key (list nil))
"Args: MATRIX &KEY (LIST NIL)
Column-list function which can optionally produce its output as a list of lists."
  (if list 
      (mapcar #'(lambda (x) (coerce x 'list)) (column-list matrix))
      (column-list matrix) ) )

(defun col (a i &key (list nil)) 
 "Args: (matrix column-number)
 Takes a matrix and returns the column specified by column-number. If the
 keyword argument :LIST is set to t, the row is returned as a list." 
  (select (column-list2 a :list list) i))
  
  
;;; strcat is a deprecated function used by some ViSta code; here's a definition:

(defun strcat (&rest strings)
"Args: &rest strings
Catenates the strings in args."
  (apply #'concatenate (combine 'string strings)))



;;########################################################################


;;;; some methods (and functions) for r-code2 dataset objects, to respond to ViSta messages


(defmeth dataset-proto :set-menu&tool-states (arg)
"Method args: args
This is a dummy method, for compatibility with ViSta."
         nil)

(defmeth dataset-proto :nvar ()
"Method args: ()
Returns the number of text and variate variables in an Arc dataset."
  (length (send self :types '(:text :variate))))

(defmeth dataset-proto :nobs ()
"Method args: ()
Returns the number of observations in an Arc dataset."
  (let ((datalist (first (send self :datalists))))
    (send datalist :length)))
	
(defun NAN-to-? (variable)
"Args: variable
changes all occurrences of not-a-number in variable to ?"
  (let ((new-var (copy-list variable)))
    (setf (select new-var (which (mapcar #'(lambda (x) (eq x not-a-number))
                                         new-var))) "?")
    new-var))

(defmeth dataset-proto :Vdata ()
"Method args: ()
Returns list containing all text and variate variables from Arc dataset, text variables first."
  (let* ((varlist (remove nil
                          (combine (send self :types '(:text)) 
                                   (send self :types '(:variate)))))
         (data  (send self :data varlist))
         (matrix (transpose (matrix (list (send self :nvar)(send self :nobs))
                                    (combine data)))))
    (NAN-to-? (combine matrix))))

(defmeth dataset-proto :active-data (ok-types)
"Method args: ()
Returns list containing all variables of types in ok-types from Arc dataset."
  (let* ((varlist (remove nil
                         (combine (if (member :text ok-types :test #'equal) 
                                      (send self :types '(:text)))
                                  (if (member :variate ok-types :test #'equal) 
                                      (send self :types '(:variate))))))
         (data (send self :data varlist))
         (matrix (transpose (matrix (list (length varlist) (send self :nobs))
                                    (combine data)))))
    (NAN-to-? (combine matrix))))

(defmeth dataset-proto :variables ()
"Method args: ()
Returns list of names of text and variate variables from Arc dataset, text variables first."
 (let ((text (send self :types '(:text)))
       (var  (send self :types '(:variate))))
   (remove nil (combine text var))))

(defmeth dataset-proto :Vtypes ()
  (let ((n-text (length (send self :data (send self :types '(:text)))))
        (n-var  (length (send self :data (send self :types '(:variate))))))
    (remove nil (combine (repeat "text" n-text) 
                         (repeat "variate" n-var)))))

(defmeth dataset-proto :data-matrix ()
"Method args: ()
Returns data matrix of all text and variate variables from Arc dataset, text variables first."
  (let* ((varlist (remove nil
                          (combine (send self :types '(:text)) 
                                   (send self :types '(:variate)))))
         (data  (send self :data varlist))
         (matrix (transpose (matrix (list (send self :nvar)(send self :nobs))
                                    (NAN-to-? (combine data))))))
    matrix))

(defmeth dataset-proto :Vlabels ()
"Method args: ()
Returns strings containing the case numbers from the Arc dataset, to be used as obs. labels."
  (let ((casenos (first (send self :data '("case-numbers")))))
    (mapcar #'num-to-string casenos)))

;;; slots and accessors

(send dataset-proto :add-slot 'datasheet-object)

(defmeth dataset-proto :datasheet-object (&optional (dsobj nil set))
"Method args: &optional (dsobj nil set)
Accessor for dataset-object slot."
  (if set (setf (slot-value 'datasheet-object) dsobj))
  (slot-value 'datasheet-object))

(send dataset-proto :add-slot 'datasheet-open)

(defmeth dataset-proto :datasheet-open (&optional (dsopen nil set))
"Method args: &optional (dsopen nil set)
Accessor for datasheet-open slot."
  (if set (setf (slot-value 'datasheet-open) dsopen))
  (slot-value 'datasheet-open))

(send dataset-proto :add-slot 'obs-states)

(defmeth dataset-proto :obs-states (&optional (states nil set))
"Method args: &optional (states nil set)
Accessor for obs-states slot."
  (if set (setf (slot-value 'obs-states) states))
  (slot-value 'obs-states))

(send dataset-proto :add-slot 'var-states)

(defmeth dataset-proto :var-states (&optional (states nil set))
"Method args: &optional (states nil set)
Accessor for var-states slot."
  (if set (setf (slot-value 'var-states) states))
  (slot-value 'var-states))

;; add necessary instance slots to dataset prototype
(send dataset-proto :slot-value 'instance-slots
      (combine (send dataset-proto :slot-value 'instance-slots)
               (list 'datasheet-object 'datasheet-open 'obs-states 
                     'var-states)))

;;; add to r-code dataset menu

(defmeth dataset-proto :browse-datasheet ()
"Method args: ()
Display datasheet, no edits permitted."
  (let ((ds (send self :datasheet-object)))
    (if ds (send ds :close)))
  (setf current-data self)
  (browse-data self) )  ; remove paren if next two lines appended
;;  the next two lines add the datasheet window to the list of graphs for the dataset (bugged)
;;  (let ((datasht (send self :datasheet-object)))
;;    (send self :graphs datasht)))

(rc-menu-item 'datasheet-menu-item "Show data sheet" :browse-datasheet)


(defmeth dataset-proto :edit-datasheet ()
"Method args: ()
Display datasheet, permit edits."
  (let ((ds (send self :datasheet-object)))
    (if ds (send ds :close)))
  (setf current-data self)
  (show-datasheet self) )  ; remove paren if next two lines appended
;;  the next two lines add the datasheet window to the list of graphs for the dataset (bugged)
;;  (let ((datasht (send self :datasheet-object)))
;;    (send self :graphs datasht)))

(rc-menu-item 'edit-datasheet-menu-item "Edit data sheet" :edit-datasheet)

(defparameter *arc-dataset-menu-items*
     (append  (list datasheet-menu-item edit-datasheet-menu-item)
              *arc-dataset-menu-items*))

;;; ViSta needs these globals

(def *vista* (send *object* :new))

(defmeth *vista* :show-obs () "")

(def location11 '(0 0))		; note that this is global

(setf *datasheet* nil)

;;;; the following code saves a datasheet in an r-code dataset

(defun convert-number-from-string (str)
"Args: str
Converts a number represented as a string into a number; returns nil if str contains ?"
    (let ((result (ignore-errors (number-from-string str))))
      (cond 
        (result result) 
        ((not (equal "?" str))
         (message-dialog "A variate has non-numeric data.")
         (error "Bad Numeric Data"))
        (t not-a-number))))

(defun ?-to-missing (str)
"Args: str
If str contains ?, returns NAN, else returns str."
  (if (equal str "?") not-a-number str))

(defun number-from-string (string)
"Args: STRING
Converts a number represented as a string into a number."
  (eval (read (make-string-input-stream string) nil)))
  
(defmeth datasheet-proto :save ()
"Method args: ()
Stuffs the data from the datasheet back into an Arc dataset object."
  (send self :edited nil)
  (let* ((dataset (send self :data-object))
         (name (send dataset :name))
         (data-matrix-strings (send self :data-matrix-strings))
         (var-names (send self :variable-strings))
         (types (send self :type-strings))
         (nvar (send self :nvar))
         (nobs (send self :nobs))
         (casenos (send dataset :find-datalist "Case-numbers")))
    (send casenos :data :data (iseq nobs))
    (send dataset :num-cases nobs)
    (dolist (i (iseq nvar))
            (let* ((var (select var-names i))
                   (type (select types i))
                   (rc-type (if (equal type "text") :text :variate))
                   (strings (coerce (col data-matrix-strings i) 'list))
                   (values (if (equal type "text")
                               (mapcar #'?-to-missing strings)
                               (mapcar #'convert-number-from-string strings)))
                   (datalist (send dataset :find-datalist var)))
              (if datalist
                  (send datalist :data :data values)
                  (send dataset rc-type :data values :name var))))
    (send (send arc :find-dataset name) :intern-data)))

(defmeth datasheet-proto :save-as (&optional name)
"Method args: &optional name
Creates a new Arc dataset, of name name, if supplied, from the data in the datasheet."
  (send self :edited nil)
  (let  ((data-matrix-strings (send self :data-matrix-strings))
         (var-names (send self :variable-strings))
         (types (send self :type-strings))
         (nvar (send self :nvar)))
    (arc :data
           (mapcar #'(lambda (i)
                       (let ((strings (coerce (col data-matrix-strings i)
                                              'list))
                             (type (select types i)))
                         (if (equal type "text")
                             (mapcar #'?-to-missing strings)
                             (mapcar #'convert-number-from-string strings))))
                   (iseq nvar))
           :data-names var-names :name name)))

(defun new-data ()
"Args: ()
Creates new Arc dataset object and a datasheet for the new dataset."
  (let* ((txt (send text-item-proto :new "Create New Dataset Named:"))
         (name (send edit-text-item-proto :new "NewData" :text-length 14))
         (OK   (send modal-button-proto :new "OK" :action #'(lambda () 
                    (list (send name :text)))))
         (cancel (send modal-button-proto :new "Cancel"))
         (dialog (send modal-dialog-proto :new
                       (list txt name  (list OK cancel)) 
                       :default-button OK))
         (return (send dialog :modal-dialog)))
    (when return
          (arc :data (list (list not-a-number)) :data-names '("Var0") :name (first return))
          (show-datasheet (eval (read (make-string-input-stream (first return)))))
          (let* ((dataset (eval (read-from-string (first return))))
                 (datalists (send dataset :datalists)))
            (send dataset :delete-datalist (first datalists))))))


;;; update Arc menu

(rc-menu-item 'new-data-menu-item "New Data" :new-spreadsheet)
(defmeth arc :new-spreadsheet () (new-data))
(defparameter *arc-menu-items2*
               (append  (list 'new-data-menu-item) *arc-menu-items2*))
(send (send arc :menu) :remove)   ; removes the menu from menu bar
(send arc :slot-value 'menu nil)  ; removes menu from prototype
(send arc :menu)                  ; rebuilds menu with correct items


;;; change this if the graphics font size is not set to the default (12 points)

(def *graphics-font-size* nil)