;;; -*- package:tv; mode:lisp; base:10.; patch-file:t; -*- ;;;
;;; $Header: /ct/window/menufix.l,v 1.2 84/03/22 08:40:43 john Exp $
;;; $Log:	/ct/window/menufix.l,v $
;;;Revision 1.2  84/03/22  08:40:43  john
;;;Tried to repair loss of (aref to the font-map)
;;;
;;;Revision 1.1  83/07/20  10:24:09  john
;;;Initial revision
;;;
;;;

;;;  John Shelton's patches to menu mouse-moves.  The code here causes menu
;;; items to be boxed in correctly, regardless of font.
;;;  Copyright (C) 1983, Computer Thought Corporation.

#-LMI
;;; This is the guts.  Given a menu and a set of coordinates, it finds
;;; the corresponding item, if any, sets CURRENT-ITEM to it, and sets up
;;; the blinker to mark that item.  If no item, the blinker is shut off.
;;;*** This tvobish code should be rewritten ***
(DEFMETHOD (BASIC-MENU :MOUSE-MOVES) (X Y
				      &AUX ITEM ITEMS ROW XREL BLINKER BLX (BLWIDTH 0)
				           COLN STOP-ITEM
					   (FILL-P (GEOMETRY-FILL-P GEOMETRY)))
  (MOUSE-SET-BLINKER-CURSORPOS)
  (SETQ ROW (// (- Y (SHEET-INSIDE-TOP)) ROW-HEIGHT)
	XREL (- X (SHEET-INSIDE-LEFT))
	BLINKER (CAR BLINKER-LIST))
  (COND ((AND ( XREL 0)	;If inside the menu
	      (< X (SHEET-INSIDE-RIGHT))
	      ( Y (SHEET-INSIDE-TOP))
	      (< Y (SHEET-INSIDE-BOTTOM)))
	 ;;If mouse is past the last displayed row, blink item on that row.
	 (AND (OR (>= (+ TOP-ROW ROW) TOTAL-ROWS) (>= ROW SCREEN-ROWS))
	      (SETQ ROW (1- (MIN SCREEN-ROWS (- TOTAL-ROWS TOP-ROW)))))
	 (IF (MINUSP ROW) (SETQ ITEMS NIL STOP-ITEM NIL)	;No items visible
	     (SETQ ITEMS (AREF ROW-MAP (+ TOP-ROW ROW))
		   STOP-ITEM (AREF ROW-MAP (+ TOP-ROW ROW 1))))
	 (COND (FILL-P				;Fill mode, cogitate
		(SETQ BLX 0)
		(DO ((L ITEMS (CDR L))
		     (ITM) (OITM NIL ITM)
		     (X 0 (+ X
			     (SETQ BLWIDTH (MENU-ITEM-STRING-WIDTH ITM))
			     MENU-INTERWORD-SPACING)))
		    ((OR (NULL L)
			 (> X XREL))	    ;If this string crosses the mouse, it's the one
		     (SETQ ITEM OITM
			   BLX (1- BLX)
			   BLWIDTH (+ BLWIDTH 1)))
		  (AND (EQ L STOP-ITEM)
		       ;; The next item on next line -- punt
		       (RETURN NIL))
		  (SETQ ITM (CAR L)
			BLX X)))
	       (T				;Columnated, find which column
		(SETQ COLN (// XREL COLUMN-WIDTH))	;Column selected
		(SETQ ITEM (CAR (NTHCDR COLN ITEMS)))	;This may be NIL
		(SETQ BLWIDTH (1+ (MENU-ITEM-STRING-WIDTH ITEM COLUMN-WIDTH)))
		(SETQ BLX (+ (* COLN COLUMN-WIDTH)	;Start of column
			     -1
			     (MAX 0 (// (- COLUMN-WIDTH	;Centering
					   MENU-INTERCOLUMN-SPACING
					   BLWIDTH)
					2))))))))
  ;; If this item is non-selectable, don't select it.
  (AND (NOT (ATOM ITEM)) (NOT (ATOM (CDR ITEM))) (NOT (ATOM (CDDR ITEM)))
       (EQ (CADR ITEM) ':NO-SELECT)
       (SETQ ITEM NIL))
  ;; Now make the blinker be where and what we have just found it should be.
  (BLINKER-SET-VISIBILITY BLINKER (NOT (NULL ITEM)))
  (SETQ CURRENT-ITEM ITEM)
  ;;  Following are the only changes to this definition.  The height of the
  ;; blinker (box) is changed to be the height of the item (plus on pixel on
  ;; each side).  The Y location is (* row row-height) like it used to be, 
  ;; PLUS A FUDGE FACTOR, which is never negative.  The fudge factor takes into
  ;; account the difference in height of the font on this item and the row-height
  ;; which is actually the height of the largest font in the menu, plus a little
  ;; bit more.  Little bit more is one-fifth of the row height, which was randomly
  ;; chosen to work on many menus.
  (COND (ITEM
	 (FUNCALL BLINKER ':SET-SIZE-AND-CURSORPOS 
		  BLWIDTH (+ (johns-font-char-height item font-map)
			     2)
		  BLX (1- (+ (* ROW ROW-HEIGHT) (- (send self ':vsp))
			     (max 0 
				  (- row-height ;;
				     (johns-font-baseline item font-map)
				     (// row-height 6)
				     ))))))))


#-LMI
;;;  This returns the font-char-height of the font used for a menu item.
;;; We look at the item to see if it has a font property, and if so, examine
;;; that font.  If not, we use the default font for this menu.
(defun johns-font-char-height (item font-map)
  (FONT-CHAR-HEIGHT
    (if (and (listp item)
	     (listp (cdr item))
	     (get (cddr item) ':FONT))
	(if (symbolp (get (cddr item) ':font))
	    (symeval (get (cddr item) ':FONT))
	    (get (cddr item) ':font))
	(AREF FONT-MAP 0))))

;;;the trailing parens were missing from this function!!!!!  -- jrm, 3/18/84
#-LMI
(defun johns-font-baseline (item font-map)
  (FONT-BASELINE
    (if (and (listp item)
	     (listp (cdr item))
	     (get (cddr item) ':FONT))
	(if (symbolp (get (cddr item) ':font))
	    (symeval (get (cddr item) ':FONT))
	    (get (cddr item) ':font))
	(aref font-map 0))))