;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (c) 1993 by William M. Perry (wmperry@indiana.edu)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Enhancements For Lucid Emacs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require 'w3)
(defvar w3-links-menu nil "Menu for w3-mode in lemacs")
(make-variable-buffer-local 'w3-links-menu)

(defvar w3-popup-menu '("WWW Browser"
			["Open Local File" w3-open-local t]
			["Open URL" w3-fetch t]
			["View Current Url" w3-view-url t]
			["View Url At Point" w3-view-this-url t]
			"-----------"
			["Document Source" w3-document-source t]
			["Edit Document Source" w3-find-this-file t]
			["Reload Document" w3-reload-document t]
			["Mail Formatted" w3-mail-current-document t]
			["Print Document" w3-print-this-url t]
			["Print Url Under Point" w3-print-url-under-point t]
			["Submit Bug Report" w3-submit-bug t]
			"-----------"
			("Group Annotations"
			 ["Add Annotation" w3-add-group-annotation t]
			 ["Edit Annotation" w3-edit-group-annotation nil]
			 ["Delete Annotation" w3-delete-group-annotation nil])
			("Personal Annotations"
			 ["Add Annotation" w3-add-personal-annotation t]
			 ["Edit Annotation" w3-edit-personal-annotation nil]
			 ["Delete Annotation" w3-delete-personal-annotation nil]))
  "Popup menu for lucid emacs")

(defvar w3-menu nil "*Emacs menu for current buffer")

