;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XAM
;;;                       Module: Fonts
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/font-meta.lisp
;;; File Creation Date: 05/21/92 14:06:57
;;; Last Modification Time: 07/24/92 13:04:31
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

(defun get-font-description (font)
  (multiple-value-bind (family face size) (get-font-family-face-size font)
    (if family
	`(:family ,family :face ,face :size ,size)
      (font-name font))))

(defun select-meta-font-sheet (window &key (reader 'font) (writer nil))
  (declare (special *meta-pool*))
  (let ((sheet (get-pool-window *meta-pool* :meta-font-sheet)))
    (with-accessors ((view-of view-of)
		     (read-function read-function)
		     (write-function write-function)) (view-of sheet)
      (setf view-of window)
      (setf read-function reader)
      (setf write-function writer))
    (popup sheet)))
  
(defmethod make-meta-sheet-named ((key (eql :meta-font-sheet)))
  (while-busy nil
    (make-window 'shadow-popup-margined-window
     :name :meta-font-sheet
     :view-of (make-instance 'access-controller)
     :margins 
     '((standard-margins
	:label-options
	(:name :label
	 :inside-border 3
	 :text "Font Properties")
	:quad-space-options
	(:name :space
	 :thickness 1)))
   :client-window 
   '(property-sheet
     :border-width 1
     :adjust-size? t
     :read-back? t
     :reactivity-entries
     ((:write-event (call :eval (setf (application-value (view-of *self*))
				    (value (part *self* :name)))))
      (:part-event (call :eval
		    (if (stringp *part-value*)
			(write-to-application *self*)
		      (progn
			(setf (application-value (view-of *self*))
			  `(:family ,(value (part *self* :family))
			    :face ,(value (part *self* :face))
			    :size ,(value (part *self* :size)))))))
                   (call :read)))
     :parts
     ((:name :family
       :label "family"
       :read-function (lambda (view-of)
			(get-font-family (application-value view-of)))
       :reactivity-entries
       ((:part-event (call :pass-part-event))
	(:write-event (call :part-event (value *self*))))
       :read-initially? nil
       :value-part 
       (:class single-choice-text-menu
        :layouter (distance-layouter :orientation :right :distance 10)
	:inside-border 0
        :parts ((:view-of :helvetica  
		 :action-docu "Select family Helvetica"
		 :text "Helvetica"
		 :font (:family :helvetica))
                (:view-of :lucida           
                 :action-docu "Select family Lucida"      
                 :text "Lucida"
		 :font (:family :lucida))
                (:view-of :lucidatypewriter           
                 :action-docu "Select family Lucida Typewriter"      
                 :text "Lucida-Typewriter"
		 :font (:family :lucidatypewriter)))))
      (:name :face
       :label "face"
       :read-function (lambda (view-of)
			(get-font-face (application-value view-of)))
       :reactivity-entries
       ((:part-event (call :pass-part-event))
	(:write-event (call :part-event (value *self*))))
       :read-initially? nil
       :value-part 
       (:class single-choice-text-menu
        :layouter (distance-layouter :orientation :right :distance 10)         
        :inside-border 0
        :parts ((:view-of :normal 
                 :action-docu "Select normal face"
                 :text "normal"
		 :font (:face :normal))
                (:view-of :bold 
                 :action-docu "Select bold face"
                 :text "bold"
		 :font (:face :bold))
                (:view-of :italic
                 :action-docu "Select italic face"
                 :text "italic"
		 :font (:face :italic))
		(:view-of :bolditalic  
                 :action-docu "Select bold-italic face"
                 :text "bold-italic"
		 :font (:face :bolditalic)))))
      (:name :size
       :label "size"
       :read-function (lambda (view-of)
			(get-font-size (application-value view-of))) 
       :reactivity-entries
       ((:part-event (call :pass-part-event))
	(:write-event (call :part-event (value *self*))))
       :read-initially? nil
       :value-part 
       (:class single-choice-text-menu
        :layouter (aligning-distance-layouter :orientation :right
				 :distance 10 :alignment :center)         
        :inside-border 0
        :parts ((:view-of 8    
                 :action-docu "Select font-size 8"
                 :text "8"
		 :font (:size 8))
                (:view-of 10     
                 :action-docu "Select font-size 10"
                 :text "10"
		 :font (:size 10))
                (:view-of 12     
                 :action-docu "Select font-size 12"
                 :text "12"
		 :font (:size 12))
                (:view-of 14     
                 :action-docu "Select font-size 14"
                 :text "14"
		 :font (:size 14))
                (:view-of 18    
                 :action-docu "Select font-size 18"
                 :text "18"
		 :font (:size 18))
                (:view-of 24     
                 :action-docu "Select font-size 24"
                 :text "24"
		 :font (:size 24)))))
      (:class text-property-field
       :name :name
       :label "name"
       :read-function (lambda (view-of)
			(font-name (application-value view-of)))
       :write-transformation string
       :reactivity-entries
       ((:part-event (call :pass-part-event))
	(:write-event (call :part-event (value *self*))))
       :read-initially? nil
       ))))))
