;;; -*- Mode:LISP; Package:LAMBDA; Readtable:ZL; Base:10 -*-

;;; Copyright LISP Machine, Inc. 1984, 1985, 1986
;;;   See filename "Copyright.Text" for
;;; licensing and release information.

;;; This here winnage, and a couple line change to LAM-GETSYL-RCH makes
;;; numeric typeout from LAM mouse sensitive.

(DEFCONSTANT *SENSITIVE-ITEM-TYPE-ALIST*
	     '((NUMBER FORCE-OBJECT-KBD-INPUT
		       "Left: shove this number. Right: Menu"
		       ("Into Kill Ring" :value FORCE-OBJECT-KILL-RING
			:documentation "put object into kill ring")
		       ("LAM Describe" :value BLIP-LAM-DESCRIBE
			:documentation "As the :DESCRIBE command")
		       ;; add _S command, etc.
		       )))

(DEFFLAVOR SENSITIVE-LISP-LISTENER
	 ()
	 (tv:notification-mixin tv:basic-mouse-sensitive-items TV:lisp-interactor)
  (:DOCUMENTATION :COMBINATION "Mouse Sensitive LISP window")
  (:DEFAULT-INIT-PLIST
    :SAVE-BITS T
    :ITEM-TYPE-ALIST *SENSITIVE-ITEM-TYPE-ALIST*))

(DEFUN RESET-ITEM-TYPE-ALIST ()
  (send *standard-output* :set-item-type-alist *SENSITIVE-ITEM-TYPE-ALIST*))

(DEFUN HANDLE-TYPEOUT-EXECUTE (BLIP STREAM)
  (FUNCALL (CADR BLIP) (CADDR BLIP) STREAM))

(DEFUN FORCE-OBJECT-KBD-INPUT (OBJECT STREAM)
  (SEND STREAM :FORCE-KBD-INPUT (FORMAT NIL "~S" OBJECT)))
    
(DEFUN FORCE-OBJECT-KILL-RING (OBJECT STREAM)
  STREAM
  (ZWEI:KILL-STRING (FORMAT NIL "~S" OBJECT)))

(DEFUN BLIP-LAM-DESCRIBE (OBJECT STREAM) STREAM
  (LET ((LAM-LAST-VALUE-TYPED OBJECT))
    (FUNCALL (GET 'DESCRIBE 'LAM-COLON-CMD) NIL)))

(DEFMETHOD (SENSITIVE-LISP-LISTENER :PRINT) (EXP DEPTH ESCAPE)
  ESCAPE
  (COND ((NUMBERP EXP)
	 (SEND SELF :ITEM 'NUMBER EXP "~S" EXP))
	('ELSE
	 (SI:PRINT-OBJECT EXP DEPTH SELF))))


;; 

;;; Mouse-left selects the blinking item, mouse-right pops up a menu near it
;;; THIS IS A MODIFIED VERSION OF (BASIC-MOUSE-SENSITIVE-ITEMS :MOUSE-CLICK)
;;; WHICH HAD A BUG THAT YOU COULD NOT SELECT THE DAMN WINDOW WITH A MOUSE CLICK!

(DEFMETHOD (SENSITIVE-LISP-LISTENER :MOUSE-CLICK) (BUTTON X Y &AUX ITEM)
  (COND ((SETQ ITEM (SEND SELF :MOUSE-SENSITIVE-ITEM X Y))
	 (LET ((ITEM-TYPE (ASSQ (TV:TYPEOUT-ITEM-TYPE ITEM) TV:ITEM-TYPE-ALIST)))
	   (WHEN ITEM-TYPE
	     (COND
	       ((EQ BUTTON #/MOUSE-1-1)
		(SEND SELF :FORCE-KBD-INPUT
		      (LIST ':TYPEOUT-EXECUTE (CADR ITEM-TYPE)
			    (TV:TYPEOUT-ITEM-ITEM ITEM)))
		T)
	       ((AND (EQ BUTTON #/MOUSE-3-1)
		     (CDDDR ITEM-TYPE))
		(PROCESS-RUN-FUNCTION "Menu Choose" #'TV:TYPEOUT-MENU-CHOOSE
				      TV:MENU (CDDDR ITEM-TYPE) ITEM SELF
				      ;; Compute a label for the menu.
				      (OR (AND (CONSP (THIRD ITEM-TYPE))
					       (CADR (THIRD ITEM-TYPE))
					       (FUNCALL (CADR (THIRD ITEM-TYPE))
							ITEM))
					  (AND (TYPEP (SECOND ITEM) 'INSTANCE)
					       (OR (SEND (SECOND ITEM) :SEND-IF-HANDLES
							 :STRING-FOR-PRINTING)
						   (SEND (SECOND ITEM) :SEND-IF-HANDLES
							 :NAME)))))
		T)
	       (T (BEEP))))))
	('ELSE
	 ;; AND HERE IS THE CODE FROM (:METHOD ESSENTIAL-MOUSE :MOUSE-CLICK)
	 ;; ARGH!!!!
	 (COND ((AND (= BUTTON #/MOUSE-1-1)
		     (NOT (SEND (SEND SELF :ALIAS-FOR-SELECTED-WINDOWS) :SELF-OR-SUBSTITUTE-SELECTED-P))
		     (OPERATION-HANDLED-P SELF :SELECT))	;paper over a bug
		(TV:MOUSE-SELECT SELF)
		T)
	       (T
		(OR (SEND SELF :SEND-IF-HANDLES
			  :FORCE-KBD-INPUT `(:MOUSE-BUTTON ,BUTTON ,SELF ,X ,Y))
		    (AND (= BUTTON #/MOUSE-3-1)
			 (TV:MOUSE-CALL-SYSTEM-MENU)
			 T)
		    (BEEP)))))))
	 

(COMPILE-FLAVOR-METHODS SENSITIVE-LISP-LISTENER)