Регистрация | Войти
Lisp — программируемый язык программирования
Лисп в первый раз в жизни
Вопрос к лисп-аудитории.

Мне скоро потребуется заменить моего друга на кружке по теории алгоритмов. Рассказывать я могу о чём угодно в течении полутора часов, и я решил рассказать о некоторых философских идеях лиспа для расширения кругозора. Пока что мне приходят в голову две темы для рассказа:
  1. Кодогенерация (макросы, использование программы как данных)
  2. ФП на примере обработки списков (lambda, map, reduce, apply и т.д.)
А какие ещё идеи по вашему мнению стоило бы включить в рассказ?

[update] Если что, то слушатели — десятиклассники, их опыт программирования недалеко выходит за школьный, но есть некоторая стандартная алгоритмическая база.
Embeddable Maxima. Советы и хитрости.

Updated: 23.01.12

Почему максиму сложно интегрировать в веб

Веб по-умолчанию многопользовательский.Максима по-умолчанию однопользовательская.Сделать максиму многопользовательской можно, но нужно желание этих пользователей пользоватся ею одновременно на одном компьютере.

Посмотреть справку


(pushnew "/path/to/embeddable-maxima" asdf:*central-registry*)
(ql:quickload :embeddable-maxima)
(in-package :maxima)

Для просмотра справки необходимо вызвать функцию describe("function-name"). Данная функция в окружении лиспа определена, как $describe. В лиспе вызывать ее следует с помощью mfuncall (maxima function caller). Например, просмотр справки для функции ratsimp.


