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

select-ord-subseq

Первоначальная функция выделяющая во входящей последовательности упорядоченые подпоследовательности.

;; выделяет упорядоченные подсписки в заданном списке
(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!

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