Библиотека функций к Script-fu

Введение

Итак, теперь наша система позволяет описывать классы с иерархиями множественного наследования и описывать обобщённые функции(generic function) и они придают динамику, придают жизнь создаваемым в системе объектам. Но так ли хороши описанные нами обобщённые функции? Да с точки зрения широко распространённых("классических") ООП систем, они полностью повторяют функциональность методов объектов. При вызове обобщённой функции, происходит диспетчеризация вызова и выбирается наиболее подходящий по типам аргументов метод обобщённой функции. НО в CLOS это НЕ ТАК!!! Да в простейшем случае это так, НО..! CLOS предоставляет более гибкий способ организации кода, когда выполняемый при вызове обобщённой функции код представляет собой не один метод, а целую группу методов. Причём создаётся эта группа динамически в момент вызова, в зависимости от текущих аргументов обобщённой функции(вернее их типов/классов). А в основе такой организации кода лежит спецификация методов обобщённой функции различными квалификаторами.

Квалификаторы методов

CLOS выделяет 4 квалификатора методов: before, primary, after и arorund. Эти квалификаторы определяют поведение и очерёдность их вызова в момент применения обобщённой функции.

Квалификатор	Роль метода
нет	Основной метод(primary)
:before	Вызывается перед основным методом
:after	Вызывается после основного метода
:around	`Обернутый вокруг всех других видов методов`

Стандартный тип комбинации методов поддерживает call-next-method(вызов следующего метода) в around-методах и в первичных методах.

При применении обобщённой функции происходит следующее:

Вызываются ВСЕ подходящие методы с квалификатором before, сначала наиболее специфичные, а затем менее специфичные.
Вызывается один наиболее спецефичный первичный метод(может не иметь квалификатора при определении) primary. Этот метод может вызвать следующий менее специфичный метод с помощью call-next-method и т.д по цепочке.
Затем вызываются ВСЕ подходящие методы с квалификатором after, сначала наименее специфичные(самые базовые), а потом всё более и более специфичные.

Это называется стандартной комбинацией методов.

НО если мы определим around метод, то он вызовется первее всех. И также вызовется только один наиболее специфичный метод. С помощью функции call-next-method он может вызвать менее специфичный around метод ИЛИ вызвать стандартную комбинацию методов(если она есть).

И всё это делается для того что бы лучше организовать код, уменьшить его дублирование, более полно использовать возможности множественного наследования. Теперь перейдём к вопросу как это реализовать.

Реализация.

Чтобы ввести квалификаторы их прежде всего надо определить. Кроме того поскольку у нас вместо одного метода может вызываться комплекс методов, надо создать структуру сохраняющую этот комплекс, чтобы удобно было по ней проходить и что бы можно было её кешировать, и не выполнять это построение при каждом вызове обобщённой функции.

