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

Введение

Готовя эту статью я интересовался, что там в других языках, что там за "дженерики"? Все языки разбирать не буду, но скажу одно: Generic function использующиеся в ЛИСПе и современые дженерики различаются как НЕБО и ЗЕМЛЯ. За дженерики в современных языках в основном ратуют строго типизированные языки, всем понятно, что писать кучу однотипного кода просто глупо. Не скажу точно, кто стоит у истоков современных "дженериков", но пожалуй одним из ранних их проявлений это ШАБЛОНЫ в С++. Почему все остальные языки типа явы и ей подобных, решили назвать свои шаблоны дженериками мне не понятно. (у меня есть язвительное замечание, что хотели как в лиспе, но получилось как всегда). Но дело в том что в ПОДОБНЫХ дженериках языки с динамической типизацией просто не нуждаются. Функция list работает с любыми типами данных, ШАБЛОНЫ не нужны! А в С++ именно контейнеры стали основной по��удительной силой использования дженериков, это просто хранилища которые хранят значения, если Си мы можем обойтись (void *) и потом привести тип к нужному, то С++ решил пойти по типобезопасному пути, ну немного "потолстев" в коде. Ну а что же там у современных его последователей?

Вот типичный дженерик, из Go

import "golang.org/x/exp/constraints"

func GMin[T constraints.Ordered](x, y T) T {
    if x < y {
        return x
    }
    return y
}

Пытаясь избавиться от типа, вводят обобщённую переменную T, но понимая что сделать то с ней ничего нельзя, пытаются как то её ТИПИЗИРОВАТЬ!!! Вводят КОНТРАКТ! А что делать когда в функции надо будет делать сложение? Надо будет к этому контракту добавить ещё контракт аддитиве? а умножение? или ещё что то? в любом случае код функции БЕДЕН! именно в силу того что мы не знаем что может прилететь нам в типе Т. Я вам расскжу что такое НАСТОЯЩИЕ ДЖЕНЕРИКИ.

Что такое Обобщённые функции(Дженерики) и для чего они нужны.

В предыдущей статье я описал проект и макросы создающие классы, а также несколько примеров их использования. Но пока наши классы "мертвы", в лучшем случае это структуры с иерархией. Что же может придать им "жизнь"? Конечно же это обобщённые функции(GENERIC FUNCTION). Что это такое? Обобщённые функции это функции меняющие своё поведение в зависимости от типов передаваемых в них аргументов. Но как они это делают? С помощью МЕТОДОВ!

Ну что бы лучше было понятно приведу простой пример, обобщённая функция plus.

(defgeneric plus x y)   ;;<-------- вот ОНО!!! объявление ДЖЕНЕРИКА!!!!

(defmethod (plus (x integer) (y integer))   ;; а это методы реализующие эту функцию для конкретных типов параметров.
    (+ x y))

(defmethod (plus (x string) (y string))
    (string-append x y))

(plus 1 2)
;; 3

(plus "Hello " "world!")
;; "Hello world!"

В "стандартных" объектных системах, где методы принадлежат классам, вызов какого либо метода, расценивают как "передачу сигнала объекту".

a.message(arg1 arg2);

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

(defgeneric mul x y)

(defmethod (mul (x scalar) (y vector))
    ....)

(defmethod (mul (x scalar) (y matrix))
    ....)

(defmethod (mul (x vector) (y matrix))
    ....)

(defmethod (mul (x matrix) (y vector))
    ....)

(defmethod (mul (x matrix) (y matrix))
    ....)

(mul (scalar! 23) (vector! 1 2 3))

