Библиотека функций к 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 переместились из списка наследования в список полей. Появился метод обрабатывающий цену для костюма. Также я написал функцию-конструктор инициализирующую поля. Таким образом если когда нибудь, я встречусь с необходимостью введения комбинаторов методов, я возможно пересмотрю свои взгляды, а пока это решение меня вполне удовлетворяет.