;;вводим квалификаторы методов
(define-macro (def-keys . param-list)  ;;описывает список ключевых слов
   `(begin  ,@(make-def-keys param-list)))

(struct qualifier-methods (primary before after around))

(define (qm-get stru key)
  (case key
    (':primary (qualifier-methods-primary stru))
    (':before  (qualifier-methods-before  stru))
    (':after   (qualifier-methods-after   stru))
    (':around  (qualifier-methods-around  stru))
    ))

(define (qm-set! stru key val)
  (case key
    (':primary (qualifier-methods-primary! stru val))
    (':before  (qualifier-methods-before!  stru val))
    (':after   (qualifier-methods-after!   stru val))
    (':around  (qualifier-methods-around!  stru val))
    ))


(def-keys :before :after :around :primary)
(define-m (qualifier? s)
  (or (eq? s :before)
      (eq? s :after)
      (eq? s :around)
      (eq? s :primary)))

макрос для определения обобщённой функции.

(define-macro (defgeneric name)
  (let* (   ;;(required-params (trim-parameters params))
	 (params       (gensym))
	 (shablon-call (gensym))
	 (cache-method (gensym))
	 (applicable-method (gensym))
	 (name-modify  (make-symbol name "-modify-method"))
	 (name-get-methods        (make-symbol name "-get-methods"))        ;;for debug
	 (name-get-methods-all    (make-symbol name "-get-methods-all"))
	 (name-get-cache-methods  (make-symbol name "-get-cache-methods"))  ;;for debug
	 (func         (gensym))
	 (fnd-method   (gensym))
	 (qual         (gensym)))
    `(begin
       (define    ,name)
       (define    ,name-modify)
       (define    ,name-get-methods)
       (define    ,name-get-methods-all)
       (define    ,name-get-cache-methods)
       (let ((*methods-cache* (make-hash 32))
	         (*methods*       (qualifier-methods! '() '() '() '())))
	 (set!  ,name (lambda-m ,params
			(let* ((,shablon-call (apply make-shablon-call-by-args ,params))
			       (,applicable-method (,name-get-methods ,shablon-call)))
			  (if (and (car ,applicable-method)
				   (has-run-method (cdr ,applicable-method)))
			      (begin
				     (apply call-methods (cdr ,applicable-method) ,params))
			      (error (join-to-str "Can't find applicable method: " ',name ", params: ") ,params "\n")))
			))
	 (set! ,name-modify (lambda-m (,shablon-call ,func ,qual)
               (when (> (hash-table-size *methods-cache*) 0)
				   (set! *methods-cache* (make-hash 32))) ;;просто сбросим кеш таблицу.
			   (let ((,fnd-method (find-method (qm-get *methods* ,qual) ,shablon-call)))
				   (if (cdr ,fnd-method)
				       (set-cdr! (car ,fnd-method) (cons ,func '()))
				       (qm-set! *methods* ,qual (cons (list ,shablon-call ,func) (qm-get *methods* ,qual)))))))
	 (set! ,name-get-methods 
	       (lambda-m (,shablon-call)
	               (let ((,cache-method  (hash-ref *methods-cache* ,shablon-call)))
				      (if (car ,cache-method)
					      ,cache-method
					      (let ((,applicable-method (build-applicable-methods *methods* ,shablon-call)))
					          (if (has-run-method ,applicable-method) 
						        (begin
						           (hash-set! *methods-cache* ,shablon-call ,applicable-method)
						           (cons #t ,applicable-method))
						           (cons #f '()))
					          )))))
	 (set! ,name-get-methods-all (lambda ()
				       *methods*))
	 (set! ,name-get-cache-methods (lambda ()
					 *methods-cache*))
       ))))

(define (find-method methods shablon)
  (find (lambda (x)
	  (equal? shablon (car x))) methods))

В макрос определения обобщённой функции мы внесли создание функции возвращающей набор методов для конкретного шаблона вызова ,name-get-methods. Для работы она не особо нужна, т.к действия по работе с хешем выполняются в основной обобщённой функции ,name(вместо ,name подставляется имя обобщённой функции), но может пригодиться при отладке работы системы. Ещё функция модификации методов стала принимать параметр qual - квалификатор, теперь все методы обобщённой фукнции разделены по квалификаторам, т.е разным спискам, для каждого квалификатора он отдельный.

макрос определения метода

;;будем в начале старта определять квалификатор метода, если его нет, то метод является primary-первичным.
(define-macro (defmethod start . body)
  (let* ((have-qual (qualifier? (car start)))
	     (name   (if have-qual (cadr start) (car start)))
	     (params (if have-qual (cddr start) (cdr start)))
	     (qual   (if have-qual (car start) :primary))
	     (names-params (map (lambda (x) (if (list? x)
					                        (car x)
					                        x))
                             params))
   	     (name-modify  (make-symbol name "-modify-method"))
	     (shablon-call (make-shablon-call-by-params params))
	     (chains-methods (gensym))
	     (tmp-cur        (gensym))
	     (in-primary     (gensym)))
    `(begin
       (when (not (defined? ',name)) ;;больше нет необходимости вызвать defgeneric
	       (defgeneric ,name))
       (,name-modify ',shablon-call
		    ;;тело метода модифицируем для возможности использовать call-next-method
		     ,(cond
		       ((eq? qual :primary)
			    `(lambda-m ,(cons chains-methods names-params)
			        (let* ((next-method-p (lambda () (not (null? (qm-get ,chains-methods :primary)))))
				           (call-next-method   (lambda ()
						                            (call-methods-rec ,chains-methods ,@names-params))))
			               ,@body))
			      )
		       ((eq? qual :around)
			     `(lambda-m ,(cons chains-methods names-params)
			         (let* ((next-method-p (lambda ()
						                       (or (not (null? (qm-get ,chains-methods :before)))
                                                   (not (null? (qm-get ,chains-methods :after)))
                                                   (not (null? (qm-get ,chains-methods :primary)))
							                       (not (null? (qm-get ,chains-methods :around))))))
				            (call-next-method   (lambda ()
						                           (call-methods-rec ,chains-methods ,@names-params))))
			                ,@body)))
		       (#t
       			`(lambda-m ,names-params
	         			   ,@body)
			      ))
		     ,qual))
    ))

Макрос определения метода обобщённой функции стал немного сложнее, в нё появилась обработка квалификаторов и в зависимости от квалификаторов в окружение создаваемой функции вносятся локально определяемые функции call-next-method и next-method-p. Именно они вызовуться когда вы в коде метода укажете проверку или вызов следующего по иерерахии метода. Но сама функция call-next-method является лишь обёрткой для функции call-methods-rec в которой и происходит вызов всего имеющегося комплекса методов, применимых для текущего набора типов аргументов.

Создание шаблонов типов параметров, шаблонов типов текущих аргументов и их предков совершенно не изменилось(и здесь не приводится). А функция filter-acceptable-methods фильтрации применимых методов и функции find-applicable-method, find-extreme потеряли свою актуальность. Зато на первый план выходит функция построения комплекса применимых методов build-applicable-methods.

(define (build-applicable-methods methods shablon)
  (let* ((shablon-parents (build-shablon-parents shablon))
	 (acceptable-methods-primary (build-acceptable-method-list (qualifier-methods-primary methods) shablon-parents))
	 (acceptable-methods-before  (build-acceptable-method-list (qualifier-methods-before  methods) shablon-parents))
	 (acceptable-methods-after   (build-acceptable-method-list (qualifier-methods-after   methods) shablon-parents))
	 (acceptable-methods-around  (build-acceptable-method-list (qualifier-methods-around  methods) shablon-parents))
	 (compare-func (make-compare-shablon-call shablon-parents))
	 (rez (qualifier-methods! '() '() '() '())))
    (qualifier-methods-around!  rez (sort-c compare-func acceptable-methods-around))
    (qualifier-methods-before!  rez (sort-c compare-func acceptable-methods-before))
    (qualifier-methods-primary! rez (sort-c compare-func acceptable-methods-primary))
    (qualifier-methods-after!   rez (reverse (sort-c compare-func acceptable-methods-after)))
    rez))

которая использует ранее уже описанные функции построения списка применимых методов build-acceptable-method-list(которая теперь применяется к различным по квалификаторам методам) и в отличии от предыдущего подхода, где искался один наилучший метод, сейчас происходит сортировка всех применимых методов, с помощью всё той же функции сравнения шаблонов, которая строиться с помощью функции make-compare-shablon-call. Конечно это долго и если такую работу надо было бы проводить при каждом вызове обобщённой функции, то проще было бы выкинуть этот проект в корзину и забыть, НО это кешируемая функция и в идеале(если не переопределять методы) она выполняется один раз при первом вызове обобщённой функции.

функции построения применимых методов и создания функции сравнения, для сортировки методов.

;;строит список приемлемых методов, т.е методов которые в принипе подходят под имеющиеся параметры.
(define-m (build-acceptable-method-list methods shablon-parents)
  (fold (lambda (prev x)
          (let ((shablon-methods (car x))
                (exclude-method   #f)
                (new-shablon     '()))
            (do ((cur-methods shablon-methods (cdr cur-methods))
                 (cur-parents shablon-parents (cdr cur-parents)))
                ((or exclude-method
                     (null? cur-methods)
                     (null? cur-parents))
                 (if exclude-method ;;выход из лямбды
                     prev
                     (if (and (null? cur-methods)
                              (null? cur-parents))
                         (cons (cons (reverse new-shablon) (cdr x) ) prev)
                         prev)))
              (if (eq? (car cur-methods) :unspec)  ;;тек аргумент в методе это класс!!
                  (set! new-shablon  (cons :unspec new-shablon))
                  (if (eq? (car cur-parents) :unspec)  ;;тек аргумент в вызове не имеет класса
                      (set! exclude-method #t)        ;;тогда метод не подходит!
                      (let ((find-in-parents
                             (find (lambda (v) (eq? (car v) (car cur-methods)))
                                   (car cur-parents))))
                        (if (cdr find-in-parents);;что то нашли в предках класс аргумента вызова
                            (set! new-shablon  (cons (car find-in-parents) new-shablon))
                            (set! exclude-method #t)))))))) ;;тогда метод не подходит
        '()
        methods)
  )

(define-m (make-compare-shablon-call shablon-parents)
  (lambda (cur-best pretendent)
    (let ((pretendent-the-best #f)
      (current-the-best    #f))
      (do ((f           (car cur-best)        (cdr f))
           (s           (car pretendent)      (cdr s))
           (cur-shablon shablon-parents (cdr cur-shablon)))
      ((or current-the-best
           pretendent-the-best
           (null? f)
           (null? s))
       (if pretendent-the-best
           #f
           #t))
    (cond ((and
        (eq? (car s) :unspec)
        (eq? (car f) :unspec))
           #f)
          ((eq? (car s) (car f))
           #f)
          ((eq? (car s) :unspec)
           (set! current-the-best #t))
          ((eq? (car f) :unspec)
           (set! pretendent-the-best #t))
          ((> (cdr (car s)) (cdr (car f)))
           (set! current-the-best #t))
          ((< (cdr (car s)) (cdr (car f)))
           (set! pretendent-the-best #t))
          (#t ;;= (cdr (car s)) (cdr (car f)) равенство по уровню,
           (let ((first (find (lambda (x) (or (eq? (car x) (car (car f))) (eq? (car x) (car (car s)))))
                  (car cur-shablon))))

         (when (cdr first)
           (if (eq? (car (car first)) (car (car s))) ;;касс перетендента первый в списке наследования?
               (set! pretendent-the-best #t)
               (set! current-the-best    #t)))
         )))
    ))))

А теперь опишем функции исполняющие полученный комплекс методов.

(define (has-run-method qm)
  (or (not (null? (qualifier-methods-around  qm)))
      (not (null? (qualifier-methods-before  qm)))
      (not (null? (qualifier-methods-primary qm)))
      (not (null? (qualifier-methods-after   qm)))))


(define (call-methods methods . params)
  (let* ((qm (qualifier-methods! (qualifier-methods-primary methods)
                                 (qualifier-methods-before  methods)
                                 (qualifier-methods-after   methods)
                                 (qualifier-methods-around  methods))))
    (apply call-methods-rec (cons qm params))))

;;ЛОГИКА: проверяем если есть методы окружения, вызываем первый из них
;;а он уже позаботиться о вызове всех остальных если это будет нужно
;; если нет такого метода переходим к нормальной обработке
;; сначала вызываем ВСЕ методы ДО, по цепочке
;; затем вызываем наилучший метод ПЕРВИЧНЫЙ, если ему будет нужно он вызовет дополнительные методы ПЕРВИЧНЫЕ
;; в конце вызываеме ВСЕ методы ПОСЛЕ
(define-m (call-methods-rec qm . params)
  (let ((rez  #f))
    (if (not (null? (qualifier-methods-around qm))) ;; если есть around методы то вызываем только их, пока они не кончатся через call-next-method
        (let ((tmp-cur (qualifier-methods-around qm)))
          (qualifier-methods-around! qm (cdr tmp-cur))
          (set! rez (apply (cadr (car tmp-cur)) (cons qm params))))
        (let ((tmp-cur (qualifier-methods-primary qm)))
          (unless (null? (qualifier-methods-before qm))
            (for-list (el (qualifier-methods-before qm))
                      (apply (cadr el) params))
            (qualifier-methods-before! qm '())) ;;мы исполнили всю цепочку методов before, цепочку обнуляем.
          (when (not (null? tmp-cur))
            (qualifier-methods-primary! qm (cdr tmp-cur))
            (set! rez (apply (cadr (car tmp-cur)) (cons qm params))))
          (unless (null? (qualifier-methods-after qm))
            (for-list (el (qualifier-methods-after qm))
                      ;;(prn "Call after: " (cadr el) "\n")
                      (apply (cadr el) params))
            (qualifier-methods-after! qm '())) ;;мы исполнили всю цепочку методов after, цепочку обнуляем.
          ))
    rez))

Назначение функции call-methods создать копию комплекса методов, т.к в процессе исполнения мы планируем менять эту структуру, а она у нас сохраняется в кеше, и если этого не сделать последующие вызовы этого комплекса будут неверными. И запустить обработку комплекса с помощью функции call-methods-rec. Она и отвечает за правильную последовательность вызова всего комплекса методов обобщённой функции. Эта функция активно и рекурсивно взаимодействует с функцией call-next-method, так что цепочка вызовов происходящая в ней может быть сложнее чем может показаться на первый взгляд.

И в принципе на этом ВСЁ!! Теперь можно посмотреть что у нас получилось.

Тестовый пример.

подготовка к работе, комманды которые надо дать в консоли Script-fu GIMP для загрузки библиотек.

;;(define path-home "D:")
(define path-home (getenv "HOME"))
(define path-lib (string-append path-home "/work/gimp/lib/"))
(define path-work (string-append path-home "/work/gimp/"))
(load (string-append path-lib "util.scm"))
(load (string-append path-lib "defun.scm"))
(load (string-append path-lib "struct2.scm"))
(load (string-append path-lib "storage.scm"))
(load (string-append path-lib "cyclic.scm"))
(load (string-append path-lib "hashtable3.scm")) ;;хеш который может работать с объектами в качестве ключей!!!
(load (string-append path-lib "sort2.scm"))
(load (string-append path-lib "tsort.scm"))
;;(load (string-append path-lib "cpl-sbcl.scm"))  ;;можно выбрать любую из функций упорядочения иерархии классов.
(load (string-append path-lib "cpl-mro.scm"))
;;(load (string-append path-lib "cpl-topext.scm"))
(load (string-append path-lib "struct2ext.scm"))
(load (string-append path-lib "queue.scm"))
(load (string-append path-lib "obj4.scm"))

В качестве примера приведу код из книги Пола Грэма "ANSI Common Lisp" стр.196. В нём используются различные типы методов и after, и before, и around.

(defclass speaker () ())

(defmethod (speak (s speaker) str)
  (prn str))

(speak (make-speaker) "I`m hungry")
;;I`m hungry

(defclass intellectual (speaker) ())

(defmethod  (:before speak  (i intellectual) string)
  (prn "Perhaps "))

(defmethod (:after speak  (i intellectual) string)
  (prn " in some sense"))


(speak (make-speaker) "I`m hungry") ;;I`m hungry
(speak (make-intellectual) "I`m hungry") ;;Perhaps I`m hungry in some sense

(defmethod (:before speak  (s speaker) string)
  (prn "I think "))

(speak (make-speaker) "I`m hungry")      ;;I think I`m hungry
(speak (make-intellectual) "I`m hungry") ;;Perhaps I think I`m hungry in some sense

(defclass courtier (speaker) ())

(defmethod (:around speak (c courtier) string)
  (prn "Does the King believe that " string "?")
  (if (eqv? read-val 'yes)
      (if (next-method-p) (call-next-method))
      (prn "Indeed, it is a preposterous idea.\n"))
  'bow)


;;здесь небольшое отличие у меня нет возможности в Script-fu получать ввод с консоли, поэтом заменю его простыми константами
(define read-val 'yes)

(speak (make-courtier) "kings will last") ;;Does the King believe that kings will last?I think kings will last bow

(define read-val 'no)

(speak (make-courtier) "the world is round")
;;Does the King believe that the world is round? Indeed, it is a preposterous idea.
;;bow

Наблюдаем сто процентное совпадение с кодом из лиспа.

Заключение

Описанная в этой статье функциональность на 90 процентов повторяет функциональность объектной системы CLOS, да здесь нет метаобъектного протокола, нет такого мощного синтаксиса описания объектов и вообще нет переменных класса. Нет выбора комбинаций методов обобщённой функции(это когда изменяют стандартный порядок выполнения методов).

Но нужна ли вообще эта функциональность? Описание инициализаторов полей вполне себе заменимо описанием в ручную создаваемым конструктором. Переменные классов, да иногда нужны и я их введу немного далее, это несложно. А комбинаторы методов это настолько странное явление, что нигде больше неиспользуется и вполне возможно было излишним при проектировании CLOS.

Вот пример использования комбинатора методов из книги Пола Грэма.

(defgeneric price (x)
   (:method-combination +))

(defclass jacket () ())
(defclass trousers () ())
(defclass suit (jacket trousers) ())

(defmethod price + ((jk jacket)) 350)
(defmethod price + ((tr trousers)) 200)

(price (make-instance ’suit))
>550

;; допустимые комбинаторы
;;+ and append list max min nconc or progn

Из кода видно, что вместо использования композиции программист пытается решить проблему наследованием. Костюм наследуется от жакета и брюк. После чего цена получается через сложение в комбинации методов. На мой взгляд это просто неверное проектное решение.

Вот как я переписал вышеприведённый пример через композицию.

(defgeneric price x)

(defclass priced () (price))
(defclass jacket (priced) ())
(defclass trousers (priced) ())
(defclass suit () 
   (jacket trousers))

(defmethod (price (p priced)) (vfield p :price))
;;(defmethod (price (jk jacket)) (vfield jk :price))
;;(defmethod (price (tr trousers)) (vfield tr :price))
(defmethod (price (s suit))
   (with-slots ((jacket trousers) s)
     (+ (price jacket) (price trousers))))

(define (suit! jk tr)
   (make-suit :jacket (make-jacket :price jk) :trousers (make-trousers :price tr)))

(price (suit! 350 200))
;;550

Элементы в описании класса suit переместились из списка наследования в список полей. Появился метод обрабатывающий цену для костюма. Также я написал функцию-конструктор инициализирующую поля. Таким образом если когда-нибудь, я встречусь с необходимостью введения комбинаторов методов, я возможно пересмотрю свои взгляды, а пока это решение меня вполне удовлетворяет.

GIMP Script-Fu ООП. Основной дизайн (а-ля CLOS)