(mul (vector! 1 2 3) (make-matrix-by-list '((1 2 3) (4 5 6)))

С точки зрения интерфейсов, обобщённая функция является интерфейсом с одной функцией(сразу вспоминайется принцип разделения интерфейсов).

Обобщённые функции могут работать с примитивными типами данных. И для их работы не нужны никакие классы. Но при такой работе отсутствует наследование и работа обобщённых функций примитивна. те. они теряют значительную часть своей функциональности.

В своём проекте я не использовал диспетчеризацию поведения обобщённых функций по примитивным типам данных. Но если есть желание создать полиморфное поведение на основе таких типов, надо создавать классы оболочки для примитивных типов и уже их описывать в качестве параметров методов ��бобщённых функций, ну или изменить диспетчер(это просто) для учёта примитивных данных.(в однои из последних статей об ООП я покажу как это сделать)

И хотя, как я показал, обобщённым функциям для своей работы не нужны никакие классы, зато классам для своей "жизни" очень нужны обобщёные функции. И в этой статье я опишу как внедрить функционал обобщённых функций в tinyscheme, а вернее в script-fu GIMP.

Макрос и функции создающие синтаксис описания обобщённых функций.

Как я уже писал мне бы хотелось определение обобщённой функции задавать в виде:

(defgeneric test-gen1 a b c d)

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

Макрос отвечающий за создание обобщённой функции, относительно прост:

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

(define-macro (defgeneric name . params)
  (let* (   ;;(required-params (trim-parameters params))
         (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-cache-methods  (make-symbol name "-get-cache-methods"))  ;;for debug
         (func         (gensym))
         (fnd-method   (gensym)))
    `(begin
       (define    ,name)
       (define    ,name-modify)
       (define    ,name-get-methods)
       (define    ,name-get-cache-methods)
       (let ((*methods-cache* (make-hash 32))
             (*methods*      '()))
     (set!  ,name (lambda-m ,params
            (let* ((,shablon-call (make-shablon-call-by-args ,@params))
                   (,cache-method  (hash-ref *methods-cache* ,shablon-call)))
              (if (car ,cache-method)
                  (begin
                ;;(prn "call cached method" (cadr ,cache-method))
                ((caddr ,cache-method) ,@params))
                  (let ((,applicable-method (find-applicable-method *methods* ,shablon-call)))
                (if ,applicable-method    ;;(((a1 . 0) (a2 . 0) :unspec) "method (a1 a2 :unspec)")
                    (begin
                      (hash-set! *methods-cache* ,shablon-call ,applicable-method)
                      ;;(prn "call method shablon: " (car  ,applicable-method) "\n")
                      ((cadr ,applicable-method) ,@params))
                    (error "Can't find applicable method: " ,name ", params: " ,@params))))
              )))
     (set! ,name-modify (lambda-m (,shablon-call ,func)
                  (if (> (hash-table-size *methods-cache*) 0)
                  (set! *methods-cache* (make-hash 32))) ;;просто сбросим кеш таблицу.
                  (let ((,fnd-method (find-method *methods* ,shablon-call)))
                (if (cdr ,fnd-method)
                    (set-cdr! (car ,fnd-method) (cons ,func '()))
                    (set! *methods* (cons (list ,shablon-call ,func) *methods*))))))
     (set! ,name-get-methods (lambda ()
                   *methods*))
     (set! ,name-get-cache-methods (lambda ()
                     *methods-cache*))
       ))))

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

в макросе мы определяем сразу четыре функции, определённые в общем локальном окружении, в котором заданы две переменные, общие для всех функций: methods-cache хеш-таблица хранящая все методы обобщённой функции, наиболее подходящии для конкретного набора типов входящих аргументов и methods список методов определённых для обобщённой функции. Первая ,name функция это сама обобщённая функция, её задача проста, выбрать наилучший применимый к данному набору параметров метод. Вторая функция ,name-modify добавляет или изменяет метод для определённого набора типов параметров. И ещё две вспомогательных функции, предназначеные для отладки и проверки состояния внутренних переменных обобщённой функции: ,name-get-methods и ,name-get-cache-methods.

Макрос отвечающий за определения метода для обобщённой функции использует фукцию ,name-modify и добавляет c её помощью к списку методов структуру содержащую шаблон вызова и сам метод. Шаблон вызова строиться по задаваемым в определении метода типам аргументов. В нашем случае это могут быть только типы классов.

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

(define-macro (defmethod start . body)
  (let* ((name   (car start))
     (params (cdr start))
     (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)))
    `(,name-modify ',shablon-call (lambda-m ,names-params ,@body))
    ))

;;создание шаблона вызова на основе списка параметров
(define (make-shablon-call-by-params  params)
  (let ((rez '()))
    (do ((cur params (cdr cur)))
        ((null? cur) (reverse rez))
      (set! rez (cons (if (list?    (car cur))
                          (cadr     (car cur))
                          :unspec) rez)))))

Чтобы обобщённая функция могла применить лучший, наиболее подходящий метод, при вызове обобщённая функция сначала определяет шаблон вызова(на основе типов каждого аргумента) с помощью make-shablon-call-by-args, затем либо извлекает подходящий метод из хеш-таблицы methods-cache, либо если такого набора типов аргументов нет, ищет наилучший применимый метод с помощью функции

`find-applicable-method`

(def-key :unspec)

;;создание шаблона вызова на основе типов аргументов функции
(define (make-shablon-call-by-args . args)
  (let ((rez '()))
    (do ((cur args (cdr cur)))
    ((null? cur) (reverse rez))
      (set! rez (cons (if (object?  (car cur))
              (type-obj (car cur))
              :unspec) rez)))))


(define (find-applicable-method methods shablon)
  (let* ((shablon-parents (build-shablon-parents shablon))
         (acceptable-method-list (build-acceptable-method-list methods shablon-parents))
         (compare-func (make-compare-shablon-call shablon-parents))
         (best (if (null? acceptable-method-list)
                   #f
                   (find-extreme compare-func
                       acceptable-method-list)) ))
    best))

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

build-acceptable-method-list и списки предшествующих классов

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

;; я буду хранить список предшествования классов в кеше (хеш-таблице), чтобы на расчитывать его при каждом обращении к функции.
(define *cache-class-precedence-list* #f)

;;при этом в макрос создания класса надо добавить функцию сброса и инициализации этого хеша.
 (define-macro (defclass . param)
     ....
   (let ((name      (car  param))
         ....)
     (let* ((parents-all (get-class-parents-all name))
	        ...)
	  ....
     `(begin
	    (set! *cache-class-precedence-list* #f) ;;сбрасываем кеш cpl
	    ,valid ,@getters ,@setters ,maker)
	 )))

;;в кеше cpl хранится два списка car это просто список cpl, а cdr это список пар классов из cpl с уровнем, как из get-class-parents-ordered
(define-m (get-class-precedence-list-all class)
  (when (not *cache-class-precedence-list*)
    (set! *cache-class-precedence-list* (make-hash 128)))
  (let ((find-cpl (hash-ref *cache-class-precedence-list* class)))
    (if (car find-cpl)
	(cdr find-cpl)
	(let* ((calc-cpl (compute-class-precedence-list class))
	       (ind      -1) ;;при этом первый элемент будет иметь индекс 0
	       (ord-cpl  (map (lambda (x) (set! ind (+ ind 1)) (cons x ind)) calc-cpl)))
	  (hash-set! *cache-class-precedence-list* class (cons calc-cpl ord-cpl))
	  (cons calc-cpl ord-cpl)))))

(define-m (get-class-precedence-list class)
  (car (get-class-precedence-list-all class)))

(define-m (get-class-precedence-list-with-level class)
  (cdr (get-class-precedence-list-all class)))

(define get-class-parents-ordered  get-class-precedence-list-with-level)


;;в шаблонах вызова, типизированные аргументы могут не совпадать!!!!!
(define (build-shablon-parents shablon)
  (let ((rez   '()))
    (for-list (cur shablon)
	      (if (eq? cur :unspec)
		  (push rez :unspec)
		  (push rez  (let  ((t1 (get-class-parents-ordered cur)))
			       (if t1
				   t1
				   '())))))
    (reverse rez)))

    
;;строит список приемлемых методов, т.е методов которые в принипе подходят под имеющиеся параметры.
(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))

а затем с помощью функции make-compare-shablon-call используя шаблон предков создаём функцию сравнивающую шаблон типов аргументов в вызове функции и шаблоны параметров из определений методов.

;make-compare-shablon-call

(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)
           (prn "(car s)  unspec \n"))
          ((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-m (find-extreme compare  lst)
  (fold (lambda (a b)
          (if (compare a b) a b))
         (car lst) (cdr lst)))

И в общем то на это ВСЁ!!! мы выполнили задачу поиска наиболее подходящего, для обработки вызова обобщённой функции, метода.

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

А теперь давайте посмотрим как это всё работает.

подготовка к работе, комманды которые надо дать в консоли 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 "obj3.scm"))

Теперь опишем тестовую иерархию классов.

тестовая иерархия классов.

(defclass a1 ()
  ( fa1-1))
(defclass b1 ()
  ((fb1-1 1)
   (fb1-2 2)
   (fb1-3 3)))
(defclass a2 (a1)
  ((fa2-1 'a)
   (fa2-2 2)
    fa2-3))
(defclass a3 (a1 b1)
  (fa3-1))
(defclass a4 (a2 a3)
  ((fa4-1 4)
   (fa4-2 5)))
(defclass a5 (a4 b1)
  ())
(defclass b2 (b1)
  ((fb2-1 4)))
(defclass b3 (b2)
  ((fb3-1 5)))
(defclass b4 (a4 a3 b3)
  ((fb4-1 6) fb4-2 (fb4-3 7)))

Давайте напишем первую обобщённую функцию и её методы для разных классов.

(defgeneric prn-obj o)

(defmethod (prn-obj (o a1))
  (prn "Obj type:" (type-obj o) "\n")
  (prn "fields:\n" "fa1-1: " (vfield o :fa1-1) "\n"))

Создадим тестовые объекты.

(define o1 (make-a1))
(define o11 (make-a1 :fa1-1 22))

(define o41 (make-a4 :fa1-1 42 :fa2-1 'b :fa2-3 43 :fa3-1 4))
(define o42 (make-a4 :fa1-1 51 :fa2-3 54 :fa3-1 55))

;;применение обобщённой функции
(for-list (o (list o1 o11 o41 o42))
   (prn-obj o))

результат

;; Obj type:a1
;; fields:
;; fa1-1: #f
;; Obj type:a1
;; fields:
;; fa1-1: 22
;; Obj type:a4
;; fields:
;; fa1-1: 42
;; Obj type:a4
;; fields:
;; fa1-1: 51

Обобщённая функция вызывает единственный метод для объекта класса и для его потомков. Определим ещё несколько методов для обобщённой функции.

(defmethod (prn-obj (o a2))
  (prn "Obj type:" (type-obj o) "\n")
  (prn "fields:\n" "fa1-1: " (vfield o :fa1-1) ", fa2-1: " (vfield o :fa2-1) ", fa2-2: " (vfield o :fa2-2) ", fa2-3: " (vfield o :fa2-3) "\n"))

(define o31 (make-a3 :fa1-1 42 :fa3-1 45))
(define o43 (make-a4 :fa1-1 42 :fa2-1 'b :fa2-3 43 :fa3-1 4 :fa4-1 'fa4val "fa4-2 13" ))

(defmethod (prn-obj (o a4))
  (prn "Obj type:" (type-obj o) "\n")
  (prn "fields:\n" "fa1-1: " (vfield o :fa1-1) ", fa2-1: " (vfield o :fa2-1) 
       ", fa2-2: "  (vfield o :fa2-2) ", fa2-3: " (vfield o :fa2-3)  ", fa3-1: " (vfield o :fa3-1) 
       ", fa4-1: " (vfield o :fa4-1) ", fa4-2: " (vfield o :fa4-2) "\n"))

(for-list (o (list o1 o11 o41 o42 o31 o43))
   (prn-obj o))

результат

Obj type:a1          <---метод для класса a1
fields:
fa1-1: #f
Obj type:a1          <---метод для класса a1
fields:
fa1-1: 22
Obj type:a4          <---метод для класса a4
fields:
fa1-1: 42, fa2-1: b, fa2-2: 2, fa2-3: 43, fa3-1: 4, fa4-1: 4, fa4-2: 5
Obj type:a4          <---метод для класса a4
fields:
fa1-1: 51, fa2-1: a, fa2-2: 2, fa2-3: 54, fa3-1: 55, fa4-1: 4, fa4-2: 5
Obj type:a3          <---метод для класса a2
fields:
fa1-1: 42
Obj type:a4          <---метод для класса a4
fields:
fa1-1: 42, fa2-1: b, fa2-2: 2, fa2-3: 43, fa3-1: 4, fa4-1: fa4val, fa4-2: 5

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

;;вызов обобщённой функции с объектом для типа которого нет неопределенного метода.
(define b11 (make-b1 :fb1-1 21 :fb1-3 23))

(prn-obj b11) ;;Error: Can't find applicable method:  #<CLOSURE> ", params: " #(b1 23 2 21)

Рассмотрим обобщённую функцию с двумя аргументами. при подготовке слегка изменим иерархию классов и заново переинициализируем тестовые объекты:

новая иерархия классов, добавили общий базовый класс и тестовые объекты

(defclass named ()
  (name))
(defclass a1 (named)
  ( fa1-1))
(defclass b1 (named)
  ((fb1-1 1)
   (fb1-2 2)
   (fb1-3 3)))
(defclass a2 (a1)
  ((fa2-1 'a)
   (fa2-2 2)
    fa2-3))
(defclass a3 (a1 b1)
  (fa3-1))
(defclass a4 (a2 a3)
  ((fa4-1 4)
   (fa4-2 5)))
(defclass a5 (a4 b1)
  ())
(defclass b2 (b1)
  ((fb2-1 4)))
(defclass b3 (b2)
  ((fb3-1 5)))
(defclass b4 (a4 a3 b3)
  ((fb4-1 6) fb4-2 (fb4-3 7)))

;;тестовые объекты
(define o1  (make-a1))
(define o11 (make-a1 :fa1-1 22))
(define o41 (make-a4 :fa1-1 42 :fa2-1 'b :fa2-3 43 :fa3-1 4))
(define o42 (make-a4 :fa1-1 51 :fa2-3 54 :fa3-1 55))
(define o31 (make-a3 :fa1-1 42 :fa3-1 45))
(define o43 (make-a4 :fa1-1 42 :fa2-1 'b :fa2-3 43 :fa3-1 4 :fa4-1 'fa4val "fa4-2 13" ))
(define b11 (make-b1 :fb1-1 21 :fb1-3 23))
(define b41 (make-b4 :fb1-1 21 :fb1-3 23))

;;нужно инициализировать имя для каждого объекта, небольшой макрохак.
(define-macro (named-obj obj)
  `(vfield! (eval ,obj) :name ,obj))

(for-list (o `(o1 o11 o41 o42 o31 o43 b11 b41))
	  (named-obj o))

Обобщённая функция связывающая два объекта.

(defgeneric message x y)
 ;; метод обрабатывающий самые базовые типы объектов.
(defmethod (message (x named) (y named))
  (prn "message from x: " (vfield x :name) " to y: " (vfield y :name) "\n"))

(message o1 o43)
;;message from x: o1 to y: o43

Добавим ещё методов

(defmethod (message (x a4) (y b1))
  (prn "message from x: " (vfield x :name) " to y: " (vfield y :name) "\n")
  (prn "x:\n")
  (prn-obj x)
  (prn "y:\n")
  (prn-obj y))


(defmethod (message (x named) (y b1))
  (prn "message from x: " (vfield x :name) " to y: " (vfield y :name) "\n")
  (prn "y:\n")
  (prn-obj y))

(defmethod (prn-obj (o named))
  (prn "Obj type:" (type-obj o) "\n")
  (prn "fields:\n" "name: " (vfield o :name) "\n"))

использование обобщённой функции двух аргументов.

(message o31 b41)
;; message (x named) (y b1) from x: o31 to y: b41
;; y:
;; Obj type:b4
;; fields:
;; fa1-1: #f, fa2-1: a, fa2-2: 2, fa2-3: #f

(message o41 b11)
;; message (x a4) (y b1) from x: o41 to y: b11
;; x:
;; Obj type:a4
;; fields:
;; fa1-1: 42, fa2-1: b, fa2-2: 2, fa2-3: 43
;; y:
;; Obj type:b1
;; fields:
;; name: b11

(message o41 b41)
;; message (x a4) (y b1) from x: o41 to y: b41
;; x:
;; Obj type:a4
;; fields:
;; fa1-1: 42, fa2-1: b, fa2-2: 2, fa2-3: 43
;; y:
;; Obj type:b4   ;;<---вызывается метод prn-obj для типа a4, а он тоже является потомком b1
;; fields:
;; fa1-1: #f, fa2-1: a, fa2-2: 2, fa2-3: #f

В последнем примере демонстрируется весьма странное поведение, мы описываем метод готовый принять объект типа b1, но передаём в него весьма далёкого его потомка b4, который в том числе и потомок a4 и когда мы применяем к нему также обобщённую функцию prn-obj, вызывается метод работающий для объектов потомков a4. Но с точки зрения вызова наилучших удовлетворяющих методов типам аргументов всё законно.

И на последок можно посмотреть, что теперь хранит наш кеш предшествования классов

(hash2pairs *cache-class-precedence-list*)
;; ((b4 (b4 a4 a2 a3 a1 b3 b2 b1 named)
;;      (b4 . 0) (a4 . 1) (a2 . 2) (a3 . 3) (a1 . 4) (b3 . 5) (b2 . 6) (b1 . 7) (named . 8))
;;  (a4 (a4 a2 a3 a1 b1 named) (a4 . 0) (a2 . 1) (a3 . 2) (a1 . 3) (b1 . 4) (named . 5))
;;  (a3 (a3 a1 b1 named) (a3 . 0) (a1 . 1) (b1 . 2) (named . 3))
;;  (b1 (b1 named) (b1 . 0) (named . 1))
;;  (a1 (a1 named) (a1 . 0) (named . 1)))

Заключение.

В данной статье рассмотрен пример описания и реализации обобщённых функций и методов реализующих поведение этих функций. Надеюсь в коде вы увидели, где используются алгоритмы упорядочения иерархий множественного наследования классов. Конечно это ещё не CLOS (это что то близкое к GOOPS-guile ООП), но здесь описан принцип построения диспетчеризации методов на основании типов(классов) аргументов обобщённой функции. И теперь я думаю становиться очевидным отличие ЛИСП интерпретации обобщённых функций от современных ШАБЛОННЫХ концепций обобщённых функций, а отличие простое, ОБОБЩЁННАЯ ФУНКЦИЯ ЛИСП имеет МНОЖЕСТВО методов реализующих её поведение, в то время как обобщённые шаблоны в современных ЯП имеют единственную реализацию - шаблон.

GIMP Script-Fu ООП. Обобщённые функции