;;; -*- Mode:Lisp; Package:HCalc; Base:8; Fonts: BIGFNT -*-
;;; (c) Copyright 1986 - Chaparral Dallas Incorporated.  All rights reserved.

;;;
;;; Define interface for Z coordinate
;;;

(Define-Input-Function Z (stream worksheet cell column row proceed-action)
		       " Z " "Set the Z coordinate."
  worksheet cell column ; not used
  (Let* ((object-name (Get-Object-Name row))
	 (db-value (Get-Slot object-name :z))
	 (old-value (if (eq db-value :undefined) 0 db-value))
	 (initial-string
	   (Fetch-Initial-Input proceed-action (format nil "~d" old-value) "0"))
	 (initial-value (Read-From-String initial-string))
	 (new-value (proceed-keypad-input
		      (format nil "Z coordinate for ~a (~d) "
			      object-name
			      old-value)
		      (if (numberp initial-value) initial-value 0)
		      stream)))
    (If (null new-value)
	(Signal-Abort)
      (Set-Slot object-name (car new-value) :z)
      (Proceed-Action-from-char (cadr new-value))))
  )

(Define-Print-Function Z (cell value string) " Z "
		       "Print the Z coordinate."
  value ; not used
  (Let ((object-name (Get-Object-Name (third (first cell))))
	(digits (Get-From-Cell cell :digits T)))
    (Unless (eq object-name :undefined)
      (if (zerop digits)
	    (Format string "~d" (Get-Slot object-name :z))
	  (Format string "~V$" digits (Get-Slot object-name :z)))))
  string)

(Define-View-Function Z (expression worksheet column row)
  expression worksheet column ; not used
  (Let ((object-name (Get-Object-Name row))
	(digits (Get-From-Cell (Access-Cell worksheet column row) :digits T)))
    (if (eq object-name :undefined)
	"Undefined"
      (if (zerop digits)
	  (Format NIL "~d" (Get-Slot object-name :z))
	(Format NIL "~V$" digits (Get-Slot object-name :z)))))
  )

;;;
;;; Define interface for Y coordinate
;;;

(Define-Input-Function Y (stream worksheet cell column row proceed-action)
		       " Y " "Set the Y coordinate."
  worksheet cell column ; not used
  (Let* ((object-name (Get-Object-Name row))
	 (db-value (Get-Slot object-name :y))
	 (old-value (if (eq db-value :undefined) 0 db-value))
	 (initial-string
	   (Fetch-Initial-Input proceed-action (format nil "~d" old-value) "0"))
	 (initial-value (Read-From-String initial-string))
	 (new-value (proceed-keypad-input
		      (format nil "Y coordinate for ~a (~d) "
			      object-name
			      old-value)
		      (if (numberp initial-value) initial-value 0)
		      stream)))
    (If (null new-value)
	(Signal-Abort)
      (Set-Slot object-name (car new-value) :y)
      (Proceed-Action-from-char (cadr new-value))))
  )

(Define-Print-Function Y (cell value string) " Y "
		       "Print the Y coordinate."
  value ; not used
  (Let ((object-name (Get-Object-Name (third (first cell))))
	(digits (Get-From-Cell cell :digits T)))
    (Unless (eq object-name :undefined)
      (if (zerop digits)
	    (Format string "~d" (Get-Slot object-name :y))
	  (Format string "~V$" digits (Get-Slot object-name :y)))))
  string)

(Define-View-Function Y (expression worksheet column row)
  expression worksheet column ; not used
  (Let ((object-name (Get-Object-Name row))
	(digits (Get-From-Cell (Access-Cell worksheet column row) :digits T)))
    (if (eq object-name :undefined)
	"Undefined"
      (if (zerop digits)
	  (Format NIL "~d" (Get-Slot object-name :y))
	(Format NIL "~V$" digits (Get-Slot object-name :y)))))
  )

;;;
;;; Define interface for X coordinate
;;;

(Define-Input-Function X (stream worksheet cell column row proceed-action)
		       " X " "Set the X coordinate."
  worksheet cell column ; not used
  (Let* ((object-name (Get-Object-Name row))
	 (db-value (Get-Slot object-name :x))
	 (old-value (if (eq db-value :undefined) 0 db-value))
	 (initial-string
	   (Fetch-Initial-Input proceed-action (format nil "~d" old-value) "0"))
	 (initial-value (Read-From-String initial-string))
	 (new-value (proceed-keypad-input
		      (format nil "X coordinate for ~a (~d) "
			      object-name
			      old-value)
		      (if (numberp initial-value) initial-value 0)
		      stream)))
    (If (null new-value)
	(Signal-Abort)
      (Set-Slot object-name (car new-value) :x)
      (Proceed-Action-from-char (cadr new-value))))
  )

