30 декабря 2011

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

28 декабря 2011

Формула успеха

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

(количество программистов * сроки создания) / Количество условных речевых оборотов

Сейчас поясню. Начинаете проект. У вас есть ТЗ, ну или заметки. Затем в процессе работы у заказчика появляются поправки. Вы в процессе всего происходящего должны посчитать сколько раз заказчик произносит слова: "если, в случае, при условии, и т.п.". Так вот, делите имеющиеся человекочасы на количество условных союзов и получаете некоторую величину, пусть "предполагаемое качество проекта". Увеличиваются часы или количество программистов - увеличивается качество. Увеличивается количество условных оборотов - качество падает.

Конечно модель весьма упрощенная.

Почему Пол Грэм продал свой бизнес? Рассказываю: у него была площадка для магазинов, "держал рынок", так сказать. Продавцы и покупатели требовали много всяких вкусняшек. Вкусняшки не менее других требований содержат условные обороты. Пол понял, что американцы начинают садиться на голову, а его даже коммон лисп не спасет, и продал бизнес Яху. А у Яху армия рабов, которая, что хочешь, то и сделает. Правда, тут бамс, и коммон лисп. Тогда сказали яху менеджеры: "Не потянем столько плюшек на cl, давайте переписывать". Как будто на другом языке у них получится реализовать столько "если", сколько нужно американскому потребителю.

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

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

26 декабря 2011

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

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

За плечами:

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

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

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

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

filonenko.mikhail at gmail com

23 декабря 2011

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();

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

20 декабря 2011

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"))

12 декабря 2011

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

06 декабря 2011

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 сейчас не содержит дат и размеров файлов.

04 декабря 2011

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"))

03 декабря 2011

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.

01 декабря 2011

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?

29 ноября 2011

Зборшчык смецця для C і C ++

Для белоруских пользователей boehm, библиотеки сборщика мусора для c/c++.

http://webhostingrating.com/libs/garbage-collector-gc-be

Оригинал:

http://www.hpl.hp.com/personal/Hans_Boehm/gc/


20 ноября 2011

Common Lisp. Демонизация.

А, собственно, опишу-ка я шаги для демонизации моего небольшого проекта restmax. Это вебоболочка для программы maxima, которая использует restas в качестве основы, и я подумал, что было бы неплохо, если она будет запускаться при старте компьютера сама по себе.
Для создания демона есть несколько путей, отсылаю для ознакомления к:
http://archimag.lisper.ru/tags/linux
http://lisper.ru/forum/thread/504

Воспользуемся наработками от архимага.

Все тривиально просто, понадобяться вам три файла, скрипт запуска sbcl, скрипт демонизации на лиспе специально для sbcl, скрипт настройки для загрузки лисп библиотек и запускаемого сайта.
  • /etc/rc.d/restas
  • /etc/restas/restas-daemon.lisp
  • /etc/restas/restas.daemon
Скрипт запуска необходимо добавить в /etc/rc.conf в парметр DAEMONS.

При этом скомпилированные файлы после запуска будут находится в /var/cache/restas/fasl, а pid запущенного процесса в /var/run/restas/restas.pid .

Для того, чтобы протестировать запуск приложения в качестве демона достаточно передать параметр nodaemon.

sudo /etc/rc.d/restas nodeamon

Скрипт для системы инициализации rc.d для арчика.

restas

#!/bin/sh

### BEGIN INIT INFO
# Provides:          restmaxdaemon
# Required-Start:    
# Required-Stop:     
# Default-Start:     2 3 4 5
# Default-Stop:      0 1 6
# Short-Description: Start restmax server at boot time
### END INIT INFO

. /etc/rc.conf
. /etc/rc.d/functions

DAEMON=sbcl
ARGS="--dynamic-space-size 400 --noinform --no-userinit --no-sysinit --load /etc/restas/restas-daemon.lisp /etc/restas/restas.daemon"

start () {
    stat_busy "Starting restas server"
    
    export LC_ALL="ru_RU.UTF-8"
    
    $DAEMON $ARGS start
    
    [ $? -eq 0 ] && stat_done || stat_fail
}

nodaemon () {
    $DAEMON $ARGS nodaemon
}

stop () {
    stat_busy "Stopping restas server"
    $DAEMON $ARGS kill
    
    [ $? -eq 0 ] && stat_done || stat_fail
}

restart () {
    stat_busy "Restart restas server"
    $DAEMON $ARGS restart
    
    [ $? -eq 0 ] && stat_done || stat_fail
}

help () {
    echo "usage: $0 "
}

