;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: 
;;;                       Module: 
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Matthias Ressel
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/transformers.lisp
;;; File Creation Date: 07/23/92 09:38:02
;;; Last Modification Time: 09/18/92 15:52:40
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; 09/18/1992 (Matthias) clos:ensure-class was not defined by LUCID-clos
;;;_____________________________________________________________________________

(in-package :xit)

;;;-----------------------------------------------------------------------------
;;;                     Basic Transformers
;;;-----------------------------------------------------------------------------

(defclass transformer ()
  ()
  (:documentation "Transformer should be mixed into every transformer."))


(defgeneric sharable-transformer-p (transformer)
  (:documentation "Used for the decision if a transformer can be shared."))

(defmethod sharable-transformer-p ((self transformer))
  "Be sceptical in regard to sharability."
  nil)

(defclass basic-transformer (transformer)
  ((read-transformation :initform #'identity
     :reader read-transformation :initarg :read-transformation)
   (write-transformation :initform #'identity
     :reader write-transformation :initarg :write-transformation))
  (:documentation "Basic-transformer has transformation functions for read and write
                   without parameters."))

(defmethod sharable-transformer-p  ((self basic-transformer))
  t)

(defmethod read-transform ((self basic-transformer) value)
  (with-slots (read-transformation) self
    (funcall read-transformation value)))

(defmethod write-transform ((self basic-transformer) value)
  (with-slots (write-transformation) self
    (funcall write-transformation value)))

(defclass string-transformer (basic-transformer)
  ((read-transformation :initform  #'convert-to-readable-string)
   (write-transformation :initform #'convert-from-string))
  (:documentation
   "String-transformer converts to and from interface value strings."))

;;;-----------------------------------------------------------------------------
;;;                     Interval Transformer
;;;-----------------------------------------------------------------------------

(defclass interval-transformer-mixin (transformer)
  ((a-low :initform 0 :accessor a-low :initarg :a-low)
   (a-high :initform 100 :accessor a-high :initarg :a-high)
   (i-low :initform 0 :accessor i-low :initarg :i-low)
   (i-high :initform 1 :accessor i-high :initarg :i-high))
  (:documentation "Interval-transformer-mixin transforms between (a-low,a-high)
                   and (i-low,i-high)."))

(defclass linear-transformer (interval-transformer-mixin)
  ()
  (:documentation "Linear-transformer linearly maps (a-low,a-high) onto
                      (i-low,i-high)."))

(defun linear-transform (value low1 high1 low2 high2)
  "Linear transformation from (low1,high1) to (low2,high2)."
  (+ low2 (* (- high2 low2)
	    (/ (- value low1)
	       (- high1 low1)))))

(defmethod read-transform ((self linear-transformer) value)
  (with-slots (a-low a-high i-low i-high) self
    (linear-transform value a-low a-high i-low i-high)))

(defmethod write-transform ((self linear-transformer) value)
  (with-slots (a-low a-high i-low i-high) self
    (linear-transform value i-low i-high a-low a-high)))

;;;________________________________________________________________________________
;;;
;;;        Monotonous Transformer
;;;________________________________________________________________________________

(defclass monotonous-transformer (interval-transformer-mixin)
  ((map-function :accessor map-function :initarg :map-function :initform #'identity)
   (inverse-function :accessor inverse-function :initarg :inverse-function
		     :initform #'identity)
   (map-left :accessor map-left :initarg :map-left :initform 0)
   (map-right :accessor map-right :initarg :map-right :initform 1))
  (:documentation "Monotonous-transformer uses the map-function and its inverse
                   for domain (map-left,map-right), linearly transformed to the
                   region delimited by (a-low,i-low) and (a-high,i-low).
                   The map-function should be inversible for interval
                   (map-left,map-right).
                   Examples are sine for (-pi/2,+pi/2) and sqrt for (0,1).
                   Ratios usually are not preserved. 
                   For exponential data try logarithmic-transformer."))

(defmethod map-min ((self monotonous-transformer))
  (with-slots (map-function map-left) self
    (funcall map-function map-left)))

(defmethod map-max ((self monotonous-transformer))
  (with-slots (map-function map-right) self
    (funcall map-function map-right)))

(defmethod read-transform ((self monotonous-transformer) value)
  (with-slots (inverse-function
	       a-low a-high i-low i-high map-left map-right) self
    (linear-transform
      (funcall inverse-function
	       (linear-transform value a-low a-high
				      (map-min self)
				      (map-max self)))
      map-left map-right i-low i-high)))

(defmethod write-transform ((self monotonous-transformer) value)
  (with-slots (inverse-function map-function
	       a-low a-high i-low i-high map-left map-right) self
    (linear-transform
     (funcall map-function
	      (linear-transform value i-low i-high map-left map-right))
     (map-min self) (map-max self)
     a-low a-high)))

;;;________________________________________________________________________________
;;;
;;;        Monotonous Transformer
;;;________________________________________________________________________________

(defclass non-monotonous-transformer (monotonous-transformer)
  ((map-function :accessor map-function :initarg :map-function :initform #'identity)
   (inverse-function :accessor inverse-function :initarg :inverse-function
		     :initform #'identity)
   (map-left :accessor map-left :initarg :map-left :initform 0)
   (map-right :accessor map-right :initarg :map-right :initform 1)
   (map-max :accessor map-max :initarg :map-max :initform 1)
   (map-min :accessor map-min :initarg :map-min :initform 0))
  (:documentation "Non-monotonous-transformer uses the map-function and its inverse
                   for domain (map-left,map-right), linearly transformed to the
                   region delimited by (a-low,i-low) and (a-high,i-low).
                   The map-function should be inversible for some part of
                   (map-left,map-right).
                   Examples are sine for (0,pi) with values (0,1).
                   For monotonous functions use monotonous-transformer."))

;;________________________________________________________________________________
;;
;;               Logarithmic Transformer
;;________________________________________________________________________________


(defclass logarithmic-transformer (interval-transformer-mixin)
  ((map-function :accessor map-function :initarg :map-function :initform #'exp)
   (inverse-function :accessor inverse-function :initarg :inverse-function
		     :initform #'log)
   (a-low :initform 1))
  (:documentation "Logarithmic-transformer transforms exponential application
                   values. Asserts that equal-length interface intervals are mapped
                   to application intervals with equal ratio.
                   Be sure that a-low and a-high are set to a positiv number."))

(defmethod read-transform ((self logarithmic-transformer) value)
  (with-slots (a-low a-high i-low i-high
	       inverse-function) self
    (linear-transform (funcall inverse-function value)
		      (funcall inverse-function a-low)
		      (funcall inverse-function a-high)
		      i-low i-high)))

(defmethod write-transform ((self logarithmic-transformer) value)
  (with-slots (inverse-function map-function
	       a-low a-high i-low i-high) self
    (funcall map-function
	     (linear-transform value i-low i-high
			       (funcall inverse-function a-low)
			       (funcall inverse-function a-high)))))

;;________________________________________________________________________________
;;
;;               Integer Transformer Mixin
;;________________________________________________________________________________

(defclass integer-transformer ()
  ((operator :type (member floor ceiling truncate round)
	     :initform 'round :initarg :operator :accessor operator))
  (:documentation "Integer-transformer converts to an integer for integer application values"))

(defmethod read-transform ((self integer-transformer) value)
  (funcall (operator self) value))

(defmethod write-transform ((self integer-transformer) value)
  (funcall (operator self) value))

;;;-----------------------------------------------------------------------------
;;;                     Transformation Mixin
;;;-----------------------------------------------------------------------------

(defclass transformation-mixin ()
  ((transformer :accessor transformer :initarg :transformer
		:initform nil :type (or transformer list)))
  (:documentation "transformation-mixin is used to transform values
                   between application and interface."))

(defmethod initialize-instance :after ((self transformation-mixin) &rest args)
  (declare (ignore args))
  (normalize-transformer self))

(defmethod (setf transformer) :after (value (self transformation-mixin))
  (declare (ignore value))
  (normalize-transformer self))

(defmethod normalize-transformer ((self transformation-mixin))
  "Converts contents of transform slot to type (or null transformer)."
  (let ((transformer (transformer self)))
    (typecase transformer
      (null)
      (transformer)
      (t
       (setf (transformer self)
	   (get-transformer
	    (if (listp transformer)
		transformer
	      (list transformer))))))))

(defmethod write-transform ((self transformation-mixin) value)
  "Apply write-transformation to value."
  (with-slots (transformer) self
    (write-transform transformer value)))

(defmethod read-transform ((self transformation-mixin) value)
  "Apply read-transformation to value."
  (with-slots (transformer) self
    (read-transform transformer value)))

(defmethod read-transform ((transformer null) value)
  "Default transformation without transformer is identity."
  value)

(defmethod write-transform ((transformer null) value)
  "Default transformation without transformer is identity."
  value)

;;; The following implements a simple transformer pool
;;; First a transformer with the same (equal) class and initargs
;;; is looked up in the pool.
;;; If one is found, it is asked if it is safe to use it again.
;;; In all other cases a new instance is created and added to the pool

(defvar *transformer-pool* (make-hash-table :test #'equal :size 100)
  "Hashtable mapping transformer-descr lists to transformer objects.")

(defun get-transformer (descr)
  "Returns a transformer object that is specified by descr list. 
It is unique if the particular transformer class is parameterized,
otherwise it is shared."
  (let ((transformer (gethash descr *transformer-pool*)))
    (cond (transformer)
	  (t
	   (let ((transformer-class (get-transformer-class (car descr))))
	     (when transformer-class
	       (setq transformer
		   (apply #'make-instance
			  transformer-class
			  (cdr descr)))
	       (when (sharable-transformer-p transformer)
		 (setf (gethash descr *transformer-pool*) transformer))))
	   transformer))))

(defvar *transformer-class-pool* (make-hash-table :test #'equal :size 20)
  "Hashtable mapping transformer-class-descr to transformer classes or names.")

(defun get-transformer-class (class-descr)
  "Returns a class mixed from classes named in class-descr."
  (cond ((listp class-descr)
	 (if (cdr class-descr)
	     (let ((class (gethash class-descr *transformer-class-pool*)))
	       (cond (class)
		     (t
		      (setf (gethash class-descr *transformer-class-pool*)
			  #-allegro
			  nil
			  #+allegro
			  (clos:ensure-class (gensym) :direct-superclasses class-descr)))))
	   (car class-descr)))
	(t class-descr)))