(defvar w3-tt-style 'w3-tt-style "Face used for fixed-width text")
(defvar w3-bold-style 'w3-bold-style "Face used for bold text")
(defvar w3-italic-style 'w3-italic-style "Face used for italicized text")
(defvar w3-underline-style 'w3-underline-style "Face used for underlined text")
(defvar w3-node-style 'w3-node-style "Face used for hypertext links")
(defvar w3-header-style 'w3-header-style "Face used for all headers")
(defvar w3-address-style 'w3-address-style "Face used for address tags")
(defvar w3-default-style 'w3-default-style "Face used for all text")

(make-variable-buffer-local 'w3-menu)
(if (not (find-face w3-header-style))
    (progn
      (make-face w3-default-style)
      (make-face w3-header-style)
      (make-face w3-bold-style)
      (make-face w3-italic-style)
      (make-face w3-underline-style)
      (make-face w3-node-style)
      (make-face w3-address-style)
      (make-face w3-tt-style)))
(if (not (face-differs-from-default-p w3-header-style))
    (copy-face 'bold-italic w3-header-style))
(if (not (face-differs-from-default-p w3-node-style))
    (copy-face 'bold w3-node-style))
(if (not (face-differs-from-default-p w3-address-style))
    (copy-face 'italic w3-address-style))
(if (not (face-differs-from-default-p w3-bold-style))
    (copy-face 'bold w3-bold-style))
(if (not (face-differs-from-default-p w3-italic-style))
    (copy-face 'italic w3-italic-style))
(if (not (face-differs-from-default-p w3-tt-style))
    (copy-face 'default w3-tt-style))
(if (not (face-differs-from-default-p w3-underline-style))
    (set-face-underline-p w3-underline-style t))

(defun w3-zone-end (zone)
  (extent-end-position zone))

(defun w3-zone-start (zone)
  (extent-start-position zone))

(defun w3-add-hotlist-menu ()
  (if (eq major-mode 'w3-mode)
      (let ((hot-menu nil)
	    (hot w3-hotlist))
	(while hot
	  (setq hot-menu (cons (vector (car (car hot))
				       (list 'w3-fetch (car (cdr (car hot))))
				       t) hot-menu)
		hot (cdr hot)))
	(add-menu '("WWW") "Hotlist" hot-menu))))

(defun w3-find-link-helper (extent link)
  "Is EXTENT the one with LINK as the name?"
  (let ((data (extent-data extent)))
    (if (equal link (car-safe (cdr data)))
	(goto-char (extent-start-position extent))
      nil)))

(defun w3-find-specific-link (link)
  "Find LINK in the current document"
  (map-extents 'w3-find-link-helper (current-buffer) (point-min) (point-max)
	       link))

(defun w3-forward-link ()
  (interactive)
  (if (extent-at (point))
      (goto-char (extent-start-position (next-extent (extent-at (point)))))
    (while (not (extent-at (point)))
      (forward-char 1)))
  (while (and
	  (equal (car-safe (extent-data (extent-at (point)))) 'w3)
	  (memq (cdr (extent-data (extent-at (point))))
		'(style address header)))
    (goto-char (extent-end-position (next-extent (extent-at (point)))))))

(defun w3-previous-extent (xt)
  (save-excursion
    (goto-char (1- (extent-start-position xt)))
    (while (and (not (extent-at (point)))
		(not (= (point) (point-min))))
      (backward-char 1))
    (if (not (extent-at (point))) nil
      (extent-at (point)))))

(defun w3-back-link ()
  (interactive)
  (if (extent-at (point))
      (goto-char (extent-start-position
		  (w3-previous-extent (extent-at (point))))))
  (while (or
	  (not (equal (car-safe (extent-data (extent-at (point)))) 'w3))
	  (memq (cdr (extent-data (extent-at (point))))
		'(header address)))
    (if (w3-previous-extent (extent-at (point)))
	(goto-char (extent-start-position (w3-previous-extent
					   (extent-at (point)))))
      (error "No previous link."))))

(defun w3-add-zone (start end style data)
  "Add highlighting (lucid)"
  (let ((ext (make-extent start end)))
    (set-extent-face ext style)
    (set-extent-data ext data)))

(defun w3-follow-mouse (e)
  (interactive "e")
  (mouse-set-point e)
  (w3-follow-link))

(defun w3-follow-link ()
  "Attempt to follow the link under the cursor" 
  (interactive)
  (if (extent-at (point))
      (let ((data (extent-data (extent-at (point)))))
	(if (and (equal (car-safe data) 'w3)
		 (not (memq (car (cdr data))
			    '(style address header))))
	    (w3-maybe-relative (car (cdr (cdr data))))
	  (message "Not on a link!")))))

(defun w3-view-this-url (&optional no-show)
  (interactive)
  (if (extent-at (point))
      (let ((data (extent-data (extent-at (point)))))
	(if (and (equal (car data) 'w3)
		 (not (memq (car (cdr data))
			    '(style address header))))
	    (if (not no-show)
		(message "%s" (car (cdr (cdr data))))
	      (car (cdr (cdr data))))
	  (error "Not on a link!")))))

(define-key w3-mode-map 'button2 'w3-follow-mouse)
(define-key w3-mode-map 'button3 'w3-popup-menu)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Functions to build menus of urls
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun w3-build-lemacs-menu ()
  "Build lemacs menus from w3-links-list"
  (let* ((hot w3-hotlist)
	 (hot-menu nil))
    (map-extents 'w3-build-links-helper)
    (setq w3-links-menu (cons "Links" w3-links-menu))
    (while hot
      (setq hot-menu
	    (cons (vector (car (car hot))
			  (list 'w3-maybe-relative (car (cdr (car hot))))
			  t) hot-menu))
      (setq hot (cdr hot)))
    (setq hot-menu (cons "Hotlist" hot-menu))
    (set-buffer-menubar (copy-sequence current-menubar))
    (add-menu nil "WWW" (append
			 (cdr w3-popup-menu)
			 (list "-------" hot-menu w3-links-menu)))))

(defun w3-build-links-helper (extent maparg)
  "Build a list of links using map-extents for lucid"
  (let ((data (extent-data extent)))
    (if (and (eq (car-safe data) 'w3)
	     (not (memq (cdr-safe data) '(header address style))))
	(setq w3-links-menu
	      (append w3-links-menu
		      (list
		       (vector (format "%s[%s]"
				       (car (cdr (cdr (cdr data))))
				       (car (cdr data)))
			       (list 'w3-maybe-relative
				     (car (cdr (cdr data)))) t))))))
  nil)

(defun w3-popup-menu (e)
  "Pop up a menu of common w3 commands"
  (interactive "e")
  (mouse-set-point e)
  (popup-menu w3-popup-menu))

(defvar w3-emphasis-style w3-italic-style)
(defvar w3-strong-style w3-bold-style)
(defvar w3-code-style w3-tt-style)
(defvar w3-samp-style w3-tt-style)
(defvar w3-kbd-style w3-tt-style)
(defvar w3-var-style w3-tt-style)
(defvar w3-dfn-style w3-bold-style)
(defvar w3-cite-style w3-underline-style)

(provide 'w3-lucid)