case "$1" in
    start) start ;;
    stop) stop ;;
    nodaemon) nodaemon ;;
    restart) restart ;;
    *) help ;;
esac

Скрипт загружает sbcl, указывая скрипт /etc/restas/restas-daemon.lisp для выполнения и передавая файл с настройками.

Теперь в папке /etc/restas необходимо разместить два файла restas-daemon.lisp и restas.daemon

restas-daemon.lisp я брал здесь. Я его модифицировал слегка, так как разработчики asdf сделали какую-то систему управления сохранением скомпилированных файлов, с которой разбиратся было лень.
Controlling-where-ASDF-saves-compiled-files

restas-daemon.lisp

;;;; restas-daemon.lisp
;;;;
;;;; Usage:
;;;; sbcl --noinform --no-userinit --no-sysinit --load /path/to/restas-daemon.lisp /path/to/daemon.conf COMMAND
;;;; where COMMAND one of: start stop zap kill restart nodaemon
;;;;
;;;; If successful, the exit code is 0, otherwise 1
;;;;
;;;; Error messages look in /var/log/messages (usually, depend on syslog configuration)
;;;;
;;;; This file is part of the RESTAS library, released under Lisp-LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Author: Moskvitin Andrey 

(defpackage #:sbcl.daemon
  (:use #:cl #:sb-alien #:sb-ext))

(in-package #:sbcl.daemon)

(defvar *daemon-config-pathname* (second *posix-argv*))
(defvar *daemon-command* (third *posix-argv*))

(defparameter *as-daemon* (not (string= *daemon-command* "nodaemon")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; WARNING!
;;;; plantform-depends constant :(
;;;; changes for you platform... or make path for sbcl ;)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(unless (boundp 'sb-unix:tiocnotty)
  (defconstant sb-unix:tiocnotty 21538))

(defconstant +PR_SET_KEEPCAPS+ 8)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; aux
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro with-exit-on-error (&body body)
  `(if *as-daemon*
       (handler-case (progn ,@body)
         (error (err)
           (with-output-to-string (*standard-output*)
             (let ((*print-escape* nil))
               (print-object err *error-output*)
               (write #\Newline :stream *error-output*)
               (sb-ext:quit :unix-status 1)))))
       (progn ,@body)))

(defmacro with-silence (&body body)
  `(with-output-to-string (*trace-output*)
     (with-output-to-string (*standard-output*)
       ,@body)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; basic parameters
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defpackage #:sbcl.daemon.preferences
  (:use #:cl)
  (:export #:*name*
           #:*user*
           #:*group*
           #:*fasldir*
           #:*pidfile*
           #:*swankport*
           #:*default-host-redirect*
           #:*asdf-central-registry*
           #:*asdf-load-systems*
           #:*sites*))

(with-exit-on-error
    (let ((*package* (find-package '#:sbcl.daemon.preferences)))
      (load *daemon-config-pathname*)))

(defmacro defpref (name &optional default)
  `(with-exit-on-error
       (defparameter ,name
         (let ((symbol (find-symbol (symbol-name ',name) '#:sbcl.daemon.preferences)))
           (if (boundp symbol)
               (symbol-value symbol)
               ,default)))))

(defpref *name* (error "The param *name* is unbound"))

(defpref *user* *name*)

(defpref *group*)

(defpref *fasldir* (format nil "/var/cache/~A/fasl/" *name*))

(defpref *pidfile* (format nil "/var/run/~A/~A.pid" *name* *name*))

(defpref *swankport*)

(defpref *asdf-central-registry*)

(defpref *asdf-load-systems*)

(defpref *sites*)

(defpref *default-host-redirect*)

(delete-package '#:sbcl.daemon.preferences)

;;;; create necessary directories

(with-silence
    (require 'sb-posix))

(ensure-directories-exist *fasldir*)
(ensure-directories-exist *pidfile*)

(let ((uid (sb-posix:passwd-uid (sb-posix:getpwnam *user*)))
      (gid (if *group*
               (sb-posix:group-gid (sb-posix:getgrnam *group*))
               (sb-posix:passwd-gid (sb-posix:getpwnam *user*)))))
  (sb-posix:chown *fasldir* uid gid)
  (sb-posix:chown (directory-namestring *pidfile*) uid gid))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Processing command line arguments
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; command-line COMMAND

;;;; quit if COMMAND is unknown

(unless (find *daemon-command* '("start" "stop" "zap" "kill" "restart" "nodaemon") :test #'string-equal)
  (with-exit-on-error
      (error "Bad command-line options")))

;;;; zap - remove pid file

(when (string-equal *daemon-command* "zap")
  (with-exit-on-error     
      (delete-file *pidfile*)
    (sb-ext:quit :unix-status 0)))

;;;; stop - send to daemon sigusr1 signal, wait and remove pid file

(defun read-pid ()
  (with-open-file (in *pidfile*)
    (read in)))

(defun stop-daemon ()
  (let ((pid (read-pid)))
    (sb-posix:kill pid sb-posix:sigusr1)
    (loop
      while (not (null (ignore-errors (sb-posix:kill pid 0))))
      do (sleep 0.1)))
  (delete-file *pidfile*))

(when (string-equal *daemon-command* "stop")
  (with-exit-on-error 
      (stop-daemon)
    (sb-ext:quit :unix-status 0)))

;;;; kill - send to daemon kill signal and remove pid file

(when (string-equal *daemon-command* "kill")
  (with-exit-on-error
      (sb-posix:kill (read-pid)
                     sb-posix:sigkill)
    (delete-file *pidfile*)
    (sb-ext:quit :unix-status 0)))

;;;; restart daemon

(when (string-equal *daemon-command* "restart")
  (with-exit-on-error
      (stop-daemon)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Start daemon!
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;; required path for sbcl :(
(sb-posix::define-call "grantpt" int minusp (fd sb-posix::file-descriptor))
(sb-posix::define-call "unlockpt" int minusp (fd sb-posix::file-descriptor))
(sb-posix::define-call "ptsname" c-string null (fd sb-posix::file-descriptor))
(sb-posix::define-call "initgroups" int minusp (user c-string) (group sb-posix::gid-t))

(defun switch-to-slave-pseudo-terminal (&optional (out #P"/dev/null") (err #P"/dev/null"))
  (flet ((c-bit-or (&rest args)
           (reduce #'(lambda (x y) (boole boole-ior x y))
                   args)))
    (let* ((fdm (sb-posix:open #P"/dev/ptmx" sb-posix:O-RDWR))
           (slavename (progn
                        (sb-posix:grantpt fdm)
                        (sb-posix:unlockpt fdm)
                        (sb-posix:ptsname fdm)))
           (fds (sb-posix:open slavename sb-posix:O-RDONLY))
           (out-fd (sb-posix:open out
                                  (c-bit-or sb-posix:O-WRONLY sb-posix:O-CREAT sb-posix:O-TRUNC)
                                  (c-bit-or sb-posix:S-IREAD sb-posix:S-IWRITE sb-posix:S-IROTH)))
           (err-fd (if (not (equal err out))
                       (sb-posix:open err
                                      (c-bit-or sb-posix:O-WRONLY sb-posix:O-CREAT sb-posix:O-TRUNC)
                                      (c-bit-or sb-posix:S-IREAD sb-posix:S-IWRITE sb-posix:S-IROTH))
                       (if out (sb-posix:dup out-fd)))))
      (sb-posix:dup2 fds 0)
      (sb-posix:dup2 out-fd 1)
      (sb-posix:dup2 err-fd 2))))

(defun change-user (name &optional group)
  (let ((gid)
        (uid))
    (when group
      (setf gid
            (sb-posix:group-gid (sb-posix:getgrnam group))))
    (let ((passwd (sb-posix:getpwnam name)))
      (unless group
        (setf gid
              (sb-posix:passwd-gid passwd))
        (setf uid
              (sb-posix:passwd-uid passwd))))
    (sb-posix:setresgid gid gid gid)
    (sb-posix:initgroups name gid)
    (sb-posix:setresuid uid uid uid)))

(defvar *status* nil)

(defun signal-handler (sig info context)
  (declare (ignore info context))
  (setf *status* sig))

(when *as-daemon*
  (sb-sys:enable-interrupt sb-posix:sigusr1 #'signal-handler)
  (sb-sys:enable-interrupt sb-posix:sigchld #'signal-handler))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; change uid and gid
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; required for start hunchentoot on port 80
(sb-posix::define-call "prctl" int minusp (option int) (arg int))
(sb-posix:prctl +PR_SET_KEEPCAPS+ 1)

(change-user *user* *group*)

;;;; required for start hunchentoot on port 80
(load-shared-object (or 
       (find-if #'probe-file
                              '("/lib/libcap.so.2" "/lib/libcap.so" "/lib/libcap.so.1"))
       (error "No supported libcap found")))

(sb-posix::define-call "cap_from_text" (* char) null-alien (text c-string))
(sb-posix::define-call "cap_set_proc" int minusp (cap_p (* char)))
(sb-posix::define-call "cap_free" int minusp (cap_p (* char)))

(let ((cap_p (sb-posix:cap-from-text "CAP_NET_BIND_SERVICE=ep")))
  (sb-posix:cap-set-proc cap_p)
  (sb-posix:cap-free cap_p))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; fork!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(when *as-daemon*
  (unless (= (sb-posix:fork) 0)
    (loop
      while (null *status*)
      do (sleep 0.1))
    (quit :unix-status (if (= *status* sb-posix:sigusr1)
                           0
                           1))))


(defparameter *ppid* (sb-posix:getppid))

;;;; set global error handler 
(defun global-error-handler (condition x)
  (declare (ignore x))
  (let ((err (with-output-to-string (out)
               (let ((*print-escape* nil))
                 (print-object condition out)))))
    (print err *error-output*)
    (sb-posix:syslog sb-posix:log-err
                     err))
  (quit :unix-status 1))

(when *as-daemon*
  (setf *debugger-hook* #'global-error-handler)

  (sb-sys:enable-interrupt sb-posix:sigusr1 :default)
  (sb-sys:enable-interrupt sb-posix:sigchld :default))

;;;; change current directory
(sb-posix:chdir #P"/")

;;;; umask
(sb-posix:umask 0)

;;;; detach from tty
(when *as-daemon*
  (let ((fd (ignore-errors (sb-posix:open #P"/dev/tty" sb-posix:O-RDWR))))
    (when fd
      (sb-posix:ioctl fd sb-unix:tiocnotty)
      (sb-posix:close fd))))

;;;; rebind standart input, output and error streams
(when *as-daemon*
  (switch-to-slave-pseudo-terminal))

;;;; start new session
(when *as-daemon*
  (sb-posix:setsid))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; load asdf
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require 'asdf)

(loop
  for path in *asdf-central-registry*
  do (push path asdf:*central-registry*))

(asdf:enable-asdf-binary-locations-compatibility
 :centralize-lisp-binaries t
 :default-toplevel-directory *fasldir*)

;;(asdf:oos 'asdf:load-op 'asdf-binary-locations)

;;(setf asdf:*centralize-lisp-binaries* t)

;;(setf asdf:*default-toplevel-directory* *fasldir*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; start swank server
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defpackage :swank-loader
  (:use :cl)
  (:export :init
   :dump-image
           :*source-directory*
   :*fasl-directory*))

(when *swankport*
  (when *fasldir*
    (defparameter swank-loader:*fasl-directory* *fasldir*))
  (asdf:oos 'asdf:load-op :swank))

(when *swankport*
  (asdf:oos 'asdf:load-op :swank))

(when *swankport*
  (setf swank:*use-dedicated-output-stream* nil)
  (swank:create-server :port *swankport*
                       :coding-system "utf-8-unix"
                       :dont-close t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Start restas server
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(asdf:operate 'asdf:load-op '#:restas)

(setf (symbol-value (read-from-string "restas:*default-host-redirect*"))
      *default-host-redirect*)

(loop
  for system in *asdf-load-systems*
  do (asdf:operate 'asdf:load-op system))

(loop
  for site in *sites*
  do (if (consp site)
         (apply #'restas:start 
                (first site)
                :hostname (second site)
                :port (third site)
                (let* ((ssl-files (fourth site)))
                  (list :ssl-certificate-file (first ssl-files)
                        :ssl-privatekey-file (second ssl-files)
                        :ssl-privatekey-password (third ssl-files))))
         (restas:start site)))

(when *as-daemon*
  (sb-sys:enable-interrupt sb-posix:sigusr1
                           #'(lambda (sig info context)                             
                               (declare (ignore sig info context))
                               (handler-case
                                   (progn 
                                     (sb-posix:syslog sb-posix:log-info "Stop ~A daemon" *name*)
                                     (error "~A stop" *name*)
                                     )
                                 (error (err)
                                   (sb-posix:syslog sb-posix:log-err
                                                    (with-output-to-string (out)
                                                      (let ((*print-escape* nil))
                                                        (print-object err out))))))
                               (sb-ext:quit :unix-status 0))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; end daemon initialize
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; write pid file
(when *as-daemon*
  (with-open-file (out *pidfile* :direction :output :if-exists :error :if-does-not-exist :create)
    (write (sb-posix:getpid) :stream out))

  (sb-posix:kill *ppid* sb-posix:sigusr1)
  (setf *debugger-hook* nil)

  (sb-posix:syslog sb-posix:log-info "Start ~A daemon" *name*))

Файл с настройками для запускаемого сайта.
Замените пользователя и пути "/home/michael/" на свои.
restas.daemon

;;;; -*- mode: lisp -*-

(defparameter *name* "restas")

(defparameter *user* "michael")

(defparameter *group* nil)

(defparameter *fasldir* #P"/var/cache/restas/fasl/")                                                    

(defparameter *pidfile* #P"/var/run/restas/restas.pid")

(defparameter *swankport* 30010)

(defparameter *default-host-redirect* nil)

(defparameter *asdf-central-registry* 
  '(#P"/usr/share/common-lisp/systems/"
    #P"/home/michael/quicklisp/dists/quicklisp/installed/systems/"
    #P"/home/michael/webspace/restmax/"))

(defparameter *asdf-load-systems* '(#:restmax))

(defparameter *sites* '((#:restmax nil 80)))

24 октября 2011

Common Lisp. Файловый http сервер.

В cl можно предоставить http доступ к папке за две формы, за что архимагу и спасибо.

(ql:quickload :restas-directory-publisher)

(restas:start :restas.directory-publisher
              :port 8080
              :context (restas:make-context (restas.directory-publisher:*baseurl* '("tmp"))
                                            (restas.directory-publisher:*directory* #P"/tmp/")
                                            (restas.directory-publisher:*autoindex* t)))

23 октября 2011

Common Lisp. Останов restas

Updated 20.11.2011

Теперь можно так:


(restas:stop-all :soft t)


Чтобы не забыть, останов restas выполняется командой:

(mapcar #'hunchentoot:stop restas::*acceptors*)
(setf restas::*acceptors* nil)

19 октября 2011

Удивительное рядом: потокобезопасность в 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

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

16 октября 2011

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.
Возможно поменять название проекта, нынешнее излишне созвучно, да и вообще хочеться использовать красивое женское имя.
Решить проблему изоляции/безопасности сессий одним махом.
Кроссбраузерность, включающая гаджеты.

14 октября 2011

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 - это через гланды.

29 сентября 2011

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?

25 сентября 2011

Common Lisp. Restas. Maxima. #2

Маленькая завлекушная картинка

В предыдущей заметке мы построили простое web приложение перенаправляющее ввод/вывод консольной программы MAXIMA. С тех пор прошло недели три, и сегодня я рад представить вам графическую web оболочку, с функцией редактирования TeX документов и встраивания в них исполняемых команд MAXIMA. А также система emacs-style клавиатурных сочетаний сделает вашу повседневную математическую работу гораздо приятнее и продуктивнее.

05 сентября 2011

Fork me плохая концепция.

Концепция fork me, вообще непонятно почему, овладела умами опенсорсников. Вот вы представте себе, что значит форкнуть проект масштаба GTK, Qt, libreoffice и т.д.? Если для исправления багов, то есть другие пути:
  1. багтрекер, список рассылки, форум и т.д.
  2. скачать исходники, пропатчить, а патч отправить куда-нибудь в пункте 1.
Если для добавления уникальной возможности, то есть такие же пути как в случае с багом.
Зачем еще нужен форк?
Ну ладно, вот есть проект более мелкого масштаба. Restas например, или cl-opengl.
Вот его например зачем форкать? Ну чтобы, баг, фичу исправить, добавить. Ну так скачайте себе репозитарий, доработайте исходный код, снимите patch, отправте патч.
За три присланных патча, можно уже напрашиваться в соразработчики. А то смотришь у всех, кому не лень по репозитарию лежит.
Ну ладно, допустим удобно merge request'ы делать. Так а что, просто создать команду разработчиков уже не модно. Нужен code review, ну так можно ветвить проект, и основной разработчик пускай ветки мержит.
Итак, какие выводы я делаю:
  • гитхаб маркетологи переборщили с "базаром"
  • либо стараются разделить и влавствовать разработчиками, потому что одно дело: один репозитарий поддерживается 5-ю разработчиками, другое дело 5 репозитариев у пяти разработчиков. Это версия моя любимая, так как пахнет мировым заговором.

Посмотрите на gitorious.org. Те же межрепозитариальные merge request'ы, но никто об этом не кричит, работают себе потихонечку. Командную разработку поддерживают. Вообще-то функциональности не так много как на гитхабе, зато все по православному бесплатно.

О, теперь внимание, Fork Me призыв смотрится особенно феерично для этого репозитария: https://github.com/torvalds/linux

04 сентября 2011

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 строчек кода:)

Пожелания, критика приветствуются.