;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*-
;;;
;;; ______________________________________________________________________
;;;
;;; The Garnet User Interface Development Environment
;;; Copyright (c) 1991 Carnegie Mellon University
;;; All rights reserved.  The CMU software License Agreement specifies
;;; the terms and conditions for use and redistribution.
;;;
;;; If you want to use this code or anything developed as part of the
;;; Garnet Project, please contact Brad Myers (Brad.Myers@CS.CMU.EDU).
;;; ______________________________________________________________________
;;;
;;; 11-Jun-91 ECP Released internally
;;;

(in-package "INTERACTORS" :nicknames '("INTER") :use '("LISP" "KR"))

;; This does the exact reverse of opal::make-xfont-name
;; It takes a string...
(defun extract-key-from-xfont-name (name)
  (let (family face-location face size-location size)
    (setq family
      (case (elt name 4)
	(#\c :fixed)		;; courier
	(#\t :serif)		;; times
	(#\h :sans-serif)))	;; helvetica
    (setq face-location
      (case family
	(:fixed 12)		;; courier
	(:serif 10)		;; times
	(:sans-serif 14)))	;; helvetica
    (setq face
      (case (elt name face-location)
	(#\b (case (elt name (+ face-location 5))
	       (#\r :bold)
	       (#\i :bold-italic)
	       (#\o :bold-italic)))
	(#\m (case (elt name (+ face-location 7))
	       (#\r :roman)
	       (#\i :italic)
	       (#\o :italic)))))
    (setq size-location
      (+ face-location
	(case face
	  (:roman 14)
	  (:bold 12)
	  (:italic 14)
	  (:bold-italic 12))))
    (setq size
      (case (elt name size-location)
	(#\0 :small)		;; 10
	(#\2 :medium)		;; 12
	(#\8 :large)		;; 18
	(#\4 :very-large)))	;; 24
    (list family face size)))

;; Next text typed will be in regular face
(Bind-Key :F2 #'(lambda (an-interactor obj event)
                  (declare (ignore an-interactor event))
		  (let ((key (extract-key-from-xfont-name
			       (xlib:font-name (g-value obj :current-font)))))
		    (setf (second key) :roman)
		    (s-value obj :current-font
		      (xlib:open-font opal::*default-x-display*
			(opal::make-xfont-name key)))))
	      Multi-Font-Text-Interactor)

;; Next text typed will be in italic face
(Bind-Key :F3 #'(lambda (an-interactor obj event)
                  (declare (ignore an-interactor event))
		  (let ((key (extract-key-from-xfont-name
			       (xlib:font-name (g-value obj :current-font)))))
		    (setf (second key) :italic)
		    (s-value obj :current-font
		      (xlib:open-font opal::*default-x-display*
			(opal::make-xfont-name key)))))
	      Multi-Font-Text-Interactor)

;; Next text typed will be in bold face
(Bind-Key :F4 #'(lambda (an-interactor obj event)
                  (declare (ignore an-interactor event))
		  (let ((key (extract-key-from-xfont-name
			       (xlib:font-name (g-value obj :current-font)))))
		    (setf (second key) :bold)
		    (s-value obj :current-font
		      (xlib:open-font opal::*default-x-display*
			(opal::make-xfont-name key)))))
	      Multi-Font-Text-Interactor)

;; Next text typed will be in bold-italic face
(Bind-Key :F5 #'(lambda (an-interactor obj event)
                  (declare (ignore an-interactor event))
		  (let ((key (extract-key-from-xfont-name
			       (xlib:font-name (g-value obj :current-font)))))
		    (setf (second key) :bold-italic)
		    (s-value obj :current-font
		      (xlib:open-font opal::*default-x-display*
			(opal::make-xfont-name key)))))
	      Multi-Font-Text-Interactor)

;; Next text typed will be in next bigger size
(Bind-Key :F6 #'(lambda (an-interactor obj event)
                  (declare (ignore an-interactor event))
		  (let ((key (extract-key-from-xfont-name
			       (xlib:font-name (g-value obj :current-font)))))
		    (setf (third key)
		      (case (third key)
			(:small :medium)
			(:medium :large)
			(:large :very-large)
			(:very-large :very-large)))
		    (s-value obj :current-font
		      (xlib:open-font opal::*default-x-display*
			(opal::make-xfont-name key)))))
	      Multi-Font-Text-Interactor)

;; Next text typed will be in next smaller size
(Bind-Key :F7 #'(lambda (an-interactor obj event)
                  (declare (ignore an-interactor event))
		  (let ((key (extract-key-from-xfont-name
			       (xlib:font-name (g-value obj :current-font)))))
		    (setf (third key)
		      (case (third key)
			(:small :small)
			(:medium :small)
			(:large :medium)
			(:very-large :large)))
		    (s-value obj :current-font
		      (xlib:open-font opal::*default-x-display*
			(opal::make-xfont-name key)))))
	      Multi-Font-Text-Interactor)

;; Next text typed will be in serif family
(Bind-Key :F8 #'(lambda (an-interactor obj event)
                  (declare (ignore an-interactor event))
		  (let ((key (extract-key-from-xfont-name
			       (xlib:font-name (g-value obj :current-font)))))
		    (setf (first key) :serif)
		    (s-value obj :current-font
		      (xlib:open-font opal::*default-x-display*
			(opal::make-xfont-name key)))))
	      Multi-Font-Text-Interactor)


;; Next text typed will be in sans-serif family
(Bind-Key :F9 #'(lambda (an-interactor obj event)
                  (declare (ignore an-interactor event))
		  (let ((key (extract-key-from-xfont-name
			       (xlib:font-name (g-value obj :current-font)))))
		    (setf (first key) :sans-serif)
		    (s-value obj :current-font
		      (xlib:open-font opal::*default-x-display*
			(opal::make-xfont-name key)))))
	      Multi-Font-Text-Interactor)

;; Next text typed will be in fixed family
(Bind-Key :F10 #'(lambda (an-interactor obj event)
                  (declare (ignore an-interactor event))
		  (let ((key (extract-key-from-xfont-name
			       (xlib:font-name (g-value obj :current-font)))))
		    (setf (first key) :fixed)
		    (s-value obj :current-font
		      (xlib:open-font opal::*default-x-display*
			(opal::make-xfont-name key)))))
	      Multi-Font-Text-Interactor)
