;;; -*- Mode:LISP; Package:SITE-DATA-EDIT; Base:10; Readtable: CL -*- ;;; Copyright (c) Lisp Machine Inc., 1986. ;;; Mouse buttons stuff so you don't have to remember the byte constants. (defvar *mouse-button* :unbound "The mouse key that invoked this command: one of :L, :M, :R") (defconstant mouse-button-symbols #(:l :m :r) "Maps the byte field into the key") (defun mouse-key-keyword-p (thing) (and (keywordp thing) (find thing mouse-button-symbols))) (deftype mouse-key-keyword () '(satisfies mouse-key-keyword-p)) (defvar *mouse-n-clicks* :unbound "The number of mouse clicks that invoked this command: a number between one and three") (deftype mouse-click-number () '(integer 1 3)) (defmacro mousecase (&rest clauses) "The element of each clause is a condition, which consists of either of a symbol (:L, :M :R) representing the mouse button, a number representing the number of clicks, or a pair of the above, \(in which case both conditions apply) or, finally and optionally, the symbol OTHERWISE (or T)." (cons 'cond (mapcar #'(lambda (clause) (let ((thing (car clause)) (conditions '())) (flet ((parse-condition (x) (push (etypecase x (mouse-key-keyword `(eq *mouse-button* ,x)) (mouse-click-number `(eq *mouse-n-clicks* ,x))) conditions))) (cond ((member thing '(t otherwise)) (push 't conditions)) ((atom thing) (parse-condition thing)) ((and (consp thing) (= (list-length thing) 2)) (parse-condition (first thing)) (parse-condition (second thing))) (t (error "Bad condition for ~S: ~S" 'mousecase thing)))) `((and ,@conditions) . ,(cdr clause)))) clauses))) (defmacro with-mousecase ((mouse-character) &body body) `(let ((*mouse-button* (svref mouse-button-symbols (ldb tv::%%kbd-mouse-button ,mouse-character))) (*mouse-n-clicks* (+ 1 (ldb tv::%%kbd-mouse-n-clicks ,mouse-character)))) ; !!! ,@body)) ;;; These might become instance variables of the window someday. (defparameter default-font :default "Font for most data") ;;; I'd like to use tv:set-standard-font here, but it seems to be impossible to name new ;;; purposes after a screen is created ! (defparameter cue-font 'fonts:tr10i "Font for data format documentation") (defparameter attribute-font 'fonts:tr12 "Font for printing the attribute name (not value)") (defparameter unhighlighted-choice-font 'fonts:hl12 "Font for an unchosen item of a multiple-choice item") (defparameter highlighted-choice-font 'fonts:hl12b "Font for a chosen item of a multiple-choice item") (defun object-editor-font-map () (list default-font ;; this should be first, others are fairly arbritrary cue-font attribute-font unhighlighted-choice-font highlighted-choice-font)) (defflavor object-editor-window ((object nil) (deleted-attributes nil) (changed-attributes nil)) ; Also contains new attributes (tv:function-text-scroll-window tv:mouse-sensitive-text-scroll-window ; tv:text-scroll-window-typeout-mixin tv:text-scroll-window tv:borders-mixin tv:top-label-mixin tv:flashy-scrolling-mixin tv:basic-scroll-bar tv:margin-scroll-mixin tv:margin-region-mixin tv:scroll-stuff-on-off-mixin tv:dont-select-with-mouse-mixin tv:window) (:default-init-plist :label '(:string "Empty" :centered) :blinker-p t :blinker-deselected-visibility :off :blinker-flavor 'tv:rectangular-blinker :deexposed-typeout-action :permit :flashy-scrolling-region '((20 0.30 0.70) (20 0.30 0.70)) :margin-scroll-regions '((:top) (:bottom)) :scroll-bar-always-displayed t :font-map (object-editor-font-map) :print-function 'print-data-line) ; see ATTRIBUTE (:gettable-instance-variables object) (:documentation "A flavor of window designed to edit attributes. Incorporates everything needed for scroll items.")) (defmethod (object-editor-window :set-object) (new-object) "Set the objected edited to NEW-OBJECT, resetting the attribute edit history. Any changes must be checked beforehand by the program." (setq object new-object changed-attributes () deleted-attributes ()) (if object (send self :set-items (send object :editor-attributes)) (send self :delete-all-items)) (send self :update-edit-label)) (defmethod (object-editor-window :set-edit-label) (string) (send self :set-label `(:centered :string ,string))) (defmethod (object-editor-window :update-edit-label) () (send self :set-edit-label (if object (string-append "Editing " (send object :name-for-editor)) "Empty"))) (defmethod (object-editor-window :adjustable-size-p) () nil) (defmethod (object-editor-window :enable-scrolling-p) () tv::scroll-bar-always-displayed) (defmethod (object-editor-window :delete-all-items) (&optional (index 0)) (do ((max (array-leader items 0) (1- max))) ((< max index) nil) (send self :delete-item max))) ;;; There should be a standard function/message to get the item the mouse is pointing at. ;;; I had to look at the CHOOSE-VARIABLE-VALUES stuff to get this code. (defmethod (object-editor-window :who-line-documentation-string) () (multiple-value-bind (window-x-offset window-y-offset) (sheet-calculate-offsets self mouse-sheet) (let ((x (- tv::mouse-x window-x-offset)) (y (- tv::mouse-y window-y-offset))) (multiple-value-bind (value type) (send self :mouse-sensitive-item x y) (when type (typecase value ; don't signal error here ! (cons (send (car value) :documentation-string type)) (instance (send value :documentation-string type)) (t "Click left to change to a new value"))))))) (defvar *window* :unbound "The window in which the object is being edited.") (defmacro catching-aborted-edit (&body body) "Catch all calls to ABORT-EDIT within BODY" `(catch 'abort-edit ,@body)) (defun abort-edit () "Call this to abort an edit." (throw 'abort-edit nil)) ;;; This is the main message. Command loops should send edit blips here. (defmethod (object-editor-window :edit-object) (type item mouse-character) (catch 'abort-edit (let ((*window* self)) (with-mousecase (mouse-character) (multiple-value-bind (item note-p) (if (eq type 'attribute) ; returns different item than forms below (send item :edit 'attribute) ; will return correct value (values (etypecase item (instance ; Just the attribute; :EDIT it. (send item :edit type) item) (cons ; The real attribute and some other information as arguments (lexpr-send (car item) :edit type (cdr item)) (car item))) t)) ; Normal edit, so note item as changed (when item (send self :edit-redisplay item) (when note-p (send self :note-changed-attribute item)))))))) (defmethod (object-editor-window :edit-redisplay) (thing) "Redisplay THING in the window." (let ((screen-index (- (if (numberp thing) thing (send self :number-of-item thing)) top-item))) (send self :redisplay screen-index (+ screen-index 1)))) (defun last-deleted-multiple-attribute-p (a) (and (send a :multiple-p) (send a :void-p))) (defmethod (object-editor-window :changed-attributes) () ;; The really changed ones don't include multiple-type attributes that set void by a delete ;; command, but then had to remain displayed because it was at least one attribute of that ;; type had to remain in the edit window. (subset-not #'last-deleted-multiple-attribute-p changed-attributes)) (defmethod (object-editor-window :deleted-attributes) () (union deleted-attributes ;; Get the attributes that are deleted, but need to be in the changed list. (subset #'last-deleted-multiple-attribute-p changed-attributes))) (defmethod (object-editor-window :note-changed-attribute) (attribute) (pushnew attribute changed-attributes)) (defmethod (object-editor-window :note-deleted-attribute) (attribute) (unless (send attribute :new-p) (pushnew attribute deleted-attributes)) ; don't need to note unless old (setq changed-attributes (delq attribute changed-attributes))) (defmethod (object-editor-window :note-reverted-attribute) (attribute) ;; Can't revert new attributes, so we don't need to check. (setq changed-attributes (delq attribute changed-attributes))) (defun editor-window-changed-object (object-editor-window) (declare (values changed-object)) (let ((changed-object (send object-editor-window :object))) (and changed-object (or (send object-editor-window :deleted-attributes) (send object-editor-window :changed-attributes)) changed-object))) (defvar *auto-test-refresh* t) ;;; A simple test method. Only understands attribute-editing blips. (defmethod (object-editor-window :test-blip) () (let ((thing (send self :list-tyi))) (send (third thing) :edit-object (first thing) (second thing) (fourth thing)) (when *auto-test-refresh* (send self :refresh)))) ;;; A useful test loop. (defmethod (object-editor-window :loop) () (with-selection-substitute (*terminal-io* self) (loop (send self :test-blip)))) (compile-flavor-methods object-editor-window)