;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Changes:
;;;  1-Oct-93 amickish Fixed drawing of border when radius less than thickness
;;; 23-Aug-93 amickish Changed hit-threshold binding in point-in-gob method
;;;               to conform to documented specifications
;;;  6-Apr-93 koz Converted with-*-styles macros to set-*-style fns
;;;               And omitted "clip-mask" as argument to draw function.
;;;  5-Oct-92 koz/amickish get-thickness --> get-old-thickness in :draw methods
;;; 28-Apr-92 ecp Improved draw-filled-roundtangle.
;;;  4-Apr-92 amickish Removed redundant :initialize method for roundtangles
;;;  4-Mar-91 d'souza Removed nickname "MO" of package Opal.
;;; 26-Jun-90 ecp Changed 0 to 0.0 in draw-arcs due to temporary xbug.

(in-package "OPAL" :use '("LISP" "KR"))
(proclaim '(declaration values))

;;; Roundtangles

(defun draw-inside-of-roundtangle (drawable xlib-gc-fill L TO W H r th)
     ;; 3 rectangles first
  (xlib:draw-rectangles drawable xlib-gc-fill
			(list (+ L r) (+ TO th) (- W r r) (- H th th)
			      (+ L th) (+ TO r) (- r th) (- H r r)
			      (- (+ L w) r) (+ TO r) (- r th) (- H r r))
			t)
     ;; fill in the quarter circles
  (xlib:draw-arcs drawable xlib-gc-fill
		  (list (+ L th) (+ To th)
			(* 2 (- r th)) (* 2 (- r th)) (/ pi 2) (/ pi 2)
			(+ L W th (* -2 r)) (+ TO th)
			(* 2 (- r th)) (* 2 (- r th)) 0.0 (/ pi 2)
			(+ L W th (* -2 r)) (+ TO H th (* -2 r))
			(* 2 (- r th)) (* 2 (- r th)) (* 3/2 pi) (/ pi 2)
			(+ L th) (+ TO H th (* -2 r))
			(* 2 (- r th)) (* 2 (- r th)) pi (/ pi 2))
		  t))


(defun draw-roundtangle-border (drawable xlib-gc-line L TO W H r th)
  (let ((th/2 (floor th 2))
	(th\2 (ceiling th 2))
	(2*r-th (- (+ r r) th)))
    (xlib:draw-segments drawable xlib-gc-line
			(list
			;; left side
			 (+ L th/2) (+ TO r (mod th 2))
			 (+ L th/2) (+ TO H (- r))
			;; bottom side
			 (+ L r (mod th 2)) (- (+ TO H) th\2)
			 (- (+ L W) r)      (- (+ TO H) th\2)
			;; right side
			 (- (+ L W) th\2) (- (+ TO H) r)
			 (- (+ L W) th\2) (+ TO r (mod th 2))
			;; top side
			 (- (+ L W) r)      (+ TO th/2)
			 (+ L r (mod th 2)) (+ TO th/2)))
    (xlib:draw-arcs drawable xlib-gc-line
		    (list
		    ;; lower left corner
		     (+ L th\2) (+ TO H th/2 (* -2 r)) 
		     2*r-th 2*r-th pi (/ pi 2)
		    ;; lower right corner
		     (+ L W th/2 (* -2 r)) (+ TO H th/2 (* -2 r))
		     2*r-th 2*r-th (* pi 3/2) (/ pi 2)
		    ;; upper right corner
		     (+ L W th/2 (* -2 r)) (+ TO th\2) 2*r-th 2*r-th
		     0.0 (/ pi 2)
		    ;; upper left corner
		     (+ L th\2) (+ TO th\2) 2*r-th 2*r-th
		     (/ pi 2) (/ pi 2)))))


(defun draw-filled-roundtangle (drawable xlib-gc-line L TO W H r)
  (xlib:draw-rectangles drawable xlib-gc-line
			(list (+ L r) TO (- W r r) r
			      L (+ TO r) W (- H r r)
			      (+ L r) (- (+ TO H) r) (- W r r) r) t)
  (xlib:draw-arcs drawable xlib-gc-line
		  (list
		   ;upper left
		   L TO (+ r r) (+ r r) (/ pi 2) (/ pi 2)
		   ;upper right
		   (- (+ L W) r r) TO (+ r r) (+ r r) 0.0 (/ pi 2)
		   ;bottom right
		   (- (+ L W) r r) (- (+ TO H) r r)
		   (+ r r) (+ r r) (* pi 3/2) (/ pi 2)
		   ;bottom left
		   L (- (+ TO H) r r) (+ r r) (+ r r) pi (/ pi 2))
		  t))



(define-method :draw opal:roundtangle (gob line-style-gc filling-style-gc
					   drawable root-window)
  (let* ((update-vals (g-local-value gob :update-slots-values))
	 (fstyle (aref update-vals *roundt-fstyle*))
	 (lstyle (aref update-vals *roundt-lstyle*))
	 (L (aref update-vals *roundt-left*))
	 (TO (aref update-vals *roundt-top*))
	 (W (max 0 (aref update-vals *roundt-width*)))
	 (H (max 0 (aref update-vals *roundt-height*)))
	 (r (aref update-vals *roundt-draw-radius*))
	 (th (min (get-old-thickness gob *roundt-lstyle* update-vals) W H))
	 (x-draw-fn (get (aref update-vals *roundt-draw-function*)
			 :x-draw-function))
	 (xlib-gc-line (opal-gc-gcontext line-style-gc))
	 (xlib-gc-fill (opal-gc-gcontext filling-style-gc)))

    (if (< th r)
	(progn
	  (when fstyle
	    (set-filling-style fstyle filling-style-gc xlib-gc-fill
			        root-window x-draw-fn)
	    (draw-inside-of-roundtangle drawable xlib-gc-fill L TO W H r th))
	  (when lstyle
	    (set-line-style lstyle line-style-gc xlib-gc-line root-window
			     x-draw-fn)
	    (draw-roundtangle-border drawable xlib-gc-line L TO W H r th)))
  ;;; on the other hand, if thickness > radius,
	(progn
	  (when (> (min W H) (+ th th))
	    (when fstyle
	      (set-filling-style fstyle filling-style-gc xlib-gc-fill
				  root-window x-draw-fn)
	      (xlib:draw-rectangle drawable xlib-gc-fill
		(+ L th) (+ TO th) (- W th th) (- H th th) t)))
	  (when lstyle
	    (set-line-style lstyle line-style-gc xlib-gc-line root-window
			    x-draw-fn)
	    (draw-roundtangle-border drawable xlib-gc-line L TO W H r th)
	    )))))


(defun point-in-roundtangle (x y left top right bottom radius)
  (and (point-in-rectangle x y left top right bottom)
       (or (<= radius 0)
       (cond
	((point-in-rectangle x y left top (+ left radius) (+ top radius))
	 (point-in-ellipse x y (+ left radius) (+ top radius) radius radius))
	((point-in-rectangle x y (- right radius) top right (+ top radius))
	 (point-in-ellipse x y (- right radius) (+ top radius) radius radius))
	((point-in-rectangle x y left (- bottom radius) (+ left radius) bottom)
	 (point-in-ellipse x y (+ left radius) (- bottom radius) radius radius))
	((point-in-rectangle x y (- right radius) (- bottom radius) right bottom)
	 (point-in-ellipse x y (- right radius) (- bottom radius) radius radius))
	(t t)
	))))

(define-method :point-in-gob opal:roundtangle (gob x y)
 (and (g-value gob :visible)
  (let* ((thickness (get-thickness gob))
	 (width (g-value gob :width))
	 (height (g-value gob :height))
	 (select-outline-only (g-value gob :select-outline-only))
	 (threshold (g-value gob :hit-threshold))
	 (radius (g-value gob :draw-radius))
	 (left (g-value gob :left))
	 (top (g-value gob :top))
	 (right (+ left width))
	 (bottom (+ top height)))
    (and (point-in-roundtangle x y (- left threshold) (- top threshold) 
			     (+ right threshold) (+ bottom threshold) 
			     (+ radius threshold))
	 (not (and select-outline-only
		   (point-in-roundtangle x y
				       (+ left thickness threshold)
				       (+ top thickness threshold)
				       (- right thickness threshold)
				       (- bottom thickness threshold)
				       (- radius thickness threshold))))))))

