Продолжение о DSL
Чето походу статья про DSL особо никому не приглянулась: комментариев нет, реакция в инете нулевая (за исключением недовольного ворчания archimag'a в своем блоге. Ну да архимаг известный брюзга: continuations в вебе архаизм, DSL застрял в середине 80-ых, и так далее :))
Ладно, в таком случае я попытаюсь поменять формат подачи информации. Вместо длинных статей, которые нужно "осиливать", буду регулярно прямо в блог постить удачные (на мой взгляд) примеры применения DSL и микро-DSL в CL. Как говорится, пусть код говорит сам за себя :)
Начнем с недавней задачки.
Вот так мы проверяли, разрешено ли нам воткнуть данное число в заданную клетку поля:
(defun move-valid-p (field row col value)
(flet ((find-in-rect (y h x w)
(iter (for i from y below (+ y h))
(iter (for j from x below (+ x w))
(for v = (aref field i j))
(when (and (or (/= i row) (/= j col)) (/= v 0) (= v value))
(return-from find-in-rect t))))
nil))
(not (or (find-in-rect row 1 0 9)
(find-in-rect 0 9 col 1)
(find-in-rect (- row (mod row 3)) 3 (- col (mod col 3)) 3)))))
Плохо: какие-то циклы по i/j -- отдает первым курсом института и паскалем. Помимо эстетического разочарования, алгоритм не блещет и оптимизированностью: некоторые клетки проверяются более одного раза, к процессорному кэшу недружелюбно, ну и т.д. Давайте придумаем здесь предметно-ориентированный язык для генерации проверок такого рода.
(defvalidator sudoku-valid-p ((field 9 9) r c v)
(no-value v in row)
(no-value v in column)
(no-value v in ninth))
Вот это уже хорошо. Давайте для наглядности попробуем приспособить язык для другой задачи, например, под задачу о восьми ферзях.
(defvalidator queens-valid-p ((field 8 8) r c v)
(value 0 in row)
(value 0 in column)
(value 0 in lt-diagonal)
(value 0 in lb-diagonal))
В данном случае, на поле у нас "1" -- стоит ферзь, "0" -- ферзя не стоит. Проверка queens-valid-p проверяет, что данный ферзь в клетке (r, c) никому не угрожает.
А теперь, комфортно описав правила для проверок на DSL, давайте сбрутфорсим соответствующие поля.
Вот судоку:
DSL-TEST> (bruteforce-field (fld (9 9) sudoku-valid-p)
(iter (for i from 1 to 9)
(try i)))
#2A((1 2 3 4 5 6 7 8 9)
(4 5 6 7 8 9 1 2 3)
(7 8 9 1 2 3 4 5 6)
(2 1 4 3 6 5 8 9 7)
(3 6 5 8 9 7 2 1 4)
(8 9 7 2 1 4 3 6 5)
(5 3 1 6 4 2 9 7 8)
(6 4 2 9 7 8 5 3 1)
(9 7 8 5 3 1 6 4 2))
Вот ферзи:
DSL-TEST> (let ((queens 8))
(bruteforce-field (fld (8 8) queens-valid-p)
(decf queens)
(try 1)
(incf queens)
(and (next) (zerop queens))))
#2A((1 0 0 0 0 0 0 0)
(0 0 0 0 1 0 0 0)
(0 0 0 0 0 0 0 1)
(0 0 0 0 0 1 0 0)
(0 0 1 0 0 0 0 0)
(0 0 0 0 0 0 1 0)
(0 1 0 0 0 0 0 0)
(0 0 0 1 0 0 0 0))
Просто, понятно, красиво. Как работает? По описанию DSL генерируется лукап-таблица размером с поле, в каждой клетке которой строится подобного вида функция:
(LAMBDA (FIELD R C V)
(DECLARE (IGNORABLE FIELD R C V)
(OPTIMIZE (SPEED 3) (SAFETY 0) (DEBUG 0))
(TYPE (SIMPLE-ARRAY FIXNUM (8 8)) FIELD)
(TYPE FIXNUM V))
(AND (ZEROP (AREF FIELD 0 1)) (ZEROP (AREF FIELD 0 2))
(ZEROP (AREF FIELD 0 3)) (ZEROP (AREF FIELD 0 4))
(ZEROP (AREF FIELD 0 5)) (ZEROP (AREF FIELD 0 6))
(ZEROP (AREF FIELD 0 7)) (ZEROP (AREF FIELD 1 0))
(ZEROP (AREF FIELD 1 1)) (ZEROP (AREF FIELD 2 0))
(ZEROP (AREF FIELD 2 2)) (ZEROP (AREF FIELD 3 0))
(ZEROP (AREF FIELD 3 3)) (ZEROP (AREF FIELD 4 0))
(ZEROP (AREF FIELD 4 4)) (ZEROP (AREF FIELD 5 0))
(ZEROP (AREF FIELD 5 5)) (ZEROP (AREF FIELD 6 0))
(ZEROP (AREF FIELD 6 6)) (ZEROP (AREF FIELD 7 0))
(ZEROP (AREF FIELD 7 7))))
Дублирующихся проверок нет, очередность как можно более линейная (во благо кэша), типы аккуратно везде расставлены и тд. Собственно функция проверки делается так:
(DEFUN QUEENS-VALID-P (FIELD R C V)
(DECLARE (OPTIMIZE (SPEED 3) (SAFETY 0) (DEBUG 0))
(TYPE (SIMPLE-ARRAY FIXNUM (8 8)) FIELD)
(TYPE (INTEGER 0 7) R)
(TYPE (INTEGER 0 7) C)
(TYPE FIXNUM V))
(FUNCALL (ELT #:G21743 (+ (* R 8) C)) FIELD R C V)))
g21743 -- это таблица.
Заметьте: все типы аккуратно промаркированы размерностями. Это оно само так получилось, мы же задали ширину/высоту поля в defvalidator ;) Любители зависимых типов должны оценить. Все что на этапе компиляции мы знаем, все можно совершенно свободно использовать во благо.
Ну и код компилятора:
(defmacro defvalidator (name ((field width height) row col value) &rest clauses)
(with-gensyms (lookup-table)
;; build lookup table
(multiple-value-bind (lookup-rules table)
(validator-clauses->rules field width height clauses)
(flet ((lookup-builder (r c)
(clrhash table)
(iter (for rule in lookup-rules)
(funcall rule r c))
(iter (for (cnd (cnd-r cnd-c)) in-hashtable table)
(unless (and (= r cnd-r) (= c cnd-c))
(collect (list (+ (* cnd-r width) cnd-c) cnd) into cnds))
(finally (return `(lambda (,field ,row ,col ,value)
(declare (ignorable ,field ,row ,col ,value)
(optimize (speed 3) (safety 0) (debug 0))
(type (simple-array fixnum (,height ,width)) ,field)
(type fixnum ,value))
(and ,@(mapcar #'second (sort cnds #'< :key #'first)))))))))
;; declare function
`(let ((,lookup-table ,(validator-build-lookup-table width height #'lookup-builder)))
(declare (type (simple-vector ,(* height width)) ,lookup-table))
(defun ,name (,field ,row ,col ,value)
(declare (optimize (speed 3) (safety 0) (debug 0))
(type (simple-array fixnum (,height ,width)) ,field)
(type (integer 0 ,(1- height)) ,row)
(type (integer 0 ,(1- width)) ,col)
(type fixnum ,value))
(funcall (elt ,lookup-table (+ (* ,row ,width) ,col)) ,field ,row ,col ,value)))))))
(defun validator-clauses->rules (field width height clauses)
(iter (with table = (make-hash-table :test 'equal))
(for (op op-value in-kw where) in clauses)
(assert (eq in-kw 'in))
(for builder = (validator-builder op op-value field))
(collect (validator-where where width height
(lambda (r c)
(setf (gethash (funcall builder r c) table) (list r c))))
into rules)
(finally (return (values rules table)))))
(defun validator-builder (op op-value field)
(lambda (row col)
(ecase op
(no-value `(/= (aref ,field ,row ,col) ,op-value))
(value (if (eql op-value 0)
`(zerop (aref ,field ,row ,col))
`(= (aref ,field ,row ,col) ,op-value))))))
(defmacro-driver (FOR var AS-SEGMENT start - end &sequence)
(declare(with-gensyms (step from to i)
(let ((kwd (if generate 'generate 'for)))
`(progn (with ,from = ,start)
(with ,to = ,end)
(with ,step = (if (<= ,from ,to) ,iterate::by (- ,iterate::by)))
(with ,i = (- ,from ,step))
(,kwd ,var next (progn (incf ,i ,step)
(when (= ,i (+ ,to ,step))
(terminate))
,i))))))
(defun validator-where (where width height builder)
(flet ((rect (y h x w)
(iter (for i from y below (+ y h))
(iter (for j from x below (+ x w))
(funcall builder i j))))
(diag (x-0 y-0 x-1 y-1)
(iter (for i as-segment y-0 - y-1)
(for j as-segment x-0 - x-1)
(when (and (<= 0 i (1- height)) (<= 0 j (1- width)))
(funcall builder i j)))))
(lambda (row col)
(ecase where
(row (rect row 1 0 width))
(column (rect 0 height col 1))
(ninth (let ((w (/ width 3)) (h (/ height 3)))
(rect (- row (mod row h)) h (- col (mod col w)) w)))
(lt-diagonal (diag (- 0 row height) (- 0 col width) (+ row height) (+ col width)))
(lb-diagonal (diag (+ row height) (- col width) (- row height) (+ col width)))))))
(defun validator-build-lookup-table (width height where-collector)
`(coerce (list ,@(iter main
(for i from 0 below height)
(iter (for j from 0 below width)
(in main (collect (funcall where-collector i j))))))
'simple-vector))
(defmacro bruteforce-field ((field (width height) valid-checker) &body body)
(with-gensyms (bruteforce r c)
`(let ((,field (make-array '(,height ,width) :initial-element 0)))
(labels ((,bruteforce (,r ,c)
(macrolet ((next () `(,',bruteforce (+ ,',r (truncate (/ (1+ ,',c) ,',width))) (mod (1+ ,',c) ,',width)))
(try (value)
`(progn (setf (aref ,',field ,',r ,',c) ,value)
(when (and (,',valid-checker ,',field ,',r ,',c ,value)
(next))
(return-from ,',bruteforce t))
(setf (aref ,',field ,',r ,',c) 0))))
(if (>= ,r ,height) t (progn ,@body)))))
(,bruteforce 0 0)
,field))))
Ладно, в таком случае я попытаюсь поменять формат подачи информации. Вместо длинных статей, которые нужно "осиливать", буду регулярно прямо в блог постить удачные (на мой взгляд) примеры применения DSL и микро-DSL в CL. Как говорится, пусть код говорит сам за себя :)
Начнем с недавней задачки.
Вот так мы проверяли, разрешено ли нам воткнуть данное число в заданную клетку поля:
(defun move-valid-p (field row col value)
(flet ((find-in-rect (y h x w)
(iter (for i from y below (+ y h))
(iter (for j from x below (+ x w))
(for v = (aref field i j))
(when (and (or (/= i row) (/= j col)) (/= v 0) (= v value))
(return-from find-in-rect t))))
nil))
(not (or (find-in-rect row 1 0 9)
(find-in-rect 0 9 col 1)
(find-in-rect (- row (mod row 3)) 3 (- col (mod col 3)) 3)))))
Плохо: какие-то циклы по i/j -- отдает первым курсом института и паскалем. Помимо эстетического разочарования, алгоритм не блещет и оптимизированностью: некоторые клетки проверяются более одного раза, к процессорному кэшу недружелюбно, ну и т.д. Давайте придумаем здесь предметно-ориентированный язык для генерации проверок такого рода.
(defvalidator sudoku-valid-p ((field 9 9) r c v)
(no-value v in row)
(no-value v in column)
(no-value v in ninth))
Вот это уже хорошо. Давайте для наглядности попробуем приспособить язык для другой задачи, например, под задачу о восьми ферзях.
(defvalidator queens-valid-p ((field 8 8) r c v)
(value 0 in row)
(value 0 in column)
(value 0 in lt-diagonal)
(value 0 in lb-diagonal))
В данном случае, на поле у нас "1" -- стоит ферзь, "0" -- ферзя не стоит. Проверка queens-valid-p проверяет, что данный ферзь в клетке (r, c) никому не угрожает.
А теперь, комфортно описав правила для проверок на DSL, давайте сбрутфорсим соответствующие поля.
Вот судоку:
DSL-TEST> (bruteforce-field (fld (9 9) sudoku-valid-p)
(iter (for i from 1 to 9)
(try i)))
#2A((1 2 3 4 5 6 7 8 9)
(4 5 6 7 8 9 1 2 3)
(7 8 9 1 2 3 4 5 6)
(2 1 4 3 6 5 8 9 7)
(3 6 5 8 9 7 2 1 4)
(8 9 7 2 1 4 3 6 5)
(5 3 1 6 4 2 9 7 8)
(6 4 2 9 7 8 5 3 1)
(9 7 8 5 3 1 6 4 2))
Вот ферзи:
DSL-TEST> (let ((queens 8))
(bruteforce-field (fld (8 8) queens-valid-p)
(decf queens)
(try 1)
(incf queens)
(and (next) (zerop queens))))
#2A((1 0 0 0 0 0 0 0)
(0 0 0 0 1 0 0 0)
(0 0 0 0 0 0 0 1)
(0 0 0 0 0 1 0 0)
(0 0 1 0 0 0 0 0)
(0 0 0 0 0 0 1 0)
(0 1 0 0 0 0 0 0)
(0 0 0 1 0 0 0 0))
Просто, понятно, красиво. Как работает? По описанию DSL генерируется лукап-таблица размером с поле, в каждой клетке которой строится подобного вида функция:
(LAMBDA (FIELD R C V)
(DECLARE (IGNORABLE FIELD R C V)
(OPTIMIZE (SPEED 3) (SAFETY 0) (DEBUG 0))
(TYPE (SIMPLE-ARRAY FIXNUM (8 8)) FIELD)
(TYPE FIXNUM V))
(AND (ZEROP (AREF FIELD 0 1)) (ZEROP (AREF FIELD 0 2))
(ZEROP (AREF FIELD 0 3)) (ZEROP (AREF FIELD 0 4))
(ZEROP (AREF FIELD 0 5)) (ZEROP (AREF FIELD 0 6))
(ZEROP (AREF FIELD 0 7)) (ZEROP (AREF FIELD 1 0))
(ZEROP (AREF FIELD 1 1)) (ZEROP (AREF FIELD 2 0))
(ZEROP (AREF FIELD 2 2)) (ZEROP (AREF FIELD 3 0))
(ZEROP (AREF FIELD 3 3)) (ZEROP (AREF FIELD 4 0))
(ZEROP (AREF FIELD 4 4)) (ZEROP (AREF FIELD 5 0))
(ZEROP (AREF FIELD 5 5)) (ZEROP (AREF FIELD 6 0))
(ZEROP (AREF FIELD 6 6)) (ZEROP (AREF FIELD 7 0))
(ZEROP (AREF FIELD 7 7))))
Дублирующихся проверок нет, очередность как можно более линейная (во благо кэша), типы аккуратно везде расставлены и тд. Собственно функция проверки делается так:
(DEFUN QUEENS-VALID-P (FIELD R C V)
(DECLARE (OPTIMIZE (SPEED 3) (SAFETY 0) (DEBUG 0))
(TYPE (SIMPLE-ARRAY FIXNUM (8 8)) FIELD)
(TYPE (INTEGER 0 7) R)
(TYPE (INTEGER 0 7) C)
(TYPE FIXNUM V))
(FUNCALL (ELT #:G21743 (+ (* R 8) C)) FIELD R C V)))
g21743 -- это таблица.
Заметьте: все типы аккуратно промаркированы размерностями. Это оно само так получилось, мы же задали ширину/высоту поля в defvalidator ;) Любители зависимых типов должны оценить. Все что на этапе компиляции мы знаем, все можно совершенно свободно использовать во благо.
Ну и код компилятора:
(defmacro defvalidator (name ((field width height) row col value) &rest clauses)
(with-gensyms (lookup-table)
;; build lookup table
(multiple-value-bind (lookup-rules table)
(validator-clauses->rules field width height clauses)
(flet ((lookup-builder (r c)
(clrhash table)
(iter (for rule in lookup-rules)
(funcall rule r c))
(iter (for (cnd (cnd-r cnd-c)) in-hashtable table)
(unless (and (= r cnd-r) (= c cnd-c))
(collect (list (+ (* cnd-r width) cnd-c) cnd) into cnds))
(finally (return `(lambda (,field ,row ,col ,value)
(declare (ignorable ,field ,row ,col ,value)
(optimize (speed 3) (safety 0) (debug 0))
(type (simple-array fixnum (,height ,width)) ,field)
(type fixnum ,value))
(and ,@(mapcar #'second (sort cnds #'< :key #'first)))))))))
;; declare function
`(let ((,lookup-table ,(validator-build-lookup-table width height #'lookup-builder)))
(declare (type (simple-vector ,(* height width)) ,lookup-table))
(defun ,name (,field ,row ,col ,value)
(declare (optimize (speed 3) (safety 0) (debug 0))
(type (simple-array fixnum (,height ,width)) ,field)
(type (integer 0 ,(1- height)) ,row)
(type (integer 0 ,(1- width)) ,col)
(type fixnum ,value))
(funcall (elt ,lookup-table (+ (* ,row ,width) ,col)) ,field ,row ,col ,value)))))))
(defun validator-clauses->rules (field width height clauses)
(iter (with table = (make-hash-table :test 'equal))
(for (op op-value in-kw where) in clauses)
(assert (eq in-kw 'in))
(for builder = (validator-builder op op-value field))
(collect (validator-where where width height
(lambda (r c)
(setf (gethash (funcall builder r c) table) (list r c))))
into rules)
(finally (return (values rules table)))))
(defun validator-builder (op op-value field)
(lambda (row col)
(ecase op
(no-value `(/= (aref ,field ,row ,col) ,op-value))
(value (if (eql op-value 0)
`(zerop (aref ,field ,row ,col))
`(= (aref ,field ,row ,col) ,op-value))))))
(defmacro-driver (FOR var AS-SEGMENT start - end &sequence)
(declare(with-gensyms (step from to i)
(let ((kwd (if generate 'generate 'for)))
`(progn (with ,from = ,start)
(with ,to = ,end)
(with ,step = (if (<= ,from ,to) ,iterate::by (- ,iterate::by)))
(with ,i = (- ,from ,step))
(,kwd ,var next (progn (incf ,i ,step)
(when (= ,i (+ ,to ,step))
(terminate))
,i))))))
(defun validator-where (where width height builder)
(flet ((rect (y h x w)
(iter (for i from y below (+ y h))
(iter (for j from x below (+ x w))
(funcall builder i j))))
(diag (x-0 y-0 x-1 y-1)
(iter (for i as-segment y-0 - y-1)
(for j as-segment x-0 - x-1)
(when (and (<= 0 i (1- height)) (<= 0 j (1- width)))
(funcall builder i j)))))
(lambda (row col)
(ecase where
(row (rect row 1 0 width))
(column (rect 0 height col 1))
(ninth (let ((w (/ width 3)) (h (/ height 3)))
(rect (- row (mod row h)) h (- col (mod col w)) w)))
(lt-diagonal (diag (- 0 row height) (- 0 col width) (+ row height) (+ col width)))
(lb-diagonal (diag (+ row height) (- col width) (- row height) (+ col width)))))))
(defun validator-build-lookup-table (width height where-collector)
`(coerce (list ,@(iter main
(for i from 0 below height)
(iter (for j from 0 below width)
(in main (collect (funcall where-collector i j))))))
'simple-vector))
(defmacro bruteforce-field ((field (width height) valid-checker) &body body)
(with-gensyms (bruteforce r c)
`(let ((,field (make-array '(,height ,width) :initial-element 0)))
(labels ((,bruteforce (,r ,c)
(macrolet ((next () `(,',bruteforce (+ ,',r (truncate (/ (1+ ,',c) ,',width))) (mod (1+ ,',c) ,',width)))
(try (value)
`(progn (setf (aref ,',field ,',r ,',c) ,value)
(when (and (,',valid-checker ,',field ,',r ,',c ,value)
(next))
(return-from ,',bruteforce t))
(setf (aref ,',field ,',r ,',c) 0))))
(if (>= ,r ,height) t (progn ,@body)))))
(,bruteforce 0 0)
,field))))