MAXIMA> (mfuncall '$describe "ratsimp")

-- Function: ratsimp ()
-- Function: ratsimp (, , ..., )
Simplifies the expression and all of its subexpressions,
including the arguments to non-rational functions. The result is
returned as the quotient of two polynomials in a recursive form,
that is, the coefficients of the main variable are polynomials in
the other variables. Variables may include non-rational functions
(e.g., `sin (x^2 + 1)') and the arguments to any such functions
are also rationally simplified.

`ratsimp (, , ..., )' enables rational
simplification with the specification of variable ordering as in
`ratvars'.

When `ratsimpexpons' is `true', `ratsimp' is applied to the
exponents of expressions during simplification.

See also `ratexpand'. Note that `ratsimp' is affected by some of
the flags which affect `ratexpand'.

Examples:

(%i1) sin (x/(x^2 + x)) = exp ((log(x) + 1)^2 - log(x)^2);
2 2
x (log(x) + 1) - log (x)
(%o1) sin(------) = %e
2
x + x
(%i2) ratsimp (%);
1 2
(%o2) sin(-----) = %e x
x + 1
(%i3) ((x - 1)^(3/2) - (x + 1)*sqrt(x - 1))/sqrt((x - 1)*(x + 1));
3/2
(x - 1) - sqrt(x - 1) (x + 1)
(%o3) --------------------------------
sqrt((x - 1) (x + 1))
(%i4) ratsimp (%);
2 sqrt(x - 1)
(%o4) - -------------
2
sqrt(x - 1)
(%i5) x^(a + 1/a), ratsimpexpons: true;
2
a + 1
------
a
(%o5) x


There are also some inexact matches for `ratsimp'.
Try `?? ratsimp' to see them.

Выполнить строку


(pushnew "/path/to/embeddable-maxima" asdf:*central-registry*)
(ql:quickload :embeddable-maxima)
(in-package :maxima)

Делай ast с помощью специальной функции macsyma-read-string, раз:

Важно не забыть один из терминальных символов ";" или "$".


MAXIMA> (macsyma-read-string "ratsimp( (2*x^2 + 3*x + 1) - (x^2 + x^2 - 2*x + 4*x + 1) );")

(($RATSIMP)
((MPLUS) ((MPLUS) ((MTIMES) 2 ((MEXPT) $X 2)) ((MTIMES) 3 $X) 1)
((MMINUS)
((MPLUS) ((MEXPT) $X 2) ((MEXPT) $X 2) ((MTIMES) ((MMINUS) 2) $X)
((MTIMES) 4 $X) 1))))

Выполняй ast с помощью вызова максимы-функции ev(expression,arg_1,arg_2,...,arg_n), два:


MAXIMA> (mfuncall '$ev *)

$X

Отображай полученное ast в строчку, три:


MAXIMA> (displa *)

x
NIL

В данном примере мы упростили выражение ((2*x^2 + 3*x + 1) - (x^2 + x^2 - 2*x + 4*x + 1)) с помощью функции ratsimp.

Простой json-rpc для maxima

Осторожно, американский стиль повествования!Верите ли вы, что я сделаю это за 42 строчки? А вот да, сделаю. Конечно это лисп, и здесь в рамках одной строки вмещается раза в два больше информации, чем в алгольных языках. При этом я еще и поиспользую кучу библиотек, хотя считается, что под cl их нет. Ладно, если не считать пустых строк, то их всего 32. Ну что поверили? А вот я опять вас обманул. Действительно полезных строк 27. Итак json-rpc сервис для maxima, для того, чтобы вы из любого языка, который умеет http и json могли решить дифференциальное уравнение второго порядка. Только здесь и только сейчас.

Загружаем три библиотеки, 1-ая строка:


(mapcar #'ql:quickload '(:embeddable-maxima :restas :cl-json))

Обозначаем restas модуль для обработки http запросов, 4-ая строка:


(restas:define-module :maxima-json-rpc
(:use #:cl #:restas #:json #:json-rpc))
(in-package :maxima-json-rpc)

Создаем функцию для проверки: заканчивается ли переданная максима команда с помощью терминальных символов $ или ;, 11-ая строка:


(defun ensure-valid-maxima-input (input)
"Returns string with appended ';', if input string does not have maxima command terminator at the end."
(let* ((input-trimmed (string-trim '(#\Space #\Newline #\Tab) input))
(last-char (char input-trimmed (1- (length input-trimmed)))))
(if (and (not (char= #\; last-char)) (not (char= #\$ last-char)))
(concatenate 'string input-trimmed ";")
input-trimmed)))

Создаем функцию, которая преобразовывает строковое выражение в АСТ для максимы, 13-ая строка:


(defun maxima-ast-from-string (input)
(maxima::macsyma-read-string (ensure-valid-maxima-input input)))

Макрос, который заставляет максиму, выводить результат в "компьютерном" синтаксисе (дроби через /, степени - ^, и т.д.), 16-ая строка:


(defmacro with-2d-output (&body body)
`(let ((maxima::$display2d nil))
,@body))

Экспортируемая функция доступная из удаленных источников. Создается с помощью json-rpc:defun-json-rpc, 24-ая строка:


(defun-json-rpc evaluate :explicit (text)
"Evaluate maxima expression"
(let ((result (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t)))
(with-output-to-string (*standard-output* result)
(with-2d-output
(maxima::displa
(maxima::mfuncall 'maxima::$ev (maxima-ast-from-string text)))))
result))

Обработчик http маршрута, например, http://127.0.0.01/jsonrpc. 31-ая строка:


(define-route jsonrpc ("jsonrpc"
:method :post
;;:content-type "application/json"
)
"json rpc route"
(let ((*json-rpc-version* +json-rpc-2.0+))
(invoke-rpc (hunchentoot:raw-post-data :force-text t))))

Ну а здесь мы предоставляет простую страничку, которая умеет с помощью jquery, ajax, json-rpc решать те самые диффуры:


(define-route example ("example")
(merge-pathnames "examples/js-maxima-rpc-client.html" (asdf:component-pathname (asdf:find-system :maxima-json-rpc))))

Последняя строка для запуска:


(restas:start '#:maxima-json-rpc :port 8080)

Да, это все оформлено и в репозитарии лежит. https://github.com/filonenko-mikhail/maxima-json-rpc

Но это еще не всё. В дополнение вы получаете простой пример на php для того, чтобы моментально находить ответы на непростые математические вопросы. Внимание, данный пример требует наличия JSON-RPC PHP!


<?php
require_once 'jsonRPCClient.php';
$maxima = new jsonRPCClient('http://127.0.0.1:8080/jsonrpc');
print "Maxima evaluator\n";
print "Evaluate ratsimp(x^2 + 2*x + 1 - (x + 1)^2)\n";
print $maxima->evaluate("ratsimp(x^2 + 2*x + 1 - (x + 1)^2)");

print "Evaluate x^2 + 2*x + 1 + (x + 1)^2 in environment x=2\n";
print $maxima->evaluate("ev(x^2 + 2*x + 1 + (x + 1)^2, x=2)");
?>

И напоследок, sh и решение диффуров. Диффуры такие:


(%i1) 'diff(f,x,2) = sin(x) + 'diff(g,x);

2
d f dg
(%o1) --- = sin(x) + --
2 dx
dx
(%i2) 'diff(f,x) + x^2 - f = 2*'diff(g,x,2);

2
2 df d g
(%o2) x + -- - f = 2 ---
dx 2
dx

sh файлик такой:


#!/bin/sh
curl -i -X POST -d "{\"jsonrpc\": \"2.0\", \"method\": \"evaluate\", \"params\": [\"desolve(['diff(f(x),x,2) = 'diff(g(x),x,1)+sin(x), 'diff(f(x),x,1)-f(x)+x^2 = 2*'diff(g(x),x,2)], [f(x),g(x)]);\"], \"id\": 1}" http://linkfly.ru:8181/jsonrpc

А теперь, кто готов все повторить, но уже на пайтоне?

P.S. А Firemax, что расширение для Firefox, очень даже неплохо справляется с задачей эмуляции emacs под броузером.

Глубоко-вложенные вычисления

Тема возникла из моих ответов на вопросы, заданные другим человеком на форумах. Речь пойдет о рекурсивных вычислениях, когда глубина вложенности выше предельно допустимой для стека вызовов. Я покажу, как такая задача может быть решена на Common Lisp. Сразу отмечу, что это возможно не всегда, но в большинстве случаев работает.

В основе лежит та же самая идея, что используется в F# Async. Мы просто переводим наши рекурсивные функции на язык продолжений.  Пугаться здесь не стоит, сами мы этого делать не станем. За нас все самое сложное и рутинное сделают WITH-CALL/CC и его специальная версия для функций DEFUN/CC из пакета CL-CONT. Ниже везде предполагается, что пакет CL-CONT импортирован.

Но прежде определимся с исходной задачей. Ниже приведены функции, которые вылетают со Stack Overflow.

(defun compute (x)
  (cond ((zerop x) 0)
        (t (+ (compute (1- x))
              1))))


(defun run ()
  (compute 10000000)) ;; Stack Overflow

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

Перепишем функции через продолжения. Функцию COMPUTE определим через DEFUN/CC. Т.е. она будет возвращать не обычное значение, а вычисление, которое еще нужно запустить. В F# это примерно означало бы то, что функция COMPUTE возвращала бы некоторое значение типа Async<'a>.

(defun/cc compute/cc (x)
  (cond ((zerop x) 0)
        (t (+ (compute/cc (1- x))
              1))))

Таким образом мы должны преобразовать всякую функцию, вложенность которой может быть огромной. Вызывать их можно из DEFUN/CC и WITH-CALL/CC:

(defun run/cc ()
  (with-call/cc (compute/cc 10000000)))

Если у вас SBCL, то на этом можно остановиться. У этой лисп-машины превосходный оптимизатор хвостового вызова. У нас фактически все операции COMPUTE превращаются в цепочку хвостовых вызовов. Поэтому все работает. Стек как бы уходит в память.

Увы, не все лисп-машины хорошо оптимизируют хвостовые вызовы. Для CLozure CL и LispWorks Personal мы по-прежнему получим Stack Overflow. К счастью есть выход - использовать трамплин.

Внутри вычисления DEFUN/CC нам доступно продолжение. Если глубина стека вызовов стала большой, то мы можем запомнить продолжение и раскрутить в обратную сторону стек, возвращая управление некоторому внешнему циклу. Внутри этого цикла мы будем проверять, а нет ли у нас очередного продолжения для, так сказать, продления вычисления. Если есть, то запускаем это продолжение. Фокус состоит в том, что при запуске продолжения стек вызовов уже очищен, что нам и требуется.

Сначала определим утилиты трамплина:

(defparameter *cont* nil)


(defun/cc trampoline-push/cc ()
  (call/cc 
   (lambda (k)
     (push k *cont*))))


(defmacro trampoline/cc (expr)
  (let ((result (gensym)))
    `(progn
       (trampoline-push/cc)
       (let ((,result ,expr))
         (trampoline-push/cc)
         ,result))))


(defmacro with-trampoline/cc (&body body)
  (let ((result (gensym)))
    `(let ((,result nil))
       (with-call/cc
         (trampoline-push/cc)
         ,@body)
       (loop while *cont*
          do (let ((cont (pop *cont*)))
               (setf ,result (funcall cont))))
       ,result)))

Утилита TRAMPOLINE-PUSH/CC кладет продолжение вычисления в ячейку *CONT* и возвращает управление внешнему циклу из WITH-TRAMPOLINE/CC, откуда все должно быть запущено. Макрос TRAMPOLINE/СС оборачивает заданное выражение, где трамплин вызывается до и после вычисления выражения.

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

(defun/cc smart-compute/cc (x)
  (cond ((zerop x) 0)
        ((zerop (mod x 100))  
         ;; on every 100th iteration use the trampoline
         (+ (trampoline/cc (smart-compute/cc (1- x)))
            1))
        (t 
         (+ (smart-compute/cc (1- x))
            1))))


 ;; No Stack Overflow
 (defun smart-run/cc ()
  (with-trampoline/cc (smart-compute/cc 10000000)))

Это работает даже для CLISP, где нет никакой оптимизации хвостового вызова. Мы успешно имитирует рекурсивный вызов с глубиной вложенности десять миллионов!
Common Lisp. Работа со звуком. CL-PortAudio.

Сразу код: караоке.

Установите PortAudio.
Включите музыку (желательно, с вокалом), и выполните следующий код:


sudo pacman -S portaudio
git clone --depth 1 https://github.com/filonenko-mikhail/cl-portaudio.git
emacs
M+x slime
(pushnew "path/to/cl-portaudio/" asdf:*central-registry*)
(ql:quickload :cl-portaudio)
(ql:quickload :cl-portaudio-tests)
(portaudio-tests:test-read-write-echo)

Теперь у вас есть 15 секунд, чтобы подпевать. Да, можно было бы подпевать и без таких сложных манипуляци, как лисп, emacs, но в результате небольшой задержки при записи/воспроизведении собственный голос звучит из колонок, как бэквокал, и я, например, понял, почему многие просят меня не подпевать радио.

CL-PortAudio

CL-PortAudio cffi-биндинги к PortAudio. PortAudio небольшая кроссплатформенная библиотека для работы со звуком. Она позволяет:

  • записывать звук;
  • воспроизводить звук.

CL-PortAudio соответственно позволяет делать эти вещи из лиспа.

Документация скопирована и переработана.

API

PortAudio предоставляет очень простое API. Для передачи данных в обоих направлениях можно использовать функцию обратного вызова (callback) или блокирующие функции чтения/записи. Блокирующие функции, надо сказать, можно "разблокировать", с помощью вызова *available функций, которые возвращают возможность чтения/записи данных.

CL-PortAudio использует только блокирующий ввод/вывод, так как функция обратного вызова исполняется в "критическом" контексте, и в ней нельзя даже память выделить, не говоря уже об интерпретаторе лиспа.

Common Lisp позволил уменьшить код основной работы со звуком до 4 функций/макросов. Вот код караоке, которое было вначале.


(use-package :portaudio)

(defconstant +frames-per-buffer+ 1024)
(defconstant +sample-rate+ 44100d0)
(defconstant +seconds+ 15)
(defconstant +sample-format+ :float)
(defconstant +num-channels+ 2)


(defun test-read-write-converted-echo ()
"Record input into an array; Separate array to channels; Merge channels into array; Play last array."
(with-audio
(format t "~%=== Wire on. Will run ~D seconds . ===~%" +seconds+)
(with-default-audio-stream (astream +num-channels+ +num-channels+ :sample-format +sample-format+ :sample-rate +sample-rate+ :frames-per-buffer +frames-per-buffer+)
(dotimes (i (round (/ (* +seconds+ +sample-rate+) +frames-per-buffer+)))
(ignore-errors (write-stream astream
(merge-channels-into-array astream
(separate-array-to-channels astream
(read-stream astream)))))))))

  • with-audio (&body body)

    Макрос инициализирует в начале и деинициализирует в конце body библиотеку portaudio.

  • with-default-audio-stream ((var num-input num-output &key (sample-format :float) (sample-rate 44100.0d0) (frames-per-buffer 1024)) &body body)

    Макрос открывает в начале и закрывает в конце поток для ввода/вывода с заданным количеством каналов, форматом данных (только :float), частотой и количеством данных за один вызов записи/чтения.Макрос также запускает и останавливает открытый поток.

  • read-stream (pa-stream)

    Читает данные из потока запущенного ранее. Возвращает одномерные массив данных типа sample-format (только 'single-float) размером (* frames-per-buffer num-input).

  • write-stream (pa-stream buffer)

    Записывает данные в поток запущенный ранее. Массив должен быть одномерным типа sample-format (только 'single-float) размером (* frames-per-buffer num-output).

  • separate-array-to-channels (pa-stream array)

    Преобразует одномерный массив в (кол-во_каналов)-мерный массив.

  • merge-channels-into-array (pa-stream channels)

    Преобразует (кол-во_каналов)-мерный массив в одномерный массив.

Бинарные сборки библиотеки PortAudio можно скачать вот здесь http://planet.plt-scheme.org/package-source/clements/portaudio.plt/2/3/lib/. Очень большое спасибо ракетчикам.

Протестировано:

  • SBCL 1.0.54, archlinux x86_64
  • SBCL 1.0.53.74.mswinmt.1092-207a13d, windows 7 x86_64 (vbox).

Первые впечатления о CAPI из LispWorks
Сегодня впервые использовал CAPI для создания каркаса будущего редактора диаграмм. Остался очень довольным. Местами не похоже на Windows Forms, WPF/Silverlight, Swing, SWT, но разобраться можно. Работает, что отрадно.

Еще очень радует среда LispWorksСейчас в проекте 250 килобайт кода на лиспе. Секунда или две после внесения изменений – и я уже вижу обновленное окошко моего редактора. Помню, как я мучился в ожидании, когда почти ту же самую задачу реализовывал на Scala с помощью IntelliJ Idea. Приходилось ждать целую вечность!
Common Lisp. 3d plot renderer.

Завлекушная картинка.

Захотелось тут написать простой интерактивный просмотрщик дву- и трехмерных графиков.

Я начал с библиотеки clx. Данная библиотека реализует протокол общения с графическим X сервером и не содержит внешних зависимостей. X сервер содержит расширение glx позволяющее использовать opengl. Я думал, что расширение glx заведется. Не завелось. Хотя под windows+cygwin/x+clx успех был, но это не моя конфигурация по-умолчанию.

На канале #lisp подсказали библиотеку glop, которую можно назвать урезанным clx'ом. Данная библиотека не реализует протокол самостоятельно, а просто является оберткой над сишными клиентами, а под windows и macos использует родные api.

Сегодня пойдет речь о том, как создать рендерер графиков на коммон лиспе с помощью библиотеки glop. По сути, это будет движок для приближения/отдаления точки и вращения вокруг нее.

Сразу же код:


(defpackage :3dplot
(:use #:cl )
(:export #:draw-plot #:while))

(in-package #:3dplot)

(defvar *min-zoom* 0.1)
(defvar *zoom-step* 0.1)
(defvar *rotate-multiplicator* 0.3)
(defvar *viewport-multiplicator* 10)

(defclass plotwindow (glop:window)
((1st-pressed :initform nil :accessor 1st-pressed)
(zoom :initform 1 :accessor zoom)
(xangle :initform 0 :accessor xangle)
(yangle :initform 0 :accessor yangle)))

(defmethod glop:on-event ((window plotwindow) (event glop:key-event))
(when (eq (glop:keysym event) :escape)
(glop:push-close-event window))
(when (and (glop:pressed event) (eq (glop:keysym event) :f))
(glop:toggle-fullscreen window))
(when (and (glop:pressed event) (eq (glop:keysym event) :g))
(glop:set-fullscreen window)))

(defmethod glop:on-event ((window plotwindow) (event glop:button-event))
(case (glop:button event)
(1 ;; main button
(setf (1st-pressed window) (glop:pressed event)))
(4 ;; scroll up
(when (> (zoom window) *min-zoom*)
(decf (zoom window) *zoom-step*)
(glop:push-event window (make-instance 'glop:resize-event :height (glop:window-height window)
:width (glop:window-width window)))))
(5 ;; scroll down
(incf (zoom window) *zoom-step*)
(glop:push-event window (make-instance 'glop:resize-event :height (glop:window-height window)
:width (glop:window-width window))))))

(defmethod glop:on-event ((window plotwindow) (event glop:mouse-motion-event))
(when (1st-pressed window)
(incf (xangle window) (* *rotate-multiplicator* (glop:dx event)))
(incf (yangle window) (* *rotate-multiplicator* (glop:dy event)))))

(defmethod glop:on-event ((window plotwindow) (event glop:resize-event))
(let* ((width (glop:width event))
(height (glop:height event))
(aspect-ratio (/ height width))
(zoom (zoom window)))
(gl:viewport 0 0 width height)
(gl:matrix-mode :projection)
(gl:load-identity)
(gl:ortho
(* zoom (- *viewport-multiplicator*))
(* zoom *viewport-multiplicator*)
(* zoom (- (* *viewport-multiplicator* aspect-ratio)))
(* zoom (* *viewport-multiplicator* aspect-ratio))
(* zoom (- *viewport-multiplicator*))
(* zoom *viewport-multiplicator*))))

(defmacro while (condition &body body)
(let ((var (gensym)))
`(do ((,var nil (progn ,@body)))
((not ,condition) ,var))))

(defun draw-3d-axes ()
"Draw opengl 3d axes"
(gl:color 0 1 0)
(gl:with-primitives :lines
(gl:vertex -10.0 0.0 0.0)
(gl:vertex 10.0 0.0 0.0)
;; arrow
(gl:vertex 10.0 0.0 0.0)
(gl:vertex 9.5 0.5 0.0)
(gl:vertex 10.0 0.0 0.0)
(gl:vertex 9.5 -0.5 0.0)

(gl:vertex 1.0 -0.2 0.0)
(gl:vertex 1.0 0.2 0.0))
(gl:color 1 1 0)
(gl:with-primitives :lines
(gl:vertex 0.0 -10.0 0.0)
(gl:vertex 0.0 10.0 0.0)
;; arrow
(gl:vertex 0.0 10.0 0.0)
(gl:vertex -0.5 9.5 0.0)
(gl:vertex 0.0 10.0 0.0)
(gl:vertex 0.5 9.5 0.0)
;;unit
(gl:vertex -0.2 1.0 0.0)
(gl:vertex 0.2 1.0 0.0))
(gl:color 0.4 0.5 1)
(gl:with-primitives :lines
(gl:vertex 0.0 0.0 -10.0)
(gl:vertex 0.0 0.0 10.0)
;; arrow
(gl:vertex 0.0 0.0 10.0)
(gl:vertex -0.5 0.0 9.5)
(gl:vertex 0.0 0.0 10.0)
(gl:vertex 0.5 0.0 9.5)
;; unit
(gl:vertex -0.2 0 1.0)
(gl:vertex 0.2 0 1.0)))

(defun draw-plot-points (fn x-start x-end x-step y-start y-end y-step)
"Draw plot of given function"
(gl:color 1 1 1)
(do ((x x-start (+ x x-step)))
((< x-end x) nil)
(gl:with-primitives :line-strip
(do ((y y-start (+ y y-step)))
((< y-end y) nil)
(gl:vertex x y (funcall fn x y)))))
(do ((y y-start (+ y y-step)))
((< y-end y) nil)
(gl:with-primitives :line-strip
(do ((x x-start (+ x x-step)))
((< x-end x) nil)
(gl:vertex x y (funcall fn x y))))))


(defun draw-plot (fn x-start x-end x-step y-start y-end y-step)
(glop:with-window (win "Interactive 3d plot" 800 600 :win-class 'plotwindow)
;; GL init
(gl:clear-color 0 0 0 0)
;; idle loop, we draw here anyway
(let ((frames 0)
(last-time (get-universal-time)))
(while (glop:dispatch-events win :blocking nil :on-foo nil)
;; rendering
(gl:matrix-mode :modelview)
(gl:load-identity)
(gl:scale 1 1 -1)
(gl:clear :color-buffer)
;; transform view
(gl:with-pushed-matrix
(gl:rotate (xangle win) 0.0 1.0 0.0)
(gl:rotate (yangle win) 1.0 0.0 0.0)
(gl:color 1 1 1)
(draw-3d-axes)
(draw-plot-points fn x-start x-end x-step y-start y-end y-step))
(gl:flush)
(glop:swap-buffers win)
(incf frames)
(when (< 1 (- (get-universal-time) last-time))
(format *standard-output* "fps ~a~%" (/ frames (- (get-universal-time) last-time)))
(setf last-time (get-universal-time))
(setf frames 0))))))

Объявляем пакет 3dplot, экспортируем из него символ draw-plot.


draw-plot fn x-start x-end x-step y-start y-end y-step

Функция принимает:

  • fn функция от двух аргументов x и y, должна вернуть числовое значение
  • x-start x-end x-step начальное, конечное и приращение аргумента x
  • y-start y-end y-step начальное, конечное и приращение аргумента y

Пример, сетчатого графика для функции z = sin(x) + cos(x), где X э [-5,5] и Y э [-5,5], шаг 0.1(э должна быть перевернута:), можете покрутить колесиком мыши или зажав левую клавишу подвигать ею.


(ql:quickload :glop)
(ql:quickload :cl-opengl)

(3dplot:draw-plot (lambda (x y) (+ (sin x) (cos y))) -5 5 0.1 -5 5 0.1)

Почему так много скобок.

Повторюсь: то, что получилось, представляет собой небольшой 3d движок. Можно даже сказать совсем небольшой. Что в нем реализовано:

  • Фокусирование на точке (0, 0, 0)
  • Приближение к данной точке
  • Отдаление от данной точки
  • Вращение вокруг данной точки


(defvar *min-zoom* 0.1)
(defvar *zoom-step* 0.1)
(defvar *rotate-multiplicator* 0.3)
(defvar *viewport-multiplicator* 10)

Это регуляторы для нашего движка.

  • *min-zoom* минимальное расстояние, меньше которого приближаться нельзя
  • *zoom-step* скорость приближения
  • *rotate-multiplicator* скорость поворота
  • *viewport-multiplicator* глобальное увеличение

Далее класс нашего окна для рисований. Наследуем его от glop:window.


(defclass plotwindow (glop:window)
...

Объект такого класса будет хранить следующие параметры.

  • 1st-pressed зажата ли левая клавиша мыши
  • zoom текущее увеличение
  • xangle текущий поворот относительно оси x
  • yangle текущий поворот относительно оси y

В этот же класс можно было бы добавить глобальные константы, но это в следующий раз.

Теперь реализуем обработчики событий от нашего окна. Первый специфируемый параметер: окно, второй - событие.


(defmethod glop:on-event ((window plotwindow) (event glop:key-event)
....

Обрабатываем нажатые клавиши мыши:

  • ESC - выход из программы. Осуществляется отсылкой сообщения glop:close-event нашему окну.
  • f - перключение полноэкранного режима
  • g - включение полноэкранного режима


(defmethod glop:on-event ((window plotwindow) (event glop:button-event)
....

Обрабатываем события от мыши. Если нажата левая клавиша: устанавливаем флаг в слоте окна 1st-pressed. Если нажата scroll up, приближем сцену, если scroll down - отдаляем. Для применения приближения или отдаления отсылаем сообщение об изменениях размеров. В обработчике того события происходит настройка сцены.


(defmethod glop:on-event ((window plotwindow) (event glop:mouse-motion-event))
....

Обработчик события передвижения мыши. Если зажата левая (главная клавиша) увеличиваем углы поворота сцены на "пробег" мыши.


(defmethod glop:on-event ((window plotwindow) (event glop:resize-event))
....

Здесь обрабатываем изменение размеров окна. Кроме того, данное событие "наступает", когда пользователь воспользовался функцией приближения/отдаления. Я не буду объяснять данный код, так как в книжках по opengl (например, redbook) это сделано гораздо лучше.


(defmacro while (condition &body body)
....

Вспомогательный макрос.


(defun draw-3d-axes ()
....

Отрисовываем оси координат, единичные отрезки и даже стрелочки. Делаем это разным цветом.

  • Ось X - зеленая
  • Ось Y - желтая
  • Ось Z - синяя


(defun draw-plot-points (fn x-start x-end x-step y-start y-end y-step)
....

Примитивная отрисовка графика.


(defun draw-plot (fn x-start x-end x-step y-start y-end y-step)
....

Главная функция. Создаем окно, настраиваем цвет фона. И в цикле обработки сообщений отрисовываем нашу сцену.

Common Lisp. Embeddable Maxima #2.

С наступившим новым годом, друзья!

Updated 01.01.2012

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

В заметке используется слово "лисп", которое означает словосочетание "common lisp" :)

Максима умеет математику решать в символьном виде.

Как я уже говорил, Максиму на данный момент лучше взять в моем репозитарии ветку quicklisp:

https://github.com/filonenko-mikhail/embeddable-maxima/tarball/quicklispили так:

git clone http://github.com/filonenko-mikhail/embeddable-maxima
git checkout quicklisp
или так добавить в оригинальный репозитарий:

git remote add fm_github http://github.com/filonenko-mikhail/embeddable-maxima.git
git fetch --depth 1 fm_github quicklisp:refs/remotes/quicklisp
git checkout -b quicklisp --track fm_github/quicklisp

Максима представляет отдельный язык для работы с математическими сущностями. Он очень напоминает то, что вы пишете на бумаге при решении какой-нибудь задачки. Все было бы хорошо, если бы математика содержала только декларативную часть. Например, мы могли использовать квадратный корень (sqrt) без необходимости создания методов вычисления этой функции для конретных чисел. Конечно есть ситуации, когда вычисление значения функции не имеет необходимости, так как она сокращается на одном из шагов решения задачи, однако это всего лишь часть всех случаев использования функции. Поэтому кроме того, что язык Максимы содержит декларативную часть математики, он еще и содержит все конструкции построения программ (или алгоритмов), а именно циклы и условные переходы. Так как максима написана на языке Лисп, то и получившийся язык очень похож на лисп. Я бы даже сказал, что язык Максима - это Лисп с инфиксной нотацией, ну и небольшим синтаксическим сахаром.

Кстати, вот экономический вопрос: что дешевле: научить пользователей предметно-ориентированному языку или подмножеству функций и конструкций хост-языка? Может проще научить математиков префиксной нотации, чем запиливать под них трансляторы, интепретаторы, компиляторы?

Теперь, собственно, код. Все выражение вводимые в Максиму транслируются в AST. AST - это дерево. Дерево в Лиспе представляется списками, элементы которых могут быть списками. Затем данное дерево интерпретируется так, как это реализовано в Максиме. Таким образом, кстати, реализован движок cl-closure-templates, где на основе AST, получаемого при разборе шаблона, генерируется лисповый генератор и с помощью parenscript javascript'овый.

Решение СЛАУ на Лиспе

Запуск окружения, все как обчыно:

emacs
M+x slime
(pushnew "/path/to/maxima/" asdf:*central-registry*)
(ql:quickload :embeddable-maxima)
;; переходим в пакет максимы так как из нее ничего не экспортируется
(in-package :maxima)

Допустим у нас есть список уравнений на языке Максима:

[2*x + y - z = 8, -3*x - y + 2*z = -11, -2*x + y + 2*z = -3]
Посмотрим как он выглядит в лисповом варианте. Для этого у Максимы есть лисповый макрос #$expr$:
#$[2*x + y - z = 8, -3*x - y + 2*z = -11, -2*x + y + 2*z = -3]$

((MLIST SIMP)
((MEQUAL SIMP) ((MPLUS SIMP) ((MTIMES SIMP) 2 $X) $Y ((MTIMES SIMP) -1 $Z)) 8)
((MEQUAL SIMP)
((MPLUS SIMP) ((MTIMES SIMP) -3 $X) ((MTIMES SIMP) -1 $Y)
((MTIMES SIMP) 2 $Z))
-11)
((MEQUAL SIMP) ((MPLUS SIMP) ((MTIMES SIMP) -2 $X) $Y ((MTIMES SIMP) 2 $Z))
-3))
Теперь давайте вызовем максимовскую функцию solve для решения системы уравнений. В лисповом окружении она имеет имя $solve:
($solve #$[2*x + y - z = 8, -3*x - y + 2*z = -11, -2*x + y + 2*z = -3]$)

((MLIST) ((MLIST) ((MEQUAL) $Z -1) ((MEQUAL) $Y 3) ((MEQUAL) $X 2)))
Для того, чтобы перевести лисповое выражение обратно в максимовское можно воспользоваться лисповой функцией displa, напрмер так:
(displa '((MLIST) ((MLIST) ((MEQUAL) $Z -1) ((MEQUAL) $Y 3) ((MEQUAL) $X 2))))

[[z = - 1, y = 3, x = 2]]
Неполное описание AST.
MLIST - является списком
SIMP - упрощено. (FIXME?)
MEQUAL - равенство из двух элементов
MPLUS - сумма
MTIMES - произведение
MDEFINE - определение функции
MPROGN - progn
$SOME_FUNCTION - вызов функции SOME_FUNCTION
....

Вызов функции определенной во время работы Максимы рекомендуют делать через mfuncall, однако функция $solve определена в Лиспе в исходниках, поэтому ее можно вызвать, как регулярную.

Теперь вы можете использовать чистый Лисп для символьных вычислений. Один способ, использовать макрос #$expr$ и функцию displa, другой - имитировать максимовскую AST с помощью обычных списков.

Дифференцирование в Лиспе

Давайте найдем производную функции:

1/3*x^3 + 1/2*x^2 + 1

Для этого используется функция diff.

($diff #$1/3*x^3 + 1/2*x^2 + 1$ #$x$)

((MPLUS SIMP) $X ((MEXPT SIMP) $X 2))

Или же в более читабельном виде:

(displa '((MPLUS SIMP) $X ((MEXPT SIMP) $X 2)))

2
x + x

Интегрирование в лиспе

Интеграл от предыдущей функции:

x^2 + x

Функция integrate:

($integrate #$x^2 + x$ #$x$)

((MPLUS SIMP) ((MTIMES SIMP) ((RAT SIMP) 1 2) ((MEXPT SIMP) $X 2))
((MTIMES SIMP) ((RAT SIMP) 1 3) ((MEXPT SIMP) $X 3)))

Читабельный вид:

(displa '((MPLUS SIMP) ((MTIMES SIMP) ((RAT SIMP) 1 2) ((MEXPT SIMP) $X 2))
((MTIMES SIMP) ((RAT SIMP) 1 3) ((MEXPT SIMP) $X 3))))

3 2
x x
-- + --
3 2

Кстати не отобразил свободный член (+C). Данная константа появляется при использовании равенства, а не выражения.

(displa ($integrate #$x^2 = - x$ #$x$))

3 2
x x
-- = %c2 - --
3 2

Вспомогательные материалы из справки Максима

37 Program Flow

37.1 Lisp and Maxima

Так как Максима написана на Лиспе, то в ней легко получать доступ к функциям и переменным Лиспа, и наоборот из Лиспа можно использовать функции и переменные определенные на языке Максима. Символы Лиспа и Максимы отличаются с помощью правил наименования. Символы лиспа, что начинаются со знака доллара "$" доступны из Максимы, как символы без знака доллара.

Символы Максимы, что начинаются со знака вопроса "?" доступны в Лиспе под именем без знака вопроса. Например, символ Максима foo доступен в Лиспе, как $FOO, тогда как символ Максима ?foo доступен в Лиспе, как FOO. Следует отметить, что ?foo пишеться без пробела между ? и foo, иначе будет ошибка.

Когда дефис "-", знак умножения "*" и другие специальные знаки для Лиспа, встречаются в символах Максимы они должны быть экранированы с помощью обратного слеша "\". Например: лисповый идентификатор *foo-bar* должен быть записан в Максиме так: ?\*foo\-bar\*.

Код на Лиспе может быть вызван из сессии Максимы. Однострочный код (содержащий одну и более форм) может быть вызван с помощью специальный команды Максимы: :lisp. Например: (%i1) :lisp (foo $x $y) вызывает функцию Лиспа foo с переменными из Максимы x и y в качестве аргументов. Конструкция :lisp может использоваться в интерактивной командной оболочке или в файле обрабатываемом с помощью batch или demo, но не с помощью load, batchload, translate_file или compile_file. Функция to_lisp открывает интерактивный командную оболочку Лиспа. Вызов (to-maxima) закрывает оболочку Лиспа и возвращает в оболочку Максимы.

Функции и переменные Лиспа, которые должны быть доступны в Максиме без изменений в названиях должны иметь символы, начинающиеся со знака доллара "$".

Максима чувствительна к регистру и различает прописные и строчные буквы в идентификаторах. Вот некоторые правила трансляции имен между Лиспом и Максимой.

1. Идентификатор в Лиспе, не заключенный в вертикальные скобки, преобразуется в идентификатор Максима в нижнем регистре вне зависимости от регистра символов. Например: лисповые $foo, $FOO и $Foo все преобразуются в foo. Это потому, что лисп ридер не различает регистр и все получаемое возводит в верхний регистр.

2. Лисповый идентификатор, содержащий все буквы или в верхнем, или в нижнем регистре и облаченный в вертикальные скобки преобразуется в символ максимы в противоположном регистре. Например: лисповые |$FOO| и |$foo| преобразуются в foo и FOO соответственно.

3. Лисповый идентификатор содержащий микс из регистров и заключенный в вертикальные скобки транслируется в максиму без преобразований. Например: лисповый |$Foo| транслируется в Foo.

Вот теперь самое важное и удобное, с помощью чего можно проводить эксперименты.

Лисповый макрос #$ позволяет использовать выражения Максимы в лисповом коде. #$expr$ разворачивает выражение Максимы в выражение на Лиспе.

Примеры:

(msetq $foo #$[x, y]$)
<=>
(%i1) foo: [x, y];

Лисповая функция displa выводит выражение в формате Максимы.

(%i1) :lisp #$[x, y, z]$
((MLIST SIMP) $X $Y $Z)
(%i1) :lisp (displa ’((MLIST SIMP) $X $Y $Z))
[x, y, z]
NIL

Функции определенные в Максиме не являются обычными лисповыми функциями. mfuncall вызывает функции Максимы. Например:

(%i1) foo(x,y) := x*y$
(%i2) :lisp (mfuncall ’$foo ’a ’b)
((MTIMES SIMP) A B)

Некоторые лисповые функции скрыты в пакете максимы, а именно:

complement   continue    //      
float functionp array
exp listen signum
atan asin acos
asinh acosh atanh
tanh cosh sinh
tan break gcd

Функция solve

solve (expr, x)
solve (expr)
solve ([eqn 1, . . . , eqn n], [x 1, . . . , x n])

Решает алгебраическое уравнение expr для переменной x и возвращает список решений. Если expr не является уравнение, предполагается равенство его нулю expr = 0. x может являтся функцией (например: f(x)) или другим не-атомным выражением, кроме суммы или произведения. x может быть опущен, если expr содержит только одну переменную. expr может быть рациональным выражение и может содержать тригонометрические функции, экспонентциальные и т.п.

solve ([eqn 1, ..., eqn n], [x 1, ..., x n]) решает системы simultaneuos (совместных?) (линейных и нелинейных) полиноминальных уравнений с помощью функций linsolve или algsolve и возвращает список решений. Функция принимает два аргумента. Первый - это список уравнений. Второй - список неизвестных переменных. Если число неизвестных совпадает со числом уравнений, второй аргумент может быть опущен.

Common Lisp. Может у кого завалялась работенка?

Неспешно ищу работу коммонлиспером. Могу всякое незаумное.

За плечами:

  • Небольшая учетная система для автошколы (postgresql (plpgsql), Qt/c++, common lisp, windows) (2 года).
  • Небольшая система планирования для гражданской авиации (oracle, Qt/c++, windows) (1,5 лет).

Могу работать удаленно, могу приехать.

Могу по-английски (в порядке убывания умения): читать, писать, слушать, разговаривать.

Можно на неполный рабочий день.

filonenko.mikhail at gmail com

Common Lisp. Embeddable Maxima.

Отрефакторил тут намедни максиму. Удалил mk:defsystem, оставил только asdf. Сделал on-fly fortran->cl компиляцию (спасибо, f2cl/packages/*.asd). Добавил внешних зависимостей доступных из quicklisp.

Ссылка: https://github.com/filonenko-mikhail/maxima

Теперь максима доступна так:


git clone --depth 1 https://filonenko-mikhail@github.com/filonenko-mikhail/embeddable-maxima.git
emacs
m+x slime
(pushnew "/path/to/maxima/" asdf:*central-registry*)
(ql:quickload :embeddable-maxima)
(cl-user::run)
run_testsuite();

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

Common Lisp. Интернационализация.

Для интернационализации будем использовать cl-l10n. Внимание, документация на сайте проекта устарела!

Загрузка:

(ql:quickload '#:cl-l10n)

Создание словарей:

(use-package :cl-l10n)

(defresources "ru_RU"
("Hello" "Привет")
("world" "мир"))

(defresources "fr_FR"
("Hello" "Bonjour")
("world" "monde"))

Включение макроридера для переводимых строк:

(enable-sharpquote-reader)

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

(with-locale (locale "ru_RU")
(format nil "~a, ~a" #"Hello" #"world"))
"Привет, мир"
(with-locale (locale "fr_FR")
(format nil "~a, ~a" #"Hello" #"world"))
"Bonjour, monde"

Для restas

Минимальные словари:

(cl-l10n:defresources "ru_RU"
("language" "Русский"))

(cl-l10n:defresources "fr_FR"
("language" "Française"))

(cl-l10n:defresources "en_US"
("language" "English"))

Роут переключающий локаль: сохраняет ее в сессии, и перенаправляет на предыдущую страницу:

(restas:define-route change-locale ("change-locale")
(let ((done (hunchentoot:parameter :|done|)))
(setf (hunchentoot:session-value :locale)
(hunchentoot:parameter :|locale|))
(restas:redirect (if done done "/"))))

Генератор меню выбора языка. Список локалей представлен в последней строке:

(defun generate-language-menu ()
(let ((current-locale (if (hunchentoot:session-value :locale)
(hunchentoot:session-value :locale)
"en_US")))
(mapcar (lambda (locale-name)
(cl-l10n:with-locale (cl-l10n:locale locale-name)
(if (string= current-locale
locale-name)
(list
:data #"language")
(list :href (restas:genurl 'change-locale
:locale locale-name
:done (hunchentoot:request-uri*))
:data #"language"))))
'("ru_RU" "en_US" "fr_FR"))))

Примерный вывод предыдущей функции:


((:HREF "/change-locale?locale=ru_RU&amp;done=/index.html" :DATA "Русский")
(:DATA "English")
(:HREF "/change-locale?locale=fr_FR&amp;done=/index.html" :DATA "Française"))

closure-templates шаблон:


<div id=language-menu>
{foreach $locale in $locales}
{if $locale.href}
<a href={$locale.href}>{$locale.data}</a>
{else}
{$locale.data}
{/if}
{/foreach}
</div>

Декоратор для выполнения роута в контексте некоторой локали, по-умолчанию en_US:


(defclass localize (routes:proxy-route) ())

(defmethod restas:process-route ((route localize) bindings)
(let ((locale (hunchentoot:session-value :locale)))
(cl-l10n:with-locale (cl-l10n:locale (if locale locale "en_US"))
(call-next-method))))

(defun @localize (origin)
(make-instance 'localize :target origin))

Примерное использование декоратора:


(cl-l10n:enable-sharpquote-reader)
(restas:define-route index ("index.html" :decorators '(@localize))
"Main page"
(list :title #"Maxima web interface"
:execute-title #"Execute"))
Подсветка Common-lisp синтаксиса в Gedit
Уже давно мне кажется странным тот факт, что в gedit  поддерживается 100500 синтаксисов разных ЯП, но нет великого LISP. Ну и мне, как всегда, приспичило это дело поправить. Не намекайте мне на то что для всего есть emacs, тут дело принципа и тяга к сервису.

Короче, подсветкой в гномовском окружении занимается gtksourceview.  
В домашней папке создаем файл ~/.local/share/gtksourceview-3.0/lisp.lang (если у вас стоит gtksouceview именно третьей версии)
В lisp.lang с помощью справочника команд и образца помещаем такое содержимое:

В итоге получится примерно так

Latency
Замерили задержки нашей мегасистемы гигагерцовым осциллографом.


Сверху вниз: входящий пакет (биржевые данные, UDP, 10Gb), выходящие пакеты по PCI-Express, исходящий пакет по 10G. Использование PCI-E для выхлопа позволяет фрагментировать исходящий пакет без особых издержек, поэтому получаются как бы отрицательные задержки: исходный UDP пакет ещё не пришёл, а обработанные данные уже начали появляться :)

Лисп при том, что самые сложные ядра написаны на лиспоподобном языке (есть свой компилятор в vhdl), плюс управляющий софт на лиспе.
Лиспостабильность
Я сто лет уже, как отказался от мирской суеты и сижу на оконном менеджере StumpWM, скомпилированном в SBCL. Всё было более-менее ровно, пока не вышел Линукс 3.0, и парсер версии ядра в SBCL расстроился и начал валиться. Проблема была быстро обнаружена самостоятельно, а потом и найдена в коммитах SBCL, но что-то меня обломало пересобирать SBCL, поэтому я попробовал пересобраться в ClozureCL, поддержку которого в StumpWM добавил девяносто лет назад.

Просидел под такой версией 4 месяца, и вообще ни разу не видел, чтобы StumpWM валился. Под SBCL он тоже нормально работал, но иногда падал. А тут вообще ровнёхонько фунциклирует. Вот что значит, когда продукт (CCL) с самого начала ведёт шарящий человек, продукт используется в коммерческих целях, и человек помимо удовольствия ещё и стабильную зряплату получает!

А у командира лиспворксовская система без перезапусков десять лет работает. Баги в рантайме ловятся, отчёты шлются ему на мыло, он их правится, шлёт обратно fasl's, система их всасывает и работает дальше.
Common Lisp. Parenscript.

В то время, как ребята из остальных тусовок всячески пишут виртуальные машины на javascript, а я, как минимум, помню:

  • assembler x86
  • erlang
  • clojure
а википедия указывает на:
  • JavaScript
  • PostScript
  • PDF
  • Ассемблер
  • Objective-J
  • Haskell
  • Prolog
  • ioctl[123]
  • Cat
  • Scheme
  • BASIC
  • Lily
  • Forth
  • PHP,
ребята на common lisp-е поленились реализовывать стандарт и просто написали транслятор.

Итак Parenscript - это транслятор из расширенного подмножества Common Lisp в JavaScript. Parenscript код может работать почти одинаково в окружении броузера (в JavaScript) и сервера (в Common Lisp).

Parenscript код пишеться также, как и Common Lisp код, тем самым мощь макросов становится доступна и в JavaScript.

Особенности Parenscript.

  • Никаких зависимостей сгенерированного JavaScript от других библиотек.
  • Использование родных JavaScript типов.
  • Сгенерированный код JavaScript можно использовать в другом несгенерированном JavaScript.
  • Читабельный код, форматирование.
  • Скорость сгенерированного кода почти такая же как и hand-made кода.

Перевел документацию по библиотеке:
http://lisper.ru/wiki/libraries%3Aparenscript

Restas и Windows

Updated 07.12.12

Появилась у меня задача: вывести простенький отчет на печать. Покалебавшись между Qt (textedit, webkit), cl-gtk2 и cl-pdf/cl-closure-template, restas и cl-closure-template, я выбрал последнее.

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

cl-gtk2 и cl-pdf - интересно, но также не решают проблем распространения, статическая объектная модель gtk создает препятствия к наследованию в cl, необходимо писать обертку для pdf/html рендера вручную, или через gir.

Самая интересность заключалась в том, что все должно было работать из-под windows.

Подробно о том, как установить cl в windows:http://habrahabr.ru/blogs/lisp/131418/.

Вкратце:

  • Скачать sbcl https://github.com/akovalenko/sbcl-win32-threads/wiki и установить
  • Скачать quicklisp.lisp.

  • sbcl
    (load "quicklisp.lisp")
    (quickstart:install)
    (quit)
    sbcl
    (ql:add-to-init-file)
    (ql:quickload :swank)
    (ql:quickload :quicklisp-slime-helper)
  • Скачать и установить emacs: http://ftp.gnu.org/pub/gnu/emacs/windows/
  • Добавить в $HOME/.emacs
      (load (expand-file-name "~/quicklisp/slime-helper.el"))
    ;; Replace "sbcl" with the path to your implementation
    (setq inferior-lisp-program "sbcl")
  • Если вы используете utf-8 кодировку в файлах, в $HOME/.sbclrc добавить
    (setf sb-impl::*default-external-format* :utf-8)

restas-directory-publisher использует iolib, однако данная библиотека не работает под windows. Для решения небольшой части проблем есть неофициальный форк для windows: http://src.knowledgetools.de/tomas/winapi/index.html.

Определите переменную среды CL_SOURCE_REGISTRY, и задайте ей следующее значение:

(:source-registry (:tree "your/path/to/lisp/libraries") :inherit-configuration)

Перейдите в директорию с библиотеками и скачайте нужную версию iolib


cd "your/path/to/lisp/libraries"
git clone --depth 1 http://src.knowledgetools.de/tomas/winapi/iolib.git

Осталось проверить минимальную работоспособность restas.


sbcl
(ql:quickload :restas)
(restas:define-module #:restas.hello-world
(:use :cl))
(in-package #:restas.hello-world)
(restas:define-route main ("")
"<h1>Hello windows world!</h1>")
(restas:start '#:restas.hello-world :port 8080)

Теперь в windows xp i386, windows 7 x86_64 можно совершать разбойные нападения с целью завладения чужим имуществом, в частности, на караваны.

P.S. Есть проблемка с restas-directory-publisher при попытке доступа к директории. iolib.syscall:stat не реализован.

P.S. Листинг директории в restas-direcory-publisher сейчас не содержит дат и размеров файлов.

Restas и Postmodern

А я напоминаю, что для подключения роутов restas сайта к postgresql базе данных служит такой механизм, как декораторы.

Действия такие:
Создаем класс унаследованный от routes:proxy-route.
Переопределяем для него метод restas:process-route, в котором:
  подключаемся к базе, и в этом контексте
    вызываем базовый метод routes:proxy-route.
Создаем функцию, возвращающую экземпляр данного класса.

Например:

  • *pgname* Имя БД
  • *pguser* Пользователь
  • *pgpassword* Пароль
  • *pghost* Сервер
  • *pgschema* Имя схемы
  • *company-name* Будет содержать комментарий для схемы *pgschema*

(defclass pg-connection-route (routes:proxy-route) ())

(defmethod restas:process-route ((route pg-connection-route) bindings)
(postmodern:with-connection (list *pgname* *pguser* *pgpassword* *pghost*)
(postmodern:execute (format nil "set search_path=~a,public" *pgschema*))
(let* ((*company-name* (postmodern:query "select description from pg_description join pg_namespace on objoid = oid and nspname = $1" *pgschema* :single)))
(call-next-method))))

(defun @pg-connection (route)
(make-instance 'pg-connection-route :target route))

Здесь кроме подключения, мы устанавливает в sql переменную search_path список тех схем базы данных, в которых в будущем будет производится поиск таблиц.

Использование:


(restas:define-route choose-client ("choose-client"
:decorators '(@pg-connection))
(list :rows
(postmodern:query "select 12 'test'")
:title "select"))
Common Lisp. cl-closure-templates, postmodern.
Updated 06.12.12

Маленький совет тем, кто сбрасывает вывод postmodern:query в cl-closure-templates. SQL тип NULL postmodern конвертирует в keyword :null, который cl-closure-templates интерпретирует как строку NULL. Для того чтобы вывести вместо NULL пустую строку, достаточно использовать if/then в шаблоне, например так:


....
{if $column}
{$column}
{/if}
.....

или так


{$column ? $column : ' '}

Вобщем-то :null при исполнении шаблона автоматически вычисляется в false.

Кроме того, если вы передаете (postmodern:query (select 1 as some_column) :alist) в closure-template, то добраться до колонки очень просто. По умолчанию postmodern конвертирует имена столбцов в keyword-ы с преобразованием подчеркивания в дефис, а closure-template в свою очередь camel нотацию преобразует в cl нотацию с дефисами. Итак, если вы используете столбец some_column, то переменная в шаблоне выглядеть будет так: someColumn.


postgres -> common lisp -> cl-closure-template
some_column -> :some-column -> someColumn.
Common Lisp. Белоруский экономический кризис.

Речь сегодня пойдет о том, что CL очень даже автоматизирует "бытовуху".Инфляция в РБ составила не менее 80% за год. Можно долго обсуждать с чем это связано, но лучше от этого не станет. До этого момента все мелко-крупные импортеры и без того все свои цены вычисляли в долларах, а теперь сюда еще и подтягиваются остальные участники белоруского "чуда".

Есть частное предприятие, оказывающее услуги населению и решившее, что цена часа услуги будет стоить 0.2 доллара. И теперь сответственно нужен журнал курсов валют. БД: postgresql, имеется доступ к интернету.

Задача: наладить sql таблицу postgresql, которая будет содержать данные о курсе доллара и автоматически добавлять в нее данные каждый день.

Создание журнала в БД postgresql с помощью postmodern:

(ql:quickload :postmodern)
(postmodern:connect-top-level "school" "user" "user" "localhost")
(postmodern:query "create table if not exists journal_currency_exchange (
                               _date date primary key,
                               _value decimal(10,2))")

S-sql это интересно, но для повседневной разработки визуальное разделение на хост язык и sql запросы благоразумнее.

Теперь необходимо этот журнал заполнить данными об изменениях курсов валют. Мне повезло: nbrb.by предоставляет xml-ку на запрос по некоторому url-у. Подробнее здесь: http://nbrb.by/statistics/Rates/XML/

Получение курсов доллара к белорусскому рублю за последний месяц, с помощью cl http клиента drakma.

Основной url: http://nbrb.by/Services/XmlExRatesDyn.aspx
Параметры:
curId - внутренний идентификатор валюты
fromDate, toDate - период для отчета

(ql:quickload :drakma)
(defvar xml-response (drakma:http-request "http://nbrb.by/Services/XmlExRatesDyn.aspx?curId=145&fromDate=11/1/2011&toDate=11/30/2011"))

Теперь необходимо разобрать полученную строку. Для этого есть cl xml парсер xmls:

CL-USER> (defvar parsed-xml (xmls:parse xml-response))
PARSED-XML
CL-USER> parsed-xml
("Currency" (("toDate" "11/30/2011") ("fromDate" "11/01/2011") ("Id" "145"))
 ("Record" (("Date" "11/01/2011")) ("Rate" NIL "8450"))
 ("Record" (("Date" "11/02/2011")) ("Rate" NIL "8530"))
 ("Record" (("Date" "11/03/2011")) ("Rate" NIL "8580"))
 ("Record" (("Date" "11/04/2011")) ("Rate" NIL "8650"))
 ("Record" (("Date" "11/05/2011")) ("Rate" NIL "8750"))
 ("Record" (("Date" "11/06/2011")) ("Rate" NIL "8750"))
 ("Record" (("Date" "11/07/2011")) ("Rate" NIL "8750"))
 ("Record" (("Date" "11/08/2011")) ("Rate" NIL "8750"))
 ("Record" (("Date" "11/09/2011")) ("Rate" NIL "8700"))
 ("Record" (("Date" "11/10/2011")) ("Rate" NIL "8790"))
 ("Record" (("Date" "11/11/2011")) ("Rate" NIL "8850"))
 ("Record" (("Date" "11/12/2011")) ("Rate" NIL "8850"))
 ("Record" (("Date" "11/13/2011")) ("Rate" NIL "8850"))
 ("Record" (("Date" "11/14/2011")) ("Rate" NIL "8850"))
 ("Record" (("Date" "11/15/2011")) ("Rate" NIL "8770"))
 ("Record" (("Date" "11/16/2011")) ("Rate" NIL "8760"))
 ("Record" (("Date" "11/17/2011")) ("Rate" NIL "8760"))
 ("Record" (("Date" "11/18/2011")) ("Rate" NIL "8760"))
 ("Record" (("Date" "11/19/2011")) ("Rate" NIL "8740"))
 ("Record" (("Date" "11/20/2011")) ("Rate" NIL "8740"))
 ("Record" (("Date" "11/21/2011")) ("Rate" NIL "8740"))
 ("Record" (("Date" "11/22/2011")) ("Rate" NIL "8720"))
 ("Record" (("Date" "11/23/2011")) ("Rate" NIL "8720"))
 ("Record" (("Date" "11/24/2011")) ("Rate" NIL "8720"))
 ("Record" (("Date" "11/25/2011")) ("Rate" NIL "8720"))
 ("Record" (("Date" "11/26/2011")) ("Rate" NIL "8670"))
 ("Record" (("Date" "11/27/2011")) ("Rate" NIL "8670"))
 ("Record" (("Date" "11/28/2011")) ("Rate" NIL "8670"))
 ("Record" (("Date" "11/29/2011")) ("Rate" NIL "8640"))
 ("Record" (("Date" "11/30/2011")) ("Rate" NIL "8600")))

Теперь надо занятся тем, для чего лисп Маккарти и придумывал - обработкой списков. Фильтруем, оставляя только Record:

CL-USER> (defvar ya-parsed-xml (remove-if-not (lambda (value) (and (listp value) (stringp (car value)) (string= (car value) "Record"))) parsed-xml))
(("Record" (("Date" "11/01/2011")) ("Rate" NIL "8450"))
 ("Record" (("Date" "11/02/2011")) ("Rate" NIL "8530"))
 ("Record" (("Date" "11/03/2011")) ("Rate" NIL "8580"))
 ("Record" (("Date" "11/04/2011")) ("Rate" NIL "8650"))
 ("Record" (("Date" "11/05/2011")) ("Rate" NIL "8750"))
 ("Record" (("Date" "11/06/2011")) ("Rate" NIL "8750"))
 ("Record" (("Date" "11/07/2011")) ("Rate" NIL "8750"))
 ("Record" (("Date" "11/08/2011")) ("Rate" NIL "8750"))
 ("Record" (("Date" "11/09/2011")) ("Rate" NIL "8700"))
 ("Record" (("Date" "11/10/2011")) ("Rate" NIL "8790"))
 ("Record" (("Date" "11/11/2011")) ("Rate" NIL "8850"))
 ("Record" (("Date" "11/12/2011")) ("Rate" NIL "8850"))
 ("Record" (("Date" "11/13/2011")) ("Rate" NIL "8850"))
 ("Record" (("Date" "11/14/2011")) ("Rate" NIL "8850"))
 ("Record" (("Date" "11/15/2011")) ("Rate" NIL "8770"))
 ("Record" (("Date" "11/16/2011")) ("Rate" NIL "8760"))
 ("Record" (("Date" "11/17/2011")) ("Rate" NIL "8760"))
 ("Record" (("Date" "11/18/2011")) ("Rate" NIL "8760"))
 ("Record" (("Date" "11/19/2011")) ("Rate" NIL "8740"))
 ("Record" (("Date" "11/20/2011")) ("Rate" NIL "8740"))
 ("Record" (("Date" "11/21/2011")) ("Rate" NIL "8740"))
 ("Record" (("Date" "11/22/2011")) ("Rate" NIL "8720"))
 ("Record" (("Date" "11/23/2011")) ("Rate" NIL "8720"))
 ("Record" (("Date" "11/24/2011")) ("Rate" NIL "8720"))
 ("Record" (("Date" "11/25/2011")) ("Rate" NIL "8720"))
 ("Record" (("Date" "11/26/2011")) ("Rate" NIL "8670"))
 ("Record" (("Date" "11/27/2011")) ("Rate" NIL "8670"))
 ("Record" (("Date" "11/28/2011")) ("Rate" NIL "8670"))
 ("Record" (("Date" "11/29/2011")) ("Rate" NIL "8640"))
 ("Record" (("Date" "11/30/2011")) ("Rate" NIL "8600")))

Сокращаем полученное дерево до списка с элементами (дата значение):

CL-USER> (defvar data (mapcar (lambda (value) (list (nth 1 (nth 0 (nth 1 value))) (nth 2 (nth 2 value)))) ya-parsed-xml))
(("11/01/2011" "8450") ("11/02/2011" "8530") ("11/03/2011" "8580")
 ("11/04/2011" "8650") ("11/05/2011" "8750") ("11/06/2011" "8750")
 ("11/07/2011" "8750") ("11/08/2011" "8750") ("11/09/2011" "8700")
 ("11/10/2011" "8790") ("11/11/2011" "8850") ("11/12/2011" "8850")
 ("11/13/2011" "8850") ("11/14/2011" "8850") ("11/15/2011" "8770")
 ("11/16/2011" "8760") ("11/17/2011" "8760") ("11/18/2011" "8760")
 ("11/19/2011" "8740") ("11/20/2011" "8740") ("11/21/2011" "8740")
 ("11/22/2011" "8720") ("11/23/2011" "8720") ("11/24/2011" "8720")
 ("11/25/2011" "8720") ("11/26/2011" "8670") ("11/27/2011" "8670")
 ("11/28/2011" "8670") ("11/29/2011" "8640") ("11/30/2011" "8600"))

Записываем в базу данных. Postgresql по умолчанию ожидает дату в формате dmy, функция to_date служит для явного задания формата даты mdy:

(mapcar (lambda (value) (postmodern:query 
                                  "insert into journal_currency_exchange(_date, _value) values (to_date($1, 'mm/dd/yyyy'), $2)" (car value) (cadr value))) data)

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

P.S. Может кто-то уже делал систему построения отчетов на CL?

И снова grabber и Common Lisp

Я тут в очередной раз мучался с cxml-stp, closure-html, plexippus-xpath, и вдруг обнаружил совершенно другой подход. И почему я раньше не знал про cl-libxml2, как вообще всё может быть проще с парсингом:


LOOT> (ql:quickload '(:cl-libxml2))
To load "cl-libxml2":
  Load 1 ASDF system:
    cl-libxml2
; Loading "cl-libxml2"

(:CL-LIBXML2)
LOOT> (html:with-parse-html (page #u"http://www.sbcl.org/platform-table.html")
  (xpath:find-string page "/html/body/div/pre"))
"git clone git://sbcl.git.sourceforge.net/gitroot/sbcl/sbcl.git"
LOOT> (defun run-many-find-string ()
  (html:with-parse-html (page #u"http://www.sbcl.org/platform-table.html")
    (time
     (dotimes (i 10000)
       (xpath:find-string page "/html/body/div/pre")))))
RUN-MANY-FIND-STRING

И скорость просто фантастика:


LOOT> (run-many-find-string)
Evaluation took:
  0.851 seconds of real time
  0.848053 seconds of total run time (0.816051 user, 0.032002 system)
  [ Run times consist of 0.004 seconds GC time, and 0.845 seconds non-GC time. ]
  99.65% CPU
  1,868,092,138 processor cycles
  22,880,088 bytes consed

Пишем grabber на Common Lisp

В этой небольшой статье я попытаюсь написать граббер, преобразовывая html в списки и выполняя поиск методом обхода списков.



Используем в качестве примера страничку Download - Steel Bank Common Lisp. Для упрощения задачи скачаем её и положим в test.html. Предположим, что нам нужно выдрать со странички строку “git clone git://sbcl.git.sourceforge.net/gitroot/sbcl/sbcl.git”.

(ql:quickload '(:iterate :split-sequence :cl-html-parse))

(defpackage :loot
  (:use :common-lisp
        :iter
        :split-sequence))

(in-package :loot)

(defparameter *all-html* (html-parse:parse-html #p"test.html"))

В переменную *all-html* будет сохранён лиспизированный html-код:

      
((:!DOCTYPE
  " HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\"")
 (:HTML
  (:HEAD (:TITLE "Download - Steel Bank Common Lisp")
   ((:LINK :REL "stylesheet" :TYPE "text/css" :HREF "sbcl.css"))
   ((:META :HTTP-EQUIV "Content-Type" :CONTENT "text/html;charset=utf-8")))
  (:BODY ((:DIV :CLASS "header") (:H1 "Steel Bank Common Lisp"))
   ((:DIV :CLASS "sidebar")
    (:UL (:LI ((:A :HREF "index.html") "About"))
     (:LI ((:A :HREF "news.html") "News"))
     (:LI ((:A :HREF "platform-table.html") "Download"))
     (:LI ((:A :HREF "getting.html") "Getting Started"))
     (:LI ((:A :HREF "history.html") "History and Copyright"))
     (:LI ((:A :HREF "porting.html") "Porting"))
     (:LI ((:A :HREF "keys.html") "Maintainer public keys"))
     (:LI ((:A :HREF "manual/index.html") "Manual"))
...
      

Для упрощения поиска по спискам превратим дерево в список (функция flatten скопирована без изменений из книги On Lisp)


(defun flatten (x)
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec (car x) (rec (cdr x) acc))))))
    (rec x nil)))

А теперь очередь за функцией find-tag, которая ищет необходимый тег:


(defun find-tag (html rules)
  (cond ((null rules) (car html))
        ((eq (car html) (car rules)) (find-tag (cdr html) (cdr rules)))
        (t (find-tag (cdr html) rules))))

Запускаем:


LOOT> (defparameter *rules* '(:html :body :div :pre))
*RULES*
LOOT> (find-tag (flatten *all-html*) *rules*)
"git clone git://sbcl.git.sourceforge.net/gitroot/sbcl/sbcl.git"

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


(defun run-many-find-tag ()
  (time
   (dotimes (i 10000)
     (find-tag (flatten *all-html*) *rules*))))

(defun profile-find-tag ()
  ;; Don't accumulate results between runs.
  (sb-profile:reset)
  ;; Calling this every time through in case any of the user-defined
  ;; functions was recompiled.
  (sb-profile:profile find-tag flatten)
  (run-many-find-tag)
  (sb-profile:report))

А теперь посмотрим насколько оно “оптимально”:


LOOT> (profile-find-tag)

Evaluation took:
  3.701 seconds of real time
  3.672230 seconds of total run time (2.152135 user, 1.520095 system)
  [ Run times consist of 0.188 seconds GC time, and 3.485 seconds non-GC time. ]
  99.22% CPU
  8,120,250,534 processor cycles
  1 page fault
  251,795,280 bytes consed
  
measuring PROFILE overhead..done
  seconds  |     gc     |    consed   |   calls   |  sec/call  |  name  
-------------------------------------------------------------
     0.313 |      0.008 |  73,815,800 |    10,000 |   0.000031 | FLATTEN
     0.000 |      0.180 | 175,403,624 | 1,380,000 |   0.000000 | FIND-TAG
-------------------------------------------------------------
     0.313 |      0.188 | 249,219,424 | 1,390,000 |            | Total

estimated total profiling overhead: 3.19 seconds
overhead estimation parameters:
  8.000001e-9s/call, 2.2959998e-6s total profiling, 1.064e-6s internal profiling
; No value

Но что если мы будем искать тег, которого не существует, чем вынудим find-tag пройтись по всему списку:


LOOT> (let ((*rules* '(:no-tag)))
        (profile-find-tag))
WARNING: FIND-TAG is already profiled, so unprofiling it first.
WARNING: FLATTEN is already profiled, so unprofiling it first.
Evaluation took:
  25.785 seconds of real time
  23.737483 seconds of total run time (13.224826 user, 10.512657 system)
  [ Run times consist of 1.540 seconds GC time, and 22.198 seconds non-GC time. ]
  92.06% CPU
  56,586,611,510 processor cycles
  456 page faults
  1,258,993,224 bytes consed
  
  seconds  |     gc     |     consed    |   calls   |  sec/call  |  name  
---------------------------------------------------------------
     0.309 |      0.000 |    73,819,008 |    10,000 |   0.000031 | FLATTEN
     0.000 |      1.540 | 1,182,643,568 | 9,240,000 |   0.000000 | FIND-TAG
---------------------------------------------------------------
     0.309 |      1.540 | 1,256,462,576 | 9,250,000 |            | Total

estimated total profiling overhead: 21.24 seconds
overhead estimation parameters:
  8.000001e-9s/call, 2.2959998e-6s total profiling, 1.064e-6s internal profiling
; No value

Опа, потребление памяти выросло в 4 раза аж до ~1.2 Gb, а реальное время выполнения с 3 секунд подскочило до 25. И всё это на такой маленькой страничке. Ускорить выполнение кода и уменьшить количество потребляемой памяти можно отказавшись от списков и использовав другие структуры данных. Думаю, если использовать cxml-stp, скорость должна возрости. Вопрос в другом: нужно ли всё это, ведь грабить одну страничку 10 тысяч раз никто не будет, скорее будут грабить 10 тысяч страниц по одному разу, и тогда всё упрётся в скорость ввода-вывода. Если будет время, то попытаюсь в скором времени описать, как я делал тоже самое с помощью cxml-stp.

Перевод OnLisp
    Продолжился перевод книги знаменитого лиспера и эссеиста Пола Грэхэма: On Lisp. Добро пожаловать желающим поучаствовать и оставить след в истории:)

https://github.com/rigidus/onlisp

Координирование перевода ведёт автор репозитория.
Задача про ip-диапазоны: cуперкомпиляция условий
В продолжение предыдущего поста.

Давайте еще раз посмотрим на код условия, которое мы генерируем по описанию диапазона:

IP-RANGES> (ip-range "104.57.221.173,104.75.219.35")
(AND
 (OR (> IP-0 104)
     (AND (= IP-0 104)
          (OR (> IP-1 57)
              (AND (= IP-1 57)
                   (OR (> IP-2 221)
                       (AND (= IP-2 221)
                            (OR (> IP-3 173) (AND (= IP-3 173) T))))))))
 (OR (< IP-0 104)
     (AND (= IP-0 104)
          (OR (< IP-1 75)
              (AND (= IP-1 75)
                   (OR (< IP-2 219)
                       (AND (= IP-2 219)
                            (OR (< IP-3 35) (AND (= IP-3 35) T)))))))))

Здесь явно чувствуется "искуственность" этого кода: глаз цепляется за бессмысленные конструкции типа (AND (= IP-3 35) T) и (AND (OR (> IP-0 104) ...) (OR (< IP-0 104) ...)).

В ряде случаев можно положиться на мудрость компилятора, который соптимизирует ненужные формы, но намного надёжней "почистить" и улучшить код сразу, еще до фактической компиляции в машкод. Благо в Common Lisp работать с кодом элементарно -- ведь это обычный список :)

Оптимизацию будем проводить путем многократной пересборки s-выражения, оптимизируя на каждом шагу какие-то конкретные поддеревья, до момента, когда ничего больше соптимизировать не удастся. Давайте накидаем каркас и сразу же упростим самую паскудную форму (AND FORM t) до просто FORM:

(defun cond-optimizer (form)
  (let ((optimized-p t))
    (labels ((walker (form)
               (flet ((assume (form) (setf optimized-p t) (return-from walker form)))
                 (if-match (and ?f t) form (assume ?f))
                 (if-match (and t ?f) form (assume ?f))
                 (if (listp form) (mapcar #'walker form) form))))
      (iter (while optimized-p) (setf optimized-p nil form (walker form)))
      form)))

Здесь собственно работа по замене выполняется в паттерн-матчинге if-match: (and ?f t) и (and t ?f) заменяем на ?f. Давайте сразу проверим, что у нас получается:

IP-RANGES> (cond-optimizer *)
(AND
 (OR (> IP-0 104)
     (AND (= IP-0 104)
          (OR (> IP-1 57)
              (AND (= IP-1 57)
                   (OR (> IP-2 221)
                       (AND (= IP-2 221) (OR (> IP-3 173) (= IP-3 173))))))))
 (OR (< IP-0 104)
     (AND (= IP-0 104)
          (OR (< IP-1 75)
              (AND (= IP-1 75)
                   (OR (< IP-2 219)
                       (AND (= IP-2 219) (OR (< IP-3 35) (= IP-3 35)))))))))

Логическое "И" с истиной мы убрали, но на этом месте сформировалась новый кандидат на оптимизацию: (OR (< IP-3 35) (= IP-3 35)) -- это ведь явно #'<=. Добавим новое правило для замены форм в cond-optimizer:

                 (if-match (or (?o ?a ?b) (= ?a ?b)) form
                           (assume (list (form-symbol ?o '=) ?a ?b)))

IP-RANGES> (cond-optimizer *)
(AND
 (OR (> IP-0 104)
     (AND (= IP-0 104)
          (OR (> IP-1 57)
              (AND (= IP-1 57)
                   (OR (> IP-2 221) (AND (= IP-2 221) (>= IP-3 173)))))))
 (OR (< IP-0 104)
     (AND (= IP-0 104)
          (OR (< IP-1 75)
              (AND (= IP-1 75)
                   (OR (< IP-2 219) (AND (= IP-2 219) (<= IP-3 35))))))))

Очень хорошо, теперь пришел черёд беды "ip-0 > 104 && ip-0 < 104" -- она тоже сильно режет глаза:

                 (if-match (and (or (> ?a ?b) ?x) (or (< ?a ?b) ?y)) form
                           (assume (list 'and ?x ?y)))

IP-RANGES> (cond-optimizer *)
(AND
 (AND (= IP-0 104)
      (OR (> IP-1 57)
          (AND (= IP-1 57)
               (OR (> IP-2 221) (AND (= IP-2 221) (>= IP-3 173))))))
 (AND (= IP-0 104)
      (OR (< IP-1 75)
          (AND (= IP-1 75) (OR (< IP-2 219) (AND (= IP-2 219) (<= IP-3 35)))))))

Форма упростилась, но дублирование (= IP-0 104) в булевом "И" тоже надо бы убрать:

                 (if-match (and (and ?a ?x) (and ?a ?y)) form
                           (assume `(and ,?a (and ,?x ,?y))))

IP-RANGES> (cond-optimizer *)
(AND (= IP-0 104)
     (AND
      (OR (> IP-1 57)
          (AND (= IP-1 57) (OR (> IP-2 221) (AND (= IP-2 221) (>= IP-3 173)))))
      (OR (< IP-1 75)
          (AND (= IP-1 75) (OR (< IP-2 219) (AND (= IP-2 219) (<= IP-3 35)))))))

Ну вот это условие уже, действительно, похоже на правду! Сходу я здесь не вижу, чего можно было бы еще упростить, поэтому, давайте погоняем наш суперкомпилятор на разных случайных диапазонах, авось глаз ещё за что-нибудь зацепится. Например, вот здесь:

IP-RANGES> (cond-optimizer (ip-range "192.168.255.255,192.169.0.0"))
(AND (= IP-0 192)
     (AND
      (OR (> IP-1 168)
          (AND (= IP-1 168)
               (OR (> IP-2 255) (AND (= IP-2 255) (>= IP-3 255)))))
      (OR (< IP-1 169)
          (AND (= IP-1 169) (OR (< IP-2 0) (AND (= IP-2 0) (<= IP-3 0)))))))

Я здесь вижу бессмысленные проверки, типа (> IP-2 255) и (< IP-2 0). Так как октет принципиально не может принимать значения вне диапазона 0-255, эти проверки можно смело выкидывать.

                 (if-match (< ?x 0) form (assume nil))
                 (if-match (<= ?x 0) form (assume (list '= ?x 0)))
                 (if-match (> ?x 255) form (assume nil))
                 (if-match (>= ?x 255) form (assume (list '= ?x 255)))
                 (if-match (> ?x 0) form (assume t))
                 (if-match (<= ?x 255) form (assume t))

IP-RANGES> (cond-optimizer *)
(AND (= IP-0 192)
     (AND
      (OR (> IP-1 168)
          (AND (= IP-1 168) (OR NIL (AND (= IP-2 255) (= IP-3 255)))))
      (OR (< IP-1 169)
          (AND (= IP-1 169) (OR NIL (AND (= IP-2 0) (= IP-3 0)))))))

Подобная оптимизация снова наоставляла артефактов вроде (OR NIL ...), поэтому есть предложение их убрать, а заодно добавить все остальные правила с константами в логических операциях:

                 (if-match (and ?f nil) form (assume nil))
                 (if-match (and nil ?f) form (assume nil))
                 (if-match (or nil ?f) form (assume ?f))
                 (if-match (or ?f nil) form (assume ?f))
                 (if-match (or t ?f) form (assume t))
                 (if-match (or ?f t) form (assume t))

IP-RANGES> (cond-optimizer *)
(AND (= IP-0 192)
     (AND (OR (> IP-1 168) (AND (= IP-1 168) (AND (= IP-2 255) (= IP-3 255))))
          (OR (< IP-1 169) (AND (= IP-1 169) (AND (= IP-2 0) (= IP-3 0))))))

Ну вот теперь вроде как совсем красота.

На всякий случай, проверим оптимизатор на граничных значениях:

IP-RANGES> (cond-optimizer (ip-range "192.0.0.0,255.255.255.255"))
(>= IP-0 192)
IP-RANGES> (cond-optimizer (ip-range "192.168.0.1,192.168.0.1"))
(AND (= IP-0 192) (AND (= IP-1 168) (AND (= IP-2 0) (= IP-3 1))))
IP-RANGES> (cond-optimizer (ip-range "0.0.0.0,192.168.0.1"))
(OR (< IP-0 192)
    (AND (= IP-0 192)
         (OR (< IP-1 168) (AND (= IP-1 168) (AND (= IP-2 0) (<= IP-3 1))))))

Ну вроде всё выглядит более-менее прилично.

Следовательно, можно вносить вызов cond-optimizer внутрь генератора ip-range:
(defun ip-range (range-string)
  (let ((values (extract-values range-string))
        (vars '(ip-0 ip-1 ip-2 ip-3)))
    (assert (= (length values) 8))
    (labels ((stairs (cmp values vars)
               (if (null values)
                   t
                   `(or (,cmp ,(car vars) ,(car values))
                        (and (= ,(car vars) ,(car values))
                             ,(stairs cmp (cdr values) (cdr vars)))))))
      (cond-optimizer 
       `(and ,(stairs '> (subseq values 0 4) vars)
             ,(stairs '< (subseq values 4 8) vars))))))

Ещё раз проверяем красоту:

IP-RANGES> (ip-range "192.0.0.0,255.255.255.255")
(>= IP-0 192)

Отлично.

В следующем посте упорядочим диапазоны по размеру, выкинем лишние (которые целиком входят в более широкие) и проведем кой-какую аналитику.
И еще раз о задачке про ip-диапазоны.
Собственно, описание задачи и варианты её решения можно почитать здесь у [info]nponeccop. Один из вариантов там предложен на CL лавсанчиком. Собственно, он меня немножечко возмутил, поэтому пришлось писать этот пост :)

Суть токова: это вполне себе рабочий код, но так на common lisp писать не надо :) Потому что так надо писать на си. На сях этот же код будет вдвое короче (хотя бы за счет отсутствия скобок и более лаконичного синтаксиса) и вдвое быстрее.

Писать руками такую простыню низкоуровнего кода на CL -- это явный провал. На лиспе надо писать программу, которая будет генерировать низкоуровневый код, это ежу понятно.

Условия нам благоприятсвуют: диапазоны грузятся один раз, а дальше только лукап. Поэтому мы попробуем решить эту задачу классическим лисповым способом: «расставить скобки вокруг спецификации и заставить её запуститься». Вот прямо так, буквально. Итак, имеем файл ranges.list такого вида:

104.72.221.173,220.57.219.35
16.65.26.150,133.42.154.151
80.241.37.220,93.109.90.13
35.165.212.97,105.166.11.16
122.143.149.115,246.17.13.31
20.44.170.80,144.105.12.169
122.132.114.84,184.165.60.95
102.111.151.45,120.152.236.26
53.252.70.24,171.51.24.110
101.103.12.180,224.55.178.136

Отлично, давайте расставим вокруг скобки, чтобы получить ranges.list.lisp:

(in-package :ip-ranges)
(gen-test-proc
  "104.72.221.173,220.57.219.35"
  "16.65.26.150,133.42.154.151"
  "80.241.37.220,93.109.90.13"
  "35.165.212.97,105.166.11.16"
  "122.143.149.115,246.17.13.31"
  "20.44.170.80,144.105.12.169"
  "122.132.114.84,184.165.60.95"
  "102.111.151.45,120.152.236.26"
  "53.252.70.24,171.51.24.110"
  "101.103.12.180,224.55.178.136"
)

Только, конечно же, не руками, а вот так:

(defun preprocess-ranges-file (filename)
  (let ((lisp-file (format nil "~a.lisp" filename)))
    (with-open-file (f-in filename)
      (with-open-file (f-out lisp-file
                             :direction :output
                             :if-exists :supersede
                             :if-does-not-exist :create
                             :external-format :ascii)
        (format f-out "(in-package :ip-ranges)~%(gen-test-proc~%")
        (iter (for range in-stream f-in using #'read-line)
              (format f-out "  \"~a\"~%" range))
        (format f-out ")~%~%")))
    lisp-file))

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

(defpackage #:ip-ranges
  (:use :cl :iterate :metatilities)
  (:shadowing-import-from :metatilities #:minimize #:finish)
  (:export #:check))

(in-package :ip-ranges)

(defun extract-values (string)
  (unless (zerop (length string))
    (multiple-value-bind (value rest-index)
        (parse-integer string :junk-allowed t)
      (if value
          (cons value (extract-values (subseq string rest-index)))
          (extract-values (subseq string 1))))))

Работать это должно так:

IP-RANGES> (extract-values "104.72.221.173,220.57.219.35")
(104 72 221 173 220 57 219 35)

Теперь надо немного пораскинуть мозгами. Вот у нас есть диапазон, заданный ip-адресами, каждый из которых представлен четырьмя октетами -- в нашем случае '(104 72 221 173) и '(220 57 219 35). Допустим, нам выдали адрес в таком же формате: ip = (list ip-0 ip-1 ip-2 ip-3); какой код должен быть в программе, которым можно проверить принадлежность этого адреса заданному диапазону? Собственно, тут даже не надо ничего делать руками (например, склеивать октеты в 32-х битный адрес и т.п.), просто тупо сгенерируем сравнение в лесенкой столбик :)

(defun ip-range (range-string)
  (let ((values (extract-values range-string))
        (vars '(ip-0 ip-1 ip-2 ip-3)))
    (assert (= (length values) 8))
    (labels ((stairs (cmp values vars)
               (if (null values)
                   t
                   `(or (,cmp ,(car vars) ,(car values))
                        (and (= ,(car vars) ,(car values))
                             ,(stairs cmp (cdr values) (cdr vars)))))))
      `(and ,(stairs '> (subseq values 0 4) vars)
            ,(stairs '< (subseq values 4 8) vars)))))

IP-RANGES> (ip-range "104.72.221.173,220.57.219.35")
(AND
 (OR (> IP-0 104)
     (AND (= IP-0 104)
          (OR (> IP-1 72)
              (AND (= IP-1 72)
                   (OR (> IP-2 221)
                       (AND (= IP-2 221)
                            (OR (> IP-3 173) (AND (= IP-3 173) T))))))))
 (OR (< IP-0 220)
     (AND (= IP-0 220)
          (OR (< IP-1 57)
              (AND (= IP-1 57)
                   (OR (< IP-2 219)
                       (AND (= IP-2 219)
                            (OR (< IP-3 35) (AND (= IP-3 35) T)))))))))

Ну а теперь у нас есть все для того, чтобы "скомпилировать спецификацию":

(defmacro gen-test-proc (&rest ranges)
  `(defun ip-check (ip-0 ip-1 ip-2 ip-3)
     (or ,@(mapcar #'ip-range ranges))))

(defun check (ip-string)
  (apply #'ip-check (extract-values ip-string)))

Вуаля:

IP-RANGES> (load (compile-file (preprocess-ranges-file #p"ranges.list")))
; compiling file "/home/swizard/devel/lisp/ip-ranges/ranges.list.lisp" (written 03 NOV 2011 11:16:02 PM):
; compiling (IN-PACKAGE :IP-RANGES)
; compiling (GEN-TEST-PROC "104.72.221.173,220.57.219.35" ...)

; /home/swizard/devel/lisp/ip-ranges/ranges.list.fasl written
; compilation finished in 0:00:00.045
T
IP-RANGES> (check "192.168.0.1")
T
IP-RANGES> (check "10.0.0.0")
NIL


Итак, еще раз, что мы сейчас сделали:
  • Расставили скобки вокруг списка ip-диапазонов.
  • Сгенерировали по описанию функцию ip-check, решающую задачу.
  • ...
  • Profit!

Красотища? Да, но пока что не особо.

  • Несмотря на константные проверки и восьмибитную сегментацию адреса, у нас получилась последовательная проверка.
  • Несмотря на автоматическую генерацию условия по диапазону, это условие генерируется какое-то кривоватое и сильно избыточное.
  • Несмотря на то, что какие-то диапазоны проверять нет смысла, так как они "поглощаются" более широкими, все равно проверяются все.
  • По условиям задачи диапазонов могут быть сотни: поэтому код надо сегментировать по функциям, чтобы не нагнуть компилятор при стратегии (optimize (speed 3))


Собственно, все это я выношу в следующий пост: суперкомпиляция условий, сегментация и препроцессинг кода и так далее. В идеале мы должны не только решить задачу, а еще и получить самый производительный код.
Устройство ASDF. Подсистема определения. UNION-OF-DEPENDENCIES.
(сказаное ниже относится к версии 2.018.3)

Это 5-ая статья цикла.
Первая статья.
Архитектура ASDF.
Предыдущая статья.

Определение (сигнатура):

    (defun* union-of-dependencies (&rest deps) ...)

    Функция применяется в parse-component-form для того, чтобы установить у компонента слот in-order-to:

   (setf (component-in-order-to ret)
      (union-of-dependencies
         in-order-to
         `((compile-op (compile-op ,@depends-on))
            (load-op (load-op ,@depends-on))
)
)
)


    ... и слот do-first:

   (setf (component-do-first ret)
            (union-of-dependencies
               do-first
               `((compile-op (load-op ,@depends-on)))
)
)


    ... эти слоты будут использоваться в ф-ии do-traverse при загрузке систем, а конкретней в подсистеме: "планирование операций". Значение слота do-first необходимо для планирования операций с зависимостями компонента. А значение слота in-order-to - для переопределения порядка операций.

    Поначалу определение union-of-dependencies кажется весьма сложным. Во-первых необходимо знать, что она возвратит свой второй аргумент если опция :in-order-to (и соотв. :do-first) не была установлена. Кроме того, если depends-on равна nil - то она возвратит nil. Применяется опция :in-order-to крайне редко (а опция :do-first - вообще не документирована), была замечена в системе weblocks-prevalence (см. weblocks-prevalence.asd в https://bitbucket.org/redline6561/weblocks-dev/src). Там она была установлена в:

    :in-ordered-to ((compile-op (prepare-prevalence-op :weblocks-prevalence))
                               (load-op (prepare-prevalence-op :weblocks-prevalence)))


    Пример возвращаемого значения. Допустим функция была вызвана со следующими аргументами:

   (union-of-dependencies
      '((compile-op (prepare-prevalence-op :weblocks-prevalence))
        (load-op (prepare-prevalence-op :weblocks-prevalence)))
      '((compile-op (compile-op "file1" "file2"))
        (load-op (load-op "file1" "file2"))))

    Результат будет таким:

    ((LOAD-OP (LOAD-OP "file2" "file1")
          (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
     (COMPILE-OP (COMPILE-OP "file2" "file1")
         (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))


                Логика работы функции. UNION-OF-DEPENDENCIES.

Определение функции:
    
(defun* union-of-dependencies (&rest deps)
   (let ((new-tree nil))
     (dolist (dep deps)
       (dolist (op-tree dep)
         (dolist (op  (cdr op-tree))
           (dolist (c (cdr op))
             (setf new-tree
                   (maybe-add-tree new-tree (car op-tree) (car op) c)
)
)
)
)
)

      new-tree
)
)


1. На первый взгляд это кажется "мозго-взрывательным". Не будем паниковать, а просто возьмём её код и немного изменим для того чтобы представить себе как она работает (благо её вполне можно отлаживать отдельно):

(let ((deps '(((compile-op (prepare-prevalence-op :weblocks-prevalence))
               (load-op (prepare-prevalence-op :weblocks-prevalence))
)

              ((compile-op (compile-op "file1" "file2"))
               (load-op (load-op "file1" "file2"))
)
)
)
)

  (let ((new-tree nil))
    (dolist (dep deps)
      (print dep)
      (dolist (op-tree dep)
        (print op-tree)
        (dolist (op  (cdr op-tree))
          (print op)
          (dolist (c (cdr op))
            (print c)
            (setf new-tree
                  (maybe-add-tree new-tree (car op-tree) (car op) c)
)
)
)
)
)

    new-tree
)
)


Первые два выводимых элемента:

((COMPILE-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
 (LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))

(COMPILE-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))

    Вроде ничего сложного. Сначала итерация по аргументам, затем по каждому списку в аргументе. Если назначить уровни вложенности элементам в deps начиная с номера 1, то можно сказать, что сейчас мы вывели элементы с уровнями вложенности 1 и 2.

Дальше стратегия несколько изменяется - итерация происходит уже не по списку а по хвосту списка:

(dolist (op  (cdr op-tree))
  (print op)
  (dolist (c (cdr op))
    (print c)
    ...
)
)


И в итоге мы добираемся до элементов с уровнями вложенности 3 и 4:

(PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)

:WEBLOCKS-PREVALENCE

А здесь мы как-то модифицируем текущее дерево (которое вначале пусто) используя элементы найденные на уровнях 2, 3 и 4:

(setf new-tree
        (maybe-add-tree new-tree (car op-tree) (car op) c)
)


Теперь уберём расставленные нами ранее вызовы print и проследим с какими именно аргументами вызывается функция maybe-add-tree, изменяющая new-tree. Для этого включим её трассировку:

   (trace maybe-add-tree)

В стандартный поток вывода, будет выведены следующие результаты трассировки:

  0: (MAYBE-ADD-TREE NIL COMPILE-OP PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)
  0: MAYBE-ADD-TREE returned
       ((COMPILE-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))
  0: (MAYBE-ADD-TREE
      ((COMPILE-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))) LOAD-OP
      PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)
  0: MAYBE-ADD-TREE returned
       ((LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
        (COMPILE-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))
  0: (MAYBE-ADD-TREE
      ((LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
       (COMPILE-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))
      COMPILE-OP COMPILE-OP "file1")
  0: MAYBE-ADD-TREE returned
       ((LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
        (COMPILE-OP (COMPILE-OP "file1")
         (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))
  0: (MAYBE-ADD-TREE
      ((LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
       (COMPILE-OP (COMPILE-OP "file1")
        (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))
      COMPILE-OP COMPILE-OP "file2")
  0: MAYBE-ADD-TREE returned
       ((LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
        (COMPILE-OP (COMPILE-OP "file2" "file1")
         (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))
  0: (MAYBE-ADD-TREE
      ((LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
       (COMPILE-OP (COMPILE-OP "file2" "file1")
        (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))
      LOAD-OP LOAD-OP "file1")
  0: MAYBE-ADD-TREE returned
       ((LOAD-OP (LOAD-OP "file1")
         (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
        (COMPILE-OP (COMPILE-OP "file2" "file1")
         (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))
  0: (MAYBE-ADD-TREE
      ((LOAD-OP (LOAD-OP "file1") (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
       (COMPILE-OP (COMPILE-OP "file2" "file1")
        (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))
      LOAD-OP LOAD-OP "file2")
  0: MAYBE-ADD-TREE returned
       ((LOAD-OP (LOAD-OP "file2" "file1")
         (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
        (COMPILE-OP (COMPILE-OP "file2" "file1")
         (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))

Как видно, всё гораздо проще чем казалось вначале - аргументы (car op-tree) и (car op) формируют "путь" по которому надо сохранить/добавить элемент c. Например, вызов формы со следующими параметрами:

    (maybe-add-tree
       '((LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
         (COMPILE-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))
       'COMPILE-OP
       'COMPILE-OP
       "file1")

вернёт:

    ((LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
     (COMPILE-OP (COMPILE-OP "file1")
                            (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))

    ... то есть по адресу compile-op/compile-op/ будет сохранён элемент "file1". Если такого адреса ещё нет,
он формируется. Если адрес есть, элемент добавляется к тому, что уже по этому адресу находится, например:

    (maybe-add-tree
       '((LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
         (COMPILE-OP (COMPILE-OP "file1")
                                (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))
       'COMPILE-OP
       'COMPILE-OP
       "file2")

вернёт:

    ((LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
     (COMPILE-OP (COMPILE-OP "file2" "file1")
                          (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))

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

2. Функция maybe-add-tree довольно тривиальна, как было сказано выше: её задача в том, чтобы обеспечить
наличие элемента по указанному адресу:

(defun* maybe-add-tree (tree op1 op2 c)
  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
Returns the new tree (which probably shares structure with the old one)"

  (let ((first-op-tree (assoc op1 tree)))
    (if first-op-tree
        (progn
          (aif (assoc op2 (cdr first-op-tree))
               (if (find c (cdr it))
                   nil
                   (setf (cdr it) (cons c (cdr it)))
)

               (setf (cdr first-op-tree)
                     (acons op2 (list c) (cdr first-op-tree))
)
)

          tree
)

        (acons op1 (list (list op2 c)) tree)
)
)
)


Логика работы достаточно прозрачна:
 - ищём список с головой = OP1
 - если не находим, то создаём свой путь /OP1/OP2 и кладём по этому пути элемент С.
 - если находим, то далее ищем второй элемент пути OP2
 - если не нашли, создаём список из OP2 и C и сохраняем его по адресу начинающемуся с OP1
 - если нашли, то добавляем элемент только если не получилось его найти с помощью функции find.

--------------------
Примечание к ф-ии maybe-add-tree (для ASDF 2.0.18.3).
    Однако не понятно, если содержимое (в перечеслении зависимостей) состоит из строк, то почему функция find вызывается без опции :test #'equal - это приводит к тому, что C всё-таки добавляется повторно, если мы имеем дело со строковыми элементами. То есть, выполнение формы:

(maybe-add-tree
 '((LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
   (COMPILE-OP (COMPILE-OP "file1")
                              (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)
)
)

 'COMPILE-OP
 'COMPILE-OP
 "file1"
)


    ... приведёт к такому, вряд ли ожидаемому разработчиками, результату:

    ((LOAD-OP (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE))
     (COMPILE-OP (COMPILE-OP "file1" "file1")
                                (PREPARE-PREVALENCE-OP :WEBLOCKS-PREVALENCE)))

Я думаю, что это небольшой баг и уже написал письмо в рассылку, с приложенным патчем ...


Исправлено в версии 2.0.18.4

-------------------
UPDATED: в версии 2.0.18.4 добавили опцию :test #'equal в вызов find в ф-ии maybe-add-tree.
-------------------
Продолжение следует ...












TRACKING-CHANGES - отслеживание изменений.
  В прошой заметке, я писал о системе ASDF-TRACKING-CHANGES, расширяющей функциональность ASDF. Это система позволяет отслеживать изменения произошедшие в лисп-системе после выполнения операции с файлами (конкретно - после их компиляции и загрузки в лисп-систему). Непосредственно за отслеживание изменений отвечает её "запчасть" - система TRACKING-CHANGES. Правда, пока (и соответственно asdf-tracking-changes тоже) она отслеживает только появление новых пакетов. Она имеет простой и интуитивно понятный интерфейс, чтобы сохранить произошедшие при выполнении кода изменения, нужно этот код обернуть макросом with-monitoring, указав ключ для последующего поиска изменений. Например:

(tracking-changes:with-monitoring :my-key (load "some-file.lisp"))

Теперь список, созданных после выполнение формы (load "some-file.lisp") пакетов можно получить так:

(tracking-changes:get-sandbox-packages-list :my-key)

Впрочем, более подробно можно почитать в README.
Ссылка на github репозитарий: https://github.com/LinkFly/tracking-changes

Расширение ASDF - ASDF-TRACKING-CHANGES
    Написал расширение для ASDF, предназначение для отслеживание изменений в лисп-системе. С помощью него можно установить какие пакеты были определены при компиляции/загрузке конкретного файла. В будущем планируется отслеживать, конечно же, не только добавление новых пакетов. Инструкции по использованию и установке читайте в README_ru:

https://github.com/LinkFly/asdf-tracking-changes/blob/master/README_ru

Собственно сабж:

https://github.com/LinkFly/asdf-tracking-changes

Устройство ASDF. Подсистема определения. PARSE-COMPONENT-FORM.
(сказаное ниже относится к версии 2.018.3)

Это 4-ая статья цикла.
Первая статья.
Архитектура ASDF.
Предыдущая статья.

    Функция PARSE-COMPONENT-FORM вызывается из ф-ии do-defsystem и представляет собой следующий и главный этап определения системы. Ф-ия строит иерархию объектов (класса component и его наследников) на основе передаваемых опций и присоединяет её к другому объекту, её определение выглядит так:

    (defun* parse-component-form (parent options) ...)

В parent передаётся объект к которому нужно присоединить создаваемую иерархию, в options передаются ключи управляющие созданием объектов. Если parse-component-form вызывается из do-defsystem, parent будет равен nil (это означает, что будет создаваться корневой объект иерархии). Список options выглядит подобно следующему:

    (:module "exp-system"
      :pathname #P"/home/someuser/lisp/asdf-experiments/"
      :depends-on nil
      :components ((:module "src"
                                  :pathname ""
                                  :components ((:file "file1")
                                                            (:static-file "static.txt")
                                                            (:file "file2" :depends-on ("file1"))
                                                            (:file "file3" :depends-on ("file1"))))))

    ... это те же опции, что используются в форме (defsystem ...) в *.asd файлах, но за исключением опции :class (так как, если она была задана, её обработка произошла до вызова parse-component-form в ф-ии do-defsystem).

            Логика работы parse-component-form.

1. Ф-ия с помощью destructuring-bind разбирает переданные параметры и устанавливает локальные переменные соответствующие их ключам. Есть правда, небольшое исключение: первые два элемента считаются обязательными (а не ключевыми) и локальными переменными для них будут type и name. Для примера выше (при разборе options) установки этих переменных будут следующие:

type = :module
name = "exp-system"

    Остальные имена локальных переменных будут соответствовать переданным ключам. Ключи :perform :explain :output-files :operation-done-p используются для создания инлайн-методов (inline methods) специализирующихся на этом компоненте, но их обработка происходит вне определения parse-component-form (конкретно в ф-ии %define-component-inline-methods вызываемой из %refresh-component-inline-methods, которая в свою очередь вызывается в конце вызова parse-component-form) и поэтому они помечены как ignorable (игнорируемые) чтобы подавить ненужные предупреждения. Вообще список возможных инлайн-методов содержится в константе +asdf-methods+. Список содержит символы именующие методы, соответственно упомянутым ключам (а также символ perform-with-restarts, соответствующий недокументированному инлайн-методу). Итак остаются следующие ключи:

    Задающие содержимое, путь, и класс компонента по умолчанию:
:components
:pathname
:default-component-class

    Задающие зависимости:
:weakly-depends-on
:depends-on

    Управляющие порядком операций:
:serial
:in-order-to
:do-first

    Дополнительные:
:version

    Чтобы вы при чтении дальнейшего описания, примерно представляли о чём идёт речь (конечно же, для более обстоятельного объяснения стоит обратится к официальной документации) ниже дано короткое описание, назначения опций:

    Задающие содержимое, путь, и класс компонента по умолчанию:
:components - компоненты, содержащиеся в данном (например файлы исходников или другие модули).
:pathname - переопределённый путь для компонента.
:default-component-class - класс, которорый будет использоваться при задании типа :file

    Задающие зависимости:
:weakly-depends-on - зависимости загружаются только в случае, если удалось их найти.
:depends-on - зависимости обязательные к загрузке.

    Управляющие порядком операций:
:serial - каждый описанный компонент, становится автоматически зависимым от предыдущего компонента.
:in-order-to - этой опцией можно переопределить порядок применения операций к компонентам.
:do-first - недокументированный ключ, также служит для тонкой настройки, порядка применения операций.

    Дополнительные:
:version - версия компонента (должна быть выше чем может быть указано в зависимостях от этого компонента).

    Кроме того, реализация позволяет использовать дополнительные ключи (для каких-нибудь собственных мета-надстроек), чуть позже список этих дополнительных ключей будет связан с лексической переменной other-args.

2. Далее parse-component-form вызывает ф-ию check-component-input для проверки значений, связанных с лексическими переменными weakly-depends-on, depends-on, components и in-order-to.

    (check-component-input type name weakly-depends-on depends-on components in-order-to)

    ... значения type и name передаются лишь для формировании сообщения об ошибке.  Проверка не сложная:
        - все проверяемые элементы должны быть списком - это раз (пусть даже и пустым).
        - если in-order-to не пустой список, первый его элемент должен быть тоже списком - это два.

3. Дальше идёт проверка того, что если определяемый компонент уже существует на том же уровне иерархии (а именно в компоненте parent), то он такого же типа, что и определяемый (иначе сигнализируется ошибка):

   (when (and parent
                        (find-component parent name)
                       ;; ignore the same object when rereading the defsystem
                        (not
                           (typep (find-component parent name)
                                       (class-for-type parent type)
)
)
)

      (error 'duplicate-names :name name)
)


    В первом вызове parse-component-form аргумент parent равен nil, поэтому проверка сразу пропускается. А вообще, суть проверки такова: если parent не nil и компонент найден в parent и тип компонента отличается от указанно типа, то имеет место коллизия имён и выбрасывается ошибка duplicate-names.
    Но почему здесь не сигнализируется ошибка, если был найден компонент того же типа и с тем же именем что и определяемый? Это было сделано для ситуации повторного чтения определения системы (например, если файл .asd изменился). Дело в том, что хэш-таблица в слоте components-by-name, объекта parent (который должен иметь тип/подтип module), используемая в методе find-component, будет содержать (при переопределении системы) старые записи компонентов. И конечно, найдется компонент с тем же именем, что и определяемый. Как видно, разработчики сделали так, чтобы сигнализация ошибки при изменении типа компонентов происходила пораньше. Непосредственно проверка того, что на том же уровне иерархии нет компонентов с одинаковым именем, осуществляется в ф-ии compute-module-components-by-name. Эта ф-ия выполняет итерацию по содержимому слота components (объекта класса/подкласса module) с тем, чтобы создать и заполнить хэш-таблицу с записями вида имя_компонента-компонент и записать её в слот components-by-name. а также сигнализировать ошибку duplicate-names, если встретились компоненты с одинаковым именем. Она будет вызвана здесь же, в parse-component-form, если определяемый компонент имеет тип/подтип module.
    В показаном выше коде, исопльзуется ф-ия class-for-type. Её определение достаточно тривиально, но имеет важный нюанс: используется слот default-component-class передаваемого объекта parent, а при равенство его NIL - динамическая переменная *default-component-class*.

    (defun* class-for-type (parent type) ...)
    CLASS-FOR-TYPE работает следующим образом:
        - пытаемся найти класс представленный символом type, сначала в пакете символа, затем в текущем пакете и наконец в пакете :asdf :

       (loop :for symbol :in (list
                                               type
                                              (find-symbol* type *package*)
                                              (find-symbol* type :asdf)
)

         :for class = (and symbol (find-class symbol nil))
         :when (and class (subtypep class 'component))
         :return class
)


        - для типа :file делается исключение, для него не обязательно иметь класс. При его использовании инстанцируемый класс выбирается следующим образом - если в слоте компонента default-component-class есть значение, то это будет возвращаемым значением, если нет, то значением будет класс *default-component-class*, который по умолчанию равен CL-SOURCE-FILE:

   (and (eq type :file)
             (or (module-default-component-class parent)
                   (find-class *default-component-class*)
)
)


Логика работы find-component здесь рассматриваться не будет, так как это тема для отдельной статьи.

4. Если была задана опция с ключом :version, то осуществляется проверка синтаксической корректности заданной версии. Это должна быть строка, содержащая числа, разделённые точками:

   (when versionp
      (unless (parse-version version nil)
        (warn ... )
)
)

5. Дополнительные ключи связываются с лексической переменной other-args:

   (let* ((other-args (remove-keys '(components pathname ... )
                                                             rest
)
)

               ...
)

      ...
)

 
    Эти ключи и их значения будут участвовать в создании (или повторной инициализации) компонента. А именно дополнительные аргументы передаются в make-instance (если компонент ещё не был создан) или в reinitialize-instance (если компонент был получен, после успешного поиска в parent), но об этом позже.

6. Лексической переменной ret присваивается компонент, если он уже был создан или конкретней: присваивается компонент с именем name содержащейся в parent:

   (let* (...
            (ret (find-component parent name))
)

      ...
)


    Если это первый вызов parse-component-form и соотв. аргумент parent равен nil, а аргумент name соответствует имени определяемой системы (оно сейчас содержится в переменной name и было передано через ключевой параметр :module) - вызов вернёт объект представляющий эту систему. Если же parent и name заданы (не равны nil), то производится поиск компонента в parent. Это нужно для того, чтобы заново не пересоздавать уже готовые объекты (а значит не выделять заново для них память, что важно).

7. Теперь обрабатывается ключик :weakly-depends-on - фактически это не что иное как список "не обязательных" систем:

   (when weakly-depends-on
      (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))
)


В этом коде происходит присоединение к depends-on тех систем которые получилось найти. Принцип такой: не нашли, значит обойдёмся. С какой стати "систем", ведь функция parse-component-form вызывается (как мы увидим позже) вообще для всех элементов системы? Очевидно ключ :weakly-depends-on имеет право быть только в форме верхнего уровня (по отношению к форме (defsystem ...). Если его указать для какого-то вложенного компонента, то логично предположить что будут подгружаться системы соответствующие именам в этом списке, что врятли соответствует ожиданиям разработчика. Видимо авторам следовало бы либо изменить поиск систем на поиск компонентов/файлов либо ввести проверку на отсутствия ключа :weakly-depends-on в описании вложенных компонентов.

8. Далее используется динамическая переменная *serial-depends-on* - если её содержимое не равно nil, это содержимое добавляется в depends-on:

   (when *serial-depends-on*
       (push *serial-depends-on* depends-on)
)


    По умолчанию *serial-depends-on* = nil, позже мы увидим в какой ситуации это будет не так. Вообще эта переменная работает совместно с ключом :serial - она содержит предыдущий, определёный в parse-component-form, компонент (на том же уровне иерархии) и как видно выше модифицирует список depends-on компонента включая туда этот компонент.

9. Далее, создаётся или переинициализируется объект класса/подкласса component:

    9.1 Если компонент был найден (при первом вызове, это понятное дело объект класса system или его наследника), то его необходимо повторно инициализировать, используя для этого, в том числе, дополнительные опции:

       (if ret
            (apply 'reinitialize-instance ret
                        :name (coerce-name name)
                        :pathname pathname
                        :parent parent
                        other-args
)

          ...
)


    9.2 Если компонента в parent не было найдено - создаётся новый объект типа, имя которого связано с локальной type. Причём создаётся натурально из указанного типа, например если у вас в определении системы указан :module создаётся объект класса module. Для получения класса по type используется уже рассмотренная выше ф-ия class-for-type. То есть, совершенно свободно можете определять свои классы в иерархии наследования которых есть класс component и использовать в списках, внутри списка опции :components (исключение составляет, как показно выше в описании ф-ии class-for-type, ключ :file):

       (if ret
            (...)
            (setf ret
                    (apply 'make-instance (class-for-type parent type)
                                :name (coerce-name name)
                                :pathname pathname
                                :parent parent
                                other-args
)
)
)


10. Для компонента вычисляется значение слота absolute-pathname: (component-pathname ret). Принцип такой: по пути к самому старшему предку в иерархии, которым должна быть система, собираются именя компонентов и присоединяются к абсолютному пути этого корневого компонента, то есть системы. Для объекта-системы же, этот слот получает значение из слота relative-pathname, который должен быть абсолютным и вычисляется ещё в do-defsystem, а связывается со слотом во время повторной инициализации.

11. Далее, если компонент класса 'module (или его наследника) то выполняются следующие действия:

    11.1 Вычисляется слот 'default-component-class:

       (setf (module-default-component-class ret)
                (or default-component-class
                      (and (typep parent 'module)
                               (module-default-component-class parent)
)
)
)


        Как видно из кода он либо берётся из ключа :default-component-class либо из соответствующего слота своего предка.
        
    10.2 Затем, на основе списков в значении ключа :components создаётся список с объектами созданными из этих списков и присваивается слоту 'components:

           (let ((*serial-depends-on* nil))
               (setf (module-components ret)
                     (loop
                        :for c-form :in components
                        :for c = (parse-component-form ret c-form)
                        :for name = (component-name c)
                        :collect c
                        :when serial :do (setf *serial-depends-on* name)
)
)
)


        Обратите внимание, что создаётся локальный контекст в котором *serial-depends-on* приравнивается к nil, а каждый объект создаётся с помощью рекурсивного вызова всё той же parse-component-form (но уже в качестве parent выступает текущий объект). Здесь мы видим принцип работы ключа :serial - если он задан, то parse-component-form выполняется в контексте в котором *serial-depends-on* приравнена к предыдущему созданному компоненту, это влияет на форму (описанную в пункте 8):

        (when *serial-depends-on*
           (push *serial-depends-on* depends-on)
)


     ... то есть модифицирует значение depends-on, добавляя к нему имя предыдущего созданного компонента.

     11.3 Заполняется слот components-by-name создаваемой хэш-таблицей для быстрого поиска компонентов по имени:

       (compute-module-components-by-name ret)

     Там же осуществляется проверка на уникальность имён компонентов.

Дальнейшие действия происходят не только для объектов класса/подкласса module.

12. Далее устанавливается слот load-dependencies:

   (setf (component-load-dependencies ret) depends-on)

    ... в значение depends-on которое как мы помним могло быть модифицировано формами:

   (when weakly-depends-on
      (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))
)

   (when *serial-depends-on*
      (push *serial-depends-on* depends-on)
)


13. Теперь будет уставка слота in-order-to:

     (setf (component-in-order-to ret)
              (union-of-dependencies
                in-order-to
               `((compile-op (compile-op ,@depends-on))
                  (load-op (load-op ,@depends-on))
)
)
)


    Тело функции union-of-dependencies выглядит довольно хитро. Подробности её внутреннего устройство тема для отдельной статьи. Для начала следует иметь в виду, что она просто возвратит свой второй аргумент если опция :in-order-to не была установлена, а значит в этом случае слот in-order-to получит значение:

    `((compile-op (compile-op ,@depends-on))
       (load-op (load-op ,@depends-on)))  

14. Работа со слотом do-first происходит аналогичным образом:

    (setf (component-do-first ret)
             (union-of-dependencies
                do-first
                `((compile-op (load-op ,@depends-on)))))

    ... т.е. если опция :do-first не использовалась, то в слоте do-first сохраняется более ясное для понимания:

    `((compile-op (load-op ,@depends-on)))

15. Далее происходит следующее: обновляются, так называемые inline методы для компонента:

    (%refresh-component-inline-methods ret rest)

    При выполнении этой формы удаляются инлайн-методы компонента и определяются заново:

    15.1 Сначала удаляются все методы сохранённые в слоте inline-methods из обобщённых функций, сохранённых в
константе +asdf-methods+:

        (%remove-component-inline-methods component)

        Код этой функции достаточно тривиален и я не буду его здесь приводить.

    15.2 Затем слот inline-methods получает новый список методов используя для этого список оставшихся опций:

        (%define-component-inline-methods component rest)

        Код этой ф-ии тоже не сложный - для каждого символа в +asdf-methods+ создаётся соответствующий keyword:

        (dolist (name +asdf-methods+)
          (let ((keyword (intern (symbol-name name) :keyword)))
           ...
)
)


        Потом на каждой итерации происходит проход по списку опций компонента

         (loop :for data = rest :then (cddr data) ...)

        ...  и для каждого ключа из списка:

        (:PERFORM-WITH-RESTARTS :PERFORM :EXPLAIN :OUTPUT-FILES :OPERATION-DONE-P)

        ... генерируется и выполняется код создающий метод на основе значения ассоциированного с ключом:

       (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
                     ,@body
)
)


        Это было неожидано, кстати. И потом, как можно догадаться, он кладётся в список слота inline-methods.

16. Возвращение созданного компонента в качестве результата.

Для более ясной картины опишу вкратце все 16 действий, выполняемые parse-component-form:

1. Разбор ключевых параметров с помощью destructuring-bind.
2. Проверка того, что опции weakly-depends-on depends-on components in-order-to заданы правильными значениями (списками).
3. Проверка на отсутствие или существование компонента только того-же типа на этом же уровне иерархии.
4. Проверка на правильное задание ключа :version.
5. Получение дополнительных ключей.
6. Попытка найти старый компонент.
7. Модифицирование зависимостей depends-on, в соотвии со слабыми зависимостями, задаваемыми ключом weakly-depends-on.
8. Добавление зависимости от предыдущего компонента, если необходимо (задана опция :serial t).
9. Создание или переинициализация компонента:
      9.1 Если компонент найден при первом вызове, то - переинициализация.
      9.2 Если не был найден, то - создание.
10. Вычисление слота absolute-pathname.
11. Получение компонента по умолчанию, создание компонентов, инициализация слота components-by-name:
      11.1 Вычисление слота default-component-class по заданной опции или по слоту предка.
      11.2 Создание компонентов на основе значения опции :components.
      11.3 Инициализация слота components-by-name для быстрого поиска компонентов.
12. Установка слота load-dependencies скорректированным значением depends-on.
13. Установка слота in-order-to.
14. Установка слота do-first.
15. Обновление инлайн-методов.
      15.1 Удаление инлайн-методов в ф-ии %remove-component-inline-methods.
      15.2 Определение инлайн-методов в ф-ии %define-component-inline-methods.
16. Возврат созданного компонента.
-----------------------------

Продолжение следует ...

Устройство ASDF. Подсистема определения. DEFSYSTEM.
(сказаное ниже относится к версии 2.018.3)

Это 3-яя статья цикла.
Первая статья.
Архитектура ASDF (предыдущая статья)

    Определение системы начинается с выполнения формы (defsystem ...). Этот тот самый DEFSYSTEM, который используется в *.asd файлах. Макрос DEFSYSTEM всего лишь "переходник", он генерирует код вызывающий обычную ф-ию DO-DEFSYSTEM:

   (defmacro defsystem (name &body options)
      `(apply 'do-defsystem ',name ',options)
)


    ... почему так? Просто выяснилось что макрос для определения системы не нужен. Но не заставлять же всех переписывать asd файлы:) Макросы вообще не стоит использовать без особой необходимости.

DO-DEFSYSTEM.
(defun* do-defsystem (name &rest options
                           &key (pathname nil pathname-arg-p) (class 'system)
                           defsystem-depends-on &allow-other-keys
)

  ...
)


    Ф-ия выполнит кое-какие настройки и вызовет в самом конце, ф-ию PARSE-COMPONENT-FORM для анализа переданных опций и создания на их основе иерархии объектов, используемой остальными подсистемами. Работа ф-ии состоит из следующих этапов:

1. Всё обёртывается кодом вводящим динамический контекст, в котором переменная *systems-being-defined* гарантировано содержит хэш-таблицу. В этой хэш-таблице будут регистрироваться системы, определяющиеся в данный момент (используется это подсистемой поиска):

    (with-system-definitions () ...)

2. Определяется локальный контекст со следующими переменными:

    2.1 name - получает строковое (каноническое) имя системы: (coerce-name name)
    2.2 registered - получает объект системы, если она уже зарегистрирована: (system-registered-p name)

        2.2.1 system-registered-p ищет систему в хэш-таблице *defined-systems*, используя её имя как ключ:

             (gethash (coerce-name name) *defined-systems*)

        2.2.2 В итоге registered получает значение как пару вида (если система всё-таки зарегистрирована):

              (3525158896 . #<SYSTEM "some-system">)

            ... в которой первый элемент является временной меткой (когда система была зарегистрирована), а второй экземпляром класса SYSTEM или его наследника.

    2.3 system - получает объект зарегистрированной системы (при необходимости, объект системы создаётся и регистрируется):

       (cdr (or registered
                     (register-system (make-instance 'system :name name))
)
)


        ... register-system выводит сообщение о регистрации системы и сохраняет список из метки времени и новой системы в хэше *defined-systems* с ключом name.

    2.4 component-options - получает все опции системы, кроме :class (remove-keys '(:class) options). Это происходит из-за того, что обработка этой опции будет происходить здесь же, в ф-ии do-defsystem.

3. Итак система уже зарегистрирована, осталось установить в объект, представляющий систему, путь к файлу, содержащему определение системы (если никаких извращений не было то это файл с расширением .asd и собственно путь к загружаемому в данный момент файлу, в котором выполняется top-level форма (defsystem ...) сгенерировавшая код для выполнения текущей ф-ии do-defsystem.):

    (%set-system-source-file (load-pathname) system)

    ... load-pathname в том числе обрабатывает символические ссылки, с помощью ф-ии resolve-symlinks* (будут ли разрешаться символические ссылки, определяется специальной переменной *resolve-symlinks* - по умолчанию установлена в T)

4. В хэш-таблицу, в упомянутой выше динамической переменной *systems-being-defined* (которая определена в дин. контексте, вводимого макросом with-system-definitions), записывается полученный объект системы:

   (setf (gethash name *systems-being-defined*) system)

5. Если система уже зарегистрирована, то обновляется время регистрации:

   (when registered
      (setf (car registered) (get-universal-time))
)


6. Подгузка систем указанных ключом defsystem-depends-on, то есть тех систем, которые необходимы не просто для работы определяемой системы, а для её непосредственного определения и регистрирования:                                                          
                                                                                                            
  (map () 'load-system defsystem-depends-on)

   ... в этих системах следует размещать код, расширяющий функциональность ASDF. Например, классы-наследники от классов с предком component, от классов с предком operation. А также свои методы для обобщённых ф-ий (например для perform) специализирующихся на своих классах и/или добавляющих функциональность с помощью стандартных комбинаторов :before, :after и :around. 

7. Изменяется класс системы, если в опциях системы указан ключ :class со значением отличным от 'system :

   (let ((class (class-for-type nil class)))
      (unless (eq (type-of system) class)
        (change-class system class)
)
)


8. Теперь самое главное, обработка указанных опций-ключей. Осуществляется она функцией parse-component-form, которая вызывается с аргументом NIL в качестве parent (ведь определяемая система является корневым элементом создаваемой иерархии, для других компонентов parent будет устанавливаться в соответствии с глубиной вложенности) и списком необходимых опций. Этот список формируется с помощью component-options (помните определяли локальную переменную, выкидывая ключ :class ?), опции: ":module name" и вычисляемого пути к компоненту, который мог быть указан ключом :pathname (если он не был указан, путь вычисляется как директория в которой находится .asd файл). В простом случае сформированный список опций будет выглядеть подобно следующему:

   (:module "exp-system"
         :depends-on nil
         :components ((:module "src"
                   :pathname ""
                   :components ((:file "file1")
                        (:static-file "static.txt")
                        (:file "file2" :depends-on ("file1"))
                        (:file "file3" :depends-on ("file1"))
)
)
)
)


------------- продолжение следует ...







О мусорщиках
Вот тут вот есть статья про то, как можно обойти gc-шный heap, чтобы победить паузы, возникающие при сборке мусора.

Надо признать, что затронутые там проблемы можно спроецировать и на SBCL. А, вдовесок, мы имеем еще пару непонятных моментов:
  1. Собственно наш мусорщик менее технологичный, нежели в JVM. Как минимум, он не параллельный и, вообще, при сборке отважно накладывает глобал-лок на весь процесс.
  2. При всех несомненных плюсах GC, мне непонятно, почему в CL нет богатых возможностей по ручному управлению памятью.

Что касается первого пунка, то я уже предлагал подумать в сторону выделенного GC, который можно будет переключать, например, глобальной переменной *current-gc*. Ну или хотя бы локальный thread-specific GC. Да, объекты, выделенные в разных кучах, не смогут ссылаться друг на друга, но в большинстве случаев это и не надо: каждая нить занята своей отдельной работой, но злобный мусорщик останавливает сразу всех, чтобы подчистить только за одной.

В какой-то мере, требуемое поведение можно сэмулировать отказавшись от нитей в пользу полноценных процессов, порожденных через fork(2). Надо сказать, что меня бы даже эта система вполне устроила, если бы не один неприятный момент, как-то отмеченный 1349: форк sbcl-ого процесса, который при старте наммапил себе восемь гигов памяти, занимает вечность :)

На втором пункте надо бы остановиться отдельно.

Действительно, в CL имеются богатые возможности для метапрограммирования, и нет никаких проблем безопасно и надежно прятать все ручное управление памятью поглубже. Начиная от RAII в стиле with-open-file, заканчивая декларативными eDSL, в которых можно аккуратно разметить необходимую область памяти и политику ее освобождения. Хотя, возможно, достаточно просто расширить интерфейс garbage collector'а, позволив выводить из-под его влияния выбранные объекты, которые он затем не имеет права трогать. А продолжительностью их жизни пусть управляет программист: ведь дофига же случаев, когда объекты не нужны уже сразу вне своего блока видимости.

Вообще, приглашаю подискутировать на эту тему :)
Устройство ASDF. Архитектура.
(сказаное ниже относится к версии 2.018.3)

Это 2-ая статья цикла.
Первая статья.

    Центральное место в ASDF занимают две иерархии классов, одна с корневым элементом component, другая с корневым элементом operation:

    Для простоты изучения следует разделить систему (концептуально) на части, в которых прослеживается сильная связность в используемых сущностях и слабая связанность между ними. Этими частями могут быть:

    1. Определение систем: определяет систему обрабатывая *.asd файлы.
    2. Поиск систем: ищет системы в оперативной памяти и файлы *.asd в путях поиска.
    3. Загрузка систем (operate, load-system).
        3.1 Планирование операций: планирует последовательность операций с каждым зависимым компонентом.
        3.2 Выполнение операций: выполняет компиляцию, загрузку и пользовательские операции.
    4. Определение путей: определяет пути анализируя иерархию компонентов и вычисляет пути сохранения *.fasl файлов.

Ниже представлено какими ф-иями и методами реализуется каждая из подсистем:

    1. Определение систем:
            - defsystem
            - parse-component-form
            - union-of-dependencies

    2. Поиск систем:
            - find-system
            - compute-source-registry
            - resolve-location

    3. Загрузка систем (operate).
       - operate
       - make-sub-operation
       - find-component

        - Планирование операций:
            - traverse                                    
                - do-traverse
                - do-dep

        - Выполнение операций:
                - perform-plan
                - perform-with-restarts
                - perform

    4. Определение путей
            - apply-output-translations
            - compute-output-translations
        - input-files
        - output-files
        - component-pathname
        
А вот наглядная схема:



Опишу вкратце логику работы:

    ПОДСИСТЕМА ЗАГРУЗКИ.
    После того, как пользователь запросил загрузку системы, выполнив например (asdf:load-system :restas), подсистема загрузки обращается к методу OPERATE. Для поиска определений систем, этот метод обращается к подсистеме поиска. Затем, планируется необходимые операции соответствующей подсистемой и запланированые операции выполняются подсистемой выполнения операций. В процессе всего этого необходимо анализировать иерархию компонентов и создавать иерархию операций, для этого используются метод FIND-COMPONENT и ф-ия MAKE-SUB-OPERATION.

    ПОДСИСТЕМА ПОИСКА.
    Активизирует подсистему поиска вызов метода FIND-SYSTEM. После активизации, подсистема пытается найти определние разыскивамой ASDF-системы в оперативной памяти и если ей это не удаётся, она пытается найти её на диске, используя для этого пути заданные в *central-registry*. Если опять не получилось она обращается к следующей возможности найти *.asd файл. А именно, она использует для поиска *source-registry*, которая перед первым обращением к ней инициализируется с использованием COMPUTE-SOURCE-REGISTRY. Эта ф-ия вычисляет пути руководствуясь (по усмолчанию) файлом source-registry.conf или директорией source-registry.conf.d, которые (опять же по умолчанию) в случае ОС Linux должны быть расположены в /home/$USER/.config/common-lisp/ директории. Внутри этой ф-ии, работает хитрый конвейр который обрабатывает некий мини-DSL предназначенный для очень гибкого, декларативного описания путей поиска. Ф-ия RESOLVE-LOCATION работает в недрах compute-source-registry и занимается непосредственно анализом значительной части этого самого мини-DSL.

    ПОДСИСТЕМА ЗАГРУЗКИ. ПОДСИСТЕМА ПЛАНИРОВАНИЯ ОПЕРАЦИЙ.    
    После всех приключений с поисками системы, управление возвращается в подсистему загрузки. Далее вступает в работу "суб-подсистема" планирования операций - вызывается главный метод этой подсистемы TRAVERSE. Он не делает особо много работы: корректирует кое-какой слот, определяет ф-ию для сбора значений и готовится к приёму и обработке результата, который должен вернуть, возможно самый сложный метод asdf, метод DO-TRAVERSE. Главная его задача в том, чтобы ходить по иерархии компонентов системы и собирать операции, которые необходимо выполнить с компонентами. Для определения и сбора операций, которые необходимо выполнить с зависимостями компонентов служит ф-ия DO-DEP. Она делает неявный рекурсивный вызов do-traverse по пути делая кое-какую полезную работу (например, проверяет версию компонента).

    ПОДСИСТЕМА ЗАГРУЗКИ. ПОДСИСТЕМА ВЫПОЛНЕНИЯ ОПЕРАЦИЙ.
    Итак операции запланированы, теперь начинает работать подсистема выполнения операций начиная с метода PERFORM-PLAN. Метод получает список запланированных операций и вызывает метод PERFORM-WITH-RESTARTS для каждой пары операций-компонент (список пар был возвращен методом traverse). Как видно из названия, метод устанавливает несколько рестартов: для перекомпиляции, рестарт позволяющий повторить операцию с компонентом, а также рестарт позволяющий считать операцию выполненой. Далее perform-with-restarts передаёт управление методу PERFORM, которая, наконец уже, выполняет операцию с компонентом. Если необходимо добавить какую-то дополнительную обработку во время компиляции и/или загрузке компонентов, то как правило добавляют методы (основные и декораторы) имено к обобщёной ф-ии perform. По умолчанию имеются только два декоратора:
    - :before - гарантирует существование директории для последующего сохранения скомпилированного файла.
    - :after - сохраняет в компоненте текущую метку времени, чтобы отметить завершение операции.
При выполнении операций компиляции и загрузки, методам требуется вычислять абсолютные пути к исходным и скомпилированным файлам, для этого используется подсистема определения путей.

    ПОДСИСТЕМА ОПРЕДЕЛЕНИЯ ПУТЕЙ.
    Один из главных методов, отвечающих за вычисление путей для операций это - INPUT-FILES. Если требуется вычислить путь к исходнику, то этот метод вызывает метод COMPONENT-PATHNAME. Принцип работы метода заключается в прохождения пути от компонента, до его самого старого предка и собирания имен, встречающихся на пути компонентов, для формирования абсолютного пути. Если требуется вычислить путь для будущего скомпилированного файла, то input-files вызывает метод OUTPUT-FILES. Он также использует метод component-pathname для получения абсолютного пути к исходнику но при этом, дополнительно обрабатывает путь с помощью ф-и APPLY-OUTPUT-TRANSLATIONS. Обработка происходит с использованием внутренней специальной переменной *output-translations*, которая инициализируется перед первым использованием. За инициализацию отвечает ф-ия COMPUTE-OUTPUT-TRANSLATIONS, она работает подобно ф-ии compute-source-registry - это тоже конвейрная обработка с анализом мини-DSL'а для определения путей.

    ПОДСИСТЕМА ОПРЕДЕЛЕНИЯ СИСТЕМ.
    Для планирования операций и определения путей, компоненты системы и их зависимости организуются в иерархию. Для построение этой иерархии применяется всем знакомый макрос DEFSYSTEM. Да, это тот самый defsystem который используется в *.asd файлах. На данный момент, он ничего не делает а просто передаёт управление ф-ии do-defsystem. Основная рабочая лошадка в do-defsystem это ф-ия PARSE-COMPONENT-FORM. Она разбирает слегка подкорректированный в do-defsystem древообразный список опций. Для разрешение зависимостей и переопределения порядка операций с этими завимостями используется ф-ия UNION-OF-DEPENDENCIES совместно со слотами in-order-to и do-first компонентов.
--------------------
    
Продолжение следует ...


UPDATE 1. Добавлен слот around-compile в класс component (в соотв. с обновленным номером версии).
Удивительное рядом: потокобезопасность в cl
Обычная задача: выполнить функцию в отдельном потоке, в моем случае это inc-counter.

Для этого можно выполнить форму:

* (defparameter *counter* 1)
* (defun inc-counter ()
(incf *counter*))
* (bordeaux-threads:make-thread (lambda () (inc-counter)))
* *counter*
2

Усложненная задача: потоков может быть несколько. Определенно функция может изменять какие-то глобальные переменные (в терминах лиспа: динамические переменные созданные функциями defvar, defparameter). Если бы передо мной была библиотека на c/c++, можно было бы опускать руки, так как с/с++ не позволяет изменять окружение выполнения функции. Думаю, что и java так же этого не позволяет. А javascript, кстати, позволяет окружение менять. А вот в common lispе для того, чтобы сделать из любой функции с побочными эфектами, функцию без них, достаточно использовать форму let. Давайте выполним теперь такой поток:

* (bordeaux-threads:make-thread (lambda () (let ((*counter* 0)) (inc-counter))))
* *counter*
2

Вот ведь, к хорошему быстро привыкаешь. Я уже два дня этим финтом пользуюсь, а только сегодня его осознал.
Устройство ASDF. Предисловие.
    В программировании на мэйнстримных языках бытует такое мнение, что система не должна быть чрезмерно гибкой. К такой точке зрения вполне можно отнестись с пониманием - ведь "гибкость" даётся не просто так, система становится сложнее, а значит больше риск внесения ошибок и соответственно это требует больше ресурсов для поддержки, Конечно, этот тезис следует иметь в виду при работе с любыми технологиями программирования. А вот в мире Лиспа дело обстоит несколько иначе: та гибкость которая обычно считается чрезмерной, здесь таковой не является, а недостаточная гибкость, считается скорее моветоном. Почему так? Да просто средства обеспечения гибкости в Лиспе достаточно просты, отлично гармонизируют с другими механизмами языка и друг другом (чего стоят одни только макросы). То есть, использования этих средств не является долгим/трудоёмким процессом (понятное дело, если не доводить это до абсурда). Дело в фундаментальной основе самого языка: минималистичный синтаксис, гомоиконность (программы представляются также как и данные), представление программ и данных в древовидной форме (в виде иерархических списков, в виде графов ... называйте как хотите). Ну а дальше уже из этого следуют/вытекают макросы, лёгкость построение "Embedded DSL" (встроеных языков предметной области) и прочее-прочее ... . Но довольно лирики, в этой статье мы поговорим об инструменте определения систем (если по проще, то: о средстве работы с библиотеками) - ASDF (Another System Definition Facility - другое средство определения систем), а точнее о элементах его внутреннего устройства и его некоторых качествах, обеспечивающих высокую гибкость.

    Это первая статья из планируемого цикла статей по внутреннему устройству ASDF. Она предназначена для знакомых с языком Common Lisp, любителей "полазить" по чужим исходным кодам и интересующихся внутренним устройством ASDF. Следует иметь в виду, что это не какое-либо подробное объяснение всех нюансов внутреннего устройства, но и не концептуальное его изложение, а лишь некий путеводитель для изучение исходного кода. В этом цикле будет рассматриваться последняя на момент написания цикла development версия, хотя практически вся информация будет долгое время актуальна и для последующих версий. Если вам нужно лишь общее представление об устройстве ASDF и рекомендации к использованию, а технические подробности внутреннего устройства вас мало интересуют, я рекомендую прочитать эти статьи:

    http://lisp-univ-etc.blogspot.com/2010/06/asdf-2.html
    http://lisp-univ-etc.blogspot.com/2010/07/asdf.html
    http://lisp-univ-etc.blogspot.com/2010/08/asdf.html

Также они рекомендуются, если вы только начинаете знакомиться с библиотекой ASDF. И конечно же не стоит забывать об официальном руководстве:

    http://common-lisp.net/project/asdf/asdf.html

Крайне рекомендуется подходить к изучения цикла статей с экспериментальной точки зрения:
    1. Узнать где у вас лежит исходник asdf.lisp (желательно чтобы он был такой же версии как будет указано в каждой из статей, на момент написания этих строк, это версия 2.018.3), хотя небольшие различия в минорной версии не должны усложнить понимание материала). Или скачать его, если ASDF не входит в штатную поставку с вашей лисп-системой.
    2. В процессе изучения статей, непосредственно анализировать место в исходном коде о котором идёт речь.
    3. Интенсивно использовать отладочные инструменты вашей лисп-системы и IDE - такие формы как (step ...), (trace ...), (break ...) и Slime debugger, в случае использования SLIME.

    Спасибо за внимание. Надеюсь этот цикл статей для кого-то будет интересен. А кому не понравится, воспринимайте это просто как "фан-арт":)

Продолжение: вторая статья цикла.

---------------------
Ссылки:

Домашняя страничка проекта:

    http://common-lisp.net/project/asdf/

Страничка посвященная ASDF на cliki'ах (там же можно найти ссылки на короткие "туториалы")

    http://www.cliki.net/asdf

Получить самую свежую, разрабатываемую git-версию можно выполнив:

    git clone git://common-lisp.net/projects/asdf/asdf.git

Также можно воспользоваться веб-интерфейсом к git-репозитарию:

    http://common-lisp.net/gitweb?p=projects/asdf/asdf.git

Узнать текущее состояние дел разработки проекта можно по ссылке:

    https://launchpad.net/asdf
------------------------------------------------
Common Lisp. Restas. Maxima. #3
Сразу же иллюстрации:


И на телефоне:


Вышло обновление проекта restmax, в рамках которого я пытаюсь создать web оболочку для программы maxima.

Репозитарий потолстел за счет встроенных зависимостей, в частности, за счет mathjax.

Проект уже сейчас можно протестировать по адресу http://asvil.dyndns.info:8081/index.html. Внимание доступность сервера зависит от того, включил ли я его:), поэтому он работает не всегда.

Пример простого TeX документа: https://github.com/filonenko-mikhail/restmax/raw/master/example/new.tex

Пожелания/ошибки и вообще критику можно писать в комментариях, а также по адресу https://github.com/filonenko-mikhail/restmax/issues.

Changelog

Встроенная maxima. Теперь maxima запускается внутри restmax на каждую сессию отдельным потоком. Поток живет 6 секунд после того, как вы закрыли страничку с repl-ом.
Отдельный поток maxima на LaTeX. Теперь для преобразования TeX документа запускается отдельный от repl-а поток maxima.
Скругленные углы у кнопок убраны.
Добавлено отображение графиков. Для этого предназначены функции семейства wx* (wxplot2d, wxplot3d, и т.д.), позаимствованные и модифицированные из wxMaxima. Отображение графиков также возможно и в документах TeX.

Известные ошибки

Сложные графики отображаются только после следующей команды. Надо поставить sleep.
maxima содержит глобальные переменные. Пока только две из них изолируются в потоке let-ом.
embedded maxima in TeX не содержит экранирования для символа }, надо поправить.
Команда quit(), приводит к зависанию hunchetoot client потока. Надо переопределить quit, добавив вывод специального маркера.

В будущем:

Сделать историю в repl.
Наладить справочную систему для maxima, TeX в виде wiki.
Возможно поменять название проекта, нынешнее излишне созвучно, да и вообще хочеться использовать красивое женское имя.
Решить проблему изоляции/безопасности сессий одним махом.
Кроссбраузерность, включающая гаджеты.
Common Lisp tips.
Напоминаю, что Зак Бин открыл ресурс для хранения советов для common lisp.

15.10.11 Updated

Вот переводы некоторых.

Поменять местами

Простой путь поменять местами значения двух символов, a и b, выглядит так:

;; BOGUS
(setf temp a)
(setf a b)
(setf b temp)

psetf (параллельный setf) может сделать это за одну форму:

(psetf a b b a)

Но самая лучшая функция для этого rotatef:

(rotatef a b)

Перенаправить вывод

Есть функция, которая что-то выводит, но вы хотите, чтобы она выводила в другое место? Вы можете связать специальный символ *standard-output* в любых макросах, которые создают временные потоки.

Например, для перенаправления вывода в строку:

* (with-output-to-string (*standard-output*) 
(print-marketing-report))
"Source,Hits
twitter,243
google,805
direct,47
"

Для перенаправления в файл:

* (with-open-file (*standard-output* #p"file.txt" :direction :output)
(print-marketing-report))
NIL

Чтение чисел с плавающей точкой

Когда reader встречает число наподобие "3.0" без маркера экспоненты, он по умолчанию конвертирует его в single-float. Вы можете изменить тип используемый в конвертации связав символ *read-default-float-format* с другим типом числа с плавающей точкой.

Например:

* (/ 22.0 7.0)
3.142857

* (setf *read-default-float-format* 'double-float)
DOUBLE-FLOAT

* (/ 22.0 7.0)
3.142857142857143

При выводе также опускается маркер экспоненты, если тип выводимого числа совпадает с типом из *read-default-float-format*.

"Прикосновение" к файлу

* Прикосновение к файлу - действие, которое меняет дату модификации файла, если он существовал, иначе сздают файл.

Для создания пустого файла, как, например делает Unix команда touch, , вы можете использовать следующий код:

;; BOGUS
(close (open "foo.txt" :direction :output
:if-does-not-exist :create
:if-exists :append))

open принимает для аргумент :direction специальное значения для "прикосновения":

(open "foo.txt" :direction :probe :if-does-not-exist :create)

Если "foo.txt" не существует, он будет создан. Поток возвращается уже закрытым. Документация говорит следующее:

"[:probe] создание "no-directional" файлового потока; файловый поток создается и закрывается перед тем, как возвращается в качестве результата."

Многострочная строка форматирования

Вы можете разбить длинную стоку форматирования с помощью тильды ~ в концетильды ~ в конце каждой подстроки каждой подстроки. Например:

* (format t "It was the best of times, ~
it was the worst of times.")
It was the best of times, it was the worst of times.

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

"двоеточие" и "собака" модификаторы имеют дополнительный смысл:

При двоеточии, перевод строки игнорируется, но все пробелы на следующей подстроке не удаляются. При собаке перевод строки сохраняется, а все пробелы в начале подстроки игнорируются.

Преобразование символов в числа

Если у вас есть символ #\7 и вы хотите получить число 7, вы можете использовать форму (parse-integer (string char)) или ASCII-ориентированный алгоритм.

(- (char-int char) (char-int #\0))

В то время, как первый вариант будет давать правильный ответ всегда, второй вариант зависит от реализации. Спецификация описывает порядок символов в таблице, однако не дает никаких гарантий относительно возвращаемых значений функций char-int и char-code.

Все равно хотите их использовать? digit-char-p не только возвращает "истину", если первый аргумент является цифрой, но возвращает данную цифру для переданного символа.

* (digit-char-p #\7)
7

Это также работает с другими системами счислений:

* (digit-char-p #\a 16)
10

Если символ не является цифрой, digit-char-p возвращает nil.

:start и :end параметры для parse-integer

parse-integer принимает :start и :end аргументы, теперь вам не нужно вытаскивать подстроки из строки для передачи в функцию parse-integer. Например, для разбора такой строки, как "2011-10-01" в числа год, месяц и день, вы можете сделать так:

(defun parse-date (string)
"Parse a date string in the form YYYY-MM-DD and return the
year, month, and day as multiple values."
(values (parse-integer string :start 0 :end 4)
(parse-integer string :start 5 :end 7)
(parse-integer string :start 8 :end 10)))

Сравнение нескольких объектов

Функции сравнения чисел =, /=, <, <=, >, >= могут принимает больше чем два аргумента. Теперь проверить, например, что числа составляют возврастающую последовательность, просто:

(< a b c d)
Для небольших списков чисел, используйте следующий алгоритм:
(apply #'< list)
Функции сравнения не чисел в основном принимают только два аргумента для сравнения, например, (string= x y z) неправильная форма, и для списка из трех и более объектов вы не можете применить данную функцию.Однако, вы можете сравнить попарно все элементы списка с помощью every. Например, для проверки все ли строки в списке эквивалентны с помощью string=.
(every #'string= list (rest list))
Следует отметить, что /= особенна; следующие вызовы не эквивалентны:
* (apply #'/= list)
T
* (every #'/= list (rest list))
T
Почему?Управление ходом исполненияУ макроса "do" (do, do*, dolist, dotimes) тело, которое ведет себя как tagbody. Вы можете поместить got tags где угодно в теле и использовать go для перехода в отмеченные места. Это может быть полезно для пропусков, повторов или других изменений выполнения итерации.Например:
(dolist (users (get-user-list)) 
:retry
...
(when some-condition
(go :retry)
...)
Common Lisp. Esrap.
Передо мной встала задача анализировать результат выполнения команд maxima (с включенным режимом imaxima). Сначала я выполнял это с помощью cl-ppcre, но регулярные выражения, будучи, несомненно, удобными, сложно расширяются.

Итак вот задача:

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

Пример:

1+1;
2+5/0;
wxplot2d(sin(x),[x,0,2]);
sin(x);
12345$
"some string";

Здесь присутствуют выводы числа, исключения, графика, символа, числа *заглушено*, строки.

Вот как будет выглядеть вывод программы maxima с загруженным пакетом imaxima.lisp.

^B^W\%o2^W2^E
^C(%i3) ^D
expt: undefined: 0 to a negative exponent.
-- an error. To debug this try: debugmode(true);
^C(%i4) ^D
^B^W\%t4^W^Gmaxout_1.png^G^E
^B^W\%o4^W^E
^C(%i5) ^D
^B^W\%o5^W\sin x^E
^C(%i6) ^D
^C(%i7) ^D
^B^W\%o7^W\verb|some string|^E
^C(%i8) ^D

Буквы с предшевствующим символом '^' являются управляющими символами.
Эти управляющие символы являются маркерами того, какой смысл имеет строка между ними.

Простая строка вывода результата выглядит как:

^B^W\%o2^W2^E

Маркеры ^B и ^E обозначают, что строка является результатом команды.
Маркеры ^W отделяют подпись текущего вывода и по совместительству название символы связанного с данным выводом.

^C(%i3) ^D

Маркеры ^C и ^D обозначают подпись приглашения к вводу команды. Данная подпись также является символом, который будет связан с введенной командой.

^B^W\%t4^W^Gmaxout_1.png^G^E

Маркеры ^B и ^E нам уже знакомы, только подпись имеет формат %t. Переменная %t будет связана с именем файла.

expt: undefined: 0 to a negative exponent.
-- an error. To debug this try: debugmode(true);

Исключение представлено просто текстом, без каких-либо маркеров.

Вывод разделяется переводом строк.

Сначала я наладил было парсинг на PEG.js на клиентской стороне, но вовремя опомнился и портировал правила на esrap. Esrap небольшая библиотека для построения парсеров. Ее использовал archimag в своем проекте cl-closure-templates, и отзывался о ней довольно положительно.

Начнем. Основная функция, которая будет нами использоваться defrule. Данная функция принимает первым аргументом правило, по которому производить разбор текста, и в другом параметре она принимает функцию, которая будет структурировать разобранные выражения. Правила напоминают простые регулярные выражения. Построение правил - нетрудное дело, если правильно думать.

Правила

Вот первая мысль для первого правила.

"У нас есть неограниченный список выражений".

Так и запишем.

(defrule expressions (* expression)
(:lambda (list)
list))

Правило (* expression) означает в expressions expression может встречаться 0 и более раз.

Форма :lambda задает функцию, которая будет иметь аргумент - список разобранных expression. Мы просто вернем этот список.

Вторая мысль:

"Перед выражением может быть пустое место, а затем либо строка вывода, либо приглашение ввода, либо просто текст(исключение)".

Вот соответственно правило:

(defrule expression (and (? whitespace) (or out in simpletext))
(:destructure (w exp)
(declare (ignore w))
exp))

(and subexpression1 subexpression1 ... subexpressionN) означает совпадение последовательно расположенных выражений.

(? whitespace) означает, что выражение может встречаться 0 или 1 раз. При 0 будет возвращен nil.

(or subexpression1 subexpression1 ... subexpressionN) означает, что на данной позиции может встречаться одно из N выражений.

Здесь мы используем форму :destructure для того, чтобы "перенаправить" результат разбора в аргументы функции. Аргумент w будет результатом (? whitespace), и exp - (or out in simpletext). Игнорируем пробелы и возвращаем результат разбора выражения.

Следующая мысль:

"Пустое место - это 1 или несколько пробельных символов (#\space #\tab #\newline)"

(defrule whitespace (+ (or #\space #\tab #\newline))
(:constant nil))

(+ subexpression) означает, что выражение встречает 1 и более раз.

Здесь мы не задаем функцию обработки, указывая какой результат для данного разбора всегда должен быть: (:constant nil).

Мысль:

"Строка вывода это маркеры ^B и ^E, а между ними выражение вывода, которое может содержать подпись, например, \%o2, строку имени файла, maxout_1.png, и текст."

Обозначим правила для маркеров:

(defrule startout #\Stx)

(defrule endout #\Enq)

Обозначим правило для строки вывода:

(defrule out (and startout (? outlbl)
(? outimg)
(* outtext) endout)
(:destructure (m1 outlbl outimg expr m2)
(declare (ignore m1 m2))
(list (cons :lbl outlbl) (cons :img outimg) (cons :expr (text expr)) (cons :tex t))))

Данным выражением

(list (cons :lbl outlbl) (cons :img outimg) (cons :expr (text expr)) (cons :tex t))))

мы создали alist содержащий структуру разбора вывода. Здесь функция text соединяет переданный ей список строк, в данном случае expr будет содержать список символов и они будут объединены в одну строку.

Далее определяем правила для outlbl, outimg, и outtext.

;; Возращаем символ, если он не является маркером конца вывода
(defrule outtext (and (! endout) character)
(:destructure (m1 ch)
(declare (ignore m1))
ch))

;; Определяем маркер для подписи
(defrule outlblbrace #\Etb
)

;; Возвращаем подпись, игнорируя маркеры
(defrule outlbl (and outlblbrace (* outlbltext) outlblbrace)
(:destructure (m1 expr m2)
(declare (ignore m1 m2))
(text expr)))

;; Возвращаем символ, если не является маркером конца подписи
(defrule outlbltext (and (! outlblbrace) character)
(:destructure (m1 ch)
(declare (ignore m1))
ch))

;; Определяем маркер для имени файла
(defrule outimgbrace #\Bel
)

;; Возвращаем имя файла, игнорируя маркеры
(defrule outimg (and outimgbrace (* outimgtext) outimgbrace)
(:destructure (m1 expr m2)
(declare (ignore m1 m2))
(text expr)))

;; Возвращаем символ, если он не является маркером конца имени файла
(defrule outimgtext (and (! outimgbrace) character)
(:destructure (m1 ch)
(declare (ignore m1))
ch))

Теперь по аналогии определим правила для строки приглашения ввода.

;; маркер начала
(defrule startin #\Etx
)

;; маркер конца
(defrule endin #\Eot
)

;; Записываем все что между маркерами
(defrule in (and startin (* intext) endin)
(:destructure (m1 expr m2)
(declare (ignore m1 m2))
(list (cons :expr (text expr)))))

;; Возвращаем символ, если он не является маркером конца
(defrule intext (and (! endin) character)
(:destructure (m1 ch)
(declare (ignore m1))
ch))

Если никакие выше правила не сработали значит перед нами просто текст вывода, это может быть текст исключения, или сессия работы maxima в lisp repl режиме.

;; Записываем текст
(defrule simpletext (+ simpletextcontent)
(:lambda (list)
(list (cons :expr (text list)))))

;; Возвращаем символ, если он не является каким-нибудь маркером начала
(defrule simpletextcontent (and (! (or startout startin)) character)
(:destructure (m1 ch)
(declare (ignore m1))
ch))

Парсинг


Создадим функцию, которая осуществит разбор текста и возврат список alist'ов с выделенными частями текста.

(defun parse-expression (text)
"Parsing imaxima output"
(parse 'expressions text))

Пример выполнения:

CL-USER> (imaxima-esrap:parse-expression "^B^W\%o7^W9^E
^C(%i8) ^D
^B^W\%o8^W9^E
^C(%i9) ^D
expt: undefined: 0 to a negative exponent.
-- an error. To debug this try: debugmode(true);
^C(%i10) ^D
^B\verb|asdfasdf|\verb| |^E
^B^W\%o10^W\verb|asdfasdf|^E
^C(%i11) ^D
expt: undefined: 0 to a negative exponent.
-- an error. To debug this try: debugmode(true);
^C(%i12) ^D
^B^W\%t12^W/home/michael/maxout_1.png^E
^B^W\%o12^W^E")
(((:LBL . "%o7") (:IMG) (:EXPR . "9") (:TEX . T)) ((:EXPR . "(%i8) "))
((:LBL . "%o8") (:IMG) (:EXPR . "9") (:TEX . T)) ((:EXPR . "(%i9) "))
((:EXPR . "expt: undefined: 0 to a negative exponent.
-- an error. To debug this try: debugmode(true);
"))
((:EXPR . "(%i10) "))
((:LBL) (:IMG) (:EXPR . "verb|asdfasdf|verb| |") (:TEX . T))
((:LBL . "%o10") (:IMG) (:EXPR . "verb|asdfasdf|") (:TEX . T))
((:EXPR . "(%i11) "))
((:EXPR . "expt: undefined: 0 to a negative exponent.
-- an error. To debug this try: debugmode(true);
"))
((:EXPR . "(%i12) "))
((:LBL . "%t12") (:IMG) (:EXPR . "/home/michael/maxout_1.png") (:TEX . T))
((:LBL . "%o12") (:IMG) (:EXPR . "") (:TEX . T)))
NIL
CL-USER>

alist я выбрал не случайно, после того как я разобрал вывод, я преобразовываю alist в json с помощью функции json:encode-json-to-string и отправляю клиентскому javascript'у.

А, вообще, так как в лиспе код является данными и наоборот, при разборе выражений можно возращать некоторый код, который затем выполнять, тем самым выполучаете интерпретатор (а на sbcl компилятороинтерпретатор) очень малой ценой. archimag в cl-closure-templates так вроде и делает, пойдя еще дальше и генерируя с помощью parenscript, на основе сгенерированного кода, код javascript . Для сравнения: разработчики Qt до сих пор не прикрутили свои классы к QtScript, то что предлагается qtscriptbindingsgenerator - это через гланды.
Почему я не люблю Python

Работая в компании, которая занимается разработкой на языке Python, сложно удерживать себя и не говорить о том, какой всё-таки неудобный и некрасивый инструмент приходится использовать ежедневно. Поэтому когда я говорю, что в Python всё плохо, то меня обычно спрашивают, а где всё хорошо? Отвечаю, что в Common Lisp (хотя так чтобы совсем всё хорошо, это конечно невозможно).

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

Рассмотрим код на питоне:

>>> with open("/tmp/workfile", "r") as f:
...     print f.readline()
...
test

И похожий код на лиспе:

CL-USER> (with-open-file (stream "/tmp/workfile" :direction :input)
           (print (read-line stream)))

"test"

Вышел аналогичный по красоте и изяществу код. При этом есть одно “НО” - это то, как внутри выглядит эта красота. Посмотрим что придётся делать на питоне, чтобы создать объект для with:

>>> class SomeContext(object):
...     def __enter__(self):
...         print "Entered context"
...     def __exit__(self, exception_type, exception_value,
...                  exception_traceback):
...         print "Leaving context"
... 
>>> with SomeContext():
...     print "Let's test with"
... 
Entered context
Let's test with
Leaving context

А теперь повторим тоже самое на лиспе:

CL-USER> (defmacro with-some-context (&body body)
           `(unwind-protect (let* ()
                             (print "Entered context")
                             ,@body)
             (print "Leaving context")))
CL-USER> (with-some-context (print "Let's test with"))

"Entered context"
"Let's test with"
"Leaving context"

Но не всякому with нужна обработка исключений, так что вариант на Common Lisp можно упростить до:

CL-USER> (defmacro with-some-context (&body body)
           `(progn
              (print "Entered context")
              ,@body
              (print "Leaving context")))
CL-USER> (with-some-context (print "Let's test with"))

"Entered context"
"Let's test with"
"Leaving context"

Лёгкое движение руки и понятность кода возросла. А в Python так и останутся эти 2 уродства: __enter__ и __exit__, плюс ещё параметры к __exit__. Это то, что называется “приколотить гвоздями”. Проблема в том, что куда не глянь, везде всё реализовано так.

realloc(3) в стиле common lisp
Одну из самых востребованных на рынке структур данных: "массив" можно получить в CL с помощью функции make-array. В принципе, зачастую этой информации достаточно для успешного и счастливого применения массивов в практике.

Но если копнуть немного поглубже, неожиданно выясняется, что, в зависимости от переданных параметров, make-array умеет возвращать различные структуры, которые только снаружи выглядят, как массивы. Существует два основных типа массивов: собственно массив и вектор. Различаются они тем, что размер первого изменить нельзя, а второго можно. Отличить их друг от друга можно достаточно просто -- по типу: название типа массива с константным размером начинается на simple-.

Здесь получился обычный массив:
CL-USER> (type-of (make-array 4))
(SIMPLE-VECTOR 4)

А здесь образовался вектор:
CL-USER> (type-of (make-array 4 :adjustable t))
(AND (VECTOR T 4) (NOT SIMPLE-ARRAY))

Кроме этого, можно иногда заметить, что, если в качестве типа элемента массива указать примитивный интегральный тип, то simple-vector'ы выраждается в simple-array, а то и в битовое поле:
CL-USER> (type-of (make-array 4 :element-type '(integer 0 128)))
(SIMPLE-ARRAY (UNSIGNED-BYTE 8) (4))
CL-USER> (type-of (make-array 4 :element-type 'fixnum))
(SIMPLE-ARRAY FIXNUM (4))
CL-USER> (type-of (make-array 4 :element-type 'bit))
(SIMPLE-BIT-VECTOR 4)

Эти simple-array'и, по-сути, являются аналогами обычных сишных массивов, поэтому интуитивно понятно, что работа с ними должна быть молниеносной. Оно так и есть, особенно при стратегии (optimize (speed 3)) -- на выходе получаем короткий ассемблерный листинг.

В целом, паттерн использования массивов примерно ясен:
  • По-возможности, указывайте и размер и интегральный тип элементам на создании массива.
  • Если тип все-таки нужен неинтегральный, хотя бы, постарайтесь определиться с размером массива. Даже если точное значение элементов определить нельзя -- не скупитесь, и выделите память по-максимуму, но сразу.
  • И только если максимальное значение размера взять неоткуда, либо оно теоретически крайне велико, пользуйтесь :adjustable и :fill-pointer

Это все, конечно, так, но есть нюанс :) На очень больших массивах разница в производительности вектора и интегрального массива получается просто чудовищной. И бывает так, что размер массива изначально неизвестен, а тормозной вектор использовать нет сил :) Я об такой пример разбился на прошлой неделе: в моем случае разница в скорости обработки (bit-vector *) против (simple-bit-vector *) на поле, размером в несколько десятков миллионов бит составила сутки против одной секунды!

Как же тогда поступить, если изначальный размер узнать ну никак нельзя, а большой массив нужно уметь наполнять и обрабатывать за вменяемое время? Я решил эту проблему имитацией realloc'а в CL:

(defpackage :realloc-test
  (:use :cl :iterate))

(in-package :realloc-test)

(defun realloc (array element-type new-size)
  (let ((new-array (make-array new-size :element-type element-type)))
    (replace new-array array)
    new-array))

Теперь для заполнения массива неизвестным количеством данных можно воспользоваться старой сишной практикой с реаллокацией, вместо использования вектора и vector-push-extend:

(defun read-stream-into-buffer (stream element-type element-reader)
  (iter (with buffer = (make-array 4 :element-type element-type))
        (with buffer-idx = 0)
        (for element in-stream stream using element-reader)
        (when (>= buffer-idx (length buffer))
          (setf buffer (realloc buffer element-type (* 2 buffer-idx))))
        (setf (elt buffer buffer-idx) element)
        (incf buffer-idx)
        (finally (return (realloc buffer element-type buffer-idx)))))

REALLOC-TEST> (with-input-from-string (s "Đây là con mèo của chúng tôi.")
                (read-stream-into-buffer s 'character #'read-char))
"Đây là con mèo của chúng tôi."
REALLOC-TEST> (type-of *)
(SIMPLE-ARRAY CHARACTER (29))

Как показывает практика, для очень больших массивов такая тактика позволяет достичь ускорения работы на несколько порядков. Особенно с использованием стратегии (optimize (speed 3)) -- производительность достигает сишной.
Тестдрайв Caveman'а

Предыдущий пост, посвящённый этой теме здесь.

Опишу в этом посте свою попытку взглянуть на Caveman поближе.

Первым делом:

CL-USER> (ql:quickload 'caveman)

Весьма странная зависимость, но что поделаешь.

CL-USER> (ql:quickload :clack-middleware-clsql)

Туториал даёт весьма ожидаемый совет для любителей скаффолдинга:

(caveman.skeleton:generate #p"lib/myapp/")

Который заканчивается тем не менее неожиданно:

The path #P"/lib/myapp//.gitignore" does not exist.
   [Condition of type SB-INT:SIMPLE-FILE-ERROR]

Restarts:
 0: [RETRY] Retry SLIME REPL evaluation request.
 1: [*ABORT] Return to SLIME's top level.
 2: [TERMINATE-THREAD] Terminate this thread (#)

Простим этот недостаток и быстро исправим его, как никак проект очень молодой:

CL-USER> (caveman.skeleton:generate
          #p"/home/dym/tmp/proga/caveman-test/lib/myapp/")
writing //home/dym/tmp/proga/caveman-test/lib/myapp//.gitignore
writing //home/dym/tmp/proga/caveman-test/lib/myapp//README.markdown
writing //home/dym/tmp/proga/caveman-test/lib/myapp//myapp-test.asd
writing //home/dym/tmp/proga/caveman-test/lib/myapp//myapp.asd
writing //home/dym/tmp/proga/caveman-test/lib/myapp/src//myapp.lisp
writing //home/dym/tmp/proga/caveman-test/lib/myapp/t//myapp.lisp
writing //home/dym/tmp/proga/caveman-test/lib/myapp/config//dev.lisp
writing //home/dym/tmp/proga/caveman-test/lib/myapp/lib/view//emb.lisp
writing //home/dym/tmp/proga/caveman-test/lib/myapp//myapp.asd
writing //home/dym/tmp/proga/caveman-test/lib/myapp/src//app.lisp
writing //home/dym/tmp/proga/caveman-test/lib/myapp/src//controller.lisp
writing //home/dym/tmp/proga/caveman-test/lib/myapp/src//myapp.lisp
writing //home/dym/tmp/proga/caveman-test/lib/myapp/static/css//main.css
writing //home/dym/tmp/proga/caveman-test/lib/myapp/t//myapp.lisp
writing //home/dym/tmp/proga/caveman-test/lib/myapp/tmpl//index.tmpl
T

Далее загружаем наш пакет:

CL-USER> (ql:quickload :myapp)
To load "myapp":
  Load 1 ASDF system:
    myapp
; Loading "myapp"
[package myapp]...................................
[package myapp.controller]
(:MYAPP)

Стартуем сервер:

CL-USER> (myapp:start)
Hunchentoot server is started.
Listening on localhost:5000.
# {B3132B1}

Ха, да он прям как Flask, запустился на 5000-ом порту :D

Немного поигравшись с Caveman’ом я пришёл к определённым выводам. Местами мои выводы очень субъективны, особенно если учесть, что данный фреймворк никак не тянет на микро, а замахнулся больше на славу RoR и Django.

Хорошее:

  • Конфигурация собрана в одном файле
  • Гибкая схема маршрутов (routes), позволяющая воплотить в жизнь любые REST идеи

Плохое (как известно, всегда легче найти недостатки, чем достоинства):

  • Жёсткая привязка к clsql
  • Желание авторов превратить Common Lisp в Python. Например, чего стоит cl-annot

Вообще, у проекта есть очень большой плюс: активные разработчики. Не проходит и недели, чтобы они не вносили изменений. Но с другой стороны, модель предложенная RESTAS как-то ближе, толи сказывается происхождение автора, толи просто в нём отсутствуют те 2 больших недостатка, что есть у Caveman. Ещё один плюс Caveman’а, который я не указал, это то, что он полностью может быть загружен с помощью quicklisp. RESTAS так не повезло, его код очень сильно зависит от новых возможностей hunchentoot, которые в stable release так и не были включены, ну и вобщем одно за другое и получается, что RESTAS нужно ставить (вместе с другими пакетами, которые ему нужны) из репозитория.

Caveman и Clack == Werkzeug и Flask в мире Common Lisp

Пример кода указанный ниже был скопирован с главной страницы Flask’а

@app.route("/")
def hello():
    return "Hello World!"

А нижеследующий пример взят со страницы Caveman’а, претендующего на роль микрофреймворка в мире Common Lisp

@url GET "/hi"
(defun say-hi (params)
  "Hello, World!")

Flask начинался как шуточный микрофреймворк, специально написанный к 1-му апреля, но на данный момент под это понятие он не подходит по ряду причин:

  • Код находится не в одном единственном файле
  • Встроенная поддержка jinja2
  • Количество обвесок продолжает увеличиваться

С Caveman’ом всё было не так. Изначально проект создавался с полной серьёзностью на какую только способны потомки самураев.

Под капотом у Flask’а скрывается Werkzeug, в документации которого легко можно найти следующий пример:

def application(environ, start_response):
    start_response('200 OK', [('Content-Type', 'text/plain')])
    return ['Hello World!']

В свою очередь Caveman использует Clack:

(clackup
  (lambda (env)
    '(200
      (:content-type "text/plain")
      ("Hello, Clack!"))))

Не перестаёт удивлять их внешняя схожесть. К счастью авторы этого и не скрывают, на сайте Clack’а чётко написано

Clack is a web application environment for Common Lisp inspired by Python’s WSGI and Ruby’s Rack

Да вобщем и Caveman на микрофреймворк не тянет, чего только стоит его зависимость от clsql

На этом пока и всё, надеюсь в ближайшее время более детально разобраться в том, что из себя представляют Caveman и Clack. Остаётся только надеятся на то, что внешняя схожесть с Flask’ом не отразилась пагубно на возможностях фреймворка.

Продолжение …

Впечатления от Clojure
Пришлось мне столкнуться по-службе с Clojure. Мои впечатления от знакомства:
  1. Первое, что бросается в глаза — это дурацкие [] и {} вместо расово верных (). Не скажу, что они упрощают чтение кода, ИМХО разница невелика. А вот написание усложняют (по крайней мере мне). Набирать закрывающие сущее мучение; вылазит вот такое ))}))]) безобразие и сиди считай скобки. Так недалеко и до JavaScript с его вечными });});});
  2. Зато, эти же самые [] и {} позволяют сделать конфиг с симпатичным синтаксисом почти-JSON.
    {
      :listen {
        :host "localhost"
        :port 8080
      }
      :db {
        :host "localhost"
        :port 5432
        :database "database"
        :user "root"
        :password "secret"
      }
    }
  3. Жутко неудобно писать императивный код. Мутабельность здесь не любят. Код, конечно, от этого становится чище, но времени на написание уходит чуть больше.
  4. Нет многострочных комментариев. Пришлось написать reader macro, добавляющий комментарии в стиле Common Lisp.
    (defn dispatch-reader-macro [ch fun]
      (let [dm (.get (doto
                       (.getDeclaredField clojure.lang.LispReader
                                          "dispatchMacros")
                       (.setAccessible true))
                     nil)]
        (aset dm (int ch) fun)))

    (defn read-comment [rdr pipe]
      (loop [s nil]
        (let [c (.read rdr)]
          (if-not (and s (= c (int \#)))
                  (recur (= c pipe))))))

    (dispatch-reader-macro \| read-comment)
    Единственное неудобство: нужно делать require во всех файлах, где эти комментарии используются.
  5. Очень понравился Leiningen. Собрать с его помощью jar-файл и запустить его на сервере оказалось очень просто. Сделано "для людей".
"Уже было в Симпсонах..."
Человек читает книжку про Коммон Лисп и делится впечатлениями о квалификаторах методов (:before, :around, :after). Забавно видеть в комментах реплику, что это можно сделать в йаве с помощью AspectJ, которую, между прочим, сварганил Грегор Кичалес, который написал книжку AMOP и принимал участие в стандартизации Коммон Лиспа.

В метафорическом переосмыслении:

- Я купил BMW 333i 86-го года. Обалдеть, там есть кондиционер!
- Ну и что такого? В Ладе "Калине" со следующего года тоже будет кондиционер!
Common Lisp. Embedded Maxima.
Оказалось все очень просто. Для того, чтобы встроить Maxim'у в свою программу достаточно скачать исходный код и действовать по инструкции INSTALL.lisp. В результате мы получим функцию cl-user::run, которую потом обернем в поток.

Пример команд для sbcl с установленным quicklisp.
$ git clone --depth 1 git://maxima.git.sourceforge.net/gitroot/maxima/maxima
$ cd maxima
$ sbcl

* (load "configure.lisp")
* (confiure)
;; При необходимости измените настройки по-умолчанию
* (quit)

$ cd src/
$ sbcl

* (load "maxima-build.lisp")
* (maxima-load)
* (cl-user::run)


Такая "хитрая" загрузка реализована с помощью данного проекта http://rpgoldman.real-time.com/lisp/defsystem.html, и видимо используется по историческим причинам. Описание пакета можно посмотреть в файле src/maxima.system

Теперь необходимо обернуть функцию cl-user::run в поток. Для этого будут использоваться bordeaux-threads. Однако, прежде чем это сделать, необходимо перенаправить потоки ввода и вывода. Просмотрев clhs, я не понял как это сделать. С какими объектами необходимо связать переменные *standard-input/output*? Попробовал string-input/output-stream и все они не давали нужную функциональность, кроме того необходимо было обеспечить потокобезопасность записи/чтения из общего буфера.
Поискав в форуме comp.lang.lisp я нашел небольшую зацепку, а точнее нашел половину реализации необходимого мне класса
http://groups.google.com/group/comp.lang.lisp/tree/browse_frm/thread/521f8553b003d916/f787c820ba323a71?rnum=1&q=redirect+*standard-input*&_done=%2Fgroup%2Fcomp.lang.lisp%2Fbrowse_frm%2Fthread%2F521f8553b003d916%3Ftvc%3D1%26q%3Dredirect%2B*standard-input*%26#doc_60988c96f64e10dd

Мне оставалось только сделать класс потока двунаправленным и обезопасить его мьютексами.

(defclass oi-buffer-stream (sb-gray:fundamental-character-input-stream sb-gray:fundamental-character-output-stream)
((buffer :initform nil :accessor buffer)
(lock :initform (bt:make-lock) :accessor lock)
(cond-var :initform (bt:make-condition-variable :name "inout") :accessor cond-var)))

(defmethod sb-gray:stream-write-char :before ((s oi-buffer-stream) character)
(declare (ignore character))
(bt:acquire-lock (lock s) T))

(defmethod sb-gray:stream-write-char ((s oi-buffer-stream) character)
(setf (buffer s) (concatenate 'string (buffer s) (list character)))
(bt:condition-notify (cond-var s)))

(defmethod sb-gray:stream-write-char :after ((s oi-buffer-stream) character)
(declare (ignore character))
(bt:release-lock (lock s)))

(defmethod sb-gray:stream-write-string :before ((s oi-buffer-stream) string &optional start end)
(declare (ignore start end))
(bt:acquire-lock (lock s) T))

(defmethod sb-gray:stream-write-string ((s oi-buffer-stream) string &optional (start 0) (end (length string)))
(setf (buffer s) (concatenate 'string (buffer s) (subseq string start end)))
(bt:condition-notify (cond-var s)))

(defmethod sb-gray:stream-write-string :after ((s oi-buffer-stream) string &optional start end)
(declare (ignore start end))
(bt:release-lock (lock s)))


(defmethod sb-gray:stream-read-char :before ((s oi-buffer-stream))
(bt:acquire-lock (lock s) T)
(unless (buffer s) (bt:condition-wait (cond-var s) (lock s))))

(defmethod sb-gray:stream-read-char ((s oi-buffer-stream))
(let* ((l (length (buffer s)))
(c (when (> l 0) (elt (buffer s) 0)))
(rest (when (> l 0) (subseq (buffer s) 1))))
(if c (progn
(if (= (length (buffer s)) 0) (setf (buffer s) nil)
(setf (buffer s) rest))
c)
(progn (setf (buffer s) nil) :eof))))

(defmethod sb-gray:stream-read-char :after ((s oi-buffer-stream))
(bt:release-lock (lock s)))

(defmethod sb-gray:stream-read-char-no-hang :before ((s oi-buffer-stream))
(bt:acquire-lock (lock s) T))

(defmethod sb-gray:stream-read-char-no-hang ((s oi-buffer-stream))
(let* ((l (length (buffer s)))
(c (when (> l 0) (elt (buffer s) 0)))
(rest (when (> l 0) (subseq (buffer s) 1))))
(if c (progn (setf (buffer s) rest)
(when (= (length (buffer s)) 0) (setf (buffer s) nil))
c)
(progn (setf (buffer s) nil) nil))))

(defmethod sb-gray:stream-read-char-no-hang :after ((s oi-buffer-stream))
(bt:release-lock (lock s)))

(defmethod sb-gray:stream-unread-char :before ((s oi-buffer-stream) c)
(bt:acquire-lock (lock s) T))

(defmethod sb-gray:stream-unread-char ((s oi-buffer-stream) c)
(let ((new (make-string (1+ (length (buffer s))))))
(setf (elt new 0) c)
(setf (subseq new 1) (buffer s))
(setf (buffer s) new)))

(defmethod sb-gray:stream-unread-char :after ((s oi-buffer-stream) c)
(bt:release-lock (lock s)))

(defmethod sb-gray:stream-read-line :before ((s oi-buffer-stream))
(bt:acquire-lock (lock s) T)
(unless (buffer s) (bt:condition-wait (cond-var s) (lock s))))

(defmethod sb-gray:stream-read-line ((s oi-buffer-stream))
(let ((what (buffer s)))
(setf (buffer s) nil)
(if what what
nil)))

(defmethod sb-gray:stream-read-line :after ((s oi-buffer-stream))
(bt:release-lock (lock s)))

Использовать его можно так:

(defvar in (make-instance 'oi-buffer-stream))
(defvar out (make-instance 'oi-buffer-stream))

(defun maxima-thread ()
(let ((*standard-input* in)
(*standard-output* out))
(cl-user::run)))

(defvar maxima-thread (bt:make-thread 'maxima-thread :name "maxima-thread"))

(read-line out)
(write-string "\"Привет мир\";" in)
(read-line out)


Вопрос: как избавиться от символа sb-gray, есть ли кросс-cl-машинный символ для gray-streams?

Заметки на полях
Вот чего в Кложуре хорошего есть, и чего нет в Коммон Лиспе - это интерфейс для создания последовательностей. Коммонлисповские elt, nth, aref, svref - это, по-сути, дупликация одной и той же функциональности: доступ к элементу последовательности.

В своём dsl мне удобно было бы расширить функциональность elt и setf elt, чтобы они работали с функциональным объектом или методом clos, но я не могу сделать это прямым способом, не прыгая с бубном вокруг эмуляции православного списка для штатного elt.

Ещё на деле сигнальный протокол вообще нигде не используется, плюс метаобъектный протокол используется только по той части, которая должна бы быть штатно в clos.
Common Lisp. Restas. Maxima. #2
Маленькая завлекушная картинка

В предыдущей заметке мы построили простое web приложение перенаправляющее ввод/вывод консольной программы MAXIMA. С тех пор прошло недели три, и сегодня я рад представить вам графическую web оболочку, с функцией редактирования TeX документов и встраивания в них исполняемых команд MAXIMA. А также система emacs-style клавиатурных сочетаний сделает вашу повседневную математическую работу гораздо приятнее и продуктивнее.



В программе MAXIMA ввод может быть двух видов:
  • слегка расширенный математический язык. Присутствуют присваивание (определение символа), условная конструкция, конструкция цикла.
  • или же s-выражения или по-другому программы на лиспе, использующие api maxima, для задания математических выражений.

Вывод представлен несколькими видами и может быть запрограммирован по своему.
  • по-умолчанию 2d - это такая печать символов, как если бы программа писала математические выражения на бумаге.
    • Пример:
    (%i1) x:12+i^2;
    2
    (%o1) i + 12
    (%i2)
  • в строку 1d - это печать в компьютерном формате (совпадает с тем как вы вводите выражения)
    • Пример:
    (%i4) display2d:false;

    (%o4) false
    (%i5) x:12+i^2;

    (%o5) i^2+12
    (%i6)
  • в TeX/LaTeX - это вывод в TeX/LaTeX формате. Используется большинством современных оболочек.
    • Файлы реализующие:
      • /usr/share/maxima/5.x.x/emacs/emaxima.lisp
      • /usr/share/maxima/5.x.x/emacs/imaxima.lisp
    • Пример:
      (%i6) tex(x:i^2+12);
      $$i^2+12$$
      (%o6) false
      (%i7)
  • в MathML - это вывод в специфицированной xml форме. Форм вобще две: одна для отображеня, а вторая для передачи смысла. wxMaxima использует свой "диалект" MathML. 
    • Файлы реализующие:
      • /usr/share/maxima/5.x.x/share/contrib/lurkmathml/mathml.lisp
      • /usr/share/maxima/5.x.x/share/contrib/maximaMathML/maximaMathML.lisp
    • Пример: 
      (%i1) load("/usr/share/maxima/5.24.0/share/contrib/lurkmathml/mathml.lisp");
      (%o1) /usr/share/maxima/5.24.0/share/contrib/lurkmathml/mathml.lisp
      (%i2) mathml(x:i^2+12);
      <math xmlns="http://www.w3.org/1998/Math/MathML"> <msup><mrow>
      <mi>i</mi> </mrow> <mn>2</mn> </msup> <mo>+</mo> <mn>12</mn> </math>(%o2) false
      (%i3)
Первым выбором стал формат MathML, как формат, который будет поддерживаться всеми браузерами "из коробки". Однако maximaMathML оказалось предоставляет два формата одновременно представления и содержания, и разделять их руками очень не хотелось. lurkmathml требует вызова дополнительной функции для вывода. Для рендеринга в браузере приходилось извращаться, хотя MathJax впоследствии решил проблему. Я решил себя не ограничивать и попробовать MathJax в связке с LaTeX выводом.

LaTeX вывод лучше всего представлен у imaxima. Данный пакет полностью перекрывает стандартный вывод, заменяя его на LaTeX. Кроме того вокруг вспомогательных меток (%i*, %o*) выставляются специальные символы, на которые можно ориентироваться при визуализации repl-a.

Я остановился на выводе предоставляемом imaxima.lisp.

Далее я подумал, что если красивый вывод сделать возможно, то недалеко и до редактирования документов с интерактивными вычислениями "вычисляемых" частей.

Некоторое время я провел в просмотрах существующих javascript html редакторов, но использовать их не хотелось, все требовали некоторой модификации под мои нужды. Кроме того многие из них по умолчанию копировали интерфейс MS офиса, что навевало тоску. Позже редактор я-таки нашел, и его автором оказался небезызвестный Марижн Хавербеке. Что за редактор и чем знаменит автор? Ответ на этот вопрос вы узнаете в конце статьи.

После продолжительного обдумывания, поисков и вновь обдумывания, я натолкнулся на косвенное мнение специалистов. В.А. Ильина, П.К. Силаев, "Система аналитический вычислений MAXIMA для физиков-теоретиков", цитаты:
"История взаимоотношений MAXIM'ы и Mathematic'и напоминают историю взаимоотношений UNIX и WinXXX."
"Так что конструировалась система [Mathematica], которая "умеет все", но делает это "все" не слишком хорошо ("чтобы хоть как-нибудь работало")."
"Опять-таки, при усовершенствовании системы [Mathematica] основное внимание уделялось оформлению, а не оптимизации работы."
"Под WinXXX (старайтесь не пользоваться WinXXX!) все совершенно аналогично."
"Любой человек набиравший настоящие формулы в TeX и в WinWord, знает насколько просто и быстро набирать команды TeX в любом текстовом редакторе и насколько мучительное занятие пользоватся "сервисом" с кнопочками в WinWord."
"При этом текст будет снабжен "боевой раскраской" - функции MAXIM'ы будут рисоваться одним цветом, переменные другим, комментарии - третьим.(6)...
(6) На взгляд авторов, это скорее недостаток, чем достоинство."
В emacs'e им даже не понравилась цветовая раскраска кода. Очень, кстати интересный вопрос: ориентируется ли программист на цвет текста при поиске необходимого кода?

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

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

Установка и запуск

Установите maxima, pdflatex:
$ sudo pacman -S texlive-bin texlive-core texlive-langcyrillic texlive-latexextra maxima sbcl
Скопируйте себе репозитарий. Загрузите quicklisp. Запустите common lisp. В данном случае sbcl. Установите некоторые зависимости.
$ git clone https://filonenko-mikhail@github.com/filonenko-mikhail/restmax.git /path/to/projects/restmax
$ cd /path/to/projects/restmax
$ curl -O http://beta.quicklisp.org/quicklisp.lisp
$ sbcl --load quicklisp.lisp
* (quicklisp-quickstart:install)
* (ql:add-to-init-file)
* (quit)
$ sbcl
* (push #p"/path/to/projects/restmax/" asdf:*central-registry*)
* (ql:quickload :restmax)
* (restas:start :restmax :port 8080)

Теперь откройте в браузере следующий адрес:
http://127.0.0.1:8080/index.html

Если не возникло проблем перед вам должна оказаться страница с кнопками переключения закладок TeX и MAXIMA.

Взаимодействие

На странице находится две закладки TeX и MAXIMA для отображения редактора TeX и MAXIMA repl'а соответственно.

На странице существует небольшая система клавиатурных сочетаний для некоторых функций. Система работает в стиле emacs/stumpwm и имеет префиксную клавишу, по-умолчанию Ctrl + c, и клавишу отмены текущей последовательности сочетаний, по-умолчанию Ctrl + g. Некоторые сочетания используются без префикса.

Для того, чтобы переключиться на вкладку MAXIMA, нажмите Ctrl+C, а затем Ctrl + Shift + m.
Для того, чтобы переключиться на вкладку TeX, нажмите Ctrl+C, а затем Ctrl + Shift + t.
Для просмотра справочника текущих клавиатурных сочетаний нажмите (без префикса) Ctrl + Shift + h.

Текущее клавиатурное сочетание отображается в левом нижнем углу.

TeX

На вкладке TeX на данный момент доступно несколько функций.
  • Открыть TeX документ [Ctrl+c Ctrl+f].
  • Сохранить TeX документ [Ctrl+c Ctrl+s].
  • Сгенерировать файл формате PDF из текущего TeX документа [Ctrl+c Ctrl+c].

Открытие документа TeX осуществляется выбором файле в крайнем левом поле и последующем нажатием кнопки Open.

Сохранение текущего документа осуществляется кнопкой Save.
Генерация PDF - кнопкой Render PDF.
Интуитивно понятно я думаю :)

Кроме того в TeX документе вы можете использовать команды Maxima окружив их тегом \maxima. Внимание: maxima не вставляет символы окружения $$, вы должны это сделать вручную.
Пример:
\maxima{eq:x+y}
После того как вы вставили тег \maxima, вы можете выделить содержимое тега и нажать сочетание Ctrl+c Ctrl+m. Даннная команда отправит выделенный текст в MAXIMA repl и выполнит его.

MAXIMA

Здесь все просто. Вводите команды maxima, нажимайте submit. Submit можно также выполнить из поля ввода команды сочетанием Ctrl+enter (без префикса).

MAXIMA repl использует imaxima.lisp для вывода и MathJax для визуализации выражений. Для того, чтобы просмотреть исходный код TeX выражения нажмите на него правой клавишей мыши и выберите пункт меню Show source. Об остальных функциях MathJax вы можете узнать здесь: http://www.mathjax.org/help/menu/

Пример

В папке /path/to/projects/restmax/example/ есть TeX документ со встроенными командами MAXIMA. Давайте его рассмотрим.
\documentclass{article}

\usepackage[utf8]{inputenc}
\usepackage[T2A]{fontenc}
\usepackage[russian]{babel}

\title{Тест-минимум}

\begin{document}
Решение квадратного уравнения.

Пусть имеется выражение:

$$ \maxima{exp:'(a*x^2+b*x+c)$exp = 0} $$

Необходимо вычислить дискриминант по формуле:

$$ \maxima{discriminant:b^2 - 4*a*c$D = discriminant} $$

\emph{Если дискриминант меньше нуля, решений нет}

\emph{Если дискриминант равен нулю, уравнение имеет один корень, вычисляемый по формуле:}

$$ \maxima{x[1,2] = -b/(2*a)} $$

\emph{Если дискриминант больше нуля, корни уравнения $ \maxima{'x[1]}, \, \maxima{'x[2]}$}:

$$ \maxima{x[1]:(-b+sqrt(D))/(2*a)$ 'x[1]=x[1]} $$
$$ \maxima{x[2]:(-b-sqrt(D))/(2*a)$ 'x[2]=x[2]} $$

Пример решения уравнения:

$$ \maxima{egvars:[a=1, b=3,c=-4]$example1:subst(egvars, exp)$example1=0} $$

Найдем дискриминант:

$$ \maxima{egdiscr:subst(egvars, discriminant)$D = egdiscr} $$

Так как дискриминант больше нуля, находим корни уравнения:

$$ \maxima{'x[1] = subst(append(egvars,[D = egdiscr]), x[1])} $$
$$ \maxima{'x[2] = subst(append(egvars,[D = egdiscr]), x[2])} $$

\end{document}
О структуре и командах TeX документа можно прочесть в книге "Не очень краткое введение в LaTeX 2ε", а мы рассмотрим только код MAXIMA.
\maxima{exp:'(a*x^2+b*x+c)$exp = 0}
Тег MAXIMA не является тегом TeX. Конструкция \maxima{} ограничивает команды, которые будут выполнены в MAXIMA. Вывод последней команды заменит данную конструкцию.

В дальнейшем мы будем рассматривать только команды. Итак первой строкой мы связываем выражение '(a*x^2+b*x+c) с символом exp. Для этого предназначен оператор связывания ":".  Одиночная кавычка используется, как и в лиспе, для запрещения вычисления подвыражения. Мы используем ее, так как в будущем символы a, b, c, x могут быть связаны со значениями и, если они будут вычислятся, мы не получим символьного выражения. Далее мы заглушаем вывод операции связывания символом "$". После чего просто создаем уравнение, левая часть которого представлена выражением exp, а правая нулем. И вывод данной команды будет вставлен в TeX документ. Вы можете это проверить выделив exp:'(a*x^2+b*x+c)$exp = 0 и нажав Ctrl+c Ctrl+m.
Оператор "=" создает уравнение, которое впоследствии может быть разрешено функциями solve, algsys или проверено на истинность функцией is.
discriminant:b^2 - 4*a*c$D = discriminant
Строка аналогичная предыдущей.
x[1,2] = -b/(2*a) 
Мы также можем создавать символы с индексами и использовать их в обычных выражениях.
x[1]:(-b+sqrt(D))/(2*a)$ 'x[1]=x[1]
x[2]:(-b-sqrt(D))/(2*a)$ 'x[2]=x[2]
В данном случае мы связываем символ x[1] с выражением (-b+sqrt(D))/(2*a). Заглушаем вывод. А затем выводим символ и его выражение.
egvars:[a=1, b=3,c=-4]$example1:subst(egvars, exp)$example1=0
Связываем символ egvars с массивом уравнений. Затем связываем символ example1 с результатом функции subst. Функция subst (substitute) осуществляет подстановку по принципу, все левые части уравнений перечисленных в списке в первом параметре будут заменены в выражении переданном во втором параметре на правые части этих уравнений. Например:
(%i1) subst (a, x+y, x + (x+y)^2 + y);
2
(%o1) y + x + a
(%i2) subst (-%i, %i, a + b*%i);
(%o2) a - %i b
egdiscr:subst(egvars, discriminant)$D = egdiscr
Так мы нашли дискриминант. Мы использовали символ egvars из предыдущей конструкции. Так можно и нужно делать, так как все конструкции выполняются в рамках одного процесса MAXIMA. Другое поведение обработчика тега maxima было бы нелогично и расточительно. Последние выражения, как вы уже заметили, служат для красивого вывода в результирующий TeX документ.
'x[1] = subst(append(egvars,[D = egdiscr]), x[1])
'x[2] = subst(append(egvars,[D = egdiscr]), x[2])
Здесь мы производим вычисления подобные вычислениям выше, кроме того, что список уравнений для подстановки формируется функцией append. Функция append принимает любое количество список и соединяет их в один.

В ближайщем будущем...

Исправить недочеты.

Реализовать:
  • поддержку графики
    • MAXIMA это вывод графиков
    • TeX вставка изображений из файлов
    • интеграция графиков и TeX документов
  • поддержка latex2html, возможно просмотр в окне браузера
    • ссылки на ресурсы содержащие документацию
      Стоит подумать над:
      • снимки вычислений для последующего использования, эдакий pastebin.
      • использование MAXIMA как внутренний, а не внешний процесс
      • справочная система по командам TeX, MAXIMA.
      • хранение файлов на сервере

      Зависимости проекта

      • core
        • maxima
        • pdflatex
      • web
        • jquery [embedded]
        • jquery.form [embedded]
        • MathJax [CDN]
        • CodeMirror [embedded]
      • common lisp
        • restas
        • restas-directory-publisher
        • bordeaux-threads
        • cl-ppcre

      Ответ на вопрос посередине: Марижн Хавербеке является автором библиотеки Postmodern для работы с Postgresql из Common Lisp и редактора кода CodeMirror, написанного на javascript. CodeMirror я использовал в странице для редактирования TeX документа.

      Напоследок несколько вопросов к публике:
      Может у кого-то есть желание предоставить sbcl хостинг для тестирования данного проекта?
      У кого есть время, в папке /path/to/projects/restmax/src/static/script/jquery.emacskeys.js лежит плагин для jQuery для emacs-style клавиатурных сочетаний, его нужно поиспользовать в своих проектах, чтобы отшлифовать.

      Как всегда очень рад услышать отзывы, критику.

      Lispworks vs SBCL
      В пятницу поспорил с начальником по поводу степени оптимизированности кода, выдаваемого лиспворксом. Я упирал на то, что SBCL выдаёт в 2-3 раза более короткий код и использует больше "продвинутых" машинных инструкций и приёмов.

      Перевёл глубоко оптимизированный исходник в вид, который SBCL съест, откомпилировал, запустил, и получил всего-то в полтора раза лучший результат. Немного пришлось попыхтеть, т.к. ошибки SBCL часто выдаёт в виде, совсем нетривиальном для понимания, а такого мощного дебаггера, как в LW, в нём нет. Поэтому чисто интуитивно нашёл, что ему не нравится.

      Задача, кстати, была: считать небольшой (100мб) pcap-файл, отфильтровать "плохие" фреймы и записать их в другой файл. Использовалась libpcap через лисповский plokami. Ещё раз подтвердился тезис, что не имеет смысла заниматься супероптимизацией кода, ограниченного медленным вводом-выводом, или работающего по сравнительно редким событиям.
      GTFL - A Graphical Terminal For Lisp

      GTFL представляет собой надстройку над веб-сервером HUNCHENTOOT и предоставляет механизм для отправки контента для клиента, которым является обычная html-страница и немного js-кода, с помощью HT-SIMPLE-AJAX.

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

      • отправить текст клиенту с помощью функции gtfl-out (с помощью разметки CL-WHO);
      • изменить или добавить содержимое элемента с указанным id на странице (replace-element-content/append-to-element). Клиент каждые 200мс обновляет содержимое страницы;
      • отправить сгенерированный html в стандартный вывод/строку или создать анонимную функцию, которая будет его возвращать (макросы: who, who2s, who-lambda);
      • создать элемент на странице с заданным id, который может свернут/развернут (make-expandable/collapsable-element);
      • создать ссылку, которая будет сворачивать/разворачивать элемент с указанным id (make-expand/collapse-link);
      • создать узел с дочерними элементами (draw-node-with-children).

      1.1 Установка

      Самый простой способ - установка с помощью quicklisp, о том как пользоваться им замечательно описано здесь.

      (ql:quickload "gtfl")
      
      

      1.2 Поддержка браузеров

      • Firefox (version > 3.0) on Mac, Windows, Linux and others
      • Safari (version > 3.0) on Mac and Windows
      • Chrome (version > 0.x) on Windows
      • Opera (version > 9.5) works as well, but the output of html-pprint looks very bad.

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

      (require 'gtfl)
      
      (in-package :gtfl)
      
      (start-gtfl)
      
      (defparameter *example-tree*
        '("top node."
          ("child node one with three children"
           ("first out of three children") ("second out of three children") ("third out of three children"))
          ("child node two with one child"
           ("very long text. very long text. very long text. very long text.
             very long text. very long text. very long text."))))
      
      (defun draw-node (string)
        (who
         (:div :style "padding:4px;border:1px solid #888;margin-top:4px;margin-bottom:4px;background-color:#eee;"
               (princ string))))
      
      (defun draw-tree (tree)
        (draw-node-with-children
         (who-lambda (draw-node (car tree)))
         (mapcar #'(lambda (x) (who-lambda (draw-tree x))) (cdr tree))))
      
      (defun draw-cell (obj)
        (cond
          ((null obj) (who-lambda (draw-node "nil")) (princ obj))
          ((atom obj) (who-lambda (draw-node obj)) (princ obj))
          ((consp obj) (draw-node-with-children (who-lambda (draw-node "cons"))
                                                            (list (who-lambda (draw-cell (car obj)))
                                                                  (who-lambda (draw-cell (cdr obj))))))))
      
      (gtfl-out (draw-tree *example-tree*))
      (gtfl-out (draw-cell '(symbol 2 another-one 4.5 "some string")))
      (gtfl-out (draw-cell (cons *example-tree* '(symbol 2 another-one 4.5 "some string"))))
      
      

      Теперь откроем http://localhost:8000/ и получим примерно следующее:

      Более сложные примеры использования можно посмотреть тут и тут, а монструозные схемы например тут.

      Common Lisp. GIS системы.

      PostGIS


      В продолжение темы о Postgresql. Я думаю многим известно, что в этой чудесной СУБД, помимо бумажек, кадров, прибылей и убылей, можно хранить геометрические данные. Для этого достаточно установить расширение PostGIS.

      Данное расширение предоставляет:

      • геометрические типы данных
      • функции для работы с ними
      • таблицы с метаданными
      • индексы

      Кроме того, PostGIS реализует интерфейс OpenGIS, что позволяет создавать приложения, не зависящие от реализации гео базы данных.

      Рассмотрим его слегка.

      PostGIS создает новый тип столбцов для Postgresql - geometry. Данный тип внутри себя может содержать следующие геометрические объекты:

      • POINT (точка)
      • LINESTRING (линия)
      • POLYGON (полигон)
      • MULTIPOINT (много точек)
      • MULTILINESTRING (много линий)
      • MULTIPOLYGON (много полигонов)
      • GEOMETRYCOLLECTION (много всего)
      Сами данные вышеназванных типов внутри Postgresql хранятся внутреннем бинарном формате, и мы нуждаемся в некоторых методах вставки и получения геометрических объектов в и из базы. В стандарте OpenGIS для этого предусмотрены два вида функций: для текстового и бинарного (не такого как внутри Postgresql) представления объектов.
      Текстовое представление служит для взаимодействия человека с машиной, бинарное, соответственно, участие человека не предполагает, а ориентируется на взаимодействие с другой программой. Названия данных представлений well-known text и well-known binary, (далее WKT и WKB).

      PostGIS функции 


      Ввод/вывод



      Для ввода/вывода используются следующие SQL функции (они, повторюсь, заявлены в OpenGIS стандарте):
      bytea WKB = ST_AsBinary(geometry);
      
      text WKT = ST_AsText(geometry);

      geometry = ST_GeomFromWKB(bytea WKB, SRID);
      geometry = ST_GeometryFromText(text WKT, SRID);

      Текстовое представление для типов объектов может выглядть, например, так:
      • POINT(0 0)
      • LINESTRING(0 0,1 1,1 2)
      • POLYGON( (0 0,4 0,4 4,0 4,0 0), (1 1, 2 1, 2 2, 1 2,1 1) )
      • MULTIPOINT(0 0,1 2)
      • MULTILINESTRING( (0 0,1 1,1 2), (2 3,3 2,5 4) )
      • MULTIPOLYGON( ( (0 0,4 0,4 4,0 4,0 0), (1 1,2 1,2 2,1 2,1 1) ), ( (-1 -1,-1 -2,-2 -2,-2 -1,-1 -1) ) )
      • GEOMETRYCOLLECTION(POINT(2 3), LINESTRING(2 3,3 4) )
      С бинарным представлением чуть позже мы будем работать с помощью библиотеки cl-ewkb.

      Кроме того PostGIS поддерживает текстовые вывод в таких форматах как:
      • GeoJSON
      • GML
      • KML
      • SVG
      • GeoHash

      Сравнения


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

      Операторы:

      && - Возвращает TRUE если ограничивающая рамка A пересекается c рамкой B.
      
      &< - Возвращает TRUE если ограничивающая рамка A пересекается или левее рамки B.
      &<| - Возвращает TRUE если ограничивающая рамка A пересекается или ниже рамки B.
      &> - Возвращает TRUE если ограничивающая рамка A пересекается или правее рамки B.
      << - Возвращает TRUE если ограничивающая рамка A строго слева от рамки B.
      <<| - Возвращает TRUE если ограничивающая рамка A строго ниже рамки B.
      = - Возвращает TRUE если ограничивающая рамка A совпадает с рамкой B.
      >> - Возвращает TRUE если ограничивающая рамка A строго правее рамки B.
      @ - Возвращает TRUE если ограничивающая рамка A содержится в рамке B.
      |&> - Возвращает TRUE если A's ограничивающая рамка пересекается или выше рамки B.
      |>> - Возвращает TRUE если A's ограничивающая рамка строго выше рамки B.
      ~ - Возвращает TRUE если ограничивающая рамка A содержит рамку B.
      ~= - Возвращает TRUE если A's ограничивающая рамка совпадает с рамкой B.

      Функции-аналоги можно посмотреть здесь, но они в рамках статьи не понядобятся:

      http://postgis.org/documentation/manual-1.5/reference.html#Spatial_Relationships_Measurements.



      Преобразования



      Функции можно посмотреть здесь: http://postgis.org/documentation/manual-1.5/reference.html#Geometry_Editors.

      Из них нам могло бы понадобиться две функции для перемещения и для масштабирования, но кто-то из программистов PostGIS подумал за нас и предоставил одну большую функцию:


      geometry ST_TransScale(geometry geomA, float deltaX, float deltaY, float XFactor, float YFactor);
      

      Переносит объект на deltaX по X, на deltaY по Y, и умножает(масштабирует) на XFactor значения абсциссы, на YFactor значения ординаты.


      Индексы



      Индексы служат интструментом ускорения поиска. В нашем случае используются GiST тип индексов. Данный тип индексов используется только для функций/операторов сравнения, которые используют ограничивающие рамки. Например, индекс будет использоваться для оператора &&, и не будет при вычислении отношения: длина LINESTRING > 1000.

      Данной информации нам пока достаточно.


      Развертывание


      Нужно было бы начать со скучной длительной истории о развертывании PostGIS'а, но мне повезло. Я натолкнулся на гостевой доступ к базе данных, которая, кроме вышеупомянутого расширения, еще и содержит географические данные стран бСССР. Данные предоставлены проектом OpenStreetMap (далее OSM). OSM некоторое время назад мигрировал с MySql на Postgres и, еще не успев применить PostGIS, хранит данные как есть (колонки latitude и longitude).
      Gis-lab'овцы импортируют часть данных из OSM с помощью программы osm2pgsql, которая и создает PostGIS объекты.
      Сначала расскажу про модель данных, используемую в OSM. Она очень простая.

      OpenStreetMap

      Ноды: Точки используемые для пометок определенных мест или для соединения сегментов.

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

      Закрытые пути (полигоны): закрытые пути - это закольцованная линия. Используется для отображения парков, озер, островов, зданий и т.д.
      Отношения: Когда различные пути соединены между собой, но не представляют один и тот же физический объект, используется отношение для описании функции каждого из пути. Они используются для описания таких вещей, как велодорожки, "turn restrictions" и участки с отверстиями.

      Изображение

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

      Подробнее: http://wiki.openstreetmap.org/wiki/Beginners_Guide_1.3.

      osm2pgsql

      Эскпортирование из OSM осуществляется в xml файл. Импортирование из данного файла в Postgresql/PostGIS базу данных выполняется программой osm2pgsql.
      Вот небольшое описание схемы импортирования.
      Взято здесь: http://wiki.openstreetmap.org/wiki/Osm2pgsql/schema.

      Нижеперечисленные таблицы содержат географические данные:
      • osm_line: содержит все импортированные пути.
      • osm_polygon: содержит все импортированные полигоны.
      • osm_point: содержит все импортированные ноды с тэгами.
      • osm_roads: содержит подмножество 'osm_line' предназначенное для низкого разрешения. Выборка производится в соответствии с тэгами (какими не известно).
      Каждая из таблиц имеет столбец way, который содержит геометрические данные. По два индекса созданы для каждой из таблиц: один на столбец osm_id и один на way. Координаты геометрических объектов в проекции EPSG:900913 AKA G00GlE.
      Примечание. На самом деле используется проекция указанная в столбце srid таблицы geometry_columns. В нашем случае это EPSG:4326. Просмотреть все возможные проекции можно в таблице spatial_ref_sys.

      Отношения напрямую не импортируются, а представляют собой несколько строк в таблице osm_line.

      Рисование


      Нам понадобится quicklisp, postmodern, cl-ewkb, и vecto. quicklisp скачайте и установите. Уже в slime разрешите зависимости.
      (mapcar #'ql:quickload '(:postmodern :cl-ewkb :vecto))
      

      Сервер баз данных запущен на gis-lab.info. Подключимся к нему:
      (in-package :postmodern) 
      
      (connect-toplevel "osm" "guest" "guest" "gis-lab.info")

      Можете просмотреть список таблиц:
      (list-tables)
      

      Их будет много, не обращайте внимания. Нам понадобяться лишь несколько из них. Метаданные о "геометрических" столбцах хранятся в таблице geometry_columns:
      (query (:select '* :from 'geometry_columns))
      

      Так неудобно, не видно названий столбцов. Давайте так:
      (query (:select '* :from 'geometry_columns) :plists)
      

      Предыдущий вариант также не удобен, давайте так.
      (defvar headers (mapcar (lambda (x) (car x)) (table-description 'geometry_columns)))
      
      (defvar rows (query (:select '* :from 'geometry_columns)))
      (format nil "~{ ~{ ~19< ~A ~> ~^|~} ~% ~}" (cons headers rows))

      Вот они таблицы:
      f_table_catalog f_table_schema f_table_name f_geometry_column coord_dimension srid type
      public all_bounds the_geom 2 4326 MULTIPOLYGON
      public osm_point way 2 4326 POINT
      public osm_line way 2 4326 LINESTRING
      public osm_polygon way 2 4326 GEOMETRY
      public osm_roads way 2 4326 LINESTRING
      Я хотел бы обратить внимание на проделанную Марижном работу. Пакет S-SQL позволяет записать SQL запрос в терминах и синтаксисе лиспа. Keyword'ы представляют собой ключевые слова SQL, символы транслируются в SQL идентификаторы, ключевые слова в начале списков - в вызовы функций или применения операторов. Подробности вы можете узнать в переводе руководства к данному пакету: ./libraries%3Apostmodern#%D0%A1%D0%BF%D1%80%D0%B0%D0%B2%D0%BE%D1%87%D0%BD%D0%BE%D0%B5%20%D1%80%D1%83%D0%BA%D0%BE%D0%B2%D0%BE%D0%B4%D1%81%D1%82%D0%B2%D0%BE%20S-SQL. Одним из плюсов S-SQL является тот факт, s-выражения получаются структурированными, в отличии от строкового SQL запроса. Это позволяет автоматически форматировать их, и облегчает визуальное "проигрывание" кода.

      Теперь давайте глянем на таблицу путей для большого масштаба поближе:
      (format nil "~:{ ~A ~% ~}" (table-description 'osm_roads))
      
      " osm_id
      note
      .....
      wood
      way
      "

      Под многоточием понимается список столбцов. Для каждого тега для объекта, представленного в таблице, заведен отдельный столбец. Логическое значение тега можно просмотреть по ссылке http://wiki.openstreetmap.org/wiki/Key:TAGNAME.
      Например, граница государства имеет тег boundary со значением равным *adminstrative*. При этом граница именно государства иммет административный уровень (тег admin_level) равный двум. А границы подчиненных государству административных територий могут иметь admin_level от 3 до 10.
      Как вы помните, индексы созданы только для столбцов *osm_id* и *way*. Засчет последнего индекса мы с легкостью может попросить данные, пересекающиеся с некоторым квадратом. Например, данные между 27 и 28 долготами и 54 и 55 широтами можно получить таким запросом.

      ;; SELECT way FROM osm_roads WHERE way && ST_GeometryFromText 'LINESTRING(27.0 54.0, 28.0 55.0)'
      
      (query (:select 'way :from 'osm_roads :where (:&& 'way (:ST_GeometryFromText "LINESTRING(27.0 54.0, 28.0 55.0)"))))

      Оператор пересечения && находит ограничивающие рамки левого и правого объектов и возвращает T, если рамки пересекаются. Мы могли бы использовать функцию ST_Intersects, но я хочу показать, как Postmodern S-SQL можно научить ранее неизвестным операторам. Сейчас он, понятное дело, не работает, так как модуль S-SQL ничего о нем не знает. Решение заключается в регистрации нового оператора:
      (register-sql-operators :2+-ary :&&)
      

      Вторым аргументом мы указали "арность" оператора, в данном случае оператор имеет смысл только при двух аргументах. Так как postmodern не имеет символа строгой 2-арности, используем "2 и более арность".

      Мы использовали LINESTRING, который представляет диагональ квадрата, которым мы и охватываем необходимые данные.
      Но не торопитесь, то, что мы получили - это просто внутреннее представление геометрического типа PostGIS. OpenGIS стандарт предполагает, что если мы хотим получить текстовый формат, мы должны преобразовать данные функцией ST_AsText. Но опять не торопитесь, у нас нет парсера текстового представления, есть только парсер бинарного в пакете cl-ewkb. Поэтому мы должны преобразовать результат SQL функцией ST_AsBinary, а затем уже в lisp-е полученный список отобразить распарсив well-known binary данные.

      Теперь вопрос касаемый рисования. Данные мы получим в квадрате (27.0 54.0, 28.0 55.0). Но библиотека vecto позволяет рисовать объекты, координаты которых целые числа. Для этого мы можем на SQL стороне масштабировать изображение. Я предлагаю увеличить в 1000 раз, соответственно в будущем размер холста у нас будет также 1000x1000, а также предлагаю сместить полученные объекты на начало координат. Все это производится функцией ST_TransScale:
      (defvar objects
      
      (mapcar (lambda (x)
      (list (car x)
      (cl-ewkb:decode (cadr x))))
      (query (:select 'name
      (:ST_AsBinary
      (:ST_TransScale 'way -27.0 -54.0 1000 1000))
      :from 'osm_roads
      :where (:&& 'way
      (:ST_GeometryFromText "LINESTRING(27.0 54.0, 28.0 55.0)"))))))
      SQL уровень

      • выбираем объекты, геометрия которых пересекаеться с квадратом bottom-left = 27.0 54.0 top-right = 28.0 55.0
      • перемещаем вектором (-27.0 -54.0)
      • увеличиваем вектором (1000 1000)
      • отображаем объекты в well-known binary.
      LISP уровень

      • отображаем объекты из well-known binary в lisp струкутры.
      Мы получаем столбец бинарных данных, пропускаем его через функцию декодирования cl-ewkb:decode и получаем вектор структур, которые нам надо отрисовать.
      Итак, у нас есть массив структур cl-ewkb:line-string, каждая из которых в свою очередь содержит массив структур cl-ewkb:point-primitive. Последняя содержит в себе координаты.

      Сначала я хотел рисовать с помощью библиотеки cl-svg и даже начал переводить руководство. Данная библиотека позволяет создавать векторную графику в формате SVG. Данный формат - это обычный xml, и библиотека по сути генерирует текстовый файл. Но когда я столкнулся с необходимостью переноса/поворота системы координат для географического представления, энтузиазм резко пропал.

      Тогда я обратился к библиотеке vecto. Что интересно, это pure-lisp решение включая зависимости, и у нас будет шанс оценить прикладную скорость реализации common lisp'а. Ну ее я собственно быстренько перевел, качество средненькое получилось. Данная библиотека позволяет рисовать из нижнего левого угла, умеет рисовать текст, ну и этого нам пока хватит.
      Повторюсь, с символом objects у нас связан вектор геометирческих объектов и их подписей. Попробуем их отрисовать.

      Экспортируем символ objects из postmodern, перейдем в пакет vecto, определим холст с помощью макроса with-canvas:
      (export 'objects)
      
      (in-package :vecto)
      (defvar objects postmodern:objects)
      (with-canvas (:width 1000 :height 1000)
      ....
      )

      Загрузим шрифт:

      ....
      
      (let ((font (get-font "/usr/share/fonts/TTF/times.ttf")))
      ....
      Установим некоторые параметры рисования (цвет, ширину линии, размер шрифта):

      ....
      
      (set-rgb-stroke 1 0 0)
      (set-line-width 1)
      (set-font font 14)
      ....

      Произведем итерацию по объектам полученным из базы данных:

      ....
      
      (map 'vector (lambda (object)
      ....
      objects)
      ....

      В анонимной функции нам необходимо создать новый контур, в месте его создания нарисуем подпись:
      ....
      
      (map 'vector (lambda (object)
      ....
      objects)
      ....

      Функция postmodern:coalesce возвращает первый не-:NULL (именно keyword) аргумент. Если аргумент не найден она возвращает NULL.

      В этой же анонимной функции рисуем все линию. Напомню, что в SQL запросе мы переместили и смасштабировали координты объектов, сейчас нам необходимо просто их округлить:

      ....
      
      (map 'vector (lambda (point)
      (line-to
      (round (cl-ewkb:point-primitive-x point))
      (round (cl-ewkb:point-primitive-y point))))
      (cl-ewkb:line-string-points-primitive (cadr object)))
      ....

      В ней же фиксируем результаты:

      ....
      
      (stroke))
      ....
      Теперь сохраняем результат в png файл:

      ....
      
      (save-png "test.png")))

      Весь блок кода ответсвенный за отрисовку:
      (export 'objects)
      
      (in-package :vecto)
      (defvar objects postmodern:objects)
      (with-canvas (:width 1000 :height 1000)
      (let ((font (get-font "/usr/share/fonts/TTF/times.ttf")))
      (set-rgb-stroke 1 0 0)
      (set-line-width 1)
      (set-font font 16)
      (map 'vector (lambda (object)
      (let ((point (elt (cl-ewkb:line-string-points-primitive (cadr object)) 0)))
      (move-to
      (round (cl-ewkb:point-primitive-x point))
      (round (cl-ewkb:point-primitive-y point)))
      (when (postmodern:coalesce (car object))
      (draw-string
      (round (cl-ewkb:point-primitive-x point))
      (round (cl-ewkb:point-primitive-y point)) (car object)))
      )
      (map 'vector (lambda (point)
      (line-to
      (round (cl-ewkb:point-primitive-x point))
      (round (cl-ewkb:point-primitive-y point))))
      (cl-ewkb:line-string-points-primitive (cadr object)))
      (stroke))
      objects)
      (save-png "test.png")))

      Заключение

      Отмечу нереализованные задачи:
      • Запрос только определенных гео объектов для разного масштаба.
      • Запрос атрибутов объектов для стиля отрисовки.
      • Атрибуты также влияют на z-order.
      • Отрисовка масштабной линейки/сетки.
      • Стилизованная отрисовка подписей к объектам.
      То что получилось, конечно, представляет собой простой GIS helloworld, но несмотря на такой большой список задач, мне кажется, то, что есть - довольно неплохой результат: возможность нарисовать карту любой точки земли за 50 строчек кода:)

      Пожелания, критика приветствуются.
      Синхронизация записи в файл между процессами в SBCL/Linux
         Кто бы там что ни говорил, а программирование под Unix не может не радовать своей простотой. Когда я писал программы под Windows взаимодействие с ОСью было куда менее простым и прозрачным. А если сюда ещё добавить мощь языка Common Lisp, а также хорошую лисп-систему (например SBCL), то разработка поднимается на принципиально другой уровень по сравнению с традиционным программированием на Си. Ниже представлена ф-ия безопасной записи в файл. Безопасной в том смысле, что если несколько процессов используют её для записи в один и тот же файл, то возможность коллизии (т.е. порчи записываемых одновременно данных) абсолютно исключена.

      (defparameter *safe-write-sleep* 0.01)
      (defun safe-write (pathname string &aux stream)
        (setf stream (open pathname :direction :output :if-does-not-exist :create :if-exists :append))
        (unwind-protect
             (loop
                until (block try-lock
                        (handler-bind ((error (lambda (condition)
                                                (if (= sb-posix:eagain
                                                       (sb-posix:syscall-errno condition)
      )

                                                    (return-from try-lock)
                                                    (error condition)
      )
      )
      )
      )

                          (sb-posix:lockf stream sb-posix:f-tlock 0)
                          (princ string stream)
                          (close stream)
      )
      )

                          
                do (sleep *safe-write-sleep*)
      )

          (close stream)
      )
      )
      Common Lisp. Postmodern.
      Я решил, что публиковать переводы или статьи в блоге это не опенсорс, потому как у других возможность повлиять на статью реализуется через комментарии, которые в блогспоте, мягко говоря, немощны. А раз архимаг предоставил нам, хоть и экспериментальную, но возможность заполнять вики на сайте lisper.ru, то надо ею воспользоваться. Она, кстати говоря, тоже не очень-то функциональна. Но мне например сложно работать в окружении свистелкоперделок, чем меньше возможностей предоставлено, тем меньше приходится задумываться о выборе, и основная деятельность направляется на содержание.

      Встречайте! Перевод документации двух частей библиотеки Postmodern.
      http://lisper.ru/wiki/libraries:postmodern

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

      Перевод ОРМ-а хромает, но мне ОРМ все равно не нравиться.

      Документацию по низкоуровневому слою CL-postgres я не переводил, так как, думаю, желающие ею воспользоваться будут знать английский язык.

      Ну и как всегда: критика и пожелания приветствуются всячески.

      P.S. Кстати говоря редактор сообщений blogspot немощен не менее. Он и недовысивиг и блокнот из него никакой.

      UPD. Не удержался и быстренько перевел external-program.
      http://lisper.ru/wiki/libraries:external-program
      Пакет cl-event-callback
             Оформил код в виде пакета. Но пока есть минус - так как использую потоки sbcl, то он работает только под ним, поэтому собираюсь перевести с sbcl-threads на bordeaux-threads.  Ссылка на проект: github.
      @2009-2010 lisper.ru