;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: General
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/general.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 06/11/92 09:11:26
;;; Last Modification By: Hubertus Hohl
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 05/27/1991 (Hubertus) added support for `busy cursors' and 
;;;                       percent-done indicators.
;;; 07/18/1991 (Matthias) fixed bug in find-pixmap
;;; 08/06/1991 (Matthias) New macro: (ignoring-errors <form>)
;;; 09/16/1991 (Matthias) New func: (query-string <string> ...)
;;; 10/02/1991 (Hubertus) New func: CONVERT-TO-FUNCTION may be used to coerce
;;;                       symbols that name functions or lambda-expressions to
;;;                       function objects. The global variable  
;;;                       *compile-lambda-expression* controls whether 
;;;                       lambda-expressions given to CONVERT-TO-FUNCTION
;;;                       should be compiled.
;;; 10/24/1991 (Hubertus) New macros: MAXF, MINF
;;; 10/25/1991 (Hubertus) Added DRAW-RECTANGLE-INSIDE, that works like 
;;;                       DRAW-RECTANGLE, except that the outline is completely 
;;;                       contained in the region specified by x, y, width, and 
;;;                       height.
;;;                       Removed buggy function FAST-DRAW-RECTANGLE. Use
;;;                       DRAW-RECTANGLE-INSIDE instead. However, note that this 
;;;                       function has different semantics regarding width and 
;;;                       height.
;;;
;;; 10/29/1991 (Juergen)  Added function find-file (originally defined in file
;;;                       sounds), which determines the full path of a file, 
;;;                       given the file name, a set of directories to be
;;;                       searched, and a set of possible file extensions.
;;;
;;; 11/22/1991 (Juergen)  The function query-x-server-host now provides a
;;;                       default which is the name of the host taken from the
;;;                       DISPLAY environment variable. 
;;;
;;; 12/03/1991 (Hubertus) Added DRAW-ROUNDED-RECTANGLE-INSIDE.
;;; 
;;; 12/19/1991 (Juergen) New functions display-variable and host-variable which
;;;                      access the respective environment variables
;;; 
;;;_____________________________________________________________________________

(in-package :xit)


;_____________________________________________________________________________
;
;                         DISPLAY and HOST access
;_____________________________________________________________________________

(defun display-variable ()
  #+excl  (system:getenv "DISPLAY")
  #+lucid (lcl:environment-variable "DISPLAY")
  #-(or lucid excl) nil
  )

(defun host-variable ()
  #+excl  (system:getenv "HOST")
  #+lucid (lcl:environment-variable "HOST")
  #-(or lucid excl) nil
  )


;______________________________________________________________________________
;
;                     Masks = Pixmaps of depth 1
;______________________________________________________________________________

(defparameter *shading-image* 50%GRAY)
;;; 11/22/1990 (Matthias) *shading-bitmap* is obsolete
(defparameter *shading-bitmap* *shading-image*
  "Maybe obsolete in the near future. Use *shading-image* instead.")

(defun find-pixmap (contact image) 
  (let ((drawable (if (realized-p contact) contact (contact-root contact))))
    (cond
     ((= (image-depth image) (contact-depth drawable))
   	  (contact-image-pixmap drawable image))
     ((= (image-depth image) 1)
      (contact-image-mask drawable image)))))

;;; 11/22/1990 (Matthias) convert (bitmap) image to (mask-)pixmap:
;;; clue::convert-image-mask does not work because it needs a contact
;;; of the given depth

(defun find-simple-mask (contact bitmap-image)
  (let* ((drawable (if (realized-p contact) contact (contact-root contact)))
	 (mask (create-pixmap :width (image-width bitmap-image)
			      :height (image-height bitmap-image)
			      :drawable drawable
			      :depth 1)))
    (using-gcontext (gc :drawable mask)
       (put-image mask gc bitmap-image :x 0 :y 0))
    mask))

;;; 11/23/1990 (Matthias)  depth defaults to contacts depth

(defun find-mask (contact bitmap-image foreground background)
  (let ((drawable (if (realized-p contact) contact (contact-root contact))))
     (contact-image-mask drawable bitmap-image :foreground foreground
			:background background)))

;_______________________________________________________________________________
;
;                               Gray pattern				       
;_______________________________________________________________________________

(defparameter *gray-tab*
    (list cluei::0%gray  cluei::6%gray  cluei::12%gray cluei::12%gray
       cluei::25%gray cluei::25%gray cluei::37%gray cluei::37%gray
       cluei::50%gray cluei::50%gray cluei::62%gray cluei::62%gray
       cluei::75%gray cluei::75%gray cluei::88%gray cluei::93%gray
       cluei::100%gray))

(defparameter *gray-steps* 16)

(defun get-gray-image (ratio)
  (declare (special *gray-tab* *gray-steps*))
  (let ((gray (nth  (round (* ratio *gray-steps*)) *gray-tab*)))
    ;; was(and gray (boundp gray) (symbol-value gray))
    gray))

		       
;;;_______________________________________
;;;
;;; Retrieving the pointer source-window
;;;_______________________________________

(defun query-pointer-source-window (&optional (window *root*))
  "Returns the subwindow of window, the pointer is actually in (the source window)."
  (declare (special *root*))
  (query-pointer-most-specific window))

(defmethod query-pointer-most-specific ((window window))
  (multiple-value-bind (x y same-screen-p child)
      (query-pointer window)
    (declare (ignore x y same-screen-p))
    (if child
	(query-pointer-most-specific child)
	window)))

(defmethod find-super-window ((window window) test
			&optional (top-window (contact-root window)))
  nil)

(defmethod find-super-window ((window basic-contact) test
			&optional (top-window (contact-root window)))
  (do ((win window (contact-parent win)))
      ((eq win top-window) nil)
    (when (funcall test win)
      (return win))))

(defmethod query-find-most-specific-window (test &optional (top-window *root*))
  (if test
      (find-super-window (query-pointer-source-window top-window)
	       test top-window)
    (query-pointer-source-window top-window)))

(defun find-specific-window (current-window &key root type test)
  (let ((predicate
	 (cond ((null type) test)
	       (test #'(lambda (win) (and (typep win type)
					 (funcall test win))))
	       (t #'(lambda (win) (typep win type))))))
    (if predicate
	(find-super-window current-window predicate root)
      (query-pointer-source-window current-window))))
  

;;;_______________________________________
;;;
;;;    Querying the X Server host 
;;;_______________________________________

(defun query-x-server-host (&optional (stream *terminal-io*))
  "query for the X server host and initialize *default-host* accordingly."
  (let* ((display-name (display-variable))
	(default-host
	 (subseq display-name 0 (position #\: display-name))))
    (when (string= default-host "unix")
      (setq default-host (host-variable))) ;; dont't use "unix" as the 
    ;; default-host!
    (query-string "Enter the X Server host:"
		  :special '*default-host*
		  :default default-host)))

;;;___________________________________
;;;
;;; Primitives for drawing rectangles
;;;___________________________________

(defun draw-rectangle-inside (drawable gcontext x y width height 
			      &optional fill-p)
  "Like DRAW-RECTANGLE, except that the outline is completely contained 
   in the region specified by x, y, width and height."

  (if fill-p
      (draw-rectangle drawable gcontext x y width height t)
    (let ((line-width (max 1 (gcontext-line-width gcontext))))
      (if (not (eq (gcontext-line-style gcontext) :solid))
	  (let ((offset (floor line-width 2)))
	    (draw-rectangle drawable gcontext
			    (+ x offset) (+ y offset)
			    (max 0 (- width offset offset))
			    (max 0 (- height offset offset))))
	(let ((w (max 0 (- width line-width)))
	      (h (max 0 (- height line-width))))
	  (with-gcontext (gcontext :fill-style :solid)
	   (using-point-vector (rect-seq 16)
	     (point-push x y)
	     (point-push w line-width)
	     (point-push x (+ y line-width))
	     (point-push line-width h)
	     (point-push (+ x line-width) (+ y height (- line-width)))
	     (point-push w line-width)
	     (point-push (+ x width (- line-width)) y)
	     (point-push line-width h)
	     (draw-rectangles drawable gcontext rect-seq t))))))))

(defun draw-rectangles-inside (parent gc regions &key (x 0) (y 0) filled-p)
  "Draws a number of rectangles inside the given REGIONS, a list of objects of type
   region, using the graphical context GC. Optional X and Y specify an offset for the   position of the rectangles in relation to the parent window."
  (dolist (r regions)
    (draw-rectangle-inside parent gc (+ x (region-x r)) (+ y (region-y r))
			   (region-w r) (region-h r) filled-p)))


(defun draw-rounded-rectangle-inside (drawable gcontext x y width height
				      corner-radius)
  "Like DRAW-RECTANGLE-INSIDE, except that the corners are rounded
   using a circular arc with radius CORNER-RADIUS"
  (let* ((line-width (max 1 (gcontext-line-width gcontext)))
	 (offset (floor line-width 2))
	 (cd (+ corner-radius corner-radius))
	 (xo (+ x offset))
	 (yo (+ y offset))
	 (xs (+ xo corner-radius))
	 (xw (+ x width (- (1+ offset))))
	 (xe (- xw corner-radius))
	 (xea (- xe corner-radius))
	 (ys (+ yo corner-radius))
	 (yh (+ y height (- (1+ offset))))
	 (ye (- yh corner-radius))
	 (yea (- ye corner-radius)))
    (draw-line drawable gcontext xs yo xe yo)
    (draw-line drawable gcontext xs yh xe yh)
    (draw-line drawable gcontext xo ys xo ye)
    (draw-line drawable gcontext xw ys xw ye)
    (draw-arc drawable gcontext xo yo cd cd #.(/ pi 2) #.(/ pi 2))
    (draw-arc drawable gcontext xo yea cd cd pi #.(/ pi 2))
    (draw-arc drawable gcontext xea yo cd cd 0 #.(/ pi 2))
    (draw-arc drawable gcontext xea yea cd cd #.(* 3/2 pi) #.(/ pi 2))
    ))


;;;_________________________
;;;
;;; Primitives for Copying
;;;_________________________

(defun copy-window-pixmaps (parent gc regions pixmaps &key (x 0) (y 0))
  (do ((pixmaps pixmaps (cdr pixmaps))
       (regions regions (cdr regions)))
      ((null pixmaps))
    (copy-area (car pixmaps) gc 0 0 (region-w (car regions)) (region-h (car regions))
	       parent (+ x (region-x (car regions))) (+ y (region-y (car regions))))))

   
(defun copy-area-region (src gc x-offset y-offset w-offset h-offset region dst)
  (let ((x (+ x-offset (region-x region)))
	(y (+ y-offset (region-y region))))
    (copy-area src gc x y (+ w-offset (region-w region))
	       (+ h-offset (region-h region)) dst x y)))

