GIMP Script-Fu Первый Дан. Сортировка

Кто бы мог представить, что в современном мире ещё можно встретить языки программирования, в которых нет сортировки как штатной функции языка? Как себе можно вообще представить программирование без этой функции?! Ну что ж знакомьтесь, это язык tinyscheme и его GIMP порт под названием Script-fu.

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

(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"))

Для её работы нам нужно написать

(define-macro (swap-val x y) ;; макрос обмена значениями переменных    (let ((tmp (gensym)))       `(let ((,tmp ,x))           (set! ,x ,y)           (set! ,y ,tmp))))  (define-macro (swap-vect-val vect x y) ;;макрос обмена значениями в массиве.    (let ((tmp (gensym))          (i   (gensym))          (j   (gensym)))       `(let* ((,i ,x)               (,j ,y)               (,tmp (vector-ref ,vect ,i)))           (vector-set! ,vect ,i (vector-ref ,vect ,j))           (vector-set! ,vect ,j ,tmp)))) 

Ну а теперь и сама сортировка ….. тадам Пузырьком:

(define (sort-bubble compare arr)    (let ((up-idx (- (vector-length arr) 1)))       (do ((i 0 (+ i 1))) ;;проходим от первого эл, до последнего             ((>= i up-idx) arr)          (do ((j (+ i 1) (- j 1))) ;; проходим от текущего эл.+1 до 0го.                ((<= j 0))             (when (compare (vector-ref arr j) (vector-ref arr (- j 1)))                (swap-vect-val arr j (- j 1)))             )          ;;(prn "i= "  i  " : " arr "\n");; можно посмотреть как меняется массив с каждой итерацией  ))) 

(define v1 (list->vector '(2 3 4 12 5 2  8 7 1))) (define v2 (list->vector '(12 34 4 22 45 11 32 4 99 9 2 4 1 10 111))) (define v3 (list->vector '(9 87 2 243 77 92 0 2437 87 334 3 23 76 7 31)))  (sort-bubble > v2) ;#( 111 99 45 34 32 22 12 11 10 9 4 4 4 2 1 ) (sort-bubble > v1) ;;#( 12 8 7 5 4 3 2 2 1 ) (sort-bubble > v3) ;;#( 2437 334 243 92 87 87 77 76 31 23 9 7 3 2 0 ) 

Чтобы тестировать результаты работы функций сортрировки можно написать простенькую функцию проверки упорядоченности массивов.

(define (sorted-array? compare arr)    (let ((up-idx (- (vector-length arr) 1))          (sorted #t))       (do ((i 1 (+ i 1))) ;;проходим от первого эл, до последнего             ((or (not sorted) (> i up-idx)) sorted)  ;;(prn "Compare: arr[" i "]= " (vector-ref arr i)   ;;     ", arr["  (- i 1) "]= " (vector-ref arr (- i 1)) "\n")          (when (compare (vector-ref arr i) (vector-ref arr (- i 1)))        (prn "error order by index: " (- i 1) ", " i "\n")                (set! sorted #f)))    ))  (map (lambda (v) (sorted-array? > v)) (list v1 v2 v3)) ;; (#t #t #t) 

Давайте рассмотрим ещё несколько типов сортировок.

Сортировка прямым включением:

(define (sort-sis compare arr) ;;сортировка прямым включением    ;;(prn "call: " arr)    (let ((up-idx (- (vector-length arr) 1)))       (do ((i 1 (+ i 1))) ;;0й элемент считаем лежащим в упорядоченной части м             ((> i up-idx) arr) ;;проходим по всем эл.          (do ((k (vector-ref arr i))               (j (- i 1) (- j 1))) ;;                ((or (< j 0) (compare (vector-ref arr j) k))                 (vector-set! arr (+ j 1) k))             (vector-set! arr (+ j 1) (vector-ref arr j)))          ;;(prn "i="  i " : " arr)  )))

Разрабатываем тестирующую функцию

Тестировать в ручную это нудное занятие, лучше иметь набор тестов по которым мы можем проверить правильность работы нашей функции. В данном случае(сортировки) этот набор можно свести к функции, которая определяет правильно ли отсортирован массив, ранее описанной функции sorted-array?. Нам остаетстся лишь научиться правильно создавать сортируемые массивы. Тут нам может прийти на помощь ранее описанное рассширение генерирующее случаные числа, у кого оно не работает, задайте свой псевдослучайный генератор чисел.

(define p-ext (string-append (getenv "HOME") "/work/scheme/tiny/gimp/")) (define p-ext-my (string-append p-ext "my-ext/myext")) (load-extension p-ext-my)

К генератору необходимы несколько функций на схеме.

(define (rand-lst m len) ;;определяем функцию получения списка случайных чисел заданной длины и огр. m     (let ((rez '()))        (for (i 1 len)           (set! rez (cons (random m)                           rez)))         rez))  (define (rand-arr m len) ;;создание массива заполненного случайными числами     (let ((rez (make-vector len)))        (for (i 0 (- len 1))       (vector-set! rez i (random m)))         rez))  (define v1 (rand-arr 10 20))  (define (random i) ;; вот это интересно, функция работает   (let ((v (rand)))     ;;(prn v "\n")  (modulo v i))) 

Поместим их в файл random.scm и будем при необходимости загружать.

(load (string-append path-lib "random.scm"))

Пишем первую функцию тестирования сортировки, принмающую число тестов n, длину массива, максимальное значение, функцию сортировки и функцию сравнения элементов.

(define (test-sort1 n len max-val sort-fun compare)    (for (i 1 n)       (let ((arr (rand-arr max-val len)))       (prn "tst: " i ", arr: " arr "\n")       (sort-fun compare arr)   (if (sorted-array? compare arr)      (prn "SORTED: " arr "\n")  (prn "!! BAD: " arr "\n"))))) 

(test-sort1 10 20 20 sort-sis <) ;;tst: 1, arr: #(19 17 16 6 14 16 10 10 14 0 14 9 2 18 12 3 18 14 1 19) ;;SORTED: #(0 1 2 3 6 9 10 10 12 14 14 14 14 16 16 17 18 18 19 19) ;;tst: 2, arr: #(17 19 4 1 19 17 5 19 0 4 16 19 1 5 5 7 1 8 17 8) ;;SORTED: #(0 1 1 1 4 4 5 5 5 7 8 8 16 17 17 17 19 19 19 19) ;;......

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

(define (test-sort2 test-lst max-val sort-fun compare) (let ((i 1))       (for-list (len test-lst)          (let ((arr (rand-arr max-val len)))         (prn "tst: " i ", arr: " arr "\n")         (sort-fun compare arr)     (if (sorted-array? compare arr)        (prn "SORTED: " arr "\n")    (prn "!! BAD: " arr "\n")))      (set! i (+ i 1))))) 

(test-sort2 (list 0 1 3 5 10 15) 20 sort-bubble >) ;;tst: 1, arr: #() ;;SORTED: #() ;;tst: 2, arr: #(11) ;;SORTED: #(11) ;;tst: 3, arr: #(8 6 16) ;;SORTED: #(16 8 6) (rand-lst 25 10)   ;; список длин массивов для тестирования так же можно заполнять случаными значениями ;;(14 11 19 4 8 21 19 13 4 11)  (test-sort2 (rand-lst 25 10) 20 sort-bubble >) ;;..... (test-sort2 (rand-lst 20 10) 20 sort-sis <) ;;tst: 1, arr: #(12 8 7 16 8 18 9) ;;SORTED: #(18 16 12 9 8 8 7) ;;tst: 2, arr: #(7 2 4 0 3 2 12 9 0 0 16 0 1 6 4 5 13 0) ;;SORTED: #(16 13 12 9 7 6 5 4 4 3 2 2 1 0 0 0 0 0) ;;............. 

Как видно из тестов сортировка прямым включением так же работает.

Сортировка прямым включением с делением пополам.

;можно использовать факт что первая половина массива уже отсортирована (define (sort-bin-ins compare arr)    (let ((up-idx (- (vector-length arr) 1)))       (do ((i 1 (+ i 1))) ;;0й элемент считаем лежащим в упорядоченной части м             ((> i up-idx) arr) ;;проходим по всем эл.          (let ((x (vector-ref arr i))                (l 0)                (r i))             (while (< l r)                (let ((m (quotient (+ l r) 2)))                   (if (compare (vector-ref arr m) x)                       (set! l (+ m 1))                       (set! r m))))             (do ((j i (- j 1))) ;;                   ((<= j r))                (vector-set! arr j  (vector-ref arr (- j 1))))             (vector-set! arr r x))          ;;(prn "i=" i " : " arr "\n")  ))) 

(test-sort1 10 20 20 sort-bin-ins >) (test-sort2 (rand-lst 20 10) 20 sort-bin-ins <)

Сортировка простым выбором.

(define (sort-str-sel compare arr)    (let ((up-idx (- (vector-length arr) 1)))       (do ((i 0 (+ i 1)))             ((>= i up-idx) arr) ;;проходим по всем эл.          (let ((x (vector-ref arr i))                (k i))             (do ((j (+ i 1) (+ j 1))) ;;                   ((> j up-idx))                (if (compare (vector-ref arr j) x)                    (begin                       (set! k j)                       (set! x (vector-ref arr k)))))             (vector-set! arr k  (vector-ref arr i))             (vector-set! arr i  x))          ;;(prn "i=" i " : " arr "\n")       ))) 

(test-sort1 10 20 20 sort-str-sel >) (test-sort1 10 20 20 sort-str-sel <) (test-sort2 (rand-lst 20 10) 20 sort-str-sel >) (test-sort2 (rand-lst 20 10) 20 sort-str-sel <)

Надеюсь вы не подумали что я второй Дональд Кнут? В реализации алгоритмов мне помогала книга Николаса Вирта: Алгоритмы + Структуры Данных = Программы. И теперь, я думаю пора заканчивать баловаться, и реализовать рабочий алгормтм сортировки, на котором можно и остановиться. Я выбрал алгоритм быстрой сортировки. Единственным препятствием к его реализации является отсутствие в тинисхеме конструкции repeat … until, много раз используемой в алгоритмах быстрой сортировки Виртом. Поэтому вначале реализуем её.

Итак, нам необходимо получить конструкцию, что то вроде:

(repeat  code  ...  ...  ((cond-exit) return-code)) ;;выполняем блок кода до тех пор пока не выполнится условие завершения цикла 

Ключевое слово until я убрал из конструкции. Просто надо помнить, что конструкция repeat будет выполняться до тех пор, пока условие выхода, в последней строке конструкции repeat, не станет истинно.

;;выдает пару: список без последнего элемента, последний элемент ;;функция нужна для макроса repeat (define (split2prev&last lst)    (define (split2prev&last-helper cur prev)       (if (pair? (cdr cur))           (split2prev&last-helper (cdr cur) (cons (car cur) prev))           (cons (reverse prev) cur)))    (if (pair? lst)        (split2prev&last-helper lst '())))  ;;конструкция цикла repeat ..... until (define-macro (repeat . param-list)    (let ((s-param  (split2prev&last param-list))          (first (gensym))          (loop  (gensym)))       (let ((body      (car s-param))             (cond-exit (caar (cdr s-param)))             (exit-body (cdar (cdr s-param))))          `(let ((,first #t))              (let ,loop ()                   (if (or ,first (not ,cond-exit))                      (begin                         (when ,first (set! ,first #f))                         ,@body                         (,loop))                      (begin                         ,@exit-body))))))) 

Тонкости работы ТиниСхемы(Script-fu).

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

Как развитые лиспы(схемы) обрабатывают определения функций? Они раскрывают все макросы имеющиеся в функции, создают AST не имеющее макросов, а некоторые идут ещё дальше и создать сначала код для виртуальной машины, а затем и для реальной, т.е осуществляют полную компиляцию функции. Тинисхема не из таких! Когда вы делаете в ней определение функции, она говорит «ок», и ничего не делая связывает код с указанной переменной(символом). Т.е тинисхема не раскрывает макросы на этапе опредления, так называемое — время компиляции, вероятно полагаясь на то, что успеет всё это сделать, как нибудь потом, например во время вызова функции.

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

Знаете, если вы скажете это программисту на любом другом языке программирования, ну он ответит, ну — «ок», без макросов, значит без макросов, зачем они вообще нужны! Но если вы это скажете более менее продвинутому лисперу, он только покрутит пальцем у виска! Как это не применять макросов? А зачем тогда вообще программировать на лиспе? Просьба не применять макросы для лиспера, равносильна просьбе к обычному человеку не дышать.

Какой же есть из этого выход? Ну во-первых, нельзя использовать функции в макросах модифицирующие тело кода. Во вторых, надо придумать какой то способ заставить тинисхему выполнить эту предварительную компиляцию функций и избавить код от макросов, на этапе определения функций. Для начала мы ограничимся именно первой рекомендацией, и именно не модифицирующая функция используется при построении кода в макросе repeat

Быстрая сортировка, рекурсивный вариант.

(define (sort-quick compare arr)   (define (sort-quick-helper l r)     ;;(prn "l= " l ", r= " r ": " arr "\n")     (let ((i l)           (j r)           (x (vector-ref arr (quotient (+ l r) 2)))           (step 0))   ;;(prn "x: " x "\n")       ;;(prn "start i,j: " i ", " j "\n")       (repeat        (while (compare (vector-ref arr i) x)           (set! i (+ i 1)))        (while (compare x  (vector-ref arr j))           (set! j (- j 1)))        (when (<= i j)           (swap-vect-val arr i j)           (set! i (+ i 1))           (set! j (- j 1)))        ;;(prn "until i,j: " i ", " j "\n")        ;;(prn "step: " step "\n")        (set! step (+ step 1))        ((> i j) #f)) ;;until       ;;(prn "after repeat i,j: " i ", " j "\n")       (when (< l j) (sort-quick-helper l j))       (when (< i r) (sort-quick-helper i r))       ))   (let ((up-idx (- (vector-length arr) 1)))      (when (>= up-idx 0) ;;при нулевой длине, сортировать не надо.          (sort-quick-helper 0 up-idx)))   arr) 

(test-sort1 10 20 20 sort-quick >) (test-sort1 10 20 20 sort-quick <) (test-sort2 (rand-lst 20 10) 20 sort-quick >) (test-sort2 (rand-lst 20 10) 20 sort-quick <)

Быстрая сортировка. Нерекурсивный вариант.

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

(define-macro (push . param-list)    (let ((var   (car  param-list))          (val   (cadr param-list))          (tmp1  (gensym)))       `(let ((,tmp1 ,val))           (set!  ,var (cons ,val ,var))           )))  (define-macro (pop . param-list)    (let ((var   (car  param-list))          (tmp1  (gensym)))       `(let ((,tmp1 (car ,var)))           (set!  ,var (cdr ,var))           ,tmp1           )))  (define empty? null?) 

(define (sort-quick2 compare arr)   (let ((stack '()))     (when (> (vector-length arr) 0)      (push stack (cons 0 (- (vector-length arr) 1)))      (repeat ;;выбрать запрос из вершины стека       (let* ((q (pop stack))              (l (car q))              (r (cdr q)))          (repeat           (let ((i l)                 (j r)                 (x (vector-ref arr (quotient (+ l r) 2))))              (repeat               (while (compare (vector-ref arr i) x)                  (set! i (+ i 1)))               (while (compare x  (vector-ref arr j))                  (set! j (- j 1)))               (when (<= i j)                  (swap-vect-val arr i j)                  (set! i (+ i 1))                  (set! j (- j 1)))               ((> i j) #f))              (when (< i r)                 (push stack (cons i r)))              (set! r j))           ((>= l r) #f))          )       ((empty? stack) #f))))   arr) 

(test-sort1 10 20 20 sort-quick2 >) (test-sort1 10 20 20 sort-quick2 <) (test-sort2 (rand-lst 20 10) 20 sort-quick2 >) (test-sort2 (rand-lst 20 10) 20 sort-quick2 <)

Быстрая сортировка, уменьшающая размер исользуемого стека для наихудшего случая.

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

(define (sort-quick3 compare arr)   (let ((stack '()))     (when (> (vector-length arr) 0)      (push stack (cons 0 (- (vector-length arr) 1)))      (repeat ;;выбрать запрос из вершины стека       (let* ((q (pop stack))              (l (car q))              (r (cdr q)))          (repeat           (let ((i l)                 (j r)                 (x (vector-ref arr (quotient (+ l r) 2))))              (repeat               (while (compare (vector-ref arr i) x)                  (set! i (+ i 1)))               (while (compare x  (vector-ref arr j))                  (set! j (- j 1)))               (when (<= i j)                  (swap-vect-val arr i j)                  (set! i (+ i 1))                  (set! j (- j 1)))               ((> i j) #f))              (if (< (- j l) (- r i))                  (begin ;;запись запроса на сортировку правой части                     (when (< i r)                        (push stack (cons i r)))                     (set! r j)) ;;продолжаем сортировать левую часть                  (begin ;;запись запроса на сортировку левой части                     (when (< l j)                        (push stack (cons l j)))                     (set! l i)))) ;продолжаем сортировать правую часть           ((>= l r) #f))          )       ((empty? stack) #f))))   arr)

(test-sort1 10 20 20 sort-quick3 >) (test-sort1 10 20 20 sort-quick3 <) (test-sort2 (rand-lst 20 10) 20 sort-quick3 >) (test-sort2 (rand-lst 20 10) 20 sort-quick3 <) 

Сортировка последовательностей.

К сожалению алгоритм быстрой сортировки не подходит для сортировки наборов данных с последовательным доступом, например таких как списки, для их сортировки используются совсем другие алгоритмы.

Рассмотрим функцию назваемую сортировкой естественным слиянием

;;сама функция сортировки слиянием, т.н. сортировка натуральным слиянием. (define (sort-natural-merge compare lst)   (if (not (null? lst))     (let ((out (select-ord-subseq compare lst)))       (repeat         (set! out (merge-ordered-lists compare out))         ((not (and (pair? out)             (pair? (car out))     (pair? (cdr out))))  (car out)))) ;;тут возврат!!! (car out)     lst)) ;;возврат если список пуст!    ;;(sort-natural-merge >  '(9 5 0 1 11 0 0 14 12 16 17 1 3 17 8 4 5 2 7)) ;;(17 17 16 14 12 11 9 8 7 5 5 4 3 2 1 1 0 0 0) 

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

Вначале функция select-ord-subseq выделяет из представленной последовательности уже имеющиеся в ней упорядоченные подпоследовательности, если их нет, то это будет список подсписков в которых только один элемент — наихудший случай. Далее в цикле с помощью функции merge-ordered-lists, сливаем упорядоченные списки в другие упорядоченные списки. Процесс попарного слияния списков очень быстро уменьшает их количество, а значит проходит быстро. Для его реализации нам нужны несколько функций.

;; выделяет упорядоченные подсписки в заданном списке (define (select-ord-subseq compare lst)   (let ((out '())         (subseq '())         (start-subseq #t))     ;;(prn "lst: " lst "\n")     (do ((cur lst (cdr cur))          (prev #f))         ((null? cur)          (if (not (null? subseq))              (set! out (cons (reverse subseq) out)))          (reverse out))       (let ((elem (car cur)))         ;;(prn "cur : " cur  ", prev: " prev ", elem: " elem "\n")         (if (or start-subseq (compare prev elem))             (begin  ;;продолжаем подпоследовательность               (when start-subseq (set! start-subseq #f))               (set! subseq (cons elem subseq))               ;;(prn "contin subseq: " subseq "\n")               )             (begin  ;;начинаем новую подпоследовательность               (set! out (cons (reverse subseq) out) )               (set! start-subseq #f)               (set! subseq (cons elem '()))               ;;(prn "new sub seq: " subseq "\n")               ))         ;;(prn "out: " out "\n")         (set! prev elem)))     ))  (select-ord-subseq < '(23 12 3 2 13 15 8 7 2 1 3 6 12)) ;;((23) (12) (3) (2 13 15) (8) (7) (2) (1 3 6 12))

;;некоторым странным образом объединяет списки (define (add-tail-to-head lst tail)   (do ((cur   lst)        (cur-t tail (cdr cur-t)))       ((null? cur-t) cur)     (set! cur (cons (car cur-t) cur))))  (add-tail-to-head '(1 2 3 4 5) '(7 8 9)) ;;(9 8 7 1 2 3 4 5)  ;;объединяет два упорядоченных списка (define (merge-ordered-list2 compare l1 l2)   (let ((out '()))     (do ((cur1 l1)          (cur2 l2))         ((or (null? cur1) (null? cur2))          (if (not (null? cur1)) ;;выход из цикла, если остались хвосты добавим их в результат              (set! out (add-tail-to-head out cur1)))          (if (not (null? cur2))              (set! out (add-tail-to-head out cur2)))          (reverse out))       (let ((el1 (car cur1))             (el2 (car cur2)))         (if (compare el1 el2)             (begin ;; добавляем выбранные элементы в результирующий список               (set! out (cons el1 out))               (set! cur1 (cdr cur1)))             (begin               (set! out (cons el2 out))               (set! cur2 (cdr cur2))))         ))))  ;;пример вызова (merge-ordered-list2 < '( 7 8 10 15) '(3 7 11 24 51 56)) ;;(3 7 7 8 10 11 15 24 51 56)  ;;сливает вместе упорядоченные списки переданные как подсписки списка lst (define (merge-ordered-lists compare lst)   (let ((out '())         (prev #f)         (first-step #t))       (do ((cur lst (cdr cur)))           ((null? cur)            (if (not first-step)                (begin                  (set! out (cons prev out))                  ))            out)     ;;(prn "cur: " cur "\n")         (let ((elem (car cur)))           (if first-step               (begin                 (set! first-step #f)                 (set! prev elem))               (begin                 (set! out (cons                            (merge-ordered-list2 compare prev elem)                            out))                 ;;(prn "have out: "  out "\n")                 (set! first-step #t))               )))))    ;;(merge-ordered-lists < '((10) (3 4 12) (5) (2 8) (7) (1))) ;;((1 7) (2 5 8) (3 4 10 12)) 

А вот теперь можно и потестировать сортировку слиянием

;;(sort-natural-merge >  '(9 5 0 1 11 0 0 14 12 16 17 1 3 17 8 4 5 2 7)) ;;(17 17 16 14 12 11 9 8 7 5 5 4 3 2 1 1 0 0 0)

Подготовка к тестированию сортировки списков

Для тестирования функций сортировки списков необходимо подготовить комплекс тестовых функций

(define (sorted-list? compare lst)    (let ((sorted #t))      (when (> (length lst) 1)       (do ((cur lst (cdr cur))) ;;проходим от первого эл, до последнего             ((or (not sorted) (null? cur) (null? (cdr cur))))  ;;(prn "Compare: (car cur)= " (car cur)   ;;     ", (cadr cur)= "  (cadr cur)  "\n")          (when (compare (cadr cur) (car cur))        (prn "error order by element: " (car cur) ", " (cadr cur) "\n")                (set! sorted #f))))     sorted))   (define (test-list-sort1 n len max-val sort-fun compare)    (for (i 1 n)       (let ((lst (rand-lst max-val len))         (rez '()))       (prn "tst: " i ", lst: " lst "\n")       (set! rez (sort-fun compare lst))   (if (sorted-list? compare rez)      (prn "SORTED: " rez "\n")  (prn "!! BAD: " rez "\n")))))    (define (test-list-sort2 test-lst max-val sort-fun compare) (let ((i 1))       (for-list (len test-lst)          (let ((lst (rand-lst max-val len))        (rez '()))         (prn "tst: " i ", lst: " lst "\n")             (set! rez (sort-fun compare lst))     (if (sorted-list? compare rez)        (prn "SORTED: " rez "\n")    (prn "!! BAD: " rez "\n")))      (set! i (+ i 1))))) 

Запуск тестов:

(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"))  (define p-ext (string-append (getenv "HOME") "/work/scheme/tiny/gimp/")) (define p-ext-my (string-append p-ext "my-ext/myext")) (load-extension p-ext-my)    ;;новые функции сортировки, генерации случайных чисел, массивов и списков и тестирования я разместил    ;;в этих файлах. (load (string-append path-lib "sort.scm")) (load (string-append path-lib "random.scm")) (load (string-append path-lib "test1.scm"))

Теперь можно выполнить построчно тесты:

(test-list-sort1 10 20 20 sort-natural-merge >) (test-list-sort1 10 20 20 sort-natural-merge <) (test-list-sort2 (rand-lst 20 10) 20 sort-natural-merge >) (test-list-sort2 (rand-lst 20 10) 20 sort-natural-merge <)

Чисто визуально, мне показалось, что сортировка списков выполняется быстрее чем сортировка массивов, хотя вычислительная сложность алгоритмов, и объем сортируемых данных приблизительно одинаковы. Учитывая, что сортировка списков написана не очень оптимально, а сортировка массивов реализована строго по Вирту, тут есть над чем задуматься!

И последний штрих, функции сортировки массивов и списков мы объединим в одну:

(define (sort compare obj)    (cond     ((pair? obj)      (sort-natural-merge compare obj))     ((vector? obj)      (sort-quick3 compare obj))     (#t #f))) 

Но если Вы попытались выполнить приведённый выше код, Вы не могли не заметить, сортировки выполняются безобразно МЕДЛЕННО. И причину я Вам уже указал, это «ленность» схемы в раскрытии макросов. Это чудовищный тормоз, который делает бессмысленным весь этот «полёт фантазии» выполняемый при написании макросов создающих синтаксические абстракции. Он полностью обесценивает применение макросов в Script-fu. На следующем занятии мы попробуем преодолеть этот недостаток tinyscheme!