четверг, 28 января 2010 г.

Алгебраические типы данных в Common Lisp

В продолжение функциональной темы. В ходе беседы у меня возникла идея того, как можно создавать и обрабатывать так называемые алгебраические типы данных (algebraic data types - ADT) вроде таких

data TaggedType a = NoneValue
                  | SingleValue a
                  | DoubleValue (a, a)

Здесь NoneValue, SingleValue и DoubleValue являются также конструкторами данных. Компилятор хаскеля по такому определению автоматически создает одноименные функции. Мы их тоже создадим. Будем делать все через списки. Первым элементом списка будет идти символическое имя конструктора, т.е. тег. Затем в списке будут идти данные. Это позволит нам различать значения.

(defun none-value ()
  (list 'none-value))

(defun single-value (a)
  (list 'single-value a))

 (defun double-value (a1 a2)
  (list 'double-value a1 a2))

Как видим, все очень просто. Теперь мы можем вручную устроить сопоставление с образцом (pattern-matching).

(defun test-tagged-type (v)
  (ecase (car v)
    (none-value (format t "NoneValue "))
    (single-value (format t "SingleValue ~A" (cadr v)))
    (double-value (format t "DoubleValue (~A, ~A)" (cadr v) (caddr v)))))

Писать каждый раз такой код – дело утомительное и ненужное. Поэтому я придумал вспомогательные утилиты.

Макрос DEFINE-ADT позволяет автоматически генерировать конструктор данных для ADT. Получается та же самая функция, создающая такой же список.

(defmacro define-adt (name &rest args)
  `(defun ,name (,@args)
     (list ',name ,@args)))

Следующий макрос позволяет более наглядно сопоставлять с образцом. Его имя похоже на имена стандартных макросов CASE, CCASE и ECASE. Приставка ADT указывает, что работа идет с алгебраическими типами данных.

(defmacro adt-case (value &body cs)
  (let* ((t-defined nil)
         (ps (loop for c in cs collect
                  (cond
                    ((eql (car c) 't)
                     (setf t-defined t)
                     (append '(t) (cdr c)))
                    (t
                     (when t-defined
                       (error "The T clause can be only the last in the form."))
                     (destructuring-bind ((name &rest args) &body body) c
                       (adt-pattern value name args body)))))))
    (if t-defined
        `(case (car ,value) ,@ps)
        `(ecase (car ,value) ,@ps))))

(defun adt-pattern (value name args body)
  `(,name
    ,(if (null args)
         `(progn ,@body)
         `(destructuring-bind (,@args) (cdr ,value) ,@body))))

Тогда наш исходный код превращается в легко-читаемый и более краткий. Более того, мы ничего не должны знать о том, что там где-то внутри используются списки для реализации ADT. Более высокий уровень абстракции!

(define-adt none-value)
(define-adt single-value a)
(define-adt double-value a1 a2)

(defun test-tagged-type (v)
  (adt-case v
    ((none-value) (format t "NoneValue"))
    ((single-value a) (format t "SingleValue ~a" a))
    ((double-value a1 a2) (format t "DoubleValue (~a, ~a)" a1 a2))))

Сопоставление с образцом было бы неполным, если бы не было замены хаскелевского шаблона “_”. Я выбрал в качестве аналога лисповский терм T. Соответствующее условие должно быть самым последним в списке, иначе компилятор выдаст ошибку.

(defun test-tagged-type-2 (v)
  (adt-case v
    ((none-value) (format t "NoneValue"))
    (t (format t "Not NoneValue"))))

И, наконец, приведу функцию, которая берет значение типа TaggedType и возвращает либо NIL, либо новую CONS-пару.

(defun tagged-type->cons (v)
  (adt-case v
    ((none-value) nil)
    ((single-value a) (list a))
    ((double-value a1 a2) (cons a1 a2))))

Пример использования:

CL-USER> (tagged-type->cons (double-value 1 2))
(1 . 2)

2 комментария:

  1. >Будем делать все через списки.

    Вот это портит все впечатление. Не надо это делать через списки.

    ОтветитьУдалить
  2. >Не надо это делать через списки.

    Списки можно заменить в случае чего. Конечный интерфейс от них не зависит. А чем они не нравятся, и что лучше использовать вместо них?

    ОтветитьУдалить