;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: GILT; 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This file created by the Garnet Interface Builder
;;; on Jun 28, 1990, 2:01 PM
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|
===============================================================================
Change Log:
     4/24/92 Pervin - Changed defvar to proclaim.
     2/18/92 Brad Myers - added constant definitions
     03/01/91 Andrew Mickish - Changed s-value's of :value slot to
                set-initial-value's in Show-Font-Dialog
     02/22/91 Osamu Hashimoto - seperated from particular gadgets
===============================================================================
|#

(in-package "GILT" :use '("LISP" "KR"))

(defparameter *Obj-For-Font-To-Modify* NIL)
(proclaim '(special FONT-PROP))

(defun Show-Font-Dialog (left top obj slot)
  (let ((oldfont (g-value obj slot))
	val)
    (setq *Obj-For-Font-To-Modify* (list oldfont obj slot))
    (set-initial-value FONT-PROP :family (or (g-value oldfont :family) :fixed))
    (set-initial-value FONT-PROP :face (case (or (g-value oldfont :face)
						 :roman)
					 (:roman NIL)
					 (:italic (list :italic))
					 (:bold (list :bold))
					 (:bold-italic (list :bold :italic))
					 (T (error "Bad face ~s" val))))
    (set-initial-value FONT-PROP :size (or (g-value oldfont :size) :medium))
    (show-in-window FONT-PROP left top)))

(defun Font-Dialog-OK-Func (gadget item)
    (let* ((oldfont (first *Obj-For-Font-To-Modify*))
	   (obj (second *Obj-For-Font-To-Modify*))
	   (slot (third *Obj-For-Font-To-Modify*))
	   (window (g-value obj :window))
	   val newfont name)
      (when (and obj slot)
	(setq name (gentemp "GILT-FONT-" "KR-DEBUG"))
	(let ((kr::*constants-disabled* T))
	  (setq newfont
	      (create-instance name Opal:Font
		 (:constant '(T))
		 (:family (or (g-local-value FONT-PROP :family :value)
			      (g-value oldfont :family)))
		 (:face (progn
			  (setq val (g-local-value FONT-PROP :face :value))
			  (cond ((= (length val) 2) :bold-italic)
				((eq (car val) :bold) :bold)
				((eq (car val) :italic) :italic)
				(T :roman))))
		 (:size (or (g-local-value FONT-PROP :size :value)
			    (g-value oldfont :size))))))
	(s-value window :created-fonts
		 (cons newfont (remove (g-value obj slot)
				       (g-value window :created-fonts))))
	(s-value obj slot newfont))
      (Font-Dialog-Cancel-Func gadget item)
      newfont))

(defun Font-Dialog-Cancel-Func (gadget item)
  (declare (ignore gadget item))
  (let ((win (g-value FONT-PROP :window)))
    (s-value win :visible NIL)
    (opal:update win))
  (setq *Obj-For-Font-To-Modify* NIL))

;;; Function called when the properties button hit with a string selected,
;;; returns T
(defun String-Props (obj)
  (Show-Font-Dialog (+ 30 (g-value obj :window :left))
		    (+ 30 (g-value obj :window :top))
		    obj :font)
  T)

