Библиотека функций к Script-fu
Введение.
Прежде чем приступить к описанию реализации обобщённых функций, надо рассказать о основном алгоритме использующемся при выборе наиболее подходящего метода, при вызове обобщённой функции.
Наша система реализует множественное наследование, поэтому при вызове обобщённой функции надо реализовать какой то способ определяющий как построить иерархию родителей, от которых наследуются классы объектов используемых в качестве аргументов обобщённой функции и на основе этих иерархий выбрать метод наилучшим образом подходящий для данного набора аргументов.
Собственно выбрать наиболее подходящий метод просто, для каждого определяемого метода мы формируем шаблон классов параметров метода, а для каждого вызова, в обобщённой функции мы будем определять шаблон классов актуальных аргументов и этот шаблон мы сравниваем с шаблонами параметров методов. Сначала выбираем наиболее подходящие методы по первому аргументу, потом по второму, потом по третьему и т.д. Так мы выберем наиболее подходящий метод. Но, например для Питона, в котором классы владеют методами, выбор метода осуществляется только по одному объекту, классу которого принадлежит метод. Проблема в другом. Как упорядочить классы-предки для каждого конкретного аргумента-объекта? А в Питоне эта проблема решается с помощью MRO, хотя на самом деле это не упроядочение методов, всего лишь упорядочение классов, и если бы в питоне можно было указывать типы(классы) аргументов, то там так же был бы реализован более сложный алгоритм выбора метода, на основе типов всех аргументов, а не только типа объекта self.
Итак, нам надо каким то образом построить упорядоченный список классов по иерархии наследования, т.е свести граф к списку.
Для начала я решал эту проблему достаточно просто, с помощью функции
get-class-parents-all-ordered
(define-m (get-class-parents-all-ordered class)
(let ((in-rez (make-hash 6))
(rez '())
(stack-class (list class))
(cur-class nil)
(parents nil))
(repeat
(set! cur-class (pop stack-class))
(set! parents (class-parents cur-class))
(if (and (car parents) (list? (cdr parents)))
(let ((tmp-stack '()))
(for-list (el (cdr parents))
(unless (car (hash-ref in-rez el))
(push tmp-stack el)
(push rez el)
(hash-set! in-rez el #t)))
(for-list (el tmp-stack) ;;перекладываем элементы из временного стека в стек классов,
(push stack-class el)) ;;при этом меняется порядок, на нужный!
))
((empty? stack-class) (reverse rez)))))
Проверим как это работает:
загрузка библиотек
(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 "hashtable2.scm"))
(load (string-append path-lib "sort2.scm"))
(load (string-append path-lib "obj3.scm"))тестовая иерархия классов.
(defclass a1 ()
(fa1-1
(fa1-2 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)))Тестируем мой первый наивный подход к упорядочению классов.
(get-class-parents-all-ordered 'a3) ;;(a1 b1)
(get-class-parents-all-ordered 'a2) ;;(a1)
(get-class-parents-all-ordered 'b3) ;;(b2 b1)
(get-class-parents-all-ordered 'a4) ;;(a2 a3 a1 b1)
(get-class-parents-all-ordered 'a5) ;;(a4 b1 a2 a3 a1) - а это уже не правильно!!! b1 стоит впереди a3
При определении класса a5 программист(тестер, то бишь я) по неизвестной причине установил наследование от b1, который уже был в списке наследования и по идее должен предшествовать классу a3, но алгоритм выдал не верный результат. С одной стороны это можно называть "фитчей" позволяющей программисту изменять порядок предшествования классов и следовательно изменять порядок вызова функций. Но на самом деле во всех системах, что CLOS, что Python, такое поведение исказит логику работы методов для методов работающих с объектами родительских классов и работать в такой системе будет совершенно не возможно. Что же делать?
Стандартные алгоритмы упорядочения при использовании множественного наследования.
Собственно проблема состоит в том чтобы "правильно" выстроить последовательность классов, входящих в иерархию наследования. Эта проблема возникает в любой системе использующей множественное наследования. Когда эта проблема решена, можно точно сказать, какой класс следует за каким, а следовательно, в таких системах как Питон, выбрать и соответствующий иерархии наследования вызываемый метод.
В CLOS SBCL есть файл: ../sbcl-2.2.8/src/pcl/cpl.lisp. В нём реализован алгоритм упорядочивающий классы в иерархии наследования. Мне он показался слишком сложным(и это на самом деле так), поэтому я попытался реализовать алгоритм работающий "почти также" как и алгоритм из CLOS, я назвал его "метод расширения графа наследования". Но прежде чем приступить к его описанию, расскажу, каким основным требованиям должна удовлетворять функция упорядочивания классов в иерархии наследования.
Класс всегда имеет приоритет над своими суперклассами.
Каждое определение класса устанавливает порядок приоритета своих прямых суперклассов.
CLOS пытается сохранить генеалогические древа вместе в списке приоритетов классов.
Первое правило думаю понятно, потомок(наследник) всегда ставиться первее своих родителей и так по всей иерархии наследования. Если бы дело ограничивалось только этим правилом, можно было бы к иерархии классов применить обычный алгоритм топологической сортировки и на этом закончить.
Вот собственно одина из реализаций алгоритма топологической сортировки:
(define (topological-sort-dfs vertices graph)
(let (;;(vertices (get-graph-vertices graph))
(visited (make-hash 16))
(temp-mark (make-hash 16))
(rez '())
(topological-sort-util nil))
(set! topological-sort-util (lambda (v)
(unless (car (hash-ref visited v))
(when (car (hash-ref temp-mark v))
(throw "have cycle!!!\n"))
(hash-set! temp-mark v #t)
(let ((near-v (hash-ref graph v)))
(for-list (u (reverse (cdr near-v)))
(topological-sort-util u)))
(hash-set! visited v #t)
(hash-del! temp-mark v)
(push rez v))))
(catch (begin (display "Error in topological-sort-dfs - have cycle!\n") '())
(for-list (v vertices)
(unless (car (hash-ref visited v))
(topological-sort-util v)))
rez)
));пример использования топологической сортировки.
(define-m (compute-class-precedence-list-topsort cls)
(topological-sort-dfs (get-class-parents-all-ordered cls) *class-hierarhy*))
(compute-class-precedence-list-topsort 'a5) ;;(a4 a2 a3 a1 b1)
(compute-class-precedence-list-topsort 'b4) ;;(b3 b2 a4 a2 a3 a1 b1)И это не очень хороший результат, потому что непонятно почему в b4 класс b3 стоит выше a4. Это интуитивно не понятно, т.к в определении класса у нас установлено (defclass b4 (a4 a3 b3). И это как раз то место где должно в дело вступать второе правило приоритизации классов. И чтобы его соблюсти я придумал очень простой способ, нужно просто перед топологической сортировкой добавить в иерархию наследования добавочные зависимости, так сказать расширить граф наследования, чтобы явно указать то, что уже не явно указано в определении класса. Напомню что граф наследования у нас это хеш таблица где ключ это имя определяемого класса, а значения это список родителей, перенесённый туда из определения класса. Таким образом расширив иерархию наследованя мы дадим функции топологической сортировки новые данные о зависимостях и она упорядочит наш граф в соответствии с 1 и 2 правилами.
;функциональная обвязка для работы алгоритма расширения графа наследования
;;нужно быстро определять длина списка больше 1, т.е 2 и выше или нет.
(define (len-more-1? l)
(not (or (null? l) (null? (cdr l)))))
;;копирует иерархию классов, но только ту, которые есть в списке классв.
(define-m (copy-class-hierarhy lst-class class-hierarhy)
(let ((rez (make-hash 16))
(tmp-base #f))
(for-list (el lst-class)
(set! tmp-base (hash-ref class-hierarhy el))
(if (car tmp-base)
(hash-set! rez el (cdr tmp-base))
(hash-set! rez el '())))
rez))
;;функция получающая список всех классов предков, отвязанная от переменной *class-hierarchy*
(define-m (get-class-parents-all-for-hierarhy class class-hierarhy)
(let ((rez (make-hash 6))
(stack-class (list class))
(cur-class nil)
(parents nil))
;;(prn "in get-class-parents-all: " class "\n")
(repeat
(set! cur-class (pop stack-class))
(set! parents (hash-ref class-hierarhy cur-class))
;;(prn parents "\n")
(if (and (car parents) (list? (cdr parents)))
;;(prn (cdr parents) "\n")
(for-list (el (cdr parents))
(push stack-class el)
(hash-set! rez el #t)))
((empty? stack-class) (hash-keys rez)))))
;;сгенерировать все сочетания пар элементов из списка.
(define-m (comb-pairs-by-list lst)
(let ((rez '()))
(do ((cur lst (cdr cur)))
((null? (cdr cur)) (reverse rez))
(for-list (second (cdr cur))
(push rez (cons (car cur) second)))
)))
вот этот вариант вычисления списка предшествования классов.
;;функция расширяющая граф зависимостей наследования классов, на основе порядка следования классов в определении класса
(define-m (extend-class-hierarhy lst-class class-hierarhy)
(let ((tmp-base #f)
(cur-car-comb #f)
(cur-based #f)
(cur-precedence #f))
(for-list (el lst-class)
(set! tmp-base (hash-ref class-hierarhy el))
(when (and (car tmp-base) (len-more-1? (cdr tmp-base)))
(for-list (comb (comb-pairs-by-list (cdr tmp-base)))
(unless (eq? cur-car-comb (car comb)) ;;небольшое кеширование, чтобы не выполнять несколько поисков по хешу
(set! cur-car-comb (car comb)) ;;для повторяющихся элементов
(set! cur-based (cdr (hash-ref class-hierarhy cur-car-comb)));;классы должны быть в хеше, поэтому результат поиска не проверяем
(set! cur-precedence (get-class-parents-all-for-hierarhy cur-car-comb class-hierarhy)))
(unless (memq cur-car-comb (get-class-parents-all-for-hierarhy (cdr comb) class-hierarhy))
;;первого класса нет в списке базовых для второго класса. можно добавлять второй в списко предшеств. первого
(unless (memq (cdr comb) cur-precedence) ;;но добавляем только если второго ещё нет в списке предшеств. первого.
(set! cur-based (cons (cdr comb) cur-based))
(set! cur-precedence (cons (cdr comb) cur-precedence))
(hash-set! class-hierarhy cur-car-comb cur-based))))
))
class-hierarhy))Мы предварительно отделяем часть иерархии наследования в отдельную иерархию и уже расришяем только её. Алгоритм отлично работает, но не сохраняет генеалогичность деревьев, т.е выполняет правила 1 и 2, но не 3!
Что такое генеалогичность деревьев? Это ситуция в иерархии наследования, когда имеются некоторые длинные цепочки наследования, когда одни классы следуют за другими некоторыми цепочками, и эту цепочку следования желательно в результирующем упорядочивании сохранить вместе, неразрывной(в той мере в которой это возможно).
Вот пример ярко выраженной генеалогичности в иерархии наследования:
Здесь отчетливо видны 3 линии генеалогичности(три длинные цепочки), которые желательно сохранить в результирующем упорядочении.
Чтобы учитывать генеалогичность, я немного изменил алгоритм расширения графа иерархии, и добавил ещё одну фазу - добавления генеалогичности.
(define-m (extend-class-hierarhy lst-class class-hierarhy)
(let ((tmp-base #f)
(cur-car-comb #f)
(cur-based #f)
(cur-precedence #f))
(set! *output-graphvz* '())
;;(save-for-output-graphvz (copy-hashtbl class-hierarhy :copy-value copy-list))
(for-list (el (reverse (topological-sort-dfs lst-class class-hierarhy))) ;;сначала проходим по иерархии и учитываем предшествование классов в объявлениях классов.
(set! tmp-base (hash-ref class-hierarhy el))
(when (and (car tmp-base) (len-more-1? (cdr tmp-base)))
(for-list (comb (comb-pairs-by-list (cdr tmp-base)))
(unless (eq? cur-car-comb (car comb)) ;;небольшое кеширование, чтобы не выполнять несколько поисков по хешу
(set! cur-car-comb (car comb)) ;;для повторяющихся элементов
(set! cur-based (cdr (hash-ref class-hierarhy cur-car-comb)));;классы в хеше, поэтому результат поиска не проверяем
(set! cur-precedence (get-class-parents-all-for-hierarhy cur-car-comb class-hierarhy)))
(let ((parents-cdr-comb (get-class-parents-all-for-hierarhy (cdr comb) class-hierarhy)))
(unless (memq cur-car-comb parents-cdr-comb)
;;первого класса нет в списке базовых для второго класса. можно добавлять второй в список предшеств. первого
(unless (memq (cdr comb) cur-precedence) ;;но добавляем только если второго ещё нет в списке предшеств. первого.
(set! cur-based (append cur-based (cons (cdr comb) nil)))
(set! cur-precedence (cons (cdr comb) cur-precedence))
(hash-set! class-hierarhy cur-car-comb cur-based))
)))))
;;(save-for-output-graphvz (copy-hashtbl class-hierarhy :copy-value copy-list))
;;после того как предшествование учтено, попробуем учесть генеалогию,
(for-list (el lst-class) ;;обходим так же как и раньше но с учётом добавленного предшествования
(set! tmp-base (hash-ref class-hierarhy el))
(when (and (car tmp-base) (len-more-1? (cdr tmp-base)))
(for-list (comb (comb-pairs-by-list (cdr tmp-base)))
(unless (eq? cur-car-comb (car comb)) ;;небольшое кеширование, чтобы не выполнять несколько поисков по хешу
(set! cur-car-comb (car comb)) ;;для повторяющихся элементов
(set! cur-based (cdr (hash-ref class-hierarhy cur-car-comb)));;классы в хеше, поэтому результат поиска не проверяем
(set! cur-precedence (get-class-parents-all-for-hierarhy cur-car-comb class-hierarhy)))
(let ((parents-cdr-comb (get-class-parents-all-for-hierarhy (cdr comb) class-hierarhy)))
(unless (memq cur-car-comb parents-cdr-comb) ;;тек. эл. car-comb не входит в число предков
(when (memq (cdr comb) cur-precedence) ;;второй класс уже добавили в список предшествования для первого класса.
(for-list (parent-car-comb cur-precedence) ;;для сохранения генеалогичности проверим каждого родителя первого класса
(unless (or (eq? parent-car-comb (cdr comb))
(memq parent-car-comb parents-cdr-comb)) ;;если родителя нет в списке наследования второго класса то:
;;можно родителю добавлять второй класс в список предшеств.
(unless (memq (cdr comb) (get-class-parents-all-for-hierarhy parent-car-comb class-hierarhy))
;;но добавляем только если второго ещё нет в списке предшеств. родителя.
(hash-set! class-hierarhy parent-car-comb (cons (cdr comb) (cdr (hash-ref class-hierarhy parent-car-comb))))
)))))))))
;;(save-for-output-graphvz (copy-hashtbl class-hierarhy :copy-value copy-list))
class-hierarhy))В коде есть несколько закоменнтированных строк вызова save-for-output-graphvz, эта функция снимает моментальный снимок(копию) получающейся иерархии, он нужен для визуализации получающегося графа с помощью graphvz. Думаю код не надо дополнительно комментировать, комментариев там достаточно, могу лишь заметить, что второй этап в значительной степени повторяет первый, только при первом расширяется граф иерархии отражая 2е правило, а на втором 3е. Но совмещать их нельзя, т.к будет нарушен приоритет установленных правил, это значительно снижает производительность алгоритма, но зачем нам быстрый алгоритм, работающий неправильно?
Итоговая функция получающая упорядоченный список предшествования классов:
(define-m (compute-class-precedence-list-topext cls)
(let* ((lst-class (cons cls (get-class-parents-all cls)))
(copy-hierarhy (copy-class-hierarhy lst-class *class-hierarhy*))
(ext-hierarchy (extend-class-hierarhy lst-class copy-hierarhy)))
(topological-sort-dfs lst-class ext-hierarchy)))Использование Graphvz для визуализации иерархии наследования.
Для демонстрации работы алгоритма расширения топологии иерерхии наследования я решил использовать пакет graphvz. Поэтому для вывода иерерхии класса я использую функцию class-to-graphvz. Она создаёт файл и код командной строки, выполнение которого привёдёт к созданию файла изображения графа.
(define-m (class-to-pairs cls)
(let* ((lst-class (cons cls (get-class-parents-all cls)))
(class-hierarhy (copy-class-hierarhy lst-class *class-hierarhy*))
(lst (hash2pairs class-hierarhy))
(rez '()))
(for-list (p lst)
(do ((parents (cdr p) (cdr parents)))
((null? parents) rez)
(set! rez (cons (cons (car p) (car parents)) rez))))
rez))
(define-m (class-to-graphvz cls file)
(with-output-to-file (string-append file ".gv")
(lambda ()
(prn "digraph G{\n")
;;(prn " rankdir=RL;\n")
(prn " rankdir=LR;\n")
(for-list (p (class-to-pairs cls))
(prn " " (car p) " -> " (cdr p) ";\n"))
(prn "}\n")))
(join-to-str "dot -Tpng " file ".gv -o " file ".png" ))Но функция class-to-graphvz рисует обычную иерархию наследования для класса. А для демонстрации работы алгоритма в код функции extend-class-hierarhy я встраивал несколько вызвов функции save-for-output-graphvz создающей последовательные снимки изменяющейся топологии. Далее дело техники, функция classext-to-graphvz обрабатывает эти снимки и расширяет граф новыми рёбрами: рёбра отображаемые чёрточками это рёбра добавляемые на 1 этапе, отражающие следования родителей в определении класса, а рёбра отображаемые точками это рёбра добавляемые на 2 этапе, отражающие зависимости накладываемые для учёта генеалогичности.
classext-to-graphvz
;;данные берём из переменной *output-graphvz*
(define-m (classext-to-graphvz lst-graph file)
(let ((first-graph (classgraph-to-onepoint-graph (caddr lst-graph)))
(ext-graph (classgraph-to-onepoint-graph (cadr lst-graph)))
(gen-graph (classgraph-to-onepoint-graph (car lst-graph))))
(with-output-to-file (string-append file ".gv")
(lambda ()
(prn "digraph G{\n")
;;(prn " rankdir=RL;\n")
(prn " rankdir=LR;\n")
(for-list (p (hash2pairs first-graph))
(prn " " (car (car p)) " -> " (cadr (car p)) ";\n"))
(for-list (p (hash2pairs ext-graph))
(unless (car (hash-ref first-graph (car p)))
(prn " " (car (car p)) " -> " (cadr (car p)) " [style=dashed];\n")))
(for-list (p (hash2pairs gen-graph))
(unless (car (hash-ref ext-graph (car p)))
(prn " " (car (car p)) " -> " (cadr (car p)) " [style=dotted];\n")))
(prn "}\n")))
(join-to-str "dot -Tpng " file ".gv -o " file ".png" )))
(define-m (classgraph-to-pairs gr)
(let* ((lst (hash2pairs gr))
(rez '()))
(for-list (p lst)
(do ((parents (cdr p) (cdr parents)))
((null? parents) rez)
(set! rez (cons (cons (car p) (car parents)) rez))))
rez))
;; создаёт хештаблицу гдле ключ это список из двух точек графа исходяще и входящей, а значение любое, хотябы #t, главное
;;чтобы дублей небыло.
(define-m (classgraph-to-onepoint-graph gr)
(let* ((lst (hash2pairs gr))
(rez (make-hash (* 2 (length lst)))))
(for-list (p lst)
(do ((parents (cdr p) (cdr parents)))
((null? parents) rez)
(hash-set! rez (list (car p) (car parents)) #t)))
rez))Пример использования команды dot из grapthvz:
;; создать файл иерархии наследования для класса q для graphvz
(class-to-graphvz 'a (string-append path-work "/doc/oop/" "gr04"))
"dot -Tpng ../work/gimp//doc/oop/gr04.gv -o ../work/gimp//doc/oop/gr04.png"
;;в коммандной строке выполняем комманду
bash>dot -Tpng ../work/gimp//doc/oop/gr04.gv -o ../work/gimp//doc/oop/gr04.png
(compute-class-precedence-list 'a) ;;необходимо сначала сформировать кадры шагов алгоритма расширения графа иерархии наследования
(classext-to-graphvz *output-graphvz* (string-append path-work "doc/oop/" "gr04t"))
"dot -Tpng ../work/gimp/doc/oop/gr04t.gv -o ../work/gimp/doc/oop/gr04t.png"
bash>dot -Tpng ../work/gimp/doc/oop/gr04t.gv -o ../work/gimp/doc/oop/gr04t.pngТаким образом вызвав class-to-graphvz, мы получим обычный граф иерархии наследования, а после вызова compute-class-precedence-list иы используя функцию classext-to-graphvz сможем увидеть расширенный граф иерархии наследования.
Но прежде чем приступить к тестированию алгоритма, посмотрим: а что же у нас уже есть из готовых алгоритмов.
MRO или С3
В питоне для реализации MRO(определение порядка следования методов) используется используется алгоритма C3-линеаризации суперкласса. Алгоритм должен удовлетворять следующим условиям: устойчивый и расширяющийся по старшинству граф, сохранение локального порядка старшинства, а также монотонность. И хотя слова в требованиях отличны от слов предявляемых к требованям алгоритма CLOS, по факту это всё те же 3 требования(на самом деле это "ясно" можно увидеть из сравнительных тестов). Но сам алгоритм действительно отличается от алгоритма CLOS(который приведён далее). Алгоритм основан на функции слияния упорядоченных списков классов. При этом слияние начинается с самых базовых классов и заканчивается слиянием списков подклассов класса для которого и выполняется линеаризация. Вот как он выглядит на Script-fu:
;;реализация алгоритма линеаризации иерархии классов C3 лежащего в основе mro из питона.
(define-m (merge-class-list seqs)
;;(prn "in merge-class-list, args: " seqs "\n")
(let ((rez '())
(cand #f))
(do ((nonemptyseqs (remove-if null? seqs) (remove-if null? (map (lambda (l) (if (eq? (car l) cand)
(cdr l)
l))
nonemptyseqs))))
((null? nonemptyseqs) (reverse rez))
(with-break
(for-list (seq nonemptyseqs)
(set! cand (car seq))
(if (cdr (find (lambda (clst) (memq cand clst)) (map cdr nonemptyseqs)))
(set! cand #f)
(break #f))))
(unless cand
(throw (join-to-str "error in: `merge-class-list` - Inconsistent hierarchy in: " seqs "\n")))
(push rez cand)
)))
(define-m (mro cls)
(let ((parents (cdr (class-parents cls))))
(merge-class-list (append (list (list cls))
(map mro parents)
(list parents)))))Это очень простой алгоритм(хотя он порождает очень сложный рекурсивный процесс), и хотя в данном виде он выполняет много лишней работы его достоинство состоит в том, что он хорошо кешируется. И если это сделать, то не нужно будет для каждого класса выполнять множество шагов по упорядочиванию иерархии классов с нуля, как это просиходит в алгоритмах CLOS.
Ну из примечательного здесь использование конструкции with-break. Это очень интересный макрос, он создает в окружении внутреннего кода, функцию break, предназначенную для быстрого выхода из выполняемого кода. Т.е. у меня есть много макросов в частности циклов, из которых невозможно выйти пока не будет выполнен весь цикл, их можно переписать и добавить туда такую возможность, но можно используя внутренний механизм Scheme по работе с продолжениями, написать такие функции как break которые восстанавливают созданное в момент вызова with-break продолжение, и цикл или какой либо другой код - прерываются и начинает выполняться это продолжение, т.е код следующий за with-break(поэтому они так и называются - продложениями). Это очень удобный механизм, через него также реализуются и исключения throw.
CLASS-PRECEDENCE-LIST из SBCL
Теперь разберём алгоритм определения списка предшествования классов из SBCL.
Алгоритм упорядочения иерархии классов из CLOS SBCL использует структуру cpd - class precedence description. Сохраняя в ней класс, его прямых предков, а так же предков которые точно должны стоять перед классом(т.е прямые предки и ещё какие то про которых достоверно известно, что они тоже предки этого класса) и счётчик.
;;class precedence description
(struct cpd (class supers after count))
(define-m (compute-cpl-sbcl root)
(compute-std-cpl root (cdr (class-parents root))))
(define-m (compute-std-cpl class supers)
(cond
((null? supers)
(list class))
((and (car supers)
(null? (cdr supers)))
(cons class (compute-std-cpl (car supers) (cdr (class-parents (car supers))))))
(#t
(let* ((all-cpds-nclasses (compute-std-cpl-phase1 class supers))
(all-cpds (compute-std-cpl-phase2 (car all-cpds-nclasses))))
(compute-std-cpl-phase3 class all-cpds (cdr all-cpds-nclasses))
))))Как видно основной алгоритм состоит из 3 этапов(предварительный рекурсивный цикл используется для простейших случаев наследования). На первом этапе создаётся список дескрипторов классов, для всех классов входящих в иерархию наследования, функция compute-std-cpl-phase1 и ещё подсчитывается число этих классов.
`compute-std-cpl-phase1`
;;строит список структур cpd для каждого класса
(define-m (compute-std-cpl-phase1 class supers)
(let ((nclasses 0)
(all-cpds '())
(table (make-hash 12)))
(let* ((get-cpd (lambda (c)
(let ((cpd (hash-ref table c)))
(if (car cpd)
(cdr cpd)
(let ((tmp (cpd! #f '() '() 0)))
(hash-set! table c tmp)
tmp)))))
(walk (lambda (c supers)
(let ((cpd (get-cpd c)))
(unless (cpd-class cpd)
(cpd-class! cpd c)
(set! nclasses (+ 1 nclasses))
(push all-cpds cpd)
(cpd-supers! cpd (map get-cpd supers))
(for-list (super supers)
(walk super (cdr (class-parents super)))))))))
(walk class supers)
(cons all-cpds nclasses))))На втором этапе, для каждого класса помещаем в последующие его непосредственных предков, а потом для каждого непосредственного предка, помещаем в последующие следующий за ним класс. Т.е сначала для базового класса, первого предка из списка наследования, а затем первому предку в последующие допбавляется второй предок, третьему-четвёрты, и так далее пока непосредственные предки не закончатся. При этом увеличивается счётчик, при добавлении первого предка на 1, а при добавлении второго предка первому(и т.д) на 2.
compute-std-cpl-phase2
(define-m (compute-std-cpl-phase2 all-cpds)
(cpds-prn all-cpds)
(for-list (cpd all-cpds)
(let ((supers (cpd-supers cpd)))
(when (pair? supers)
(cpd-after! cpd (append (cpd-after cpd) supers)) ;;непосредств. предков добавляем к последующим
(cpd-count! (car supers) (+ 1 (cpd-count (car supers)))) ;;первому непосредственному предку добавим 1
(do ((t1 supers (cdr t1))) ;;для каждого предка начиная со второго
((null? (cdr t1))) ;;
(cpd-count! (cadr t1) (+ 2 (cpd-count (cadr t1)))) ;;добавляем 2
(cpd-after! (car t1) (cons (cadr t1) (cpd-after (car t1))))) ;;доб. к текущему в последующие следующий.
)))
all-cpds)
Заключительный этап создающий упорядочение вначале создаёт список кандидатов, с нулевым счётчиком предшествования и запускает цикл, работающий пока есть кандидаты на упорядочение и счётчик подлежащих упорядочению классов не является нулевым. На каждом шагу из списка кандидатов выбирается один наиболее достойный и переводится в список упорядочения. Выбранный удаляется из списка кандидатов, и в конце цикла, если у потомков выбранного класса есть классы подходящие в кандидаты, то список кандидатов расширяется ими.
compute-std-cpl-phase3
(define-m (compute-std-cpl-phase3 class all-cpds nclasses)
(cpds-prn all-cpds)
(let ((candidates '())
(next-cpd #f)
(rcpl '()))
(for-list (cpd all-cpds)
(when (zero? (cpd-count cpd))
(push candidates cpd)))
(do ()
((and (null? candidates)
(zero? nclasses)) (reverse rcpl))
(when (null? candidates)
(throw (join-to-str "Error in: compute-std-cpl-phase3 for class: " class "\n")))
(if (null? (cdr candidates))
(begin ;;остался один кандидат
(set! next-cpd (car candidates))
(set! candidates '()))
(set! next-cpd ;;кандидатов много, что делать?
(with-break ;;tie-breaker
(for-list (c rcpl) ;;для каждого класса из уже выбранных
(let ((supers (cdr (class-parents c)))) ;;выберем непосредственных предков.
(if (memq (cpd-class (car candidates)) supers) ;;если первый кандидат в предках
(break (pop candidates)) ;;он будет следующим cpd
(do ((loc candidates (cdr loc)))
((null? (cdr loc))) ;;?????
(let ((cpd (cadr loc))) ;;начианя со 2 cpd проверяем
(when (memq (cpd-class cpd) supers) ;;не является ли он непосредственным предком.
(set-cdr! loc (cddr loc)) ;;если да удаляем его из списка кандидатов
(break cpd)))))))))) ;; и он будет следующим cpd
(set! nclasses (- nclasses 1))
(push rcpl (cpd-class next-cpd))
(for-list (after (cpd-after next-cpd)) ;;для всех кто был предком выбранного cpd
(cpd-count! after (- (cpd-count after) 1)) ;;уменьшаем счетчик
(when (zero? (cpd-count after))
(push candidates after))) ;;у кого счётчик ноль будет кандидатом
)))
Несмотря на то, что я не до конца понял принцип назначения весов счётчика в cpd алгоритм из sbcl я перенёс в схему достаточно точно, так что его можно использовать на равне с mro и алгоритмом расширения топологии.
Тестирование.
Тестирование в данном случае преследует цель проверить корректность работы алгоритмов и соотвествие их реализации алгоритма вычисления списка предшествования классов в CLOS. Поэтому выбрана достаточно(с моей точки зрения) широкая линейка иерархий классов. Скорость алгоритмов в данном случае не так важна, хотя и желательна.
Пример простой иерархии классов:
;; gr01
(defclass a () ())
(defclass b () ())
(defclass c () ())
(defclass d () ())
(defclass s (a b) ())
(defclass r (c d) ())
(defclass q (s r) ())
;;упорядочение иерархии различными алгоритмами
(compute-class-precedence-list 'q) ;;(q s a b r c d)
(mro 'q) ;;(q s a b r c d)
(compute-cpl-sbcl 'q) ;;(q s a b r c d)
Граф получающийся в алгоритме расширения графа иерархии.
В этом примере все три алгоритма дают одинаковые результаты.
Пример генеалогичной иерархии классов:
;; gr02
(defclass d1 () ())
(defclass d (d1) ())
(defclass b3 (d) ())
(defclass b2 (b3) ())
(defclass b1 (b2) ())
(defclass b (b1) ())
(defclass c3 (d) ())
(defclass c2 (c3) ())
(defclass c1 (c2) ())
(defclass c (c1) ())
(defclass a (b c) ())
(compute-class-precedence-list 'a) ;;(a b b1 b2 b3 c c1 c2 c3 d d1)
(mro 'a) ;;(a b b1 b2 b3 c c1 c2 c3 d d1)
(compute-cpl-sbcl 'a) ;;(a b b1 b2 b3 c c1 c2 c3 d d1)
Граф получающийся в алгоритме расширения графа иерархии.
Пример вложенной генеалогичности в иерархии классов:
;; gr02-1
(defclass d1 () ())
(defclass d (d1) ())
(defclass b3 (d) ())
(defclass b2a2 (b3) ())
(defclass b2a1 (b2a2) ())
(defclass b2a (b2a1) ())
(defclass b2b (b3) ())
(defclass b1 (b2a b2b) ())
(defclass b (b1) ())
(defclass c3 (d) ())
(defclass c2 (c3) ())
(defclass c1 (c2) ())
(defclass c (c1) ())
(defclass a (b c) ())
(compute-class-precedence-list 'a) ;;(a b b1 b2a b2a1 b2a2 b2b b3 c c1 c2 c3 d d1)
(mro 'a) ;;(a b b1 b2a b2a1 b2a2 b2b b3 c c1 c2 c3 d d1)
(compute-cpl-sbcl 'a) ;;(a b b1 b2a b2a1 b2a2 b2b b3 c c1 c2 c3 d d1)Граф получающийся в алгоритме расширения графа иерархии.
Пример разрушенной генеалогичности(смешанным наследованием) в иерархии классов:
;; gr03
(defclass d1 () ())
(defclass d (d1) ())
(defclass b3 (d) ())
(defclass b2 (b3) ())
(defclass b1 (b2) ())
(defclass b (b1 c2) ())
(defclass c3 (d) ())
(defclass c2 (c3) ())
(defclass c1 (c2) ())
(defclass c (c1) ())
(defclass a (b c) ())
(compute-class-precedence-list 'a) ;;(a b b1 b2 b3 c c1 c2 c3 d d1)
(mro 'a) ;;(a b b1 b2 b3 c c1 c2 c3 d d1)
(compute-cpl-sbcl 'a) ;;(a b b1 b2 b3 c c1 c2 c3 d d1)
Граф получающийся в алгоритме расширения графа иерархии.
Пример сложной генеалогичности в иерархии классов:
;; gr04
(defclass f2 () ())
(defclass f1 (f2) ())
(defclass f (f1) ())
(defclass d2 (f) ())
(defclass d1 (d2) ())
(defclass d (d1) ())
(defclass b2 (f) ())
(defclass b1 (b2) ())
(defclass b (b1) ())
(defclass c1 (f) ())
(defclass c (c1) ())
(defclass a (b c d) ())
(compute-class-precedence-list 'a) ;;(a b b1 b2 c c1 d d1 d2 f f1 f2)
(mro 'a) ;;(a b b1 b2 c c1 d d1 d2 f f1 f2)
(compute-cpl-sbcl 'a) ;;(a b b1 b2 c c1 d d1 d2 f f1 f2)
Граф получающийся в алгоритме расширения графа иерархии.
Пример разрушенной сложной генеалогичности в иерархии классов:
(defclass f2 () ())
(defclass f1 (f2) ())
(defclass f (f1) ())
(defclass d2 (f) ())
(defclass d1 (d2) ())
(defclass d (d1) ())
(defclass b2 (f) ())
(defclass b1 (b2) ())
(defclass b (b1 d1) ())
(defclass c1 (f) ())
(defclass c (c1) ())
(defclass a (b c d) ())
(compute-class-precedence-list 'a) ;;(a b b1 b2 c c1 d d1 d2 f f1 f2)
(mro 'a) ;;(a b b1 b2 c c1 d d1 d2 f f1 f2)
(compute-cpl-sbcl 'a) ;;(a b b1 b2 c c1 d d1 d2 f f1 f2)
Граф получающийся в алгоритме расширения графа иерархии.
;Пример разрушенной сложной генеалогичности в иерархии классов:
;; gr04-2
(defclass f2 () ())
(defclass f1 (f2) ())
(defclass f (f1) ())
(defclass d2 (f) ())
(defclass d1 (d2) ())
(defclass d (d1) ())
(defclass b2 (f) ())
(defclass b1 (b2) ())
(defclass b (b1 d1) ())
(defclass c1 (f) ())
(defclass c (c1 b1) ())
(defclass a (b c d) ())
(compute-class-precedence-list 'a) ;;(a b c c1 b1 b2 d d1 d2 f f1 f2)
(mro 'a) ;;(a b c c1 b1 b2 d d1 d2 f f1 f2)
(compute-cpl-sbcl 'a) ;;(a b c c1 b1 b2 d d1 d2 f f1 f2)
Граф получающийся в алгоритме расширения графа иерархии.
Пример разрушенной сложной генеалогичности в иерархии классов(отличается от предыдущей порядком предков классе c):
;; gr04-3
(defclass f2 () ())
(defclass f1 (f2) ())
(defclass f (f1) ())
(defclass d2 (f) ())
(defclass d1 (d2) ())
(defclass d (d1) ())
(defclass b2 (f) ())
(defclass b1 (b2) ())
(defclass b (b1 d1) ())
(defclass c1 (f) ())
(defclass c (b1 c1) ())
(defclass a (b c d) ())
(compute-class-precedence-list 'a) ;;(a b c b1 b2 c1 d d1 d2 f f1 f2)
(mro 'a) ;;(a b c b1 b2 c1 d d1 d2 f f1 f2)
(compute-cpl-sbcl 'a) ;;(a b c b1 b2 c1 d d1 d2 f f1 f2)
Граф получающийся в алгоритме расширения графа иерархии.
Пример тестовой CLOS иерархии классов:
(defclass a () ())
(defclass b () ())
(defclass c () ())
(defclass s (a b) ())
(defclass r (a c) ())
(defclass q (s r) ())
(compute-class-precedence-list 'q) ;;(q s r a c b)
(mro 'q) ;;(q s r a b c)
(compute-cpl-sbcl 'q) ;;(q s r a c b)
Граф получающийся в алгоритме расширения графа иерархии.
И здесь, мне кажется, алгоритмы CLOS SBCL и расширения топологии, дают не верный результат ставя c впереди b, с точки зрения интуитивного понимания s предшествует r, а значит классы из иерерхии s должны предшествовать классам из иерархии r, если это не противоречит 1 правилу. А получается что генеалогичность нарушена, хотя её и так нет, нет какой то длинной или существенной цепочки наследования. Но не смотря на это по моему мнению алгоритм MRO даёт более адекватный результат, хотя различие в результатах алгоритмов не критично.
Пример базовой тествой иерархии классов:
(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)))
(compute-class-precedence-list 'a5) ;;(a5 a4 a2 a3 a1 b1)
(mro 'a5) ;;(a5 a4 a2 a3 a1 b1)
(compute-cpl-sbcl 'a5) ;;(a5 a4 a2 a3 a1 b1)
(compute-class-precedence-list 'b4) ;;(b4 a4 a2 a3 a1 b3 b2 b1)
(mro 'b4) ;;(b4 a4 a2 a3 a1 b3 b2 b1)
(compute-cpl-sbcl 'b4) ;;(b4 a4 a2 a3 a1 b3 b2 b1)
Граф получающийся в алгоритме расширения графа иерархии.
Пример с нарушением порядка наследования в иерархии классов:
Это интересный пример на котором оба алгоритма MRO и SBCL выдают ошибку, т.к порядок предшествования предков в классах C и D противоположный, а мы пытаемся их унаследовать в классе E.
;; gr11
(defclass A () ())
(defclass B () ())
(defclass C (A B) ())
(defclass D (B A) ())
(defclass E (C D) ())
(compute-class-precedence-list 'E) ;;(E C D B A)
(mro 'E) ;;Error: error in: `merge-class-list` - Inconsistent hierarchy
(compute-cpl-sbcl 'E) ;;Error: Error in: compute-std-cpl-phase3 for class: E
Граф получающийся в алгоритме расширения графа иерархии.
Оба стандартных алгоритма болезненно реагируют на попытку объединить классы с различным порядком наследования, хотя это нарушение было совершено до объединения и по идее методы классов предков с резличными порядками наследования не должны работать. А если они работают, т.е не зависят от порядка наследования, то возможно этот порядок и не так важен? Тогда может быть и не стоит так остро реагировать на противоречие в порядке наследования классов? Алгоритмы CLOS и MRO не могут выйти из этой ситуации, в то время как алгоритму расширения топологии на это наплевать(т.е он не отслеживает эту ситуацию), он берёт первую попавшуюся последовательность и на основе неё строит упорядочение.
Пример сложной иерархии классов:
(defclass O () ())
(defclass A (O) ())
(defclass B (O) ())
(defclass C (O) ())
(defclass D (O) ())
(defclass E (O) ())
(defclass K1 (A B C) ())
(defclass K2 (D B E) ())
(defclass K3 (D A) ())
(defclass Z (K1 K2 K3) ())
(compute-class-precedence-list 'Z) ;;(Z K1 K2 K3 D A B C E O)
(mro 'Z) ;;(Z K1 K2 K3 D A B C E O)
(compute-cpl-sbcl 'Z) ;;(Z K1 K2 K3 D A B E C O)
Граф получающийся в алгоритме расширения графа иерархии.
Из последнего примера видно что алгоритмы могут по разному упорядочить классы C и E. И хотя можно сказать что эти классы не зависимы, но по 2му правилу, их потомки имеют упорядочение, а уже сами эти классы могут быть упорядочены по правилу генеалогичности, что и видно из графика расширенной иерархии. Таким образом алгоритм реализованный в CLOS SBCL не вполне удовлетворяет предъявляемым ему требованиям. Можно конечно подумать что это я неправильно реализовал этот алгоритм на схеме, но я проверял его и в лиспе, результат такой же.
Выводы.
Все алгоритмы представленные в этой статье могут быть использованы для упроядочения иерархий наследования классов. Различие в их результатах незначительное(оно происходит от того что граф наследования не предоставляет информации о приоритете некоторых классов, поэтому различия проистекают чисто из за разницы в подходах реализации обработки графа иерархии описанных алгоритмов). Но наибольшую устойчивость и интуитивную понятность получаемых результатов демонстрирует алгоритм MRO(C3). И хотя в представленном виде его лучше не применять, в силу значительного количества лишней работы проделываемой в нём, он хорошо кешируется. И я бы рекомендовал использовать для работы множественного наследования использовать именно его.