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

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

Введение.

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

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

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

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

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

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

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