Создаём абстракцию точки. Первая проба.

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

;; абстракция двумерной точки
(define (p! x y)
   (cons x y))     ;;конструктор
      
(define (p-x p)    ;;функции доступа к значениям координат точки
   (car p))

(define (p-y p)
   (cdr p))

(define (p-x! p v) ;;функции модификации значений координат точки.
   (set-car! p v))

(define (p-y! p v)
   (set-cdr! p v))
       
(define (cp-p p)   ;;создание копии точки.
   (p! (p-x p) (p-y p)))

(define p1 (p! 12 -2))
;p1
p1
;;(12 . -2)
(p-x p1)
;;12
(p-y p1)
;;-2
(p-x! p1 4)
;;(4 . -2)
(p-y! p1 3)
;;(4 . 3)
p1
;;(4 . 3)

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

Добавляем в тинисхему возможность создавать структуры.

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

Как бы мне хотелось определять структуры? На примере точки, например так:

(struct p (x y))

Данная запись определяет структуру двумерной точки с именем p состоящую из двух полей, с именами x и y. Так же эта запись должна создавать все методы доступа и модификации полей структуры, аналогичные указанным выше.

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

;simple macro struct
(define-macro (struct . param)

(define (make-name-stru base postfix)
   (string->symbol (string-append (symbol->string base) postfix)))

(define (make-validator name)
   (let ((f-name name)
         (t-stru (gensym)))
      `(define (,(make-name-stru f-name "?")       ,t-stru)
          (and (vector? ,t-stru) (eq? (vector-ref ,t-stru 0) ',f-name)))))

(define (make-fields-list lst-name)
   (let ((cur lst-name)
         (new-lst '())
         (cur-ind 1))
      (while (not (null? cur))
         (set! new-lst (cons (cons (car cur) cur-ind) new-lst))
         (set! cur-ind (+ cur-ind 1))
         (set! cur (cdr cur)))
      (reverse new-lst)))

;;Процедура создает процедуру создания структуры
(define (make-maker name fields)
   (let ((f-name name)
         (l-stru (length fields))
         (s (gensym)) ;;name local structure
         (t-stru  (gensym)))
      `(define (,(make-name-stru f-name "!")  ,@(map car fields))
          (let ((,s (make-vector ,(+ 1 l-stru))))
             (vector-set! ,s 0 ',f-name)
             ;; в цикле мы создаем список присваивания, и вставляем его в макрос
             ,@(let ((rez '())
                     (cur     fields))
                  (while (not (null? cur))
                     ;;(print cur)
                     (set! rez (cons `(vector-set! ,s
                                                   ,(cdr (car cur))
                                                   ,(car (car cur)))
                                     rez))
                     (set! cur (cdr cur)))
                  (reverse rez))
             ,s))))

;;процедура создаёт все процедуры доступа к полям структуры.
(define (make-getters name fields)
   (let ((f-name name)
         (l-stru (length fields))
         ;;(s (gensym)) ;;name local structure
         (t-stru  (gensym)))
      (let ((rez '())
            (cur  fields))
         (while (not (null? cur))
            (set! rez (cons
                       `(define (,(make-name-stru
                                   f-name
                                   (string-append "-"
                                                  (symbol->string
                                                   (car (car cur)))))
                                 ,t-stru)
                           (vector-ref ,t-stru ,(cdr (car cur))))
                       rez))
            (set! cur (cdr cur)))
         (reverse rez))))

;; процедура создаёт все процедуры модификации полей структуры
(define (make-setters name fields)
   (let ((f-name name)
         (l-stru (length fields))
         (v (gensym))
         (t-stru  (gensym)))
      (let ((rez '())
            (cur  fields))
         (while (not (null? cur))
            (set! rez (cons
                       `(define (,(make-name-stru
                                   f-name
                                   (string-append "-"
                                                  (symbol->string
                                                   (car (car cur)))
                                                  "!"))
                                 ,t-stru ,v)
                           (vector-set! ,t-stru ,(cdr (car cur)) ,v))
                       rez))
            (set! cur (cdr cur)))
         (reverse rez))))

;;тело (define-macro (struct . param)
;;(print param)
(let* ((name (car  param))
       (fields (make-fields-list (car (cdr  param))))
       (l-fields  (length fields))
       (valid (make-validator name))
       (maker (make-maker     name fields))
       (getters (make-getters name fields))
       (setters (make-setters name fields)))
   `(begin ,valid ,@getters ,@setters ,maker))
);;end (define-macro (struct . param)

Код данного макроса хранится в файле lib/sctruct.scm.

Давайте теперь проверим работу со стркутурами.

(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 "struct.scm"))

(struct p (x y))
;; p!
(define p1 (p! 12  3))
;; p1
(define p2 (cons 12 3))
;; p2
(p? p1)
;; #t
(p? p2)
;; #f
(p-y p1)
;; 3
(p-x! p1 22)
;; #( p 22 3 )
p1
;; #( p 22 3 )
(p-y! p1 -2)
;; #( p 22 -2 )
p1
;; #( p 22 -2 )

Как видно объявление структуры p, создало функции доступа и модификации, создания и валидации структуры. Созданный макрос фактически добавляет в тинисхему новый тип данных - структуры. Единственный минус этого подхода в том, что при ошибке использования этих функций они будут сообщать о неправильном применении операций работающих с векторами, а не со структурами. Поскольку это очень простые функции, обработку ошибок я не делал. Правда есть ещё один недостаток, если бы мы работали непосредственно с массивами и адресами ячеек, наш код был бы менее понятен, но более быстр. Нам не надо было бы тратить время на вызов функции, функций которые дают нам смысловую ясность используемого действия, сравните (p-x p1) и (vector-ref p1 1). Возможен ли такой подход при котором, наш код сохранял бы эту смысловую ясность, но не было бы вызова функции? Да возможен! Для этого необходимо, что бы макрос struct генерировал не функции доступа и изменения полей структуры, а макросы! Раскрытие которых содержало бы только вызовы базовых функций работы с массивом. Этот вариант работы приведён в файле struct2.scm.

(define (make-getters name fields)
   (let ((f-name name)
         (l-stru (length fields))
         ;;(s (gensym)) ;;name local structure
         (t-stru  (gensym)))
      (let ((rez '())
            (cur  fields))
         (while (not (null? cur))
            (set! rez (cons
                       `(define-macro (,(make-name-stru
                                   f-name
                                   (string-append "-"
                                                  (symbol->string
                                                   (car (car cur)))))
                                 ,t-stru)
                            `(vector-ref ,,t-stru ,,(cdr (car cur))))
                       rez))
            (set! cur (cdr cur)))
         (reverse rez))))

Отличие от генерации функций минимально. Зато теперь функция создания операций доступа к полям структуры, генерирует не определения функций, а определения макросов, раскрытие которых оставит только операцию vector-ref. Да что я вам говорю, вот смотрите:

(macro-expand '(p-x p1))
;;(vector-ref p1 1)

Контур.

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

Функция рисования контура, довольно проста:

;(контур это список точек)
(define (draw-contour img contour)
   (let* ((num-points (length contour))
          ;;(points     (cons-array (* 2 num-points) 'double))
          (points     (make-vector (* 2 num-points) 'double))
          (i   0)
          (cur contour)
          (dw         (car (gimp-image-get-active-drawable img))))
      (while (< i num-points)
         (vector-set! points (* 2 i)       (p-x (car cur)))
         (vector-set! points (+ (* 2 i) 1) (p-y (car cur)))
         (set! i   (+ i 1))
         (set! cur (cdr cur)))
      (gimp-paintbrush-default  dw (* 2  num-points) points)))

Теперь опишем функцию создающую контур окружности

(define (make-circle-n  x y radius num-points)
   (let* ((angle-delta (/ (* 2 *pi*) num-points))
          (i 0)
          (contour     '())
          (p0 (p! 0 0)))
      (while (< i num-points)
         (let ((angle (* i angle-delta)))
            (set! contour
               (cons (p! (+ x (* (sin angle) radius))
                         (+ y (* (cos angle) radius))) contour))
            (set! i (+ i 1))))
      (set! contour (cons p0 contour))
      (set! contour (reverse contour))
      (p-x! p0 (p-x (car contour)))
      (p-y! p0 (p-y (car contour)))
      contour))

Здесь используется не очень понятная конструкция с изменением p0, которое, вроде бы далее нигде не используется, на самом деле это небольшой хак, основанный на том что во всех переменных мы работаем со ссылками. Нам нужно добавить точку p0 в конец списка, чтобы получить замкнутый контур. но как это сделать? вначале вычислить и запомнить? Но тогда формула расчета будет повторяться в нескольких местах. Запомнить первую расчитанную точку, ну тогда в цикле надо всё время повторять проверку на то что мы рассчитываем не первую точку. Поэтому создаем пустую точку и добавляем её в конец списка, и потом перевернув список, инициализируем пустую точку данными из первой точки списка. А точка p0 как раз указывает на ту же структуру, которая находиться после реверса в конце списка.

(define c1 (make-circle-n 100 100 20 4))
;;c1
c1
;;(#( p 100 120 ) #( p 120 100 ) #( p 100 80 ) #( p 80 100 ) #( p 100 120 ))

(load (string-append path-lib "img.scm"))
(define i1 (create-1-layer-img 640 480))

(draw-contour i1 c1)
(define c2 (make-circle-n 200 100 50 12))
(draw-contour i1 c2)

Первая проба создания функций работающих с точками.

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

(define (move-p x y p)
   (p-x! p (+ x (p-x p)))
   (p-y! p (+ y (p-y p)))
   p)

``` lisp
(define (gr2rad g) ;;преобразует градусы в радианы(все базовые функции оперируют в радианах)
   (/ (* g *pi*) 180))

(define (rad2gr r) ;;преобразует радианы в градусы
   (/ (* r 180) *pi*))

(define (p2angle-gr x y) ;;вычисляет угол в градусах до точки.
   (rad2gr (angle-xy x y)))

(define (angle-xy x y)  ;;вычисляем угол с осью Х до точки.
   (let* ((t (if (= x 0) 0.000001 x))
          (ba  (atan (/ y t))))
      (cond
       ((and (>= x 0) (>= y 0)) ba)
       ((and (< x 0)  (< y 0))  (+ *pi* ba))
       ((and (< x 0)  (>= y 0)) (+ *pi* ba))
       ((and (>= x 0) (< y 0))  (+ (* 2 *pi*) ba)))))

(define (dist-xy x y) ;;расстояние от начала координат до точки.
   (sqrt (+ (* x x) (* y y ))))


(define (sum-angle a1 a2) ;;сложение углов, углы заданы в радианах.
   (let ((rez (+ a1 a2))
         (pi2 (* 2 *pi*)))
      (while (> rez pi2)
         (set! rez (- rez pi2)))
      rez))

(define (rotate-p base angle pr) ;;вращение точки pr вокруг точки base на угол angle(заданным в радианах)
   (let* ((r-x (- (p-x pr) (p-x base)))
          (r-y (- (p-y pr) (p-y base)))
          (angle-b (angle-xy r-x r-y))
          (angle-rez (sum-angle angle-b angle))
          (radius  (dist-xy r-x r-y)))
      (p-x! pr (+ (p-x base) (* radius (cos angle-rez))))
      (p-y! pr (+ (p-y base) (* radius (sin angle-rez))))
      pr))
```

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

(define p1 (p! 12 -13))
(move-p -5 12 p1) 
;;(p 7 -1)
p1
;;#(p 7 -1)	

Из примера видно, что функция move-p является деструктивной, т.е изменяющей свой аргумент, и то что она не обозначена знаком ! является упущением программиста, т.е моим - извините. Это отклонение от стиля именования функций в схеме, старайтесь не допускать таких ошибок в своём коде. Аналогично можно сказать и про функцию rotate-p. Данные функции должны были бы выглядеть так:

(define (move-p! x y p)
   (p-x! p (+ x (p-x p)))
   (p-y! p (+ y (p-y p)))
   p)


(define (move-p x y p)
   (p! (+ x (p-x p))
       (+ y (p-y p))))

(define (rotate-p! base angle pr) ;;вращение точки pr вокруг точки base на угол angle(заданным в градусах).
   (let* ((r-x (- (p-x pr) (p-x base)))
          (r-y (- (p-y pr) (p-y base)))
          (angle-b (angle-xy r-x r-y))
          (angle-rez (sum-angle angle-b angle))
          (radius  (dist-xy r-x r-y)))
      (p-x! pr (+ (p-x base) (* radius (cos angle-rez))))
      (p-y! pr (+ (p-y base) (* radius (sin angle-rez))))
      pr))


(define (rotate-p base angle pr) ;;вращение точки pr вокруг точки base на угол angle(заданным в градусах).
   (let* ((r-x (- (p-x pr) (p-x base)))
          (r-y (- (p-y pr) (p-y base)))
          (angle-b (angle-xy r-x r-y))
          (angle-rez (sum-angle angle-b angle))
          (radius  (dist-xy r-x r-y)))
      (p! (+ (p-x base) (* radius (cos angle-rez)))
          (+ (p-y base) (* radius (sin angle-rez))))))

(rotate-p (p! 0 0) 0 (p! 1 0))
;; #( p 1 0 )
(rotate-p (p! 0 0) (/ *pi* 2) (p! 1 0))
;; #( p 6.123031769e-017 1 )
(rotate-p (p! 0 0) *pi* (p! 1 0))
;; #( p -1 1.224606354e-016 )
(rotate-p (p! 0 0) (* *pi* (/ 3 2)) (p! 1 0))
;; #( p -1.836909531e-016 -1 )

(rotate-p (p! 3 2) 0 (p! 4 2))
;; #( p 4 2 )
(rotate-p (p! 3 2) (/ *pi* 2) (p! 4 2))
;; #( p 3 3 )
(rotate-p (p! 3 2) *pi* (p! 4 2))
;; #( p 2 2 )
(rotate-p (p! 3 2) (* *pi* (/ 3 2)) (p! 4 2))
;; #( p 3 1 )
(rotate-p (p! 3 2) (* *pi* 2) (p! 4 2))
;; #( p 4 2 )

Создание функций работающих с контурами.

Напишем функцию создания прямоугольного контура.

(define (make-rect  x y width height)
   (let* ((contour     '())
          (p0 (p! x y)))
      (set! contour (cons p0 contour))
      (set! contour (cons (p! (+ x width) y) contour))
      (set! contour (cons (p! (+ x width) (+ y height)) contour))
      (set! contour (cons (p! x           (+ y height)) contour))
      (set! contour (cons p0 contour))
      (set! contour (reverse contour))
      contour))

Попробуем работу этой функции, с применением созданных выше функций манипулирующих точками.

(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 "img.scm"))
(load (string-append path-lib "struct2.scm"))
(load (string-append path-lib "point.scm"))
(load (string-append path-lib "tr2d.scm"))    ;;просто в контуре используются трансформации
(load (string-append path-lib "contour.scm")) ;;но о них позже.

(define i1 (create-1-layer-img 640 480))  ;;создаём изображение

(define r1 (make-rect 20 100 80 50))
(define r2 (map (lambda (p)
                     (move-p 30 80 p))
				r1))	 

(define c1 (make-circle-n 200 150 50 7))
(define c2 (map (lambda (p)
                     (move-p 100 -20 p))
				c1))
				
(for-list (el (list r1 r2 c1 c2))
     (draw-contour i1 el))

Получаем вот такое изображение:

Контуры в работе с выделениями.

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

(define (select-from-contour img contour op)
   (let* ((num-points (length contour))
          (points     (make-vector (* 2 num-points) 'double))
          (i   0)
          (cur contour))
      (while (< i num-points)
         (vector-set! points (* 2 i)       (p-x (car cur)))
         (vector-set! points (+ (* 2 i) 1) (p-y (car cur)))
         (set! i   (+ i 1))
         (set! cur (cdr cur)))
      (gimp-free-select  img (- (* 2  num-points) 1) points op 0 0 0)))

Давайте продемонстриуем её работу, закрасим выделенный контур.

(define c2 (make-circle-n  200 150 50 20))
(select-from-contour i1 c2  CHANNEL-OP-REPLACE)
(gimp-context-set-foreground '(221 141 241)) ;;установим цвет переднего плана 
;;что то розовенькое
(gimp-edit-fill (car (gimp-image-active-drawable i1))  FOREGROUND-FILL)

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

(gimp-selection-none i1) ;;отменить действующее выделение
(gimp-selection-all i1)  ;;выделить всё изображение.

Кисти.

Работа с кистями в гимпе очень простая, хотя и она претерпела изменения с версии 2.6 до 2.10. Так что в этих версиях используются немного разные вызовы функций.

(gimp-brushes-get-list ".*") ;;Посмотреть список всех кистей в системе.
;;(60 ("Буфер обмена" "Буфер обмена #1" "My Brush1" "My Brush1 #1" "1. Pixel" 
;;"2. Block 01" "2. Block 02" "2. Block 03" "2. Hardness 025" "2. Hardness 050" 
;;"2. Hardness 075" "2. Hardness 100" "2. Star" "Acrylic 01" "Acrylic 02" 
;;"Acrylic 03" "Acrylic 04" "Acrylic 05 #2"  ..........

(gimp-context-get-brush i1) ;;посмотреть кисть установленную в текущем контексте.
;;("My Brush1 #1")

(gimp-context-set-brush   "Circle Fuzzy (07)") ;;установить желаемую кисть.

Так же в script-fu есть как набор функций позволяющих редактировать сами кисти, это функции под названием gimp-brush-new, gimp-brush-rename, gimp-brush-set-...., так и функции дающие возможность редактировать значение отдельных параметров кисти в текущем контексте, например:

(gimp-context-get-brush-size)
;;7.0
(gimp-context-set-brush-size 20)

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

Градиенты.

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

(gimp-gradients-get-list ".*") ;; Список градиентов в системе.
;;(76 ("Пользовательский" "Основной в прозрачный" "Основной в фоновый  
;;(HSV против часовой )" "Основной в фоновый (HSV по часовой )" 
;;"Основной в фоновый (RGB)" "Основной в фоновый (резкий переход)" "Abstract 1" 
;;"Abstract 2" "Abstract 3" "Aneurism" "Blinds" "Blue Green" "Browns" .........

(gimp-context-get-gradient) ;; установленный в текущем контексте градинет
;;("Full saturation spectrum CCW")


;;нарисуем прямоугольное выделение.
(define r2 (make-rect-contour 100 150 200 50))
;;делаем выделение

(define (test-grad1 i contour pf pt)
	(select-from-countur i contour  CHANNEL-OP-REPLACE)
    (gimp-drawable-edit-gradient-fill (car (gimp-image-active-drawable i1))
                    GRADIENT-LINEAR 0
                    FALSE 1 0  1 
                    (p-x pf) (p-y pf) (p-x pt) (p-y pt)))

;;(test-grad1 i1 r2 (nth 0 r2) (nth 2 r2))
;;(test-grad1 i1 r2 (nth 0 r2 0) (nth 1 r2))
;;(test-grad1 i1 r2 (nth 0 r2 0) (nth 2 r2))

(define (move-contour to-x to-y c)
   (map (lambda (p)
           (move-p to-x to-y p)) c))

(define (grp-test-grad1 i contour dy lst-ind-grad-point)
  (let ((cur-dy 0))
	(for-list (cur lst-ind-grad-point)
	    (let ((cur-contour (move-contour 0 cur-dy contour)))
	       (test-grad1 i  cur-contour
	                  (nth (car  cur) cur-contour) 
		              (nth (cadr cur) cur-contour))
	       (set! cur-dy (+ dy cur-dy)))))

(grp-test-grad1 i1 r2 55 '((0 1) (0 2) (0 3) (1 0) (1 3))) 

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

Это был лишь небольшой пример работы с линейным градиентом, помимо линейного, функция может работать с десятком других типов градиентов. См. описание функции gimp-drawable-edit-gradient-fill.

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