(Define-Print-Function X (cell value string) " X "
		       "Print the X coordinate."
  value ; not used
  (Let ((object-name (Get-Object-Name (third (first cell))))
	(digits (Get-From-Cell cell :digits T)))
    (Unless (eq object-name :undefined)
      (if (zerop digits)
	    (Format string "~d" (Get-Slot object-name :x))
	  (Format string "~V$" digits (Get-Slot object-name :x)))))
  string)

(Define-View-Function X (expression worksheet column row)
  expression worksheet column ; not used
  (Let ((object-name (Get-Object-Name row))
	(digits (Get-From-Cell (Access-Cell worksheet column row) :digits T)))
    (if (eq object-name :undefined)
	"Undefined"
      (if (zerop digits)
	  (Format NIL "~d" (Get-Slot object-name :x))
	(Format NIL "~V$" digits (Get-Slot object-name :x)))))
  )

;;;
;;; Define interface for Shape Attribute
;;;

(DefVar *Shape-Menu-Items*
	'((" Cube " :value "Cube" :font fonts:tr18
	   :documentation "Set the shape to cube.")
	  (" Pyramid " :value "Pyramid" :font fonts:tr18
	   :documentation "Set the shape to pyramid.")
	  (" Box " :value "Box" :font fonts:tr18
	   :documentation "Set the shape to Box.")
	  (" Sphere " :value "Sphere" :font fonts:tr18
	   :documentation "Set the shape to red.")
	  (" Cone " :value "Cone" :font fonts:tr18
	   :documentation "Set the shape to red." )
	  (" Undefined " :value "Undefined" :font fonts:tr18
	   :documentation "Set the shape to be undefined." )
	  ))

