;;; puframe.el --- popup frame near cursor position

;; Copyright (C) 1998 KITAJIMA Akira.

;; Author: KITAJIMA Akira <kitajima@ics.es.osaka-u.ac.jp
;; Create: 1998/06/25(Thu)
;; Version: 0
;; Keyword: frame

;; $Id$

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Code:

(defun puframe-record-original-frame ()
  (setq puframe-original-frame (selected-frame)))

;;;
;;; special display
;;;

(defvar puframe-special-frame-max-height 20)

(defun puframe-popup-special-display-frame (frame)
  (when (boundp 'puframe-making-frame)
    (setq puframe-making-frame t)
    (setq puframe-special-frame frame)))

(defun puframe-special-display-initialize ()
  (add-hook 'pre-command-hook 'puframe-record-original-frame)
  (add-hook 'after-make-frame-functions 'puframe-popup-special-display-frame)

  (defadvice special-display-popup-frame (around make-frame-flag activate)
    "make flag"
    (let ((special-display-frame-alist
	   (cons '(visibility) special-display-frame-alist))
	  puframe-making-frame)
      ad-do-it
      (let ((height (save-excursion
		      (select-frame puframe-special-frame)
		      (set-buffer (window-buffer (frame-selected-window)))
		      (1+ (count-lines (point-min) (point-max))))))
	(set-frame-height puframe-special-frame
			  (min height puframe-special-frame-max-height))
	(if puframe-making-frame
	    (puframe-float-frame puframe-special-frame
				 puframe-original-frame))
	(make-frame-visible puframe-special-frame)))))

;;;
;;; minibuffer
;;;

(defun puframe-minibuffer-setup ()
  (puframe-float-frame default-minibuffer-frame
		       puframe-original-frame)
  (setq puframe-original-frame (select-frame default-minibuffer-frame)))

(defun puframe-minibuffer-restore ()
  (set-frame-position default-minibuffer-frame
		      (car minibuffer-frame-default-position)
		      (cdr minibuffer-frame-default-position)))

(defun puframe-minibuffer-initialize ()
  ;; make frames to use minibuffer frame
  (let ((mb (assq 'minibuffer default-frame-alist)))
    (if mb
	(setcdr mb nil)
      (setq default-frame-alist
	    (cons '(minibuffer) default-frame-alist))))
  (unless (boundp 'minibuffer-frame-default-position)
    (let ((left (cdr (assq 'left minibuffer-frame-alist)))
	  (top (cdr (assq 'top minibuffer-frame-alist))))
      (defvar minibuffer-frame-default-position
	(cons (or left 1) (or top 1)))))
  (setq minibuffer-auto-raise t
	resize-minibuffer-frame t)

  ;; setup hooks properly
  (add-hook 'pre-command-hook 'puframe-record-original-frame)
  (add-hook 'minibuffer-setup-hook 'puframe-minibuffer-setup)
  (add-hook 'minibuffer-exit-hook 'puframe-minibuffer-restore))

;;;
;;; floating frame
;;;

(defvar puframe-float-frame-offset-x 2)
(defvar puframe-float-frame-offset-y (frame-char-height))

(defconst puframe-display-pixel-height
  (if (eq window-system 'x)
      (x-display-pixel-height)
    10000))
(defconst puframe-display-pixel-width
  (if (eq window-system 'x)
      (x-display-pixel-width)
    10000))

(defvar puframe-border-adjust-border 1
  "*Adjustment for border width of the window manager")
(defvar puframe-border-adjust-top 24
  "*Adjustment for titlebar height of the window manager")


(defun puframe-get-vertical-cursor-position-in-window (window)
  "GET vertical cursor position of WINDOW."
  (save-excursion
    (select-window window)
    (let ((point (point))
	  (l 0))
      (goto-char (window-start))
      (while (< (point) point)
	(forward-line 1)
	(setq l (1+ l)))
      (if (= (point) point)
	  (1+ l)
	l))))


(defun puframe-get-vertical-cursor-position (window &optional frame)
  "Get vertical cursor position of WINDOW in FRAME."
  (if frame
      (select-frame frame))
  (let* ((start-window (frame-first-window))
	 (current-window start-window)
	 (height (if (/= (window-width current-window)
			 (frame-width frame))
		     1
		   (1+ (window-height current-window))))
	 (horizontal-splitted-window
	  (if (= (window-width current-window)
		 (frame-width frame))
	      0
	    1)))
    (if (eq window current-window)
	(puframe-get-vertical-cursor-position-in-window current-window)
      (catch 'finished
	(while (not (eq (setq current-window
			      (next-window current-window))
			start-window))
	  (if (eq window current-window)
	      (throw 'finished
		     (+ height
			(puframe-get-vertical-cursor-position-in-window
			 current-window)
			-1))
	    ;; window not found
	    (if (/= (window-width current-window)
		    (frame-width frame))
		;; horizontally splitted window
		(cond ((= horizontal-splitted-window 0)
		       ;; first time
		       (setq horizontal-splitted-window
			     (1+ horizontal-splitted-window)))
		      ((= horizontal-splitted-window 1)
		       (setq height
			     (+ height (window-height current-window))
			     horizontal-splitted-window
			     (1+ horizontal-splitted-window)))
		      (t
		       (throw 'finished (frame-height frame)))) ; give up
	      (setq height
		    (+ height (window-height current-window))))))))))


(defun puframe-cursor-position (frame)
  "Get cursor position of FRAME."
  (let* ((frame-param (frame-parameters frame))
	 (frame-left (eval (cdr (assq 'left frame-param))))
	 (frame-top (eval (cdr (assq 'top frame-param))))
	 (cursor-x 0)			; not yet implemented
	 (cursor-y (1+ (puframe-get-vertical-cursor-position
			(frame-selected-window frame)
			frame))))
    (cons (+ frame-left (* (frame-char-width frame) cursor-x))
	  (+ frame-top (* (frame-char-height frame) cursor-y)))))


(defun puframe-place-frame-inside-display (&optional frame left top)
  "Place FRAME to inside the display.
If specify (LEFT, TOP), place FRAME at that point as long as the FRAME is
inside the display."
  (interactive)
  (let* ((frame-param (frame-parameters frame))
	 (max-left (- puframe-display-pixel-width
		      (frame-pixel-width frame)
		      puframe-border-adjust-border))
	 (max-top (- puframe-display-pixel-height
		     (frame-pixel-height frame)
		     puframe-border-adjust-top)))
    (or left
	(setq left (eval (cdr (assq 'left frame-param)))))
    (or top
	(setq top (eval (cdr (assq 'top frame-param)))))
    (set-frame-position (or frame
			    (selected-frame))
			(max 0 (min (+ left puframe-border-adjust-border)
				    max-left))
			(max 0 (min (+ top puframe-border-adjust-border)
				    max-top)))))


(defun puframe-float-frame (frame orig-frame)
  "Place FRAME to near cursor position on ORIG-FRAME."
  (let* ((cursor-position (puframe-cursor-position orig-frame))
	 (frame-x (+ (car cursor-position)
		     puframe-float-frame-offset-x))
	 (frame-y (+ (cdr cursor-position)
		     puframe-float-frame-offset-y)))
    (puframe-place-frame-inside-display frame frame-x frame-y)))

;;;
;;; Utilities
;;;

(defun puframe-make-special-frame-invisible ()
  (interactive)
  (and (boundp 'puframe-special-frame)
       (frame-live-p puframe-special-frame)
       (make-frame-invisible puframe-special-frame)))

;(global-set-key [?\C-z ?\C-s ?\C-i] 'puframe-make-special-frame-invisible)

(defun puframe-goto-special-frame ()
  (interactive)
  (and (boundp 'puframe-special-frame)
       (frame-live-p puframe-special-frame)
       (progn
	 (let ((orig-frame (selected-frame)))
	   (raise-frame puframe-special-frame)
	   (select-frame puframe-special-frame)
	   (make-frame-invisible orig-frame)
	   (make-frame-visible orig-frame)))))

;(global-set-key [?\C-z ?\C-s ?\C-s] 'puframe-goto-special-frame)

(provide 'puframe)

;;; puframe.el ends here