;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Title Window
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/title-window.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 08/04/92 11:49:32
;;; Last Modification By: Matthias Ressel
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; [Juergen  Tue Nov  6 11:18:31 1990] resources are mostly defined in 
;;;   initforms instead of in define-resources, so that they are inherited
;;;   much like defaults
;;; 09/12/1991 (Matthias) Changed display-title (title-window) 
;;;
;;; 10/29/1991 (Juergen) Width or height of title-windows are no longer
;;;                      adjusted when no width or height initargs are 
;;;                      specified, since they can also be initialized via 
;;;                      resources.  Automatic adjustment of window size now 
;;;                      only takes place when adjust-size? is t or size is 
;;;                      too small to show the full title.
;;;                      Note: title-window is only a mixin class and,
;;;                            anyway, use margined-windows instead!
;;;_____________________________________________________________________________

(in-package :xit)

;_______________________________________________________________________________

(defcontact title-window (adjustable-window)
  ((title :type stringable
	  :initform nil
	  :accessor title
	  :initarg :title)
   (title-font :type font
	       :reader title-font
	       :initarg :title-font))
  (:resources
    (title-font :initform '(:face :bold)))
  (:documentation "abstract class providing a window with a title bar"))

(defevent title-window :exposure)

(defmethod initialize-instance :after ((self title-window) &rest init-args)
   (with-slots (adjust-size? width height) self
    (let ((display-width (display-width self))
	  (display-height (display-height self)))
	(when (or adjust-size?
		  ;; width can be specified by resources!
		  ;(not (getf init-args :width))
		  (< width display-width))
	  (setf width display-width))
	(when (or adjust-size?
		  ;; height can be specified by resources!
		  ;(not (getf init-args :height))
		  (< height display-height))
	  (setf height display-height)))))

(defmethod y-margin ((self title-window))
  (+ (text-height (title-font self)) 2
     (inside-border self)))

(defmethod y-margins :around ((self title-window))
  (+ (text-height (title-font self)) 2
     (call-next-method)))

(defmethod display-width ((self title-window))
  (with-accessors ((font title-font) (title title)) self
    (max (if title
	     (text-width font title)
	     0)
	 (x-margins self))))

(defmethod display-height ((self title-window))
  (y-margins self))

(defmethod adjusted-window-size ((self title-window))
  (with-accessors ((font title-font) (title title)) self
    (multiple-value-bind (width height)
	(call-next-method)
      (values width (+ (inside-border self) 2 height)))))
  
(defmethod (setf title) :after (string (self title-window))
  (declare (ignore string))
  (with-slots (width height) self
    (resize-window self width height))
  (update self))

(defmethod (setf title-font) (font-spec (self title-window))
  (with-slots (width height title-font) self
    (setf title-font (convert self font-spec 'font))
    (resize-window self width height))
  (update self)
  font-spec)

(defmethod display-title ((self title-window))
  (when (realized-p self)
    (with-slots (width title title-font) self
      (using-gcontext (gc :drawable self :foreground *black-pixel*)
	(draw-rectangle-inside self gc
			0 0 width (+ (text-height title-font) 2) t))
      ;; 09/12/1991 (Matthias) changed function and foreground:
      (using-gcontext (gc :drawable self :function BOOLE-1 :font title-font
				:foreground *white-pixel*)
	(draw-glyphs self gc
		     0
		     (max-char-ascent title-font)
		     title)))))

(defmethod display ((self title-window) &optional x y width height &key)
  (declare (ignore x y width height))
  (display-title self))

;;; the following method keeps the title always visible
(defmethod resize-window :around ((self title-window) &optional width height)
   (if width
       (call-next-method self (max width
				   (display-width self))
			      (max height
				   (display-height self)))
       (call-next-method)))


;(defmethod resize-window :after ((self title-window) &optional width height)
;  (declare (ignore width height))
;  (display-title self)
;  )

;(defmethod do-adjust-window-size :after ((self title-window))
;  (display-title self)
;	   )