(Define-Input-Function Shape (stream worksheet cell column row proceed-action)
		       " Shape " "Choose a shape."
  stream cell worksheet column proceed-action ; not used
  (Let ((object-name (Get-Object-Name row)))
    (if (eq object-name :undefined)
	(Display-Message :error "This row does not have a object name.")
      (Let ((new-shape
	      (With-Default-Help *Shape-Menu-Items*
		(With-Mouse-Position-Preserved
		  (command-menu-choose
		    *Shape-Menu-Items*
		    '(:string "Choose a Shape" :font fonts:METSI))))))
	(if (Null new-shape)
	    (Signal-Abort)
	  (Set-Slot object-name new-shape :shape)))))
    ;; return proceed type
    :none)

(Define-Print-Function Shape (cell value string)
		       " Shape " "Print cell contents as a shape."
  value ; not used
  (Let ((object-name (Get-Object-Name (third (first cell)))))
    (Unless (eq object-name :undefined)
      (format string "~a" (Get-Slot object-name :shape))))
  string)

(Define-View-Function Shape (expression worksheet column row)
  expression worksheet column ; not used
  (Let* ((object-name (Get-Object-Name row))
	 (shape (get-slot object-name :shape)))
    (format NIL "~a" shape)))

;;;
;;; Define interface for Color
;;;

(DefVar *Color-Menu-Items*
	'((" Blue " :value "Blue" :font fonts:tr18
	   :documentation "Set the color to blue.")
	  (" Green " :value "Green" :font fonts:tr18
	   :documentation "Set the color to green.")
	  (" Orange " :value "Orange" :font fonts:tr18
	   :documentation "Set the color to orange.")
	  (" Red " :value "Red" :font fonts:tr18
	   :documentation "Set the color to red.")
	  (" White " :value "White" :font fonts:tr18
	   :documentation "Set the color to red." )
	  (" Yellow " :value "Yellow" :font fonts:tr18
	   :documentation "Set the color to yellow." )
	  (" Undefined " :value "Undefined" :font fonts:tr18
	   :documentation "Set the color to be undefined." )
	  ))

(Define-Input-Function Color (stream worksheet cell column row proceed-action)
		       " Color " "Choose a color."
  stream cell worksheet column proceed-action ; not used
  (Let ((object-name (Get-Object-Name row)))
    (if (eq object-name :undefined)
	(Display-Message :error "This row does not have a object name.")
      (Let ((new-color
	      (With-Default-Help *Color-Menu-Items*
		(With-Mouse-Position-Preserved
		  (command-menu-choose
		    *Color-Menu-Items*
		    '(:string "Choose a Color" :font fonts:METSI))))))
	(if (Null new-color)
	    (Signal-Abort)
	  (Set-Slot object-name new-color :color)))))
    ;; return proceed type
    :none
  )

(Define-Print-Function Color (cell value string)
		       " Color " "Print cell contents as a color."
  value ; not used
  (Let ((object-name (Get-Object-Name (third (first cell)))))
    (Unless (eq object-name :undefined)
      (format string "~a" (Get-Slot object-name :color))))
  string)

(Define-View-Function Color (expression worksheet column row)
  expression worksheet column ; not used
  (Let* ((object-name (Get-Object-Name row))
	 (color (get-slot object-name :color)))
    (format NIL "~a" color)))

;;;
;;; Define interface for Object Name
;;;

(Define-Input-Function Object
		       (stream worksheet cell column row proceed-action)
		       " Object " "Choose a shape."
  stream worksheet cell column ; not used
  (Let* ((old-value (Get-Object-Name row))
	 new-object-name new-proceed-action)
    (Multiple-Value (new-object-name new-proceed-action)
      (Read-S-Exp "Enter New Object Name: "
		  "Error - Enter New Object Name: "
		  (Fetch-Initial-Input
		    (or proceed-action (eq old-value :undefined))
		    (format NIL "~a" old-value))))
    (do ()
	((Symbolp new-object-name)
	 (put-to-cell cell (list 'quote new-object-name) :expression))
      (Multiple-Value (new-object-name new-proceed-action)
	(Read-S-Exp
	  "Error - object name must be a symbol - Enter New Object Name: "
	  "Error - Enter New Object Name: "
	  (Fetch-Initial-Input
		    (or proceed-action (eq old-value :undefined))
		    (format NIL "~a" old-value))))
      )
    new-proceed-action)
  )

(Define-Print-Function Object (cell value string)
		       " Object " "Print cell contents as an object."
  cell ; not used
  (format string "~a" value)
  string)

(Define-View-Function Object (expression worksheet column row)
  worksheet column row ; not used
  (format NIL "~a" (eval expression))
  )

;;;
;;; Some support functions
;;;

(Defun Get-Object-Name (row)
  (Let* ((*column* 1)
	 (*row* row)
	 (cell (Access-Cell *spread-sheet* *column* *row*)))
    (if (null cell)
	:undefined
      (Or (Get-From-Cell cell :value) :undefined)))
  )

(Defun Set-Slot (part-name value slot-name)
  (PutProp part-name value slot-name))

(Defun Get-Slot (part-name slot-name)
  (Or (Get part-name slot-name) "Undefined"))














;;; Args are in view coordinates.
(Defun View-Cell (view view-column view-row)
  (Let* ((*column* (View-to-WorkSheet-Column view view-column))
	 (*row* (View-to-WorkSheet-Row view view-row))
	 (*spread-sheet* (WorkSheet-View-WorkSheet view))
	 (cell (Or (Access-Cell *spread-sheet* *column* *row*)
		   (Create-Cell *column* *row*)))
	 (expression (Or (Get-From-Cell cell :expression) :undefined))
	 (input-type (Get-From-Cell cell :input-function t))
	 (protected-string (if (eq (Get-From-Cell cell :protection t) 'yes)
			       "- Protected "
			     ""))
	 (input-name (Or (Input-Function-Print-Name input-type) input-type))
	 (view-function (Get input-type :view-function)))
    (Display-Message
      :status "Cell ~a (~a~a): ~a"
      (cell-name *column* *row*)
      input-name
      protected-string
      (cond (view-function
	     (Funcall view-function expression *spread-sheet* *column* *row*))
	    ((eq expression :undefined)
	     "Undefined")
	    ((or (eq input-type 'S-exp) (eq input-name input-type))
	     (format NIL "~s" (Form-For-Printing expression)))
	    (T (Print-Expression-for-Cell expression *column* *row*)))))
  )

(DefMacro Define-View-Function (name arglist &body body)
  `(Defun (,name :view-function) ,arglist . ,body))