call/hc

I don't always use Lisp...

2011-09-12T15:02:00.000-07:00

By Jim.

(Image generated by quickmeme.com)

paste.call-cc.org (pastiche)

2011-06-07T17:59:00.000-07:00

Hoje foi anunciado o serviço de pasting em call-cc.org (o servidor do projeto Chicken), disponibilizado através de http://paste.call-cc.org. Em linhas gerais, o serviço permite colar trechos de código para que outras pessoas possam ver. É bem útil em discussões via IRC.

paste.call-cc.org executa pastiche, uma aplicação para a web desenvolvida por Christian Kellermann. É feita em Chicken Scheme, usando awful.

Chicken 4.7.0

2011-05-26T03:49:00.000-07:00

Ontem foi lançada a versão 4.7.0 do sistema Chicken, com várias correções de problemas e melhorias. A lista de novidades está no arquivo NEWS.

Uma das mais significativas modificações foi a substituição do sistema de expressões regulares. A unidade antiga (regex), agora é um egg. A implementação nova é irregex, em Scheme puro.

"Novo" equipamento

2011-04-28T16:33:00.000-07:00

Amplificador de microfones Stevaux (50W, com 6L6 na saída).

Alguém sabe mais sobre esta marca? Até onde sei, foi (é?) um fabricante de transformadores e caixas metálicas.

Todo o circuito é valvulado, inclusive a fonte.

Fotos em resolução maior podem ser vistas em http://parenteses.org/mario/fotos/stevaux

Chicken no Twitter

2011-04-21T06:17:00.000-07:00

Chicken entrou no moderno mundo da web social com uma conta no twitter.

Primeiro esboço de R7RS

2011-04-16T03:52:00.000-07:00

Ontem foi anunciado o primeiro esboço [PDF] da nova versão da especificação de Scheme.

O comitê responsável por preparar a nova versão da especificação decidiu dividi-la em duas partes: uma básica e outra com funcionalidades opcionais que podem não ser necessárias ou adequadas em alguns contextos. O documento anunciado é referente à parte básica (small language).

Felizmente, R7RS baseia-se em R5RS, e não em R6RS. O texto preliminar da nova especificação é de leitura agradável, não sendo tão "denso" quanto o das versões anteriores.

Novas versões para awful e extensões de suporte a bancos de dados

2011-04-12T04:22:00.000-07:00

Há pouco foram lançadas versões novas das extensões awful, awful-sql-de-lite, awful-sqlite3 e awful-postgresql.

Os destaques da nova versão de awful são as melhorias significativas para possibilitar a instalação de múltiplos aplicativos em um mesmo virtual host, uma interface sobre spiffy-request-vars e a correção de um bug crítico devido ao reuso de threads feito pelo servidor web Spiffy.

As notas sobre a nova versão de awful (0.31) estão abaixo:


* Added a tiny wrapper around spiffy-request-vars, adding the
   with-request-variables macro and exporting
   spiffy-request-vars's converters.
* Updated JQuery from version 1.5.1 to 1.5.2.
* Better support for multiple applications under the same virtual
  host (add-request-handler-hook! and remove-request-handler-hook!)
* $db checks if database access is enabled via (enable-db) and
  throws an error if it is not.
* Fixed critical bug regarding to parameters and thread reuse by Spiffy
* Fixed redirect-to but introduced in version 0.29

As novas versões das extensões de suporte a sistemas de bancos de dados exportam um novo procedimento para permitir o chaveamento entre bases de diferentes bancos. Assim, o uso de múltiplos sistemas de bancos de dados (e múltiplas bases de dados) em awful fica facilitado.

Alinhamento de astros

2011-04-08T04:26:00.000-07:00

Uma coincidência: atualmente as duas mais expressivas implementações de compilador de Scheme->C (Chicken e Gambit) e um dos mais importantes compiladores de C (GCC) estão na mesma versão: 4.6.

A expectativa é que Chicken quebre esse alinhamento nos próximos dias com o lançamento da versão 4.7.

Hoje a versão release candidate para 4.7.0 foi atualizada no branch prerelease do repositório git do compilador.

Também hoje foi lançado o tarball de desenvolvimento, versão 4.6.7, com as funcionalidades que farão parte da versão 4.7.0.

Awful 0.29

2011-02-27T10:58:00.000-08:00

Há pouco foi lançada a versão 0.29 de awful. Nada de muito revolucionário nesta nova versão, mas correção de pelo menos um bug crítico e novas funcionalidades/atualizações menores. O changelog para a versão 0.29 está abaixo:


* Updated JQuery from version 1.5.0 to 1.5.1.
* ajax and periodical-ajax bugfix (for situations when they
  are used simultaneously, or periodical-ajax and add-javascript).
* The default URI for ajax-library is now protocol-relative
  (thanks to Peter Bex).
* Added the javascript-position parameter.

REPL ilustrado

2011-02-26T18:41:00.000-08:00

O REPL (Read, Eval, Print, Loop), vulgar e erroneamente conhecido como interpretador (existem compiladores com ambiente interativo), é uma das ferramentas mais indispensáveis para programadores. É o tipo de coisa que, depois que nos acostumamos a usar, é difícil viver sem.

Abaixo está uma implementação simplificada e graficamente comentada em Chicken Scheme que ilustra o conceito:

O código acima é executável:

$ csi -s repl.scm
(define (fatorial n) (if (< n 2) 1 (* n (fatorial (- n 1)))))
#<unspecified>
(fatorial 6)
720

Recarregando aplicações em awful através do Emacs

2011-02-07T13:05:00.000-08:00

Abaixo está um hackzinho para recarregar aplicações em awful através do Emacs, o qual pode ser bem útil quando usando awful no modo desenvolvimento (--development-mode). No modo de desenvolvimento, awful automaticamente define o caminho /reload, o qual, quando requisitado, recarrega as aplicações.

(defun awful-reload ()
  (interactive)
  (shell-command "lynx -dump http://localhost:8080/reload"))

(add-hook 'scheme-mode-hook
   #'(lambda ()
       (local-set-key "\C-cR" 'awful-reload)))

O código acima define uma função interativa (awful-reload) que pode ser invocada no Emacs através de C-cR estando-se no modo Scheme.

O cliente HTTP pode ser qualquer um de linha de comando. O lynx serve bem a este propósito por fornecer a opção -dump, que gera a saída sem formatação, a qual pode ser exibida com facilidade no buffer do Emacs.

Abaixo está um screenshot do Emacs logo após a execução de awful-reload através de C-cR.

Awful 0.28 e awful-ssl

2011-02-06T15:10:00.000-08:00

Hoje foi lançada a versão 0.28 de awful. A nova versão apresenta correções de bugs, soluções para algumas limitações e algumas novas funcionalidades.

Também foi lançada a versão inicial da extensão awful-ssl, a qual permite o uso de awful com SSL de forma fácil.

accents-substitute

2010-11-18T15:08:00.000-08:00

Seguidamente tenho a necessidade de remover acentos de textos em português. Há umas semanas fiz uma extensão para Chicken chamada accents-substitute substituir caracteres acentuados pelos correspondentes sem acento (ou com entidades de HTML).

A extensão aceita textos em Latin1 (ISO-8859-1) ou UTF-8, havendo um módulo para cada codificação, ambos provendo o mesmo procedimento: accents-substitute (nome inspirado em string-substitute, da extensão regex).

Para facilitar o uso no dia-a-dia, fiz um pequeno script que usa o procedimento {{accents-substitute}}. Abaixo estão alguns exemplos de uso:

$ accents-substitute --help
Usage: accents-substitute [ --encoding= ] [ --mode= ] [ input file ]

Default values:
   mode: ascii
   encoding: utf8

$ cat lisp-br
Lisp-BR é um projeto que tem por objetivo divulgar linguagens de
programação da família Lisp no Brasil e formar uma comunidade de
usuários que tenham vontade de aprender não só uma nova forma de
programar, mas também uma nova maneira de pensar!

$ cat lisp-br | accents-substitute 
Lisp-BR e um projeto que tem por objetivo divulgar linguagens de
programacao da familia Lisp no Brasil e formar uma comunidade de
usuarios que tenham vontade de aprender nao so uma nova forma de
programar, mas tambem uma nova maneira de pensar!

$ accents-substitute --mode=html lisp-br
Lisp-BR &eacute; um projeto que tem por objetivo divulgar linguagens de
programa&ccedil;&atilde;o da fam&iacute;lia Lisp no Brasil e formar uma comunidade de
usu&aacute;rios que tenham vontade de aprender n&atilde;o s&oacute; uma nova forma de
programar, mas tamb&eacute;m uma nova maneira de pensar!

O código da ferramenta de linha de comando está a seguir:

#!/bin/sh
#| -*- scheme -*-
exec csi -s $0 "$@"
|#

(use
 (rename
  accents-substitute-latin1
  (accents-substitute accents-substitute-latin1))
 (rename
  accents-substitute-utf8
  (accents-substitute accents-substitute-utf8)))

(use posix regex (srfi 1 13))

(define (command-line-argument option args)
  ;; Return the argument associated to the command line option OPTION
  ;; in ARGS or #f if OPTION is not found in ARGS or doesn't have any
  ;; argument.
  (let ((val (any (cut string-match (string-append option "=(.*)") <>) args)))
    (and val (cadr val))))

(define (usage #!optional exit-code)
  (print "Usage: " (pathname-strip-directory (program-name))
         " [ --encoding=<utf8|latin1> ] [ --mode=<ascii|html> ] [ input file ]")
  (print "\nDefault values:\n"
         "    mode: ascii\n"
         "    encoding: utf8")
  (when exit-code (exit exit-code)))

(let* ((args (command-line-arguments))
       (mode (command-line-argument "--mode" args))
       (encoding (command-line-argument "--encoding" args))
       (paramless-args (remove (cut string-prefix? "--" <>) args))
       (accents-substitute accents-substitute-utf8))

  (when (or (member "-h" args) (member "--help" args))
    (usage 0))

  (when (and encoding (not (member encoding '("utf8" "latin1"))))
    (print "'" encoding "' is not a valid encoding.")
    (exit 1))

  (when (and mode (not (member mode '("ascii" "html"))))
    (print "'" mode "' is not a valid mode.")
    (exit 1))

  (when (equal? encoding "latin1")
    (set! accents-substitute accents-substitute-latin1))

  (let ((port (if (null? paramless-args)
                  (current-input-port)
                  (open-input-file (car paramless-args)))))
    (let loop ()
      (let ((line (read-line port)))
        (unless (eof-object? line)
          (print (accents-substitute line mode: (and mode (string->symbol mode))))
          (loop))))
    (unless (null? paramless-args)
      (close-input-port port))))

Adicionei este exemplo de aplicação à seção Examples da documentação de accents-substitute.

Awful no Windows ("That's too awful")

2010-10-05T04:09:00.000-07:00

Com a correção da extensão sendfile (por David Krentzlin) para Windows, awful passa a funcionar também no sistema das telas azuis.

As correções ainda não foram oficialmente lançadas (i.e., ainda não estão disponíveis para serem instaladas via chicken-install), mas podem ser obtidas em http://code.call-cc.org/svn/chicken-eggs/release/4/sendfile/trunk/ (usuário: anonymous, sem senha).

Chicken 4.6.0

2010-09-13T04:27:00.000-07:00

Foi lançada hoje a versão 4.6.0 de Chicken. O download da nova versão pode ser feito de http://code.call-cc.org. As novidades estão listadas no arquivo NEWS.

Migração de site estático para awful: tratando requisições por index.html

2010-09-11T12:42:00.000-07:00

Até pouco tempo atrás a minha página pessoal era totalmente estática. Depois que comecei a desenvolver awful achei que seria meio vergonhoso se a minha própria página não usasse o software que produzo. Então resolvi refazê-la usando awful (eu poderia simplesmente jogar os arquivos estáticos para o servidor web disponibilizá-los, mas não teria graça).

Um problema que ocorreu na migração do site estático para o com use de awful foi a ausência de arquivos index.html. Várias páginas eram disponibilizadas e referenciadas através um arquivo index.html, e esses arquivos não existem mais na nova estrutura com awful. A solução que adotei foi redirecionar os acessos aos arquivos index.html para o nome do "diretório" que os contém (na verdade não são diretórios, mas URIs associadas a procedimentos em Scheme).

Por exemplo, antes havia http://parenteses.org/mario/index.html. Hoje há um procedimento associado a http://parenteses.org/mario.

Com a possibilidade de associar procedimentos a URIs que casa com uma expressão regular, fazer com que http://parenteses.org/mario responda por http://parenteses.org/mario/index.html se torna bem fácil:

(use awful)

(define-page (regexp "/mario/.*index.html")
  (lambda (path)
    (redirect-to (string-chomp path "index.html"))))

Assim, todas as requisições por recursos /index.html disponíveis no caminho /mario/ serão redirecionadas para /.

Substituindo ferrugem por bolhas

2010-09-09T16:52:00.000-07:00

Neste domingo recebi um inesperado telefonema do Douglas, guitarrista da Crossfire, convidando para reunirmos a banda e fazer um som. Não tocávamos juntos desde o final de 2008 e eu havia parado de tocar no ano passado.

Depois de um ano sem tocar baixo, decidi arriscar para ver no que daria. Surpreendentemente, tocamos durante duas horas como se estivéssemos tocando regularmente. Fiquei impressionado.

Impressionante também foram as seqüelas. Esta é a foto dos meus dedos logo após o término do ensaio:

Esse é o estado dos meus dedos hoje:

Fica a dica: se fores tocar depois de um ano parado(a), use palheta. :-)

Chicken Gazette

2010-09-09T16:37:00.000-07:00

Há algumas semanas foi lançada a Chicken Gazette, uma publicação semanal de notícias sobre o sistema Chicken. Até agora já foram publicadas duas edições, as quais tratam de vários assuntos relacionados a Chicken, desde aspectos técnicos a questões sociais, de infraestrutura, últimos acontecimentos no desenvolvimento e curiosidades em geral.

A elaboração das edições é rotativa, ou seja, a cada semana há um editor diferente. A primeira edição ficou por conta de Christian Kellerman, a segunda por Moritz Heidkamp e a terceira está sendo elaborada por Alaric Snell-Pym.

As edições da Chicken Gazette podem ser acompanhadas através de feeds atom.

Awful 0.26

2010-08-28T09:29:00.000-07:00

Há pouco lancei a versão 0.26 de awful. A principal novidade é a integração de um editor em javascript para o web REPL (o texto anterior é sobre isso).

Houve algumas modificações para tornar o web REPL mais útil para desenvolvimento interativo, como a possibilidade de redefinir e eliminar definições de páginas em tempo de execução.

Coloquei em http://wiki.call-cc.org/video/awful-guess.ogv um vídeo mostrando o desenvolvimento de um simples jogo de adivinhação de números, com o uso de ajax e do web REPL.

Em http://parenteses.org/jogos há versões mais elaboradas de jogos no mesmo estilo.

Awful fancy web REPL

2010-08-20T17:58:00.001-07:00

Estou pensando em adicionar um editor de código em Javascript ao web REPL de awful. A idéia é facilitar a prototipação rápida, execução de testes, depuração e correção de problemas de forma fácil e com o servidor em execução.

A versão de desenvolvimento de awful contém um código inicial para isso. Abaixo está um screencast do que está implementado até agora.

O arquivo do vídeo, com uma qualidade significativamente melhor do que o mostrado acima, pode ser obtido em http://parenteses.org/mario/misc/fancy-web-repl.ogv (~6.1MB).

O editor em Javascript que estou utilizando é o Codemirror.

Emacs rápido

2010-08-20T17:32:00.000-07:00

Uma dica para usuários de Emacs que apelam para editores mais limitados como zile, nano e vi (risada sarcástica aqui) para edição rápida de arquivos (e.g., arquivos de configuração):

emacs -Q -nw

Um rápido e impreciso benchmark na máquina que estou usando agora mostra os seguintes resultados para abrir e fechar o Emacs 10 vezes:


$ time for i in `seq 10`; do \
>     emacs -Q -nw --eval '(save-buffers-kill-emacs)'; \
> done
real    0m0.753s
user    0m0.596s
sys     0m0.140s

Menos de 1 segundo para abrir e fechar o Emacs 10 vezes.

Habilitar modos que tornam o uso do Emacs mais confortável, como transient-mark-mode, global-font-lock-mode e show-paren-mode não custa caro:


$ time for i in `seq 10`; do\
>      emacs -Q -nw --eval \
>        '(progn (global-font-lock-mode t)
>                (transient-mark-mode t)
>                (show-paren-mode t)
>                (save-buffers-kill-emacs))'; \
> done
real    0m0.800s
user    0m0.616s
sys     0m0.168s

Novamente, menos de um segundo para abrir e fechar o Emacs 10 vezes, com coloração de sintaxe e tudo (inclusive um interpretador de Lisp). :-)

Awful 0.25

2010-08-17T15:59:00.000-07:00

Há pouco foi lançada a versão 0.25 de awful. A seguir são descritas as novidades.

O servidor awful admite novos parâmetros de linha de comando: --development-mode, --ip-address e --port. Os parâmetros --development-mode e --port servem, respectivamente, para fazer com que o servidor escute nos dados endereço IP e porta.

O parâmetro --development-mode ativa o modo de desenvolvimento de awful. Neste modo, funcionalidades como o Web REPL e o Session inspector são automaticamente ativadas. O caminho /reload também é automaticamente criado para que as aplicações possam ser recarregadas sem que seja necessário reiniciar o servidor. No modo de desenvolvimento, mensagens de erro das aplicações são exibidas no cliente (e.g., navegador). Abaixo está um exemplo (erro.scm):

#!/usr/bin/awful

(use awful)

(define-page (main-page-path)
  (lambda ()
    (++ "Oops " 'erro)))

Para executar no modo de desenvolvimento:

$ awful --development-mode erro.scm

Ao acessar http://localhost:8080/ a mensagem de erro do screenshot abaixo é exibida no navegador, seguida de um link para o Web REPL.

Quando executado em modo de desenvolvimento, o parâmetro development-mode? tem como valor #t.

Outra novidade é o parâmetro awful-response-headers o qual permite ajustar os campos do cabeçalho de resposta para o cliente. Abaixo está um exemplo de um procedimento para associar URIs a respostas JSON:

#!/usr/bin/awful

(use awful)

(define (define-json path body)
  (define-page path
    (lambda ()
      (awful-response-headers '((content-type "text/json")))
      (body))
    no-template: #t))

(define-json (main-page-path)
  (lambda ()
    "{a: 1}"))

A menos que explicitamente fornecido, awful calcula automaticamente o tamanho da resposta e o atribui ao campo Content-Length.

Hoje também disponibilizei um pequeno texto com instruções sobre como instalar awful em sistemas Unix[-like].

Operações em caminhos para arquivos em buffers do Emacs

2010-08-11T15:24:00.000-07:00

Seguidamente sinto a falta de funções no Emacs para ver o caminho completo para o arquivo aberto no buffer que estou editando (poder copiar o caminho completo seria um plus). A seguir estão duas pequenas funções para fazer isso.

show-buffer-file-name exibe na echo area do Emacs o caminho completo para o arquivo. copy-buffer-file-name coloca o caminho completo do para o arquivo no topo do kill ring do Emacs (no X Window, também copia para a área de seleção primária, o que pode ser útil para quem, como eu, usa bastante a combinacao Emacs + emulador de terminal).

(defun show-buffer-file-name ()
  (interactive)
  (message buffer-file-name))

(defun copy-buffer-file-name ()
  (interactive)
  (if buffer-file-name
      (kill-new buffer-file-name)))

Awful 0.24

2010-07-20T16:05:00.000-07:00

Há pouco foi lançada a versão 0.24 de awful. As novidades que mais se destacam, além de algumas pequenas melhorias e da correção de alguns bugs que ocorriam em casos especiais, há o suporte inicial a armazenamento de identificadores de sessão em cookies (via spiffy-cookies) e o suporte a redirecionamentos de forma fácil (procedimento redirect-to).

A seguir está um exemplo de definição de um redirecionador:


(define-page "/mario"
  (lambda ()
    (redirect-to "http://parenteses.org/mario")))

A definição do redirecionador pode ser encurtada com o uso de cut:


(define-page "/mario" (cut redirect-to "http://parenteses.org/mario"))

Também aproveitei para dar uma embelezada no web REPL e no inspetor de sessão (screenshots abaixo).

10 anos de Chicken!

2010-07-20T03:47:00.000-07:00

Há dez anos foi publicado o anúncio da primeira versão pública de Chicken: http://groups.google.com/group/comp.lang.scheme/msg/edfb2da16fd89fae

Em http://web.archive.org/web/20000824034645/http://www.anu.ie/felix/chicken.html está a página do projeto, como era na época.

Chicken 4.5.0

2010-05-17T18:55:00.000-07:00

Alguns minutos atrás foi anunciado o lançamento da versão 4.5.0 de Chicken. A lista de novidades está em http://chicken.wiki.br/releases/4.5.0/NEWS.

Há cinqüenta anos...

2010-05-12T06:57:00.000-07:00

LISP I, PROGRAMMER'S MANUAL (PDF).

Awful: expressões regulares para dispatching de URLs

2010-05-09T16:03:00.000-07:00

Há pouco fiz o commit da mais nova versão de awful (0.18) . A novidade mais significativa desta versão é o suporte a dispatching de URLs através de expressões regulares. Em outras palavras, agora é possível associar uma expressão regular a um procedimento a ser executado. Assim, se o caminho da URL da requisição bate com a expressão regular, o procedimento é invocado com o caminho como argumento.

Abaixo está um exemplo simples que ilustra o que a nova versão pode fazer:

(use awful srfi-1 regex)

(define-page (regexp "/add/.*")
  (lambda (path)
    (let ((numbers (filter-map string->number (string-split path "/"))))
      (number->string (apply + numbers)))))

Se acessarmos o servidor executando o código acima através da URL http://host:port/add/1/2/3 o resultado exibido será 6.

Org mode e links para mensagens no Gnus

2010-05-09T10:34:00.000-07:00

Esses dias passei os olhos sobre um guia compacto sobre o Org mode e
achei uma coisa super útil: a possibilidade de fazer links do
documento em Org para mensagens do Gnus.

A sintaxe é a seguinte:

[[gnus:<mailbox>#<mensagem id>][<texto>]]

Onde:

<mailbox> é a mailbox aonde está armazenada a mensagem

<mensagem id> é o número da mensagem na mailbox

<texto> é o texto que aparecerá no link

Exemplo:

[[gnus:lists.chicken-users#2045 [Coisa para ler sobre Chicken]]

Algumas combinações de teclas:

C-c C-l: cria um link interativamente

C-C C-o: segue o link sob o cursor

Awful scripts

2010-04-26T19:18:00.000-07:00

Uma dica rápida para executar aplicações web em awful como scripts em sistemas Unix[-compatíveis]: usando a linha com shebang.

Dessa forma, basta executar o arquivo com a aplicação web como se fosse um arquivo executável qualquer:

$ cat hello-world.scm
#! /usr/bin/awful

(use awful)

(define-page (main-page-path)
  (lambda ()
    "Hello, world!"))

$ ./hello-word.scm

Sintaxe para definição de "curried procedures"

2010-04-16T16:38:00.000-07:00

A definição de curried procedures é bastante usual em Scheme. Consiste em fazer com que o valor produzido por um procedimento seja outro procedimento.

Abaixo está um exemplo de um criador de objetos que respondem a mensagens:

(define (make-obj)
  (lambda (message)
    (case message
      ((hello) "Hello!")
      ((bye) "Bye bye!")
      (else (error "Unknown message.")))))

O código acima já está com uma sintaxe simplificada para definições de procedimentos. A forma mais longa seria:

(define make-obj
  (lambda ()
    (lambda (message)
      (case message
        ((hello) "Hello!")
        ((bye) "Bye bye!")
 (else (error "Unknown message."))))))

Não está na especificação da linguagem, mas algumas implementações oferecem a possibilidade de usar uma sintaxe mais simplificada para a definição de curried procedures:

(define ((make-obj) message)
  (case message
    ((hello) "Hello!")
    ((bye) "Bye bye!")
    (else (error "Unknown message."))))

Das implementações em que testei, Chicken, Guile, MIT Scheme e PLT admitem essa sintaxe para definição de curried procedures. Ypsilon e Gambit não admitem.

Documentação de Chicken com chicken-doc

2010-04-15T17:16:00.000-07:00

chicken-doc é uma extensão do sistema Chicken para pesquisa e navegação na documentação do compilador e das extensões através da linha de comando.

É bem parecida com uma extensão que eu havia feito há uns anos: man. Na época da extensão man, a documentação de Chicken era no formato textinfo. man, então, fazia o parsing do arquivo texinfo e gerava um arquivo com expressões simbólicas de fácil pesquisa em Scheme. Depois da adoção de wiki para a documentação do compilador, a extensão man caiu em desuso.

chicken-doc, diferentemente da extensão man, faz o parsing de arquivos fonte do wiki, incluindo a documentação das extensões, R5RS e algumas SRFIs! Hoje foi lançada a versão 0.3.2 com a funcionalidade de pesquisa na documentação.

O uso de chicken-doc depende da geração da base de dados onde serão feitas as pesquisas. Para gerar a base de dados, é necessária a extensão chicken-doc-admin. Em http://chicken.wiki.br/eggref/4/chicken-doc-admin#quick-start há um passo-a-passo sobre como gerar a base.

Após gerada a base, pode-se usar a ferramenta de linha de comando chicken-doc:


$ chicken-doc
usage: chicken-doc -s|-c|-i path
       chicken-doc -f id
       chicken-doc -m re
       chicken-doc id | path
   -s path        Show signature
   -c path        Show table of contents (child IDs)
   -i path        Show documentation
   -f id          Show all matching paths for ID
 where ID is a single identifier and PATH is zero or
 more IDs comprising a path from the documentation root,
 separated by spaces or the # character.

   -m re          Show all matching paths for RE
 where RE is a POSIX regular expression.  Similar to -f.

When no option is given, guess the user's intent.  With
a single ID, find the ID (as with -f) and show its
documentation (as with -i) or show all matching paths
if multiple matches exist.  If more than one ID is
provided, show documentation on the path (as with -i).

Examples:
  -f open/rdonly           # Show matches for open/rdonly
  -s posix open/rdonly     # Show signature of open/rdonly in Unit posix
  -s 9p open/rdonly        # Show signature of open/rdonly in 9p egg
  -i 9p#open/rdonly        # Show documentation for same
  -c posix                 # Show TOC for Unit posix
  -c                       # Show toplevel TOC
  -m call-                 # Show identifiers containing call-
  -m -file$                # Show identifiers ending in -file
  use                      # Show doc for "use" in chicken core
  posix                    # Show doc for Unit posix
  open/rdonly              # Show matches for open/rdonly
  posix open/rdonly        # Show doc for open/rdonly in Unit posix

Alguns exemplos de uso:


$ chicken-doc reverse
path: (scheme reverse)

-- procedure: (reverse list)

Returns a newly allocated list consisting of the elements of list in
reverse order.

    (reverse '(a b c))                      ===>  (c b a)
    (reverse '(a (b c) d (e (f))))
                    ===>  ((e (f)) d (b c) a)

A primeira linha indica o "caminho" para o símbolo procurado. O primeiro símbolo do caminho pode ser scheme (indicando que é o símbolo é um componente da especificação da linguagem), o nome de uma unit de Chicken, uma SRFI ou uma extensão. É possível que ele possa ser encontrado em mais de um módulo. Neste caso, chicken-doc apresenta uma lista de opções:


$ chicken-doc enable-db
Found 3 matches:
(awful-sql-de-lite enable-db)  (enable-db)
(awful-sqlite3 enable-db)      (enable-db)
(awful-postgresql enable-db)   (enable-db)


$ chicken-doc awful-postgresql enable-db

-- procedure: (enable-db)

Enable Postgresql support for awful
(http://chicken.wiki.br/eggref/4/awful). This procedure basically sets
up awful to use the connection, disconnection, query and query escaping
procedures for Postgresql databases.

Com a versão lançada hoje, é possivel pesquisar na base de identificadores de procedimentos, macros e parâmetros. Exemplos:


$ chicken-doc -m '^string->'
(library string->blob)               (string->blob STRING)
(byte-blob string->byte-blob)        (string->byte-blob STRING) => BYTE-BLOB
(sxml-transforms string->goodHTML)   (string->goodHTML html)
(library string->keyword)            (string->keyword STRING)
(scheme string->list)                (string->list string)
(scheme string->number)              (string->number string radix)
(scheme string->symbol)              (string->symbol string)
(posix string->time)                 (string->time TIME [FORMAT])
(library string->uninterned-symbol)  (string->uninterned-symbol STRING)

O argumento para o parâmetro -m é uma expressão regular.

Algumas das funcionalidades de chicken-doc podem também ser usadas no REPL:


$ csi

CHICKEN
(c)2008-2010 The Chicken Team
(c)2000-2007 Felix L. Winkelmann
Version 4.4.4 
linux-unix-gnu-x86 [ manyargs dload ptables ]
compiled 2010-03-30 on dellito (Linux)

; loading ./.csirc ...
csi> (use chicken-doc)
csi> ,doc string-intersperse
path: (data-structures string-intersperse)

-- procedure: (string-intersperse LIST [STRING])

Returns a string that contains all strings in `LIST` concatenated together.
`STRING` is placed between each concatenated string and defaults to `" "`.

    (string-intersperse '("one" "two") "three")

is equivalent to

    (apply string-append (intersperse '("one" "two") "three"))

csi> ,wtf concatenate
(srfi-1 concatenate)            (concatenate  list-of-lists) -> value
(srfi-1 concatenate!)           (concatenate! list-of-lists) -> value
(ports make-concatenated-port)  (make-concatenated-port PORT1 PORT2 ...)

O comando ,doc mostra a documentação do símbolo dado como argumento. O comando ,wtf (de where to find ;-)) é equivalente à opção de linha de comando -m de chicken-doc.

Uma opção interessante para uso de chicken-doc é associar uma tecla de atalho para executá-lo no emacs. Em http://chicken.wiki.br/eggref/4/chicken-doc há dicas sobre como fazer isso.

Lies, damn lies and benchmarks

2010-03-30T17:06:00.000-07:00

Esses dias me deparei com um texto que mostra um benchmark simplificado (bastante ingênuo, na verdade) cujo título é "Holy Shmoly, Ruby 1.9 smokes Python away!". O benchmark baseia-se na execução do cálculo da série de Fibonacci. A implementação é recursiva e exercita, basicamente, chamadas de função e aritmética básica. São comparadas as implementações de Python e Ruby.

Embora seja muito simplificado, este benchmark desencadeou várias surpresas.

Surpresa 1 -- A implementação de Ruby está ficando mais rápida

Esta surpresa, na realidade, foi dupla para mim. Eu tinha idéia de que a implementação de Ruby era "meio lenta", mas não sabia que era tão lenta. A parte boa da surpresa é que a versão 1.9 está consideravelmente mais rápida.

Como referência para as próximas medições, abaixo estão os tempos de execução que obtive na minha máquina com as implementações em Ruby para Fibonacci de 0 a 39 (Ruby 1.8 e 1.9):

def fib(n)
    if n == 0 || n == 1
         n
    else
        fib(n-1) + fib(n-2)
    end
end

40.times do |i|
    puts "n=#{i} => #{fib(i)}"
end

Ruby 1.8	Ruby 1.9
real 9m26.377s user 8m11.039s sys 1m15.273s	real 1m14.576s user 1m14.565s sys 0m0.020s

Surpresa 2 -- O desempenho de Python

Ao longo deste texto vou mostrar algumas extensões que fiz ao benchmark original, o que acabou gerando mais surpresas. A primeira dela foi medir o desempenho de Python usando o JIT Psyco. Abaixo estão o código utilizado e os resultados obtidos na minha máquina:

Python puro (sem Psyco)

#! /usr/bin/env python
def fib(n):
if n == 0 or n == 1:
  return n
else:
  return fib(n-1) + fib(n-2)


for i in xrange(40):
    print "n=%d => %d" % (i, fib(i))

time ./fib.py
n=0 => 0
n=1 => 1
...
n=39 => 63245986

real    2m21.908s
user    2m21.349s
sys     0m0.016s

Python com Psyco

#! /usr/bin/env python
import psyco
psyco.full()

def fib(n):
if n == 0 or n == 1:
  return n
else:
  return fib(n-1) + fib(n-2)


for i in xrange(40):
    print "n=%d => %d" % (i, fib(i))

time ./fib.py
n=0 => 0
n=1 => 1
...
n=39 => 63245986

real    0m6.998s
user    0m6.948s
sys     0m0.008s

Com o uso de Psyco, o tempo de execução foi de ~2m22s para ~7s. Impressionante.

Surpresa 3 -- O desempenho de Chicken

Decidi estender o benchmark um pouco mais e implementar o algoritmo em Scheme, com Chicken:

(define (fib n)
  (if (or (= n 0) (= n 1))
    n
    (+ (fib (- n 1)) (fib (- n 2)))))

(let loop ((n 0))
  (when (< n 40)
    (print "n=" n " => " (fib n))
    (loop (+ n 1))))

O desempenho de Chicken, quando interpretando código, é violentamente lento (e esperado, pelo menos por mim):

time csi -s fib.scm
n=0 => 0
n=1 => 1
...
n=39 => 63245986

real    5m21.635s
user    5m20.696s
sys     0m0.916s

Quando o código é compilado com Chicken, há uma melhora significativa no desempenho:

$ csc fib.scm
time ./fib
n=0 => 0
n=1 => 1
...
n=39 => 63245986

real    0m29.996s
user    0m29.938s
sys     0m0.060s

Usando um pouco de agressividade na otimização:

$ csc -O5 fib.scm
time ./fib
n=0 => 0
n=1 => 1
...
n=39 => 63245986

real    0m21.506s
user    0m21.405s
sys     0m0.012s

Com a compilação do código em Chicken, foi possível baixar o tempo de execução de mais de 5 minutos para pouco mais de 20 segundos.

Por curiosidade, resolvi ver o tempo que uma implementação em C, nos mesmos moldes, levaria:

#include <stdio.h>

int fib(int n) {
    if (n == 0 || n == 1) {
        return n;
    } else {
        return fib(n - 1) + fib(n - 2);
    }
}


int main() {
    int n;
    for (n=0; n<40; n++) {
        printf("n=%d => %d\n", n, fib(n));
    }
}

$ gcc -O3 -ffast-math -fomit-frame-pointer -o fib-c fib-c.c
$ time ./fib-c
n=0 => 0
n=1 => 1
...
n=39 => 63245986

real    0m1.374s
user    0m1.372s
sys     0m0.004s

Até aqui, temos C, Python + Psyco e Chicken (compilado) nas três primeiras colocações em tempo de execução. Porém, há um detalhe na implementação em Chicken que faz uma certa diferença: o operadores numéricos (e.g., +, =) aceitam um número arbitrário de argumentos, diferentemente dos operadores numéricos das outras linguagens, que são binários. Obviamente, há um custo para isso. Entretanto, Chicken dispõe de procedimentos binários para operações numéricas com inteiros (com prefixo fx):

(define (fib n)
  (if (or (fx= n 0) (fx= n 1))
    n
    (fx+ (fib (fx- n 1)) (fib (fx- n 2)))))

(let loop ((n 0))
  (when (fx< n 40)
    (print "n=" n " => " (fib n))
    (loop (fx+ n 1))))

compilando e executando este código, temos:

$ csc -O5 fibfx.scm
$ time ./fibfx
n=0 => 0
n=1 => 1
...
n=39 => 63245986

real    0m1.088s
user    0m1.088s
sys     0m0.000s

A surpresa aqui é que o tempo de execução de uma implementação em Scheme é menor do que o de uma implementação em C. E, mais intrigante ainda, é que Chicken compila para C. :-) Porém, a estratégia de compilação usada por Chicken gera código C mais otimizado do que um humano programando.

No final das contas, temos os seguintes tempos, ordenados por ordem decrescente de tempo de execução:

Ruby 1.8	9m26.377s
Chicken (interpretado)	5m21.635s
Python puro	2m21.908s
Ruby 1.9	1m14.576s
Python + Psyco	0m6.998s
C	0m1.374s
Chicken (compilado)	0m1.088s

As seguintes versões de interpretadores e compiladores foram usadas:

Python	2.6.4
Psyco	1.6
Ruby	1.8 e 1.9
Chicken	4.4.4
GCC	4.4.1

As medições foram feitas em um processador de 2.4GHz com sistema operacional Ubuntu Linux.

Vale ressaltar, novamente, que esse benchmark, embora tenha gerado algumas surpresas, representa muito pouco para avaliação de desempenho de implementações de linguagens de programação.

Publicação dinâmica de arquivos estáticos com awful

2010-03-29T16:39:00.000-07:00

Hoje um usuário no canal #chicken (freenode.net) levantou a questão de como servir conteúdo dinâmico a partir de arquivos estáticos, mas sem publicar os arquivos estáticos diretamente. É, parece confuso. Um exemplo seria ter o diretório de documentos do servidor vazio e gerar conteúdo dinâmico a partir de arquivos estáticos e código executado no servidor. Isto é exatamente o que awful faz (via define-page). Porém, o usuário queria disponibilizar conteúdo dinâmico em vários formatos, não apenas em [X]HTML. Por exemplo, servir uma imagem através da URL http://servidor/imagem, onde imagem não é um arquivo no diretório de documentos do servidor. Além disso, ele queria que http://servidor/imagem retornasse a própria imagem, não uma página em HTML com <img src="imagem">.

Confesso que isso não foi algo que cogitei quando implementei define-page. Pensei no uso de define-page para a definição de páginas em [X]HTML ou de texto, não para imagens, vídeos ou formatos arbitrários.

Para a minha surpresa, a solução é bastante simples com o uso do procedimento send-static-file, de Spiffy:

(define-page "img"

  (lambda ()
    (begin
       (send-static-file "/home/mario/img.png")
      "")))

O código acima faz com que send-static-file ajuste os cabeçalhos HTTP para indicar que a resposta é um arquivo de imagem (com base na extensão) e envie o conteúdo do arquivo dado como argumento.

Porém, send-static-file considera que o caminho do arquivo passado como argumento está a partir do diretório de documentos do servidor web (i.e., o caminho passado como argumento será concatenado com o diretório de documentos do servidor web). Tentativas de passar um caminho absoluto, obviamente, não funcionam, pois o caminho absoluto será concatenado ao diretório de documentos do servidor, possivelmente apontando para um arquivo que não existe ou, com certeza, apontando para o arquivo errado.

A solução para este problema, no entanto, também é fácil: basta temporariamente mudar o valor do parâmetro que indica o diretório de documentos do servidor (root-path):

(define-page "img"

  (lambda ()
    (begin
      (parameterize ((root-path "/"))
         (send-static-file "/home/mario/img.png"))
      "")))

No exemplo acima, configurei o diretório de documentos do servidor web para ser /, de forma que eu possa referenciar arquivos através do caminho absoluto. O uso de parameterize garante que a definição temporária será válida apenas durante a execução do seu corpo (send-static-file, no exemplo).

Obviamente, a definição de URLs para envio de objetos estáticos de forma dinâmica pode ser simplificada se definirmos um procedimento para isso:

(define (define-static-file url-path abs-path)
  (define-page url-path
    (lambda ()
      (begin

        (parameterize ((root-path "/"))
          (send-static-file abs-path))
        ""))))

Estando define-static-file definido, publicar um arquivo estático de forma dinâmica, basta:

(define-static-file "img" "/home/mario/img.png")

Awful em 35 segundos

2010-03-24T16:46:00.000-07:00

Hoje vi na lista de usuários brasileiros de Python uma mensagem em que era apontado um vídeo sobre o framework Bottle. O vídeo mostra o desenvolvimento de um "hello world" no framework em 36 segundos. Resolvi fazer o mesmo com awful e consegui (oh!) em 35 segundos.

Típica medição inútil, mas aí está. :-)

Não sei se é possível visualizar o vídeo em uma resolução maior com esse tocador de vídeos do blogger. Na dúvida, coloquei umas cópias em http://parenteses.org/mario/misc/awful.avi e http://parenteses.org/mario/misc/awful.ogv.

Scheme sem parênteses

2010-03-08T16:48:00.000-08:00

Para aqueles que não usam Scheme só por causa dos parênteses: seus problemas acabaram! Basta substituir os parênteses por colchetes.

[define [fatorial n]
  [if [< n 2]
      1
      [* n [fatorial [- n 1]]]]]

[display [fatorial 5]]
[newline]

Exemplos com algumas implementações:

Chicken:

$ csi -s fatorial.scm 
120

Gambit:

$ gsi fatorial.scm 
120

PLT:

$ mzscheme -f fatorial.scm 
120

Ypsilon:

$ ypsilon fatorial.scm 
120

Embora [ e ] sejam caracteres reservados em R5RS, muitas implementações os utilizam como sinônimos para parênteses. É comum a prática de uso de colchetes para associações entre variáveis e valores em formas let. Exemplo:

(let ([a 3]
      [b 4]
      [c 5])
   (+ a b c))

Eu, particularmente, não costumo usar colchetes como sinônimo de parênteses, mas já vi muito código que usa.

try/catch em Scheme

2010-02-26T14:20:00.000-08:00

Para quem não gosta da sintaxe para tratamento de exceções de handle-exceptions (SRFI-12), a seguir está uma pequena macro para transformar a sintaxe de handle-exceptions em uma com try/catch:

(define-syntax try
  (syntax-rules (catch)
    ((_ attempt (catch exn handler ...))
     (handle-exceptions exn
                        (begin handler ...)
                        attempt))))

Exemplos de uso:

(define (try-car l #!optional default)
  (try (car l)
       (catch exn default)))

csi> (try-car '(1 2 3 4))
1
csi> (try-car '())
#f
csi> (try-car '() '())
()

Arc challenge em awful

2010-02-23T16:42:00.000-08:00

Há dois anos, Paul Graham propôs o seguinte desafio (arc challenge):

Write a program that causes the url said (e.g. http://localhost:port/said) to produce a page with an input field and a submit button. When the submit button is pressed, that should produce a second page with a single link saying "click here." When that is clicked it should lead to a third page that says "you said: ..." where ... is whatever the user typed in the original input field. The third page must only show what the user actually typed. I.e. the value entered in the input field must not be passed in the url, or it would be possible to change the behavior of the final page by editing the url.

Abaixo está uma implementação para o arc challenge em awful:

(use awful html-utils spiffy-request-vars)

(define-session-page "said"
  (lambda ()
    (with-request-vars $ (said)
      (cond (said
             ($session-set! 'said said)
             (link "said" "click here"))
            (($session 'said)
             => (lambda (said)
                  (++ "You said: " said)))
            (else (form (++ (text-input 'said)
                            (submit-input))
                        action: "said"
                        method: 'post))))))

Para testar o programa, basta executar:

$ awful arc-challenge.scm

E acessar http://localhost:8080/said

doctests em Scheme

2010-02-16T05:48:00.000-08:00

No ano passado, o Luciano Ramalho criou um grupo para estudo do livro Structure and Interpretation of Computer Programs. O grupo ainda existe mas está com as atividades paradas atualmente. Boa parte dos componentes do grupo são usuários de Python. O Luciano é um usuário de Python e mencionou a falta, em Scheme, de uma facilidade que existe em Python: a possibilidade de de especificar testes em docstrings.

A minha argumentação com relação a esta funcionalidade em Scheme é de que não deve ser feita da mesma forma como em Python, pois em Scheme, diferentemente de Python, docstrings são ambíguas. O equivalente a docstrings em Scheme só poderia ser feito através de comentários (doccomments?).

Em Python, a ambigüidade não existe porque funções exigem um comando return para indicar que a função terminará e desviará o fluxo de execução para o ponto imediatamente seguinte ao de onde foi invocada, opcionalmente, devolvendo resultados. Em Scheme, não há um comando return explícito (a menos que seja definido um procedimento de escape de uma continuação, mas este é um caso bem específico e não muito usual). O valor produzido por um procedimento é o valor resultante da última expressão avaliada. No caso de procedimentos em que a única expressão a ser avaliada é uma string, tem-se a ambigüidade. Exemplo:

(define (proc)
  "Isso é uma docstring ou uma string legítima?")

A ambigüidade que ocorre com docstrings é a mesma que ocorre com doctests. Se a única expressão a ser avaliada por um procedimento for uma string, como saber a string deve ser o resultado da avaliação do procedimento ou simplesmente uma docstring? Em Scheme, é uma ambigüidade. Em Python a ambigüidade é resolvida com o comando return.

Ignorando a ambigüidade que pode ocorrer em algumas definições, implementei em Scheme um esquema semelhante a doctests em Python. A implementação não é de uso geral, mas serve como " prova de conceito" (ainda que o conceito não esteja totalmente correto :-)).

A sintaxe das strings de teste é a seguinte:

a expressão sob teste, que seria digitada no REPL, deve ser precedida por >

o resultado esperado deve ser precedido por :

O parser das strings de teste é bastante limitado. Não são admitidas múltiplas linhas para expressões de teste nem de resultado. O parser ignora linhas não iniciadas por > ou :.

A única forma sintática para declaração de procedimentos admitida é:

(define (proc args)
  body)

Outras formas, como as abaixo, não são suportadas:

(define proc
  (lambda (args)
    body))

(define proc #f)
(set! proc (lambda (args) body))

(define proc
  (let ()
    (lambda (args)
      body)))

Teste de procedimentos resultantes da expansão de macros também não é suportado.

A implementação consiste, basicamente, de um procedimento doctest que lê todas as formas (forms) do arquivo em que é invocado e procura por definições com o padrão

(define (proc args)
  "doctest"
  body)

Então a string com os testes é extraída da definição e é passada para o parser de strings de teste, o qual avalia as expressões e os resultados esperados e imprime o resultado.

Um aspecto interessante da implementação é a forma como o parsing do código é feito: com manipulação de listas (estrutura de dados usada para representar código em Scheme).

O código da implementação, em Chicken Scheme, está abaixo:

(use posix (srfi 1 13))

(define (doctest)

  (define (pick-teststrings forms)
    ;; Retorna uma alist '((procname1 . test-string1) (proname2 . test-string2) ...)
    (filter-map
     (lambda (form)
       (and (list? form)
            (eq? (car form) 'define)
            (not (null? (cddr form))) ;; (define sym)
            (and (pair? (cadr form))   ;; (define (proc ...))
                 (string? (caddr form))
                 (cons (caadr form) ;; procname
                       (caddr form))))) ;; test-string
     forms))

  (define (check test result)
    (let* ((error-test #f)
           (error-result #f)
           (err-msg (lambda (e)
                      (with-output-to-string (cut print-error-message e))))
           (pass
            (equal? (handle-exceptions e
                                       (begin
                                         (set! error-test (err-msg e))
                                         #f)
                                       (eval test))
                    (handle-exceptions e
                                       (begin
                                         (set! error-result (err-msg e))
                                         #t)
                                       (eval result)))))
      (if (or error-test error-result)
          (display
           (string-append
            "Erro executando "
            (->string (if error-test test result))
            " --> " (or error-test error-result)))
          (if pass
              (print test " = " result "  [ok]")
              (print test " != " result "  [fail]")
              ))))
  
  (define (parse-teststring teststring)
    (define (parse-line line prefix)
      (and (string-prefix? (->string prefix) line)
           (with-input-from-string
               (string-trim line (lambda (c) (char=? c prefix)))
             read)))
    (let ((tests '())
          (results '()))
      (for-each (lambda (line)
                  (set! line (string-trim-both line))
                  (cond ((parse-line line #\>)
                         => (lambda (expr)
                              (set! tests (cons expr tests))))
                        ((parse-line line #\:)
                         => (lambda (expr)
                              (set! results (cons expr results))))))
                (with-input-from-string teststring read-lines))
      (values tests results)))
 
  (let ((forms (with-input-from-file (program-name) read-file)))
    (for-each (lambda (procname/teststring)
                (let ((procname (car procname/teststring))
                      (teststring (cdr procname/teststring)))
                  (print "===== " procname " =====")
                  (let-values (((tests results) (parse-teststring teststring)))
                    (for-each (lambda (test result)
                                (check test result))
                              (reverse tests)
                              (reverse results)))
                  (print "")))
              (pick-teststrings forms))))

Abaixo estão exemplos de uso de doctests e, em seguinda, a saída da execução dos testes:

#!/usr/bin/csi -script

(load "doctest.scm")

(define (plus a b)
  " Aqui estao os testes
> (plus 3 4)
:  7
> (plus 4 5 0)
: 8
> (plus 4 5)
: 8
"
  (+ a b))


(define (minus a b)
  "
> (minus (plus 3 4) 3)
:  4
> (minus 4 5 0)
:    8
> (minus 4 5)
: 8
"
  (- a b))

(define (sort-list-string l)
  "
> (sort-list-string '(\"b\" \"o\" \"p\" \"h\" \"v\"))
: '(\"b\" \"h\" \"o\" \"p\" \"v\")
"
  (sort l (cut string-ci<? <> <>)))

(define (fatorial n)
  "
> (fatorial 1)
: 1
> (fatorial 2)
: 2
> (fatorial 3)
: 6
> (fatorial 5)
: 120
> (fatorial 10)
: 3
> (plus (fatorial 0) (fatorial 3))
: 7
"
  (if (< n 2)
      1
      (* n (fatorial (sub1 n)))))

(doctest)

A saída da execução dos doctests é mostrada abaixo:

===== plus =====
(plus 3 4) = 7  [ok]
Erro executando (plus 4 5 0) --> Error: bad argument count - received 3 but expected 2: #
(plus 4 5) != 8  [fail]

===== minus =====
(minus (plus 3 4) 3) = 4  [ok]
Erro executando (minus 4 5 0) --> Error: bad argument count - received 3 but expected 2: #
(minus 4 5) != 8  [fail]

===== sort-list-string =====
(sort-list-string (quote (b o p h v))) = (quote (b h o p v))  [ok]

===== fatorial =====
(fatorial 1) = 1  [ok]
(fatorial 2) = 2  [ok]
(fatorial 3) = 6  [ok]
(fatorial 5) = 120  [ok]
(fatorial 10) != 3  [fail]
(plus (fatorial 0) (fatorial 3)) = 7  [ok]

markerpen.el

2010-02-16T05:20:00.000-08:00

markerpen.el é uma extensão interessante para destacar regiões quaisquer de buffers do Emacs. Analogamente, é como destacar o texto de um documento com uma caneta marca-textos (daí o nome markerpen).

Para destacar uma região, basta selecionar a região desejada e executar M-x markerpen-mark-region. Para eliminar o destaque, deve-se selecionar a região e executar M-x markerpen-clear-region. Obviamente, é possível definir atalhos de teclas para esses comandos.

As cores podem ser selecionadas a partir de perfis disponibilizados pela extensão. A seleção é feita através dos comandos M-x markerpenn, onde n é um número de 1 a 10 (há 10 perfis pré-programados).

Cálculo de fatorial através de redirecionamentos de páginas

2010-02-08T14:19:00.000-08:00

Abaixo está uma aplicação absurdamente inútil e sem sentido usando awful: cálculo de fatorial através de redirecionamentos de páginas.

Para calcular o fatorial de 5, por exemplo, basta executar o servidor com a aplicação:

$ awful awful-fatorial.scm

e acessar http://localhost:8080/?n=5 (a entrada de dados é feita através da variável n).

O código está a seguir:

(use awful html-tags html-utils)

(root-path ".")

(define-page (main-page-path)
  (lambda ()
    (let* ((n ($ 'n 0 string->number))
           (current ($ 'current n string->number))
           (accum ($ 'accum 1 string->number))
           (finished? (< current 2)))
      (html-page
       (if finished?
           (<h1> n "! = " accum)
           "")
       headers: (if finished?
                    ""
                    (<meta> http-equiv: "refresh"
                            content: (conc "0;url=?n=" n
                                           "&accum=" (* current accum)
                                           "&current=" (sub1 current)))))))
  no-template: #t)

Suporte a múltiplos bancos de dados para Awful

2010-02-06T10:48:00.001-08:00

A partir da versão 0.10, awful passa a oferecer suporte a múltiplos bancos de dados. Atualmente há suporte para PostgreSQL (através da extensão postgresql) e SQLite3 (através da extensão sqlite3 ou sql-de-lite).

Há uma extensão para cada tipo de base de dados: awful-postgresql, awful-sqlite3 e awful-sql-de-lite. No caso de SQLite3, pode-se optar por usar tanto a extensão sqlite3 ou sql-de-lite (duas extensões diferentes para acesso a bases SQLite3).

A forma de acesso a bases de dados continua praticamente a mesma: através do procedimento $db, o qual faz uso das facilidades oferecidas por awful (conexão transparente, fechamento automático). A única diferença é que agora é necessário carregar a extensão relativa ao tipo de base de dados que pretende-se acessar (e.g., (use awful awful-postgresql)) e usar enable-db como um procedimento sem argumentos, não um parâmetro com argumento booleano, como antes.

Abaixo está um exemplo completo de uma aplicação que gera uma página HTML com uma tabela contendo dados de nome e endereço da tabela users de uma base de dados PostgreSQL:

(use awful awful-sql-de-lite html-utils)

(enable-db)

(db-credentials "db.db")

(define-page (main-page-path)
  (lambda ()
    (tabularize ($db "select name, address from users"))))

Para publicar esta página, basta executar (supondo que o código acima está no arquivo users.scm):

$ awful users.scm

(ficará disponível em http://localhost:8080).

Se um dia for necessário migrar essa base de dados para PostgreSQL, basta usar (use awful-postgresl) em vez de (use awful-sql-de-lite) e ajustar a configuração de credenciais para acesso ao banco (no caso de SQLite3, a credencial é o caminho para o arquivo com a base de dados). Se a estrutura da base de dados não for modificada, e se forem usadas consultas SQL portáveis, o código Scheme não precisará ser alterado.

Opcionalmente, a página pode ser compilada:

$ csc -s users.scm
$ awful users.so

Simples assim. :-)

Woof em Chicken

2010-01-26T10:15:00.000-08:00

Há uns dias li sobre o woof, um programa para compartilhar arquivos via HTTP. A descrição do site é mais detalhada:

I guess everybody with a laptop has experienced this problem at some
point: You plug into a network and just want to exchange files with
other participants. It always is a pain until you can exchange
files with the person vis-a-vis.

Of course there are a lot of tools to tackle this problem. For large
scale communities there are dozens of filesharing networks. However,
they don't work for small local networks. Of course you could put your
stuff to exchange on a local web server, but who really wants to
maintain this? Tools like the ingenious
npush/npoll are
extremely helpful, provided that both parties have it installed,

SAFT/sendfile
also aims to solve this problem, but needs a permanently running daemon...

Woof (Web Offer One File) tries a different approach. It
assumes that everybody has a web-browser or a commandline web-client
installed. Woof is a small simple stupid webserver that can
easily be invoked on a single file. Your partner can access the file
with tools he trusts (e.g. wget). No need to enter
passwords on keyboards where you don't know about keyboard sniffers, no
need to start a huge lot of infrastructure, just do a

$ woof filename

and tell the recipient the URL woof spits out. When he got that
file, woof will quit and everything is done.

Abaixo está uma implementação em setenta e poucas linhas de código em Chicken Scheme, usando o servidor web Spiffy.

#! /usr/bin/csi -s
(use posix srfi-13 spiffy)

(define (woof file count ip-addr port)
  (when port (server-port port))
  (root-path (or (pathname-directory file) (current-directory)))
  (let ((current-count 0)
        (ip-addresses (and ip-addr (string-split ip-addr ",")))
        (file (pathname-strip-directory file)))
    (handle-file
     (lambda (path)
       (if (equal? (pathname-strip-directory path) file)
           (if (or (not ip-addr) (member (remote-address) ip-addresses))
               (let* ((ext (pathname-extension path))
                      (handler (alist-ref ext (file-extension-handlers)
                                          string-ci=? send-static-file)))
                 (set! current-count (add1 current-count))
                 (print "Serving file " file
                        " to " (remote-address)
                        " (count=" current-count ").")
                 (handler path)
                 (when (>= current-count count)
                   (exit 0)))
               (begin

                 (print "Denying access to host " (remote-address) ".")
                 (send-status 403 "Forbidden")))
           (begin
             (print "Denying access to file " path ".")
             (send-status 403 "Forbidden")))))
    (print "Sharing '" file "' with "

           (if ip-addresses
               (string-intersperse ip-addresses ", ")
               "anybody")
           ".")
    (print "URL: http://" (get-host-name) ":" port "/" file)
    (start-server)))

(define (usage #!optional exit-code)
  (display
   (string-append
    (pathname-strip-directory (program-name))
    " [ --port=<port> ] [ --ip-addr=<ip address> ] [ --count=<count> ] file\n")
   (if exit-code (current-error-port) (current-output-port)))
  (when exit-code (exit exit-code)))

(define (cl-option-value option args #!optional (converter identity))
  (let loop ((args args))
    (and (not (null? args))
         (let ((arg (car args)))
           (if (string-prefix? option arg)
               (cond ((string-match (string-append option "=(.*)") arg)
                      => (lambda (m)
                           (converter (cadr m))))
                     (else (loop (cdr args))))
               (loop (cdr args)))))))
         
(let ((args (command-line-arguments)))
  (when (null? args)
    (usage 1))
  (when (or (member "-h" args) (member "--help" args))
    (usage 0))
  (let ((count (cl-option-value "--count" args string->number))
        (ip-addr (cl-option-value "--ip-addr" args))
        (port (cl-option-value "--port" args string->number))
        (file (car (reverse args))))
    (if (file-exists? file)
        (woof file (or count 1) ip-addr port)
        (begin

          (display (string-append file " does not exist.\n")
                   (current-error-port))
          (exit 1)))))

Nem todas as funcionalidades do woof original estão presentes, mas é possível especificar:

o arquivo a ser compartilhado

a porta a ser usada pelo servidor

o número IP da máquina que poderá pegar o arquivo (pode-se liberar o acesso para mais de uma máquina separando os números IP por vírgula)

o número de vezes que o arquivo pode ser acessado

Abaixo está a sintaxe para utilização do woof em Chicken na linha de comando:

$ woof --help                                  
woof [ --port=<port> ] [ --ip-addr=<ip address> ] [ --count=<count> ] file

jsmin para Chicken Scheme

2010-01-23T16:21:00.000-08:00

Há pouco fiz o commit no repositório de extensões do sistema Chicken de uma tradução para Scheme do código C do jsmin, de Douglas Crockford.

A extensão fornece apenas dois procedimentos: jsmin-string e jsmin-file, as quais compactam o código javascript considerando como entrada, respectivamente, uma string e um arquivo.

O código Scheme traduzido de código C (sem uso da FFI) não é dos mais bonitos :-), pois a tradução foi feita praticamente linha-a-linha (inclusive mantendo os returns, implementados através de call/cc).

Programação para a Web com Awful

2010-01-23T03:03:00.000-08:00

Há uns dias comecei a desenvolver mais uma tentativa de tornar a programação para a Web mais "fácil". O resultado é uma extensão para o sistema Chicken (versão 4) que fornece as seguintes funcionalidades:

Interfaces simples para o uso de bases de dados Postgresql

Suporte a Ajax através da biblioteca JQuery

Acesso fácil às variáveis de requisições HTTP (tanto da query string (método GET) quando do corpo da requisição (e.g., método POST)

Flexibilidade: há vários parâmetros de configuração

A compilação de páginas para código nativo para a plataforma alvo é fácil

Disponibilidade de um visualizador de sessão

Disponibilidade de um REPL que pode ser acessado através do navegador (via HTTP) para a depuração de aplicações para a web

Tentei fazer uma documentação razoável, que cobrisse boa parte da implementação. Ela está em http://chicken.wiki.br/eggref/4/awful. Na documentação podem ser vistos exemplos de aplicações simples que demonstram algumas das funcionalidades.

Sobre o nome: é só um nome. :-) Em http://chicken.wiki.br/eggref/4/awful#the-name há algumas possíveis interpretações caso AWFUL fosse uma sigla.

Introspecção de módulos em Chicken Scheme

2009-12-10T14:15:00.000-08:00

Abaixo está um pequeno procedimento para inspecionar símbolos de módulos importados no sistema Chicken (para a versão 4). É semelhante à função dir de Python.

(define (introspect #!optional symbol)
  (if symbol
      (let ((module-data (alist-ref symbol ##sys#module-table)))
        (if module-data
            (let-values (((_ module-symbols _) (##sys#module-exports module-data)))
              (map car module-symbols))
            (let loop ((syms (##sys#current-environment)))
              (if (null? syms)
                  '()
                  (let* ((sym/sym+prefix (car syms))
                         (sym+prefix (symbol->string (cdr sym/sym+prefix)))
                         (tokens (string-split sym+prefix "#" #t))
                         (prefix (car tokens)))
                    (if (equal? (->string symbol) prefix)
                        (cons (string->symbol (string-intersperse (cdr tokens) ""))
                              (loop (cdr syms)))
                        (loop (cdr syms))))))))
      (map car (##sys#current-environment))))

Exemplos de uso

$ csi -n

CHICKEN
(c)2008-2009 The Chicken Team
(c)2000-2007 Felix L. Winkelmann
Version 4.2.0 - SVN rev. 16023
linux-unix-gnu-x86 [ manyargs dload ptables applyhook ]
compiled 2009-10-20 on dellito (Linux)

#;1> ,l introspection.scm
; loading introspection.scm ...
#;1> (introspect)
()
#;2> (import html-utils)
; loading /usr/local/chicken-4.2.0/lib/chicken/4/html-utils.import.so ...
; loading /usr/local/chicken-4.2.0/lib/chicken/4/chicken.import.so ...
; loading /usr/local/chicken-4.2.0/lib/chicken/4/scheme.import.so ...
; loading /usr/local/chicken-4.2.0/lib/chicken/4/files.import.so ...
; loading /usr/local/chicken-4.2.0/lib/chicken/4/data-structures.import.so ...
; loading /usr/local/chicken-4.2.0/lib/chicken/4/srfi-13.import.so ...
; loading /usr/local/chicken-4.2.0/lib/chicken/4/posix.import.so ...
; loading /usr/local/chicken-4.2.0/lib/chicken/4/utils.import.so ...
; loading /usr/local/chicken-4.2.0/lib/chicken/4/html-tags.import.so ...
; loading /usr/local/chicken-4.2.0/lib/chicken/4/srfi-1.import.so ...
#;3> (introspect 'html-utils)
(tabularize itemize enumerate html-page combo-box hidden-input)
#;4> (introspect 'srfi-1)
(alist-cons alist-copy alist-delete alist-delete! any append! append-map append-map!
append-reverse append-reverse! assoc break break! car+cdr circular-list circular-list? 
concatenate concatenate! cons* count delete delete! delete-duplicates delete-duplicates! 
dotted-list? drop drop-right drop-right! drop-while eighth every fifth filter filter! filter-map 
find find-tail first fold fold-right fourth iota last last-pair length+ list-copy list-index 
list-tabulate list= lset-adjoin lset-diff+intersection lset-diff+intersection! lset-difference 
lset-difference! lset-intersection lset-intersection! lset-union lset-union! lset-xor lset-xor! 
lset<= lset= make-list map map! map-in-order member ninth not-pair? null-list? pair-fold 
pair-fold-right pair-for-each partition partition! proper-list? reduce reduce-right remove 
remove! reverse! second seventh sixth span span! split-at split-at! take take! take-right 
take-while take-while! tenth third unfold unfold-right unzip1 unzip2 unzip3 unzip4 unzip5 xcons 
zip)

Opções utilizadas nos diferentes níveis de otimização do GCC

2009-12-01T16:00:00.000-08:00

Hoje surgiu uma dica interessante na lista de discussão do GCC. Está reproduzida abaixo:

From: "John (Eljay) Love-Jensen"
Subject: Re: How can I find out which optimizing techniques were used for  each function?
To: Byoungyoung Lee, GCC-help 
Date: Tue, 1 Dec 2009 04:51:11 -0800

Hi Byoungyoung Lee,

> Is there anyway in gcc to log the information about which compiler
> options were actually used to optimize each function?
> For example, if I compile a program with option -O3, how could I
> figure out which specific options (such as -funroll-loops or something
> like that) were used to optimize function X ?

I use this technique:

echo '' | gcc -O3 -fverbose-asm -S -xc - -o O3.s
cat O3.s

In the created O3.s assembly source comment, it mentions which flags were
enabled by the -O3 switch.

If you want a detailed assembly line-by-line diagnostic of which particular
optimization was used for a given algorithm, you'll have to do some more
sleuthing.

Such as using -fno-<flag> to disable all the flags, and enable them
one-by-one.

Or perhaps by dumping the compiler state after each optimization pass (which
I think is usually only used as a diagnostic aid for making changes to GCC
itself).

Also, the majority of optimizations do not have a toggle-able flag to
enable/disable them.  As I understand it...  -O1 enables a whole lot of
optimizations that do not have toggle-able flags.  -O2 enables a few more.
-O3 enables one-or-two more.

HTH,
--Eljay

Indentação de and-let* no Emacs

2009-12-01T15:49:00.000-08:00

A indentação padrão do Emacs para a expressão and-let* não é das melhores. Abaixo está a expressão a ser avaliada no Emacs para fazer com que a indentação padrão de and-let* (Figura 1) fique como a da Figura 2:

(put 'and-let* 'scheme-indent-function 1)

Suporte a versionamento de bibliotecas de carga dinâmica para Chicken 4.2.0

2009-11-24T09:19:00.000-08:00

Coloquei em http://parenteses.org/mario/misc/chicken-4.2.0-soname.patch um patch para a versão estável mais recente do sistema Chicken (4.2.0). Este patch recoloca o suporte a versionamento das bibliotecas de carga dinâmica usadas pelo runtime. Isso permite que várias versões do sistema Chicken convivam pacificamente quando instaladas no mesmo sistema operacional (i.e., o compilador de uma versão não tentará usar bibliotecas de carga dinâmica do compilador de outra versão).

O patch é, na verdade, um backport do suporte que existe na versão de desenvolvimento do sistema Chicken para a versão estável mais recente. A versão 4.3.0 deverá sair com esta correção.

Corrigindo o Sawfish no Ubuntu 9.10

2009-11-18T13:54:00.000-08:00

Lamentavelmente, a versão do Sawfish fornecida pelo Ubuntu 9.10 contém um bug. Felizmente, há uma forma fácil de corrigi-lo. Abaixo está uma receita de bolo:


1. $ sudo apt-get source sawfish
2. $ sudo apt-get build-dep sawfish
3. $ cd sawfish-1.3.5.2
4. $ wget http://parenteses.org/mario/misc/sawfish-patch.diff
5. $ patch -p1 --ignore-whitespace < sawfish-patch.diff
6. $ dpkg-buildpackage -rfakeroot -uc -b
7. $ sudo dpkg -i ../sawfish_1.3.5.2-1_i386.deb

O passo 1 instala os fontes do pacote do sawfish.

O passo 2 instala os pacotes necessários para a compilação do sawfish.

O passo 3 é óbvio.

O passo 4 baixa o patch a ser aplicado para que o sawfish passe a funcionar (é o patch disponível em http://sawfish.wikia.com/wiki/Fix_sawfish_server_connection).

O passo 5 aplica o patch nos fontes do sawfish.

O passo 6 compila o código corrigido e gera os pacotes (.deb).

O passo 7 instala o pacote com o sawfish corrigido.

Com isso, os programas sawfish-client e sawfish-ui passam a funcionar normalmente.


$ sawfish-client 
sawfish 1.3.5.2, Copyright (C) 1999-2000 John Harper
sawfish comes with ABSOLUTELY NO WARRANTY; for details see the file COPYING

Enter `,help' to list commands.
user>

Don't cross my way

2009-11-07T09:22:00.000-08:00

Na semana passada o Eduardo me enviou a versão final da música que gravou mais recentemente (Don't Cross My Way). A composição e as gravações de guitarra e vocal foram feitas por ele. A bateria foi gravada pelo Fábio Cruz (Tela), a gaita pelo Mateus Brod e o baixo por mim.

A música está disponível na página do Eduardo no MySpace.

Jogo para iPhone em Scheme

2009-10-24T12:15:00.000-07:00

O Scheme hacker Alex Queiroz implementou o jogo Reverso para iPhone. Os comentários de Alex sobre a implementação do jogo estão em http://www.ventonegro.org/2009/10/scheme-hits-the-app-store/.

Certamente uma aplicação muito interessante da linguagem. Alex utilizou a implementação Gambit (assim como Chicken, compila Scheme para C) e diz que o código resultante é 90% Scheme e 10% Objective-C.

web-scheme para Chicken 4

2009-09-03T15:56:00.000-07:00

Vou aproveitar a transição de versões do sistema Chicken (versão 3 -> versão 4, com algumas incompatibilidades) para lançar uma versão nova de web-scheme, totalmente incompatível com a versão anterior (para Chicken 3). Eu mesmo provavelmente serei o maior prejudicado pelas incompatibilidades. Sem exagero, devo ter algumas dezenas de milhares de linhas de código usando web-scheme e Chicken 3. Mas o momento é esse.

Se bem me lembro, a extensão web-scheme foi lançada em 2005 e, desde então, venho pensando em algumas melhorias que só podem ser implementadas quebrando a compatibilidade com versões anteriores. Como Chicken 4 de certa forma faz isso, vou aproveitar a onda. :-)

As duas maiores modificações são sintáticas.

Uma das coisas que me incomodam em web-scheme para Chicken 3 é o mapeamento direto de nomes de tags para procedimentos. Inicialmente me pareceu uma boa idéia, e na maioria dos casos é, mas há situações que tornam esse aspecto inconveniente. Por exemplo, o procedimento equivalente à tag map, deveria, a rigor, ser map. Obviamente isso causa problemas em Scheme.

Casos semelhantes ocorrem com tags com nomes muito usuais como select (Chicken define uma macro com esse nome), title, i ou object.

Em Chicken 4 há a possibilidade de se importar um módulo prefixando símbolos do módulo importado. Então, por exemplo, seria possível importar o módulo web-scheme prefixando os procedimentos por ws:. Nos casos como o do procedimento map, não usar um prefixo seria suicídio. É difícil algum código em Scheme não fazer uso de map. web-scheme para Chicken 3 coloca "de fábrica" o prefixo ws: nos procedimentos map e select, para evitar conflito de nomes com os respectivos procedimento e macro correspondentes. Isso já é meio feio em Chicken 3, em que não há uma forma direta para se importar uma biblioteca de extensão com um prefixo -- em Chicken 4 seria muito feio, pois se o usuário decide prefixar os símbolos do módulo, ficarão dois prefixos para map e select!

Decidi, então, modificar o nome de todos os procedimentos correspondentes a tags HTML e usar uma notação semelhante à usada por Hop. Assim, em vez de (pre "texto"), tem-se (<pre> "texto").

Não estou totalmente satisfeito com esta notação, pois é conflitante com a convenção de nomes de classes quando se usa um sistema de objetos. Em Scheme não chega a ser um grande problema, pois o uso de classes não é muito usual. Em Common Lisp essa decisão seria mais problemática, pois CLOS é bastante usado. Optei por essa sitaxe porque claramente lembra a sintaxe de tags HTML e provavelmente desenvolvedores para a Web associarão <pre> à tag pre de HTML e não à classe pre de algum código parte de um sistema de objetos.

A outra modificação é com relação à sintaxe para atributos e valores de atributos de tags. Em web-scheme para Chicken 3 usa-se da seguinte forma:

(a 'href "http://minha-url.com" "Minha URL")

Em web-scheme para Chicken 4 decidi usar parâmetros por palavra-chave para representar atributos. Fica, então, assim:

(<a> href: "http://minha-url.com" "Minha URL")

As razões para esta mudaça são puramente técnicas. No esquema usado em web-scheme para Chicken 3, precisei implementar um parser para extrair atributos e seus respectivos valores. Usando parâmetros por palavra-chave, ganho o parser "de brinde" de Chicken, melhor e mais rápido.

O esquema de atributos usado por web-scheme para Chicken 3 tem uma limitação chata quando espera-se poder usar ou não atributos em função do fluxo de execução do código. Exemplo: no caso de um procedimento text-input como um wrapper para o elemento input de tipo texto:

(define (text-input text #!key maxlength)
     (if maxlength
       (input 'type "text" 'maxlength maxlength 'value text)
       (input 'type "text" 'value text)))

Em web-scheme para Chicken 3 não há uma forma "fácil" (i.e., sem eval ou macros) de fazer isso sem duplicar código. Em web-scheme para Chicken 4 bastará:

(define (text-input text #!key maxlength)
    (<input> type: "text" maxlength: maxlength value: text)

O uso de parâmetros por palavra-chave dá essa flexibilidade, o que é tratado internamente pelo código que gera o HTML. Se o valor de um parâmetro for #f o par atributo/valor não é gerado. Em web-scheme para Chicken 3 geraria uma certa complicação nos casos de atributos que não requerem valor, como selected em elementos select.

Essas serão as modificações mais radicais. Haverá também modificações nos procedimentos extras de web-scheme, os quais não estão diretamente relacionados ao mapeamento tags->procedimentos. Mas essa parte ainda está em estudo.

Fatiamento de seqüências em Scheme

2009-07-29T17:53:00.000-07:00

Python oferece uma funcionalidade interessante para ser usadas com seqüências (string, listas e qualquer objeto com o método __getslice__, suponho). O fatiamento de Python admite índices negativos, omissão de índices e índices maiores que o tamanho da seqüência.

Exemplos:

>>> "abcdef"[3:6]
'def'
>>> [1, 2, 3, 4, 5][:3]
[1, 2, 3]
>>> [1,2,3,4,5][:-3]
[1, 2]
>>> [1,2,3,4,5][-3:]
[3, 4, 5]
>>> [1,2,3,4,5][-10:]
[1, 2, 3, 4, 5]

A seguir está uma implementação de algo parecido para Chicken, que funciona com listas, vetores, strings e permite a adição de fatiadores personalizados para o procedimento slice.

#!/usr/bin/csi -script

(use (srfi 1 13))

(define slice
 (let ()
   (define (positive? n) (> n 0))
   (define (negative? n) (< n 0))
   (define (both-positive? n m) (and n m (>= n 0) (>= m 0)))
 
   (define (from/to from to len)
     (cond
      ((and from (> from len))         ; [XXX:2]
        #f)
      ((and (both-positive? from to)   ; [1:2]
             from to
            (> to from)
            (< to len))
       (cons from to))
      ((and (both-positive? from to)   ; [1:XXX]
             from to
            (> to from)
            (>= to len))
       (cons from len))
      ((and (both-positive? from to)   ; [2:1]
             from to
            (> from to))
       #f)
      ((and from                       ; [-1:]
             (< from 0)
            (not to))
       (cons (if (>= (abs from) len)
                 0
                 (+ len from))
             len))
      ((and (not from)                 ; [:-1]
             to
            (< to 0))
       (cons 0
             (if (>= (abs to) len)
                 len
                 (+ len to))))
      ((and from                       ; [1:]
             (>= from 0)
            (not to))
       (cons from len))
      ((and from to                    ; [-2:-1]
             (< from 0)
            (< to 0)
            (< to from))
       #f)
      ((and from to                    ; [-1:-2]
             (< from 0)
            (< to 0))
       (cons (if (>= (abs from) len)
                 0
                 (+ len from))
             (if (>= (abs to) len)
                 len
                 (+ len to))))      
      (else #f)))

   (define (generic-slicer obj from to ruler empty obj-slicer)
     (let* ((len (ruler obj))
            (from&to (from/to from to len))
            (from (and from&to (car from&to)))
            (to (and from&to (cdr from&to))))
       (if (and from to)
           (obj-slicer obj from to)
           empty)))

   (define (string-slice s from to)
     (generic-slicer s from to string-length "" substring))

   (define (list-slice l from to)
     (generic-slicer l from to length '()
                     (lambda (l from to)
                       (take (drop l from) (- to from)))))

   (define (vector-slice v from to)
     (define (subvector vector start end)
       (let ((sub (make-vector (- end start))))
         (let loop ((i 0))
           (if (< i (- end start))
               (begin (vector-set! sub i (vector-ref vector (+ i start)))
                      (loop (+ i 1)))))
         sub))
     (generic-slicer v from to vector-length '#() subvector))


   (let ((slicers
          (list (lambda (obj)
                  (and (string? obj)
                       string-slice))
                (lambda (obj)
                  (and (vector? obj)
                       vector-slice))
                (lambda (obj)
                  (and (list? obj)
                       list-slice)))))
     (lambda (obj #!optional from to)
       (if (procedure? obj)
           (set! slicers (cons obj slicers))
           (let loop ((slicers slicers))
             (if (null? slicers)
                 (error "No slicer for the given object.")
                 (let* ((slicer (car slicers))
                        (slice (slicer obj)))
                   (if slice
                       (slice obj from to)
                       (loop (cdr slicers)))))))))))

Abaixo está o arquivo de teste do código de fatiamento (usando a extensão test), o qual também serve como exemplo de uso.

#!/usr/bin/csi -script

(use test)

(load "slice.scm")

;;;
;;; Strings
;;;
(define s "1234567")

(display "s = ")
(pp s)
(test "" (slice s 0 0))
(test "" (slice s 1 0))
(test "1" (slice s 0 1))
(test "" (slice s 10 10))
(test "1234567" (slice s 0 10))
(test "" (slice s 10 0))

(test "1234567" (slice s 0))
(test "7" (slice s -1))
(test "" (slice s 10))
(test "1234567" (slice s -10))
(test "4567" (slice s -4))

(test "" (slice s -4 -4))
(test "45" (slice s -4 -2))
(test "" (slice s -4 -10))
(test "123" (slice s -10 -4))


;;;
;;; Lists
;;;
(define l '(1 2 3 4 5 6 7))

(newline)
(display "l = ")
(pp l)

(test '() (slice l 0 0))
(test '() (slice l 1 0))
(test '(1) (slice l 0 1))
(test '(2 3) (slice l 1 3))
(test '() (slice l 10 10))
(test '(1 2 3 4 5 6 7) (slice l 0 10))
(test '() (slice l 10 0))

(test '(1 2 3 4 5 6 7) (slice l 0))
(test '(7) (slice l -1))
(test '() (slice l 10))
(test '(1 2 3 4 5 6 7) (slice l -10))
(test '(4 5 6 7) (slice l -4))

(test '() (slice l -4 -4))
(test '(4 5) (slice l -4 -2))
(test '() (slice l -4 -10))
(test '(1 2 3) (slice l -10 -4))

;;;
;;; Vectors
;;;
(define v '#(1 2 3 4 5 6 7))

(newline)
(display "v = ")
(pp v)

(test '#() (slice v 0 0))
(test '#() (slice v 1 0))
(test '#(1) (slice v 0 1))
(test '#(2 3) (slice v 1 3))
(test '#() (slice v 10 10))
(test '#(1 2 3 4 5 6 7) (slice v 0 10))
(test '#() (slice v 10 0))

(test '#(1 2 3 4 5 6 7) (slice v 0))
(test '#(7) (slice v -1))
(test '#() (slice v 10))
(test '#(1 2 3 4 5 6 7) (slice v -10))
(test '#(4 5 6 7) (slice v -4))

(test '#() (slice v -4 -4))
(test '#(4 5) (slice v -4 -2))
(test '#() (slice v -4 -10))
(test '#(1 2 3) (slice v -10 -4))

;;;
;;; Custom object
;;;
(define-record custom-string text)

(define s (make-custom-string "custom string"))
(slice (lambda (obj)
        (and (custom-string? obj)
             (lambda (obj from to)
               (handle-exceptions
                exn
                ""
                (substring (custom-string-text obj) from to))))))

(newline)
(display "s = ")
(pp s)

(test "" (slice s 0 0))
(test "" (slice s 1 0))
(test "c" (slice s 0 1))

A seguir está a saída da execução do programa de teste:

s = "1234567"
(slice s 0 0) .................................. [ PASS]
(slice s 1 0) .................................. [ PASS]
(slice s 0 1) .................................. [ PASS]
(slice s 10 10) ................................ [ PASS]
(slice s 0 10) ................................. [ PASS]
(slice s 10 0) ................................. [ PASS]
(slice s 0) .................................... [ PASS]
(slice s -1) ................................... [ PASS]
(slice s 10) ................................... [ PASS]
(slice s -10) .................................. [ PASS]
(slice s -4) ................................... [ PASS]
(slice s -4 -4) ................................ [ PASS]
(slice s -4 -2) ................................ [ PASS]
(slice s -4 -10) ............................... [ PASS]
(slice s -10 -4) ............................... [ PASS]

l = (1 2 3 4 5 6 7)
(slice l 0 0) .................................. [ PASS]
(slice l 1 0) .................................. [ PASS]
(slice l 0 1) .................................. [ PASS]
(slice l 1 3) .................................. [ PASS]
(slice l 10 10) ................................ [ PASS]
(slice l 0 10) ................................. [ PASS]
(slice l 10 0) ................................. [ PASS]
(slice l 0) .................................... [ PASS]
(slice l -1) ................................... [ PASS]
(slice l 10) ................................... [ PASS]
(slice l -10) .................................. [ PASS]
(slice l -4) ................................... [ PASS]
(slice l -4 -4) ................................ [ PASS]
(slice l -4 -2) ................................ [ PASS]
(slice l -4 -10) ............................... [ PASS]
(slice l -10 -4) ............................... [ PASS]

v = #(1 2 3 4 5 6 7)
(slice v 0 0) .................................. [ PASS]
(slice v 1 0) .................................. [ PASS]
(slice v 0 1) .................................. [ PASS]
(slice v 1 3) .................................. [ PASS]
(slice v 10 10) ................................ [ PASS]
(slice v 0 10) ................................. [ PASS]
(slice v 10 0) ................................. [ PASS]
(slice v 0) .................................... [ PASS]
(slice v -1) ................................... [ PASS]
(slice v 10) ................................... [ PASS]
(slice v -10) .................................. [ PASS]
(slice v -4) ................................... [ PASS]
(slice v -4 -4) ................................ [ PASS]
(slice v -4 -2) ................................ [ PASS]
(slice v -4 -10) ............................... [ PASS]
(slice v -10 -4) ............................... [ PASS]

s = #<custom-string>
(slice s 0 0) .................................. [ PASS]
(slice s 1 0) .................................. [ PASS]
(slice s 0 1) .................................. [ PASS]

Spam via telefone

2009-07-29T17:11:00.000-07:00

Como se não bastasse a praga de spams que assola o mundo dos e-mails, há algum tempo venho recebendo propagandas não solicitadas da própria companhia telefônica (TIM) -- tanto através de SMS como, ultimamente, por ligações e mensagens de voz.

Hoje decidi ligar para a TIM para ver se conseguia me livrar desse transtorno. O atendente me disse que não é possível desativar esse "serviço" e sugeriu que eu mandasse um e-mail para a ouvidoria TIM, cujo endereço estaria disponível no site da empresa. Quando eu disse que não faria por medo de começar a receber spam da TIM por e-mail também, ele mesmo deu uma risada discreta, como se estivesse pensando "ele tem razão, é muita burrice fazer isso".

Do fundo do baú

2009-05-21T17:02:00.001-07:00

Em algum outro baú, mais fundo, devo ter as apostilas dos cursos. :-)

Disparador de programas para Sawfish

2009-05-07T19:10:00.000-07:00

Havia tempos que eu queria um disparador de aplicações para usar com o Sawfish. Nunca tinha encontrado um que tivesse me agradado. Basicamente, gostaria de um que fosse simples, permitisse completar o nome de programas com TAB, que fosse rápido e que não ocupasse muita memória. Com uma rápida pesquisa na Internet, achei o código em http://www.skamphausen.de/cgi-bin/ska/download/runner.jl, o qual faz exatamente o que eu queria e satisfaz todos os meus requisitos: como é implementado em rep, não é preciso nem criar um novo processo; e a implementação é minúscula.

Depois de uma leve refatorada no código, estou usando o seguinte:

(require 'prompt)

(define (uniq l #!optional in)
  ;; Elimina replicas na lista L usando o procedimento IN para
  ;; verificar se um dado elemento se encontra na lista.
  (let ((unique '()))
    (let loop ((l l))
      (if (null l)
          unique
          (let ((head (car l)))
            (unless ((or in member) head unique)
              (setq unique (cons head unique)))
            (loop (cdr l)))))
    (reverse unique)))

(define runner
  (let* ((paths (uniq (delete-if-not file-directory-p
         (string-split ":" (getenv "PATH")))))
  (completions (uniq (apply append (mapcar directory-files paths)))))
    (lambda ()
      (interactive)
      (let ((cmd (prompt-from-list completions "Run: " "" t)))
 (system (concat cmd " &"))))))

Adicionei o procedimento uniq para eliminar eventuais réplicas na lista de comandos. Ela é mais flexível que uniquify-list, do Sawfish (a comparação é feita exclusivamente usando eq). uniq aceita um argumento opcional que é o procedimento de comparação (em caso de omissão, usa member).

O procedimento runner monta uma lista de elementos para serem usados como possíveis alternativas para completar palavras digitadas pelo usuário (tab completion), a qual é usada por prompt-from-list, do módulo prompt. As alternativas são os arquivos nos diretórios apontados pela variável de ambiente PATH.

Associei o procedimento runner à combinação de teclas H-RET (Hyper-Enter):

(bind-keys global-keymap
...
   "H-RET"  (lambda () (runner))
...)

A seguir está um screenshot:

O prompt criado pelo procedimento prompt-from-list define um mapa de teclas. Assim, quando em uso, o prompt aceita as seguintes combinações de teclas associadas a procedimentos (de prompt.jl, so Sawfish):

(bind-keys prompt-keymap
     "ESC" prompt-exit
     "C-g" prompt-exit
     "C-u" prompt-clear
     "BS" prompt-backspace
     "C-k" prompt-kill-line
     "Left" prompt-backward-character
     "C-b" prompt-backward-character
     "Right" prompt-forward-character
     "C-f" prompt-forward-character
     "C-Left" prompt-backward-word
     "M-b" prompt-backward-word
     "A-b" prompt-backward-word
     "C-Right" prompt-forward-word
     "M-f" prompt-forward-word
     "A-f" prompt-forward-word
     "C-a" prompt-beginning-of-line
     "C-e" prompt-end-of-line
     "TAB" prompt-complete
     "RET" prompt-accept
     "Up" prompt-previous
     "Down" prompt-next
     "M-n" prompt-next
     "M-p" prompt-previous
     "A-n" prompt-next
     "A-p" prompt-previous))

Sawfish

2009-04-26T08:24:00.000-07:00

O Sawfish é um dos softwares da lista dos que eu não gostaria de parar de usar. Assim como o Emacs, é o tipo de software que, depois que se entende e aprende a usar, é difícil de largar.

O Sawfish durante algum tempo foi o gerenciador de janelas do ambiente de desktop Gnome. Por razões ainda não muito claras para mim, foi substituído pelo Metacity.

Assim como o Emacs, um dos grandes diferenciais do Sawfish é o fato de ser programável em uma linguagem de alto nível da família Lisp. Sawfish usa a linguagem rep (Read, Eval, Print), a qual inicialmente foi inspirada por Elisp (Emacs Lisp). A concepção do Sawfish segue a mesma linha do Emacs: prover uma API em uma linguagem de alto nível para desenvolvimento voltado às aplicações a que se destina (abstração). Manipulação de texto no caso do Emacs e gerenciamento de janelas no caso do Sawfish. Com base na API de alto nível, os aplicativos são desenvolvidos. Assim são desenvolvidos o Emacs e o Sawfish. A maior parte do código do Emacs é em Elisp e a maior parte do código do Sawfish é em rep.

O fato de prover uma API para desenvolvimento em uma linguagem de alto nível faz com que o Sawfish seja altamente (e facilmente!) personalizável e extensível. Além das possibilidades de configuração e extensão através de código em rep, Sawfish também dispõe de um configurador gráfico, o qual, por baixo dos panos, apenas gera e executa código rep para configurar o gerenciador de janelas (similar à interface para personalização do Emacs).

Seguindo a tradição de linguagens Lisp e de aplicativos que usam Lisp como linguagem de extensão/implementacao, Sawfish também oferece um REPL para avaliação de expressões rep. Abaixo está um exemplo de sessão com o REPL do Sawfish:

$ sawfish-client
sawfish 1.3.3, Copyright (C) 1999-2000 John Harper
sawfish comes with ABSOLUTELY NO WARRANTY; for details see the file COPYING

Enter `,help' to list commands.
user> (define emacs (get-window-by-name-re "emacs.*"))
user> emacs
#<window 1e00011>
user> (window-name emacs)
"emacs@mandolate"
user> (window-visible-p emacs)
t
user> (window-iconified-p emacs)
()
user> (window-dimensions emacs)
(798 . 742)
user> (window-border-width emacs)
0
user> (window-framed-p emacs)
t
user> (window-depth emacs)
0
user> (window-absolute-position emacs)
(68 . 0)
user> (window-sticky-p emacs)
()
user> (move-window-to emacs 200 100)
#<window 1e00011>
user> (window-absolute-position emacs)
(200 . 100)

O Manual de Programação do Sawfish documenta a API para programação e extensão do gerenciador de janelas.

Abaixo está um screenshot com temas pouco usuais do sawfish (cada janela pode ser decorada com um tema diferente).

A seguir está um exemplo de aplicação feita na linguagem de extensão do Sawfish. Os aplicativos no canto superior esquerdo da tela são dockapps (aqui há vários deles). Quando um dockapp é executado em um gerenciador de janelas sem suporte a dock, o aplicativo é mostrado como uma janela normal, com bordas, decorações e respondendo a eventos como qualquer outra janela. Quando o gerenciador de janelas oferece suporte a dockapps, ou quando se usa um programa externo para gerenciar dockapps, eles são mostrados como no screenshot e têm comportamento diferenciado (são exibidos em todas as áreas de trabalho, não são cobertos por outras janelas quando elas são maximizadas etc).

A extensão para gerenciamento de dockapps pode ser obtida em http://paginas.ucpel.tche.br/~mario/english/utils/sawdock/.

Criptografia simples (ingênua)

2009-04-24T18:54:00.000-07:00

A seguir está um esquema simples de criptografia para autenticação em páginas web. Não é um esquema seguro e não envolve chaves públicas (criptografia de chaves assimétricas).

O esquema consiste em apresentar para o usuário uma matriz de números aleatórios (puzzle) para que ele possa dali extrair o texto a ser enviado para ser validado. A cada acesso à pagina uma matriz aleatória nova é exibida. Somente o usuário e o software para valição de senha sabem o segredo (chave) para determinar se a senha está ou não correta.

Na implementação mostrada a seguir (em Chicken Scheme), o código para valição de senha verifica se:

a senha possui quatro caracteres

o primeiro caractere da senha é igual ao caractere do canto superior esquerdo da matriz de números

o segundo caractere da senha é igual ao caractere do canto superior direito da matriz de números

o terceiro caractere da senha é igual ao caractere do canto inferior esquerdo da matriz de números

o quarto caractere da senha é igual ao caractere do canto inferior direito da matriz de números

Ou seja, o validador verifica se a senha corresponde aos números dos quatro cantos da matriz números concatenados no sentido horário, começando pelo canto superior esquerdo.

Obviamente o validador de senha é dos mais simples, mas poderia usar técnicas mais elaboradas como, por exemplo, o código de Beale. Neste caso, o validador teria um texto padrão, o qual seria de conhecimento do usuário, e os números da matriz indicariam a posição das letras no texto. Assim, o usuário digitaria as letras correspondentes às posições do texto indicadas em lugares pré-determinados da matriz (o uso da matriz é uma otimização sobre o código de Beale -- originalmente seriam apresentados apenas os números indicando a posição das letras no texto).

O código de servidor web (extensão spiffy de Chicken) está abaixo (web-server.scm):

#!/usr/bin/csi -script

(use spiffy spiffy-utils web-scheme web-scheme-handler (srfi 1 13))

(spiffy-file-ext-handlers `(("ws" . ,web-scheme-handler)))
(spiffy-tcp-port 8080)
(spiffy-root-path "./")

(start-server)

A implementação do esquema de autenticação está a seguir (index.ws):

(define (make-puzzle)
  ;; Retorna uma lista de listas de numeros aleatorios entre 0 e 9
  ;; (inclusive 0 e 9).
  (let* ((line-length 40)
         (num-columns 10)
         (random-line
          (lambda ()
            (map (lambda (_) (random 10))
                 (iota line-length)))))
    (map (lambda (_)
           (random-line))
         (iota num-columns))))

(define (valid-passwd? passwd puzzle)
  ;; Chave (ingenua): a senha corresponde aos numeros dos cantos da
  ;; tabela de numeros concatenados no sentido horario, comecando pelo
  ;; canto superior esquerdo.

  (define ($ pos)
    ;; Retorna o caractere da posicao POS em PASSWD, ou #f se POS nao
    ;; existir em PASSWD.
    (handle-exceptions exn #f (->string (string-ref passwd pos))))

  (define (check pw-pos key-pos)
    (equal? ($ pw-pos) (number->string key-pos)))
    
  (and passwd
       (= (string-length passwd) 4)
       (check 0 (caar puzzle))
       (check 1 (last (car puzzle)))
       (check 2 (car (last puzzle)))
       (check 3 (last (last puzzle)))))

(define (auth-page #!optional preamble)
  ;; Pagina de autenticacao.
  (ws:page
   (let ((puzzle (make-puzzle)))
     (center
      (if preamble (p preamble) "")
      (ws:make-table puzzle)
      (form 'method "post"
            (input 'type "hidden" 'name "puzzle"
                   'value (with-output-to-string (cut pp puzzle)))
            (input 'type "password" 'name "passwd")
            (input 'type "submit"))))))

(let ((passwd (post-var "passwd"))
      (puzzle (post-var "puzzle")))
  (if (and puzzle passwd)
      (if (valid-passwd? passwd (with-input-from-string puzzle read))
          (ws:page "Senha correta")
          (auth-page "Senha errada!"))
      (auth-page)))

Camiseta do projeto Chicken!

2009-04-24T15:47:00.000-07:00

Há umas semanas, Felix Winkelmann, autor e principal desenvolvedor do projeto Chicken Scheme, gentilmente me enviou um e-mail informando que me mandaria uma camiseta do projeto Chicken. Hoje, para a minha felicidade, recebi a camiseta. Muito bonita. :-)

Um tempo atrás tentei fazer uma camiseta dessas no site http://www.camisaonline.com.br/ mas fui roubado. Efetuei o pagamento e nunca recebi a camiseta nem resposta para os vários e-mails que enviei para o endereço de contato. Não comprem desse site.

Definição de procedimentos e return explícito

2009-03-30T19:14:00.000-07:00

A seguir está um pequeno hack em Chicken Scheme usando procedimento de escape (via call/cc) e definição de macros ao estilo de Common Lisp. No final das contas, tem-se definições de função como em Python ou Ruby, incluindo return explícito (para os masoquistas).

(define-macro (def procname args . body)
  `(define (,procname ,@args)
     (call/cc (lambda (return)
                ,@body))))

Exemplo de uso (considerando programadores de linguagens cujo if não passa seu resultado para a sua continuação):

(def fatorial(n)
     (if (< n 2)
         (return 1)
         (return (* n (fatorial (sub1 n))))))

Exemplo de uso (considerando um schemer sendo obrigado a usar return):

(def fatorial(n)
     (return (if (< n 2)
                 1
                 (* n (fatorial (sub1 n))))))

Código equivalente em Scheme puro:

(define (fatorial n)
  (if (< n 2)
      1
      (* n (fatorial (sub1 n)))))

Americanas: "inconsistências"

2008-12-09T06:26:00.001-08:00

Há umas semanas tentei comprar um notebook das Americanas. Um dia após eu ter feito o pedido, recebo um e-mail pedindo para enviar dados a serem avaliados pela instituição financeira responsável pelo meu cartão de crédito. No mesmo dia respondi o e-mail com as informações solicitadas (com as mesmas informações que usei em compras feitas nas Americanas anteriormente).

Dois dias depois recebo um e-mail indicando que as informações haviam sido recebidas e que a análise demoraria até 36h. Depois de mais dois dias recebo um e-mail informando que o pedido havia sido suspenso devido a inconsistência de informações na sua compra e também à ausência de contato nossa Central de Atendimento. Ressalto que respondi todas as requisições de contato e pedidos de informações que a mim chegaram.

Via e-mail, tentei obter informações sobre a razão da suspensão do pedido, mas não obtive resposta.

Hoje fui ver a fatura do meu cartão de crédito e percebi que o valor da parcela da compra havia sido debitado. É claro, ficou a dúvida: se as informações eram inconsistentes para efetuar a compra, por que não eram inconsistentes para fazer a cobrança?

Tentei fazer esta pergunta para o atendimento online das Americanas, via chat. A conversa está abaixo (fui fazendo a captura das telas conforme a conversa se desenvolvia, pois temia que o texto fosse desaparecer quando o atentente desejasse -- o que de fato aconteceu).

Não consegui capturar a última tela, pois o atendente "desligou".

Fica o conselho: cautela ao comprar das Americanas.

Interpretador de COW em Chicken Scheme

2008-12-05T05:34:00.000-08:00

Dando seqüência à série implementações de interpretadores de linguagens que não servem para nada (iniciada com um interpretador de assembly), a seguir está a implementação de um interpretador para a linguagem COW em Chicken Scheme.

Da página da linguagem:

The COW programming language was designed with the bovine in mind. Given that cows have somewhat limited vocabulary skills, it seemed natural to incorporate only the words they know into the language. As a result, all instructions are some variation on "moo" which just so happens to be the only word they really understand.

Abaixo estão o código da implementação e um programa exemplo:

(use srfi-1)

(define *memory* (make-vector 1 0))
(define *program* #f)
(define *ip* 0) ;; instruction pointer
(define *mp* 0) ;; memory pointer
(define *register* #f)
(define instructions
  '(("moo" . 0) ("mOo" . 1) ("moO" . 2) ("mOO" . 3) ("Moo" . 4)
    ("MOo" . 5) ("MoO" . 6) ("MOO" . 7) ("OOO" . 8) ("MMM" . 9)
    ("OOM" . 10) ("oom" . 11)))

(define (sanitize-code code)
  ;; removes non-cow instructions and returns a list containing valid cow code
  (map string->symbol
       (filter (cut alist-ref <> instructions equal?)
               (flatten (map string-split code)))))

(define (get-address snippet from to)
  (let ((scope 0)
        (address #f))
    (let loop ((code snippet))
      (if (and (null? code) (not address))
          (terminate)
          (let* ((current-instr (car code))
                 (instr (cdr current-instr))
                 (pos (car current-instr)))
            (cond ((eq? instr from)
                   (set! scope (add1 scope))
                   (loop (cdr code)))
                  ((and (not (zero? scope)) (eq? instr to))
                   (set! scope (sub1 scope))
                   (loop (cdr code)))
                  ((and (zero? scope) (eq? instr to)) pos)
                  (else (loop (cdr code)))))))))

(define (MOO-address)
  (get-address (reverse (take *program* (sub1 *ip*))) 'moo 'MOO))

(define (moo-address)
  (get-address (drop *program* (+ 2 *ip*)) 'MOO 'moo))

(define (mem-get) (vector-ref *memory* *mp*))

(define (maybe-resize-mem!)
  (let ((vlen (vector-length *memory*)))
    (when (>= (add1 *mp*) vlen)
      (set! *memory* (vector-resize *memory* (add1 vlen) 0)))))

(define (mem-set! val)
  (maybe-resize-mem!)
  (vector-set! *memory* *mp* val))

(define (terminate #!optional (exit-code 0))
  (print "Terminating.")
  (exit exit-code))

(define (moo-interpreter file)
  (let* ((sane-code (sanitize-code (read-lines file)))
         (program-len (length sane-code))
         (debug? (getenv "COWDEBUG")))
    (set! *program* (map cons (iota program-len) sane-code))
    (when debug? (display "prog> ") (pp *program*))
    (let loop ()
      (when debug?
        (print "-----------------------------------")
        (print *program*)
        (display "mem> ") (pp *memory*)
        (print "*mp*> " *mp*)
        (print "*ip*> " *ip*)
        (print "*register*>  " *register*))
      (when (> *ip* program-len) (terminate))
        (if (null? *program*)
            (terminate)
            (let* ((current-instr (alist-ref *ip* *program*))
                   ;; special-instr => instructions that modify *ip*
                   (special-instrs '(MOO mOO moo))
                   (special-instr? (memq current-instr special-instrs)))
              (when (eq? current-instr 'mOO)
                (unless (memq (mem-get) (map cdr instructions))
                  (terminate))
                (set! current-instr (alist-ref (mem-get) *program*))
                (set! special-instr? (memq current-instr special-instrs)))
              (when debug?
                (display "current-instr> ")
                (display (if special-instr? "(*) " ""))
                (pp  current-instr))
              (case current-instr
                ((moo) (set! *ip* (MOO-address)))
                ((mOo) (maybe-resize-mem!) (set! *mp* (sub1 *mp*)))
                ((moO) (maybe-resize-mem!) (set! *mp* (add1 *mp*)))
                ((Moo) (if (zero? (mem-get))
                           (mem-set! (string->number (->string (read-line))))
                           (print (integer->char (mem-get)))))
                ((MOo) (mem-set! (sub1 (mem-get))))
                ((MoO) (mem-set! (add1 (mem-get))))
                ((MOO) (if (zero? (mem-get))
                           (set! *ip* (add1 (moo-address)))
                           (set! *ip* (add1 *ip*))))
                ((OOO) (mem-set! 0))
                ((MMM) (if *register*
                           (begin (mem-set! *register*)
                                  (set! *register* #f))
                           (set! *register* (mem-get))))
                ((OOM) (print (mem-get)))
                ((oom) (mem-set! (string->number (read-line)))))
              (unless special-instr? (set! *ip* (add1 *ip*)))))
        (loop))))

(define (usage #!optional (exit-code 0))
  (print "Usage: " (program-name) " <input file>")
  (exit exit-code))

(let ((args (command-line-arguments)))
  (if (null? args)
      (usage 1)
      (let ((file (car args)))
        (if (file-exists? (car args))
            (moo-interpreter file)
            (begin
              (print file ": not found.")
              (exit 1))))))

Obs.: se a variável COWDEBUG estiver definida no ambiente, o interpretador exibe informações para depuração.

Aqui está a implementação de um gerador da série de Fibonacci em COW (um dos exemplos disponibilizados no site da linguagem):


MoO
moO
MoO
mOo
[[ main loop ]]
MOO
[[ print first number ]]
OOM
[[ temp copy of first number ]]
MMM
moO
moO
MMM
mOo
mOo
[[ store second number off in the first position now ]]
moO
MMM
mOo
MMM
[[ move back to temp number ]]
moO
moO
[[ use temp to add to first and store in second in loop ]]
MOO
MOo
mOo
MoO
moO
moo
mOo
mOo
moo

Executando este exemplo com o interpretador, temos:


$ csi -s cow.scm fib.cow
1
1
2
3
5
8
13
21
34
55
89
144
233
377
610
987
1597
2584
4181
6765
10946
17711
28657
...

Algum voluntário para implementar as Distributed Digestion eXtentions? :-)

Scheme na Apple?

2008-11-19T06:04:00.000-08:00

Estava dando uma olhada em uma apresentação sobre o MacOSX que o Drebes divulgou em uma lista de discussão e me deparei com a seguinte tela:

Com uma rápida pesquisada, encontrei o seguinte texto:

While there is no documentation of the format of the policy file, there are several examples available in /usr/share/sandbox which give clues to what a policy can do. These policies seem to use a Scheme-like syntax and provide abilities to restrict file access (based on pathname), restrict interprocess communication (IPC) such as shared memory, restrict network access, restrict signals, restrict many process-related actions, restrict sysctls, and more.

Interessante.

Chicken LiveCD na LatinoWare 2008

2008-10-28T11:30:00.000-07:00

Como não será possível levar a torradeira para a Latinoware 2008, levarei alguns LiveCDs de Chicken para os interessados. Serão poucas unidades (~20). Faça sua reserva na seção de comentários. :-)

Chicken LiveCD 0.4

2008-10-22T04:39:00.000-07:00

A versão 0.4 do Chicken LiveCD está disponível em http://g3pd.ufpel.tche.br/chicken/livecd/.

Esta versão contém:

Chicken 3.4.0

mais de 300 eggs instalados

Emacs + Quack + scheme-complete

Manual em PDF

várias ferramentas e bibliotecas para desenvolvimento com Chicken

Esta versão do LiveCD é baseada no Ubuntu. Usei o Reconstructor para remasterizar o CD.

Correctly answer a simple skill testing question

2008-10-20T12:06:00.000-07:00

Ainda não decidi se devo chorar ou dar risada:

Há uma thread na lista de discussão da implementação PLT com a discussão gerada por uma simples questão.

Lisp na LatinoWare 2008!

2008-10-17T13:50:00.000-07:00

A LatinoWare 2008, V Conferência Latino-Americana de Software Livre, que ocorrerá de 30 de outubro a 1^o. de novembro em Foz do Iguaçu, PR, contará com três apresentações especificamente sobre Lisp! Serão 3 horas consecutivas sobre parênteses no dia 31/10/2008:

15h-16h	Usando Common Lisp no Dia-a-dia	Pedro Ribeiro Kroger Junior
16h-17h	Chicken - Uma Implementação de Scheme para Aplicações Práticas	Mario Domenech Goulart
17h-18h	CL-Weblocks - Programando Aplicações Web com Blocos	Vilson Vieira da Silva Junior

A programação completa do evento está em http://lapsi.latinoware.org/index.php?page=grade.GradeEvento&id=1.

Interface para manipulação de grupos no LDAP

2008-09-04T06:15:00.000-07:00

A seguir está uma simples, rápida e não muito elegante interface para manipulação de grupos de usuários no LDAP (Lightweight Directory Access Protocol) que usa o programa cpu por baixo dos panos. A implementação é em Chicken Scheme.

Com esta ferramenta são possíveis as seguintes operações:

Listar grupos aos quais um dado usuário pertence

Listar usuários que fazem parte de um dado grupo

Adicionar usuário a grupo

Exemplos:


$ ldap-groups.scm -h
Uso: ldap-groups.scm -h | -a <user> <group> | -l <group> | -g <user>

-a : adiciona <user> ao grupo <group> (cria <group> se nao existir)
-l : lista os usuarios do grupo <group>
-g : lista os grupos a que pertence o usuario <user>

Listando os usuários do grupo admin:


$ ldap-groups.scm -l admin
mario
joao

Listando os grupos a que pertenço:


$ ldap-groups.scm -g mario
sgpc
admin

Adicionando o meu usuário ao grupo printer:


$ ldap-groups.scm -a mario printer

O código está abaixo:

(use posix srfi-13)

(define (system-output . command)
  (let ((cmd (string-intersperse (map ->string command))))
    (read-all (open-input-pipe (sprintf "~A 2>&1" cmd)))))

(define *groups-data* #f)

(define (set-groups-data!)
  (set! *groups-data*
  ;; lista de listas (("grupo" "user1" "user2" ... "usern"))
        (let ((data (with-input-from-string
                        (cadr (string-split-fields
                               "Group Entries\n"
                               (system-output "cpu cat")
                               infix:))
                      read-lines)))
          (map (lambda (line)
                 (let ((ldata (string-split line ":")))
                   (cons (car ldata) ;; nome do grupo
                         (let ((users (cdddr ldata))) ;; usuarios
                           (if (null? users)
                               '()
                               (map
                                string-trim-both
                                (string-split (car users) ",")))))))
               data))))

(define (get-groups user)
  (let ((user-groups '()))
    (for-each (lambda (group/users)
                (when (member user (cdr group/users))
                  (set! user-groups
                        (cons (car group/users) user-groups))))
              *groups-data*)
    user-groups))

(define (group-exists? group)
  (not (not (alist-ref group *groups-data* equal?))))

(define (get-users group)
  (alist-ref group *groups-data* equal?))

(define (add-user-to-group! user group)
  (unless (group-exists? group)
    (let ((cmd (conc "cpu groupadd " group)))
      (print cmd)
      (system-output cmd)))
  (let ((cmd (conc "cpu usermod " user " -G "
                   (string-intersperse
                    (cons group (get-groups user)) ","))))
    (print cmd)
    (system-output cmd)))

(define (usage #!optional exit-code)
  (print #<#EOF
Uso: #(program-name) -h | -a <user> <group> | -l <group> | -g <user>

-a : adiciona <user> ao grupo <group> (cria <group> se nao existir)
-l : lista os usuarios do grupo <group>
-g : lista os grupos a que pertence o usuario <user>
EOF
)
  (when exit-code
    (exit exit-code)))

(let ((args (command-line-arguments)))
  (when (null? args)
    (usage 1))
  (set-groups-data!)
  (cond ((member (car args) '("-h" "--help" "-help"))
         (usage))
        ((member "-a" args)
         (add-user-to-group! (cadr args) (caddr args)))
        ((member "-l" args)
         (map print (or (get-users (cadr args)) '())))
        ((member "-g" args)
         (map print (or (get-groups (cadr args)) '())))
        (else (usage 1))))

Configurando o tamanho do stack trace

2008-08-11T14:13:00.000-07:00

Chicken dispõe de uma opção para configurar o tamanho do relatório de chamadas de procedimentos (stack trace) a ser exibido em caso de erro. Se a configuração for omitida, o valor 8 é usado, o que significa que serão exibidas as últimas 8 chamadas de procedimento.

Para algumas aplicações, esse número pode ser muito pequeno, mas pode ser aumentado com o parâmetro -:aNUMBER, onde NUMBER é o número de chamadas a ser mostrado (http://chicken.wiki.br/Using%20the%20compiler#runtime-options).

Abaixo está um exemplo de uma situação onde o aumento do stack trace pode ser útil:

(define (l) (error 'oops))
(define (k) (l))
(define (j) (k))
(define (i) (j))
(define (h) (i))
(define (g) (h))
(define (f) (g))
(define (e) (f))
(define (d) (e))
(define (c) (d))
(define (b) (c))
(define (a) (b))

(a)

Executando este código com o interpretador, temos:


$ csi -s oops.scm
Error: oops

        Call history:

                  [e] (f)
                  [f] (g)
                  [g] (h)
                  [h] (i)
                  [i] (j)
                  [j] (k)
                  [k] (l)
                  [l] (error (quote oops))        <--

Com esse relatório, não fica claro que quem originou a chamada de l foi a. Mas, se aumentarmos o tamanho do relatório:


$ csi -:a14 -s oops.scm
Error: oops

        Call history:

                        (a)
                  (a)
                  [a] (b)
                  [b] (c)
                  [c] (d)
                  [d] (e)
                  [e] (f)
                  [f] (g)
                  [g] (h)
                  [h] (i)
                  [i] (j)
                  [j] (k)
                  [k] (l)
                  [l] (error (quote oops))        <--

O parâmetro -:aNUMBER também é válido para programas compilados com o compilador de Chicken (csc):


$ csc oops.scm
$ ./oops
Error: oops

        Call history:

        oops.scm: 8    f
        oops.scm: 7    g
        oops.scm: 6    h
        oops.scm: 5    i
        oops.scm: 4    j
        oops.scm: 3    k
        oops.scm: 2    l
        oops.scm: 1    error                    <--

$ ./oops -:a14
Error: oops

        Call history:

        oops.scm: 14   a
        oops.scm: 12   b
        oops.scm: 11   c
        oops.scm: 10   d
        oops.scm: 9    e
        oops.scm: 8    f
        oops.scm: 7    g
        oops.scm: 6    h
        oops.scm: 5    i
        oops.scm: 4    j
        oops.scm: 3    k
        oops.scm: 2    l
        oops.scm: 1    error                    <--

Chicken Web REPL

2008-08-06T08:54:00.001-07:00

Há algum tempo eu e o Vilson estávamos discutindo sobre REPLs na Web (não lembro o que desencadeou esse tópico -- também é possível que o tópico não tenha sido esse -- tá feio o caso da minha memória). Bem, o fato é que desta conversa surgiu a idéia de fazer um REPL via Web para Chicken. Lembrei do egg sandbox, do Chicken Playground (um ambiente chroot com uma instalação de Debian, Chicken e um monte de eggs) e fiz um Web REPL simples para Chicken.

Em seguida, o Vilson descobriu o EditArea (um editor de código em Javascript) e modificou para adicionar um suporte básico a Common Lisp. Enviou o código para mim e eu, com base nele, adicionei suporte básico a Scheme.

O resultado está em http://repl.ucpel.tche.br:8080.

Uma das funcionalidades interessantes do Web REPL é o uso de sessões HTTP para manter coisas como histórico de trechos de código submetidos ao avaliador e definições feitas na sessão. A implementação de sessões é feita com o egg http-session.

O Web REPL também usa os eggs web-scheme, ajax, spiffy-utils e spiffy (servidor web).

REPL de Chicken para acesso a bases de dados do Postgres

2008-08-06T08:15:00.000-07:00

A seguir está uma forma de usar o REPL de Chicken (csi) como um REPL para bases de dados do Postgres.

Com isso, tem-se um REPL que possibilita a execução de consultas SQL e código Scheme. A implementação usa o próprio REPL do sistema Chicken e alguns eggs como: postgresql (para acesso so Postgres), readline (para edição de linhas de comando, histórico) e stty (para configuração do terminal na leitura de senhas).

O programa db-repl.scm usa como argumentos não interativos (opcionais) o usuário do banco de dados, o nome do host e a base de dados, os quais devem ser fornecidos no seguinte formato:

<usuario>@<host>/<base de dados>

Quando executado, o programa pede para o usuário digitar a senha.

A associação do REPL de Chicken com a base de dados é feita através da definição de comandos do REPL (toplevel-command). Na implementação mostrada abaixo, são definidos três comandos:

tables: mostras as tabelas da base de dados.

table: mostra estrutura da tabela dada como argumento (nome e tipo das colunas e se podem ou não ser nulas).

-: executa a consulta SQL dada como argumento.

Exemplos:

csi -s db-repl.scm mario@localhost/sgpc
Senha: *****

#;1> ,tables
perms
news
users_sites
ticket_comments
ticket_attachments
obj_type
acervos
autores
videos
audios
images
objects
texts
scanners
users
wiki
sites
tickets

#;1> ,table news
news_id                       integer                       NO
user_id                       integer                       NO
site_id                       integer                       NO
timestamp                     timestamp without time zone   YES
title                         character varying(100)        NO
news                          text                          YES

#;1> ,- select * from news
(#(2
   1
   1
   #(2008 7 30 19 37 54 271625)
   "Teste."
   "teste

   === titulo")
 #(3
   1
   1
   #(2008 7 30 19 40 27 180765)
   "Outra notícia!"
   "Aqui vai o texto da notícia.

[[image:http://subversion.tigris.org/branding/images/logo.gif|Logo]]"))

Obviamente, os comandos para acesso ao banco de dados disponibilizados através do REPL podem ser estendidos. O texto PostgreSQL INFORMATION_SCHEMA fornece várias dicas de como extrair informações de bases de dados do Postgres.

Nesta implementação, o parâmetro pg-repl:conn armazena o objeto que representa a conexão com o banco de dados, de forma que ele pode ser usado pelos procedimentos do egg postgresql para a execução de consultas:


#;1> (define query  "select * from news")
#;2> (vector-ref (car (pg:query-tuples query (pg-repl:conn))) 3)
#(2008 7 30 19 37 54 271625)

O código do programa (db-repl.scm) está a seguir:

(use utils postgresql readline stty regex (srfi 13))

(define pg-repl:conn (make-parameter #f))

(define (pg-repl:query . query)
  (pg:query-tuples
   (string-intersperse (map ->string query) "")
   (pg-repl:conn)))

(toplevel-command
 '-
 (lambda ()
   (pp (pg-repl:query
        (with-output-to-string
          (cut print (read-line)))))))

(toplevel-command
 'table
 (lambda ()
   (let* ((table (string-trim-both (read-line)))
          (cols
           (pg-repl:query
            "select column_name,data_type,"
            "character_maximum_length,is_nullable "
            "from information_schema.columns "
            "where table_name = '" table "'")))
     (if (null? cols)
         (print "Tabela \"" table "\" nao existe.")
         (for-each
          (lambda (f)
            (let ((colname (vector-ref f 0))
                  (type (vector-ref f 1))
                  (size (let ((size (vector-ref f 2)))
                          (if (pg:sql-null-object? size)
                              ""
                              (conc "(" size ")"))))
                  (nullable (vector-ref f 3)))
              (print
               colname
               (make-string
                (- 30 (string-length colname)))
               type size
               (make-string
                (- 30 (string-length (conc type size))))
               nullable)))
          cols)))))

(toplevel-command
 'tables
 (lambda ()
   (for-each
    (lambda (item)
      (print (vector-ref item 0)))
    (pg-repl:query
     "select table_name from information_schema.tables "
     "where table_type = 'BASE TABLE' "
     "and table_schema not in "
     "('pg_catalog', 'information_schema')"))))

(define (pg-repl:usage #!optional exit-code)
  (print (program-name) " [<user>@<server>/<database>]")
  (when exit-code (exit exit-code)))

(let ((args (command-line-arguments))
      (user "postgres")
      (host "localhost")
      (db "template")
      (passwd #f))

  ;; Restaura o terminal em caso de termino via C-c
  (set-signal-handler! signal/int
                       (lambda (_) (stty '(echo))))

  (unless (or (null? args) (equal? "\"\"" (car args)))
    (let* ((cred (string-trim-both
                  (car args)
                  (cut memq <> '(#\space #\newline #\")))) ;"
           (@tokens (string-split cred "@"))
           (/tokens (if (null? @tokens)
                        '()
                        (string-split (cadr @tokens) "/"))))
      (if (and (null? @tokens) (null? /tokens))
          (pg-repl:usage 1)
          (begin
            (unless (null? @tokens)
              (set! user (car @tokens)))
            (unless (null? /tokens)
              (set! host (car /tokens))
              (set! db (cadr /tokens)))))))
  (display "Senha: ")
  (pg-repl:conn
   (pg:connect
    `((user . ,user)
      (dbname . ,db)
      (host . ,host)
      (password . ,(with-stty '(not echo) read-line)))))
  (current-input-port (make-gnu-readline-port))
  (gnu-history-install-file-manager
   (string-append (or (getenv "HOME") ".")
                  "/.csi.history"))
  (newline)
  (repl))

Copy & comment

2008-07-31T19:18:00.000-07:00

Para quem seguidamente, como eu:

1. tem preguiça de criar uma revisão no VCS para alterar algo pequeno no código (só para ver se dá certo -- se não der, volta atrás rapidinho);

2. acha muito trabalhoso usar o editor de texto para duplicar um trecho de código (i.e., copiar & colar) e comentar uma das partes.

A função a seguir (em Elisp, para Emacs) faz as tarefas do item 2 para quem se enquadra no perfil do item 1:

(defun copy&comment (begin end)
  (interactive "r")
  (save-excursion
    (copy-region-as-kill begin end)
    (goto-char end)
    (yank)
    (comment-region begin end)))

Interpretador de assembly em Scheme

2008-07-08T05:53:00.000-07:00

Dando continuidade à série de programas inúteis que só servem para alimentar a procrastinação, a seguir estão a descrição e implementação (em Chicken Scheme) de um pequeno interpretador de uma linguagem assembly bem simples.

A linguagem possui apenas seis instruções e opera somente com números:

add <reg> <number | reg>: Soma um número ou o conteúdo do registrador usado como segundo argumento com o conteúdo do registrador usado como primeiro argumento. O resultado é armazenado no registrador usado como primeiro argumento.

mov <reg> <number | reg>: Armazena o número ou o conteúdo do registrador usado como segundo argumento no registrador usado como primeiro argumento.

lbl <label>: Associa um endereço de memória a um rótulo, o qual pode ser referenciado no programa pelas instruções jmp e jnz.

jmp <label>: Desvia o fluxo de execução para <label> (uma marca determinada através da instrução lbl).

jnz <reg> <label>: Desvia o fluxo de execução para <label> se o conteúdo do registrador usado como primeiro argumento for diferente de zero.

out <number | reg>: Imprime o número ou conteúdo do registrador usado como argumento.

A arquitetura hipotética considerada possui 8 registradores para leitura e escrita (r1 a r8), nenhum deles com função específica. Há também um registrador somente para leitura (ip) que armazena o endereço de memória da última instrução executada.

Por simplicidade, a sintaxe das instruções é semelhante à sintaxe de Scheme, ou seja, usa parênteses. Por exemplo:

(mov r1 3)

O código do interpretador está a seguir (tiny-assembly.scm):

;; Instrucoes:
;;     add <reg> <number | reg>
;;     mov <reg> <number | reg>
;;     jmp <label>
;;     jnz <reg> <label>
;;     lbl <label>
;;     out <number | reg>
;;
;; Registradores: r1..r8
;; Registrador "read-only": ip

(use srfi-1)

(define (run code)
  (define memory (map cons (iota (length code)) code))
  (define labels '())
  (define registers
    '((r1 . 0) (r2 . 0) (r3 . 0) (r4 . 0)
      (r5 . 0) (r6 . 0) (r7 . 0) (r8 . 0)))
  (define ip 0)
  (define code-len (length code))

  (define (die . msg)
    (print "Error: "
           (string-intersperse (map ->string msg) ""))
    (exit 1))

  (define (next-ip)
    (set! ip (add1 ip)))

  (define (reg-get register)
    (alist-ref register registers))

  (define (val-get thing)
    (if (eq? thing 'ip)
        ip
        (if (number? thing)
            thing
            (reg-get thing))))

  (define (reg-set! reg val)
    (set! registers
          (alist-update! reg (val-get val) registers)))

  (define (label-address label)
    (alist-ref label labels))

  (define (add reg val)
    (reg-set! reg (+ (reg-get reg) (val-get val))))

  (define (mov reg val)
    (reg-set! reg (val-get val)))

  (define (jmp label)
    (let ((address (or (reg-get label)
                       (label-address label))))
      (if address
          (set! ip address)
          (die "label " label " not found."))))

  (define (jnz reg label)
    (if (zero? (reg-get reg))
        (next-ip)
        (jmp label)))

  (define (lbl label)
    (set! labels (alist-update! label ip labels)))

  (define (finished? ip) (>= ip code-len))

  (set! labels
        (map (lambda (label)
               (cons (caddr label) (car label)))
             (filter (lambda (expr)
                       (eq? (cadr expr) 'lbl))
                     memory)))
  (let loop ()
    (if (finished? ip)
        (exit)
        (begin
          (let* ((expr (alist-ref ip memory))
                 (op (car expr))
                 (arg1 (cadr expr))
                 (arg2 (and (not (null? (cddr expr)))
                            (caddr expr))))
            (case op
              ((mov) (mov arg1 arg2))
              ((add) (add arg1 arg2))
              ((jmp) (jmp arg1))
              ((jnz) (jnz arg1 arg2))
              ((lbl) (noop))
              ((out) (print
                      (or (reg-get arg1)
                          (if (eq? arg1 'ip)
                              ip
                              arg1))))
              (else (die op ": unknown command.")))
            (unless (memq op '(jmp jnz))
              (next-ip)))
          (loop)))))

;;; Command line parser
(let ((args (command-line-arguments)))
  (when (null? args)
    (print "Usage: " (program-name) " <input-file>")
    (exit 1))
  (let ((file (car args)))
    (unless (file-exists? file)
      (print "Could not open " file)
      (exit 1))
    (run (handle-exceptions
          exn
          (die "parse error.")
          (with-input-from-file file read-file)))))

A seguir estão alguns exemplos de código assembly e uso com o interpretador:

Multiplicação

A linguagem não possui uma instrução para multiplicação. Abaixo está a implementação de uma rotina para multiplicar dois números (7 x 4):

(mov r1 7)
(mov r2 4)
(mov r4 ip)
(jmp mul)
(jmp end)

;; Multiplicacao (x * y)
;; x -> r1
;; y -> r2
;; produto -> r3
;; endereco de retorno -> r4
(lbl mul)
(jnz r1 not-zero)
(jmp end)
(lbl not-zero)
(mov r3 0)
(lbl loopmul)
(add r3 r2)
(add r1 -1)
(jnz r1 loopmul)
(add r4 2)
(jmp r4)

(lbl end)
(out r3)

$ csi -s tiny-assembly.scm multiplicacao.asm
28

Fatorial

Toda e qualquer implementação de linguagem inútil deve mostrar uma implementação de fatorial como exemplo. Abaixo está a implementação usando o assembly descrito neste texto (where's your god now?!):

(mov r5 7) ;; entrada de dados

;; Fatorial
;;     entrada -> r5
;;     resultado -> r6
(lbl fatorial)
(mov r6 1)
(lbl fat-loop)
(jnz r5 fat-not-0)
(jmp end)
(lbl fat-not-0)
(add r5 -1)
(jnz r5 fat-not-1)
(jmp end)
(lbl fat-not-1)
(add r5 1)
(mov r1 r6)
(mov r2 r5)
(mov r4 ip)
(jmp mul)
(mov r6 r3)
(add r5 -1)
(jmp fat-loop)

;; Multiplicacao (x * y)
;;     x -> r1
;;     y -> r2
;;     produto -> r3
;;     endereco de retorno -> r4
(lbl mul)
(jnz r1 mul-not-0)
(jmp end)
(lbl mul-not-0)
(mov r3 0)
(lbl loopmul)
(add r3 r2)
(add r1 -1)
(jnz r1 loopmul)
(add r4 2)
(jmp r4)

(lbl end)
(out r6) ;; imprime o resultado

$ csi -s tiny-assembly.scm fatorial.asm
5040

Contagem de definições no toplevel

2008-07-02T06:01:00.000-07:00

Dando início a uma série de programas para geração de estatísticas inúteis, abaixo está um pequeno código para contagem de definições feitas no toplevel (em Chicken Scheme).

(use srfi-1)

(define count-defines
  (let* ((definers '(define define-macro define-constant
                     define-inline define-syntax))
         (count-defines
          (lambda (file)
            (cons file
                  (length
                   (filter
                    (lambda (form)
                      (and (pair? form)
                           (memq (car form) definers)))
                    (with-input-from-file
                        file read-file)))))))
    (lambda (files)
      (let ((defines-count (map count-defines files)))
        (for-each (lambda (file/defcount)
                    (print (car file/defcount) ": "
                           (cdr file/defcount)))
                  defines-count)
        (print "Total: "
               (reduce + 0 (map cdr defines-count)))))))

(let ((files (command-line-arguments)))
  (if (null? files)
      (exit 0)
      (count-defines files)))

Exemplos de uso:


$ csi -s count-defines.scm count-defines.scm
count-defines.scm: 1
Total: 1


$ csi -s count-defines.scm spiffy/trunk/*.scm
spiffy/trunk/cgi-handler.scm: 5
spiffy/trunk/simple-directory-handler.scm: 4
spiffy/trunk/spiffy-base.scm: 70
spiffy/trunk/spiffy.scm: 1
spiffy/trunk/ssp-handler.scm: 10
spiffy/trunk/web-scheme-handler.scm: 4
Total: 94

Embora este programa não diga muita coisa de útil sobre o código que analisa, serve para mostrar um dos aspectos mais interessantes de Lisp: a possibilidade de se tratar, naturalmente, código como dados. Basicamente, a contagem de definições no toplevel consiste em ler todas as expressões de um arquivo e verificar se o car de cada expressão é um dos símbolos define, define-macro, define-constant, define-inline ou define-syntax (se a expressão for um par).

Este tipo de análise não é muito útil porque, pelo menos em Chicken, é possível especificar o que deve ser "visível" ou não no código compilado. Isto pode ser feito com as declarações export e hide. Outros motivos são que este programa não consegue inferir as definições de toplevel que serão geradas através da expansão de macros (web-scheme, por exemplo, usa esta estratégia) e que não computa definições feitas dentro de blocos cond-expand.

Acessando base de dados SQL com Scheme

2008-06-19T15:53:00.000-07:00

Em alguns projetos em que estou trabalhando seguidamente tenho que acessar tabelas de bases de dados. Costumo usar o Postgres através do egg postgresql do sistema Chicken.

Para evitar de esquecer de fechar as conexões com o banco, normalmente uso um procedimento que recebe uma query como argumento. Este procedimento abre a conexão com o banco, executa a query e fecha a conexão automaticamente (o desempenho que se dane :-)). As credenciais do banco mantenho em um parâmetro (definido com make-parameter). O procedimento é algo como:

(define db-credentials (make-parameter '()))

(define (db-query query)
  (let* ((db (pg:connect (db-credentials)))
         (output (pg:query-tuples query db)))
    (pg:close db)
    output))

Mesmo com o uso do procedimento db-query, o acesso a colunas do banco não é das tarefas mais simples. Abaixo está um exemplo em que quero acessar as colunas username e email de uma tabela e associar o valor delas à variáveis em Scheme:

(db-credentials '((host . "localhost")
                  (user . "usuario")
                  (password . "****")
                  (dbname . "nome-da-base")))

(let* ((results
        (let ((results
               (db-query
                "select username,email from users where user_id=1")))
          (if (null? results)
              #f
              (car results))))
       (username (and results (vector-ref results 0)))
       (email (and results (vector-ref results 1))))
  (print username)
  (print email))

Como pode ser visto no exemplo, associar valores de colunas da base de dados a variáveis em Scheme é uma certa novela. Para facilitar esta tarefa, fiz o esquema mostrado abaixo:

(use postgresql)

(define db-map:credentials (make-parameter '()))

(define db-map:create-object
  (let ()
    (define (db-query query)
      (let* ((db (pg:connect (db-map:credentials)))
             (output (pg:query-tuples query db)))
        (pg:close db)
        output))
    (lambda (query fields)
      (let* ((query-results (let ((results (db-query query)))
                              (if (null? results)
                                  #f
                                  (car results)))))
        (lambda (field)
          (and query-results
               (let ((pos (list-index (cut eq? <> field)
                                      fields)))
                 (vector-ref query-results pos))))))))

O procedimento db-map:create-object recebe uma query SQL e uma lista de símbolos a serem associados com os valores das colunas obtidos como resultado da execução da query. db-map:create-object retorna um procedimento que recebe como argumento um símbolo representando uma coluna da base de dados e que retorna o valor associado ao símbolo.

Assim, para acessar o valor das colunas username e email, faço o seguinte:

(let ((obj (db-map:create-object
            "select username,email from users where user_id=1"
            '(username email))))
  (print (obj 'username))
  (print (obj 'email)))

A ordem dos símbolos da lista passada como segundo argumento deve ser a mesma dos valores das colunas resultantes da query SQL.

Persistência de dados (e código!) em Scheme

2008-06-12T07:32:00.000-07:00

Hoje eu e o Vilson estávamos conversando sobre persistência de dados (e código!) em Lisp. Fiz um exemplo simples e estou colocando abaixo para não perder a viagem. :-)

O exemplo implementa um objeto mem (criado com o procedimento make-mem) e procedimentos para manipulação desse tipo de objeto: mem-get (para leitura de dados) e mem-set! (para escrita em memória e em disco).

A leitura de dados é sempre feita da memória (exceto na criação do objeto, que pode aproveitar dados do arquivo passado como argumento). As escritas são feitas em memória e em disco.

Os dados são armazenados em uma hash-table e indexados por símbolos.

Abaixo está a implementação simplificada (em Chicken Scheme), que usa o egg s11n:

(use s11n)

(define (make-mem file)
  (cons file (if (file-exists? file)
                 (with-input-from-file
                     file
                   (cut deserialize))
                 (make-hash-table))))

(define (mem-get mem key #!optional default)
  (hash-table-ref/default (cdr mem) key default))

(define (mem-set! mem key val)
  (let ((file (car mem))
        (data (cdr mem)))
    (hash-table-set! data key val)
    (with-output-to-file file (cut serialize data))))

A seguir está um exemplo que armazena uma lista e um procedimento (código!):

(let ((mem (make-mem "teste.data")))
  (print  (mem-get mem 'a))
  (mem-set! mem 'a '(1 2 3))
  (print  (mem-get mem 'a))
  (mem-set! mem 'soma (lambda (a b) (+ a b)))
  (print ((mem-get mem 'soma) 2 2)))

O resultado da execução do código do exemplo é (caso em que teste.data inicialmente não existe):


#f
(1 2 3)
4

Minimização de poluição no espaço de nomes

2008-05-30T12:52:00.000-07:00

Uma forma interessante de minimizar a poluição do espaço de nomes em Scheme é usando uma combinação de define, let e set!, tirando proveito das regras de escopo.

Supondo o seguinte caso: tenho um arquivo (uma biblioteca) que será usado por outras pessoas e embutido em outros códigos. Neste arquivo estarão alguns procedimentos que serão parte da API e procedimentos auxiliares úteis para o desenvolvimento do próprio código desta biblioteca. Mesmo sem usar um sistema de módulos, é possível minimizar a poluição do espaço de nomes que seria causado pelos procedimentos auxiliares com a seguinte estratégia:


(define proc-api-1 #f)
(define proc-api-2 #f)

(let ()
  (define (proc-aux arg) (codigo))
  (set! proc-api-1 (lambda () (proc-aux 3)))
  (set! proc-api-2 (lambda () (proc-aux (proc-aux 1000)))))

No exemplo temos dois símbolos visíveis no escopo mais amplo (toplevel) deste arquivo : proc-api-1 e proc-api-2. A outra definição proc-aux, que é útil para a implementação dos procedimentos da API, fica no escopo do bloco (let () ...), ou seja, não é visível do toplevel. Dentro do bloco (let () ...), então, fazemos a atribuição do código dos procedimentos da API às variáveis definidas no toplevel.

Um exemplo mais prático (mas não menos besta):

(define ul #f)
(define li #f)
(define p #f)

 (let ()

   (define cria-tag
     (lambda (nome)
       (let ((nome (symbol->string nome)))
         (lambda args
           (string-append "<" nome ">"
                          (string-intersperse args "")
                          "</" nome ">"))))

     (set! ul (cria-tag 'ul))
     (set! li (cria-tag 'li))
     (set! p (cria-tag 'p)))

Executando isso no REPL, podemos ver o efeito da estratégia usada:


$ csi -n

CHICKEN
(c)2008 The Chicken Team
(c)2000-2007 Felix L. Winkelmann
Version 3.2.0 - linux-unix-gnu-x86      [ manyargs dload ptables applyhook ]
SVN rev. 10664  compiled 2008-05-08 on ze-dureza (Linux)

#;1> (load "cria-tag.scm")
; loading cria-tag.scm ...
#;2> p
#<procedure (? . args)>
#;3> li
#<procedure (? . args)>
#;4> ul
#<procedure (? . args)>
#;5> cria-tag
Error: unbound variable: cria-tag
#;5> (p "nada")
"<p>nada</p>"

Conforme esperado, a definição de cria-tag não é visível no toplevel, mas as funções que a usam funcionam.

Esta estratégia é bastante usada na implementação do sistema Chicken, por exemplo.

Giannini Thunder Sound Bass II

2008-05-24T19:16:00.000-07:00

Neste final de semana meu pai me trouxe de presente um amplificador valvulado da década de 70, um Thunder Sound II, da Giannini. Um amplificador desses estava em uma das posições mais altas da minha lista de sonhos de consumo.

Inicialmente ele só ligava, as vávulas acendiam, mas o sinal da entrada não era amplificado. Havia apenas um zumbido no alto-falante da caixa em que liguei o amplificador.

Hoje decidi abri-lo para ver se descobria qual era o defeito. Para a minha sorte, era apenas um capacitor solto. Bastou soldá-lo de volta no lugar e o amplificador passou a funcionar. Os potenciômetros não estão lá grandes coisas (aceitável, dada a idade do troço), provavelmente serão trocados.

Fotos do amplificador em http://g3pd.ucpel.tche.br/~mario/fotos/thunder-sound

Geração de tablaturas em Scheme

2008-05-14T07:18:00.000-07:00

O Pedro provavelmente vai me chamar de imbecil por eu estar apresentando um programa para geração de um tipo de notação musical tão primitiva, simplória e pouco representativa. Mas azar :-). Para analfabetos musicais como eu, tablaturas são uma forma simples de representar notas a serem tocadas em um instrumento.

O programa a seguir (em Chicken Scheme) gera tablaturas para contrabaixos de quatro cordas com duas oitavas por corda. Adaptar para guitarra/violão e para a notação de acordes não deve ser difícil.

(use (srfi 1))

(define (deriva-nota corda #!optional (desloc 0) oitava)
  ;; deriva notas a partir de corda e posicao de referencia
  ;; representando a nota mais grave
  (let* ((corda-vazia (make-vector 4 '-))
         (pos-corda-0 (+ desloc (if oitava 12 0)))
         (pos (case corda
                ((0) pos-corda-0)
                ((1) (+ pos-corda-0 7))
                ((2) (+ pos-corda-0 2))
                ((3) (+ pos-corda-0 9)))))
    (vector-set! corda-vazia corda
                 (if (and (>= pos 12) (not oitava))
                     (- pos 12)
                     pos))
    (vector->list corda-vazia)))

(define-macro (cria-notas)
  ;; cria funcoes com nome correspondente `as notas
  (let ((notas/desloc '((E  . 0)
                        (F  . 1)
                        (F# . 2)
                        (G  . 3)
                        (G# . 4)
                        (Ab . 4)
                        (A  . 5)
                        (A# . 6)
                        (Bb . 6)
                        (B  . 7)
                        (C  . 8)
                        (C# . 9)
                        (Db . 9)
                        (D  . 10)
                        (D# . 11)
                        (Eb . 11))))
    (append
     '(begin)
     (map (lambda (nota)
            `(define (,(car nota) corda #!optional oitava)
               (deriva-nota corda ,(cdr nota) oitava)))
          notas/desloc))))

;; gera as definicoes das funcoes
(cria-notas)

(define (formata-corda corda notas)
  (string-append
   (case corda
     ((0) "G")
     ((1) "D")
     ((2) "A")
     ((3) "E"))
   " |"
   (string-intersperse
    (map (lambda (nota)
           (string-append
            "--"
            (->string nota)
            (if (and (number? nota) (> nota 9))
                "-"
                "--")))
         (map
          (case corda
            ((0) cadddr)
            ((1) caddr)
            ((2) cadr)
            ((3) car))
          notas))
    "") "|"))

(define (tablatura . notas)
  (define notas/corda 10) ;; numero maximo de notas por
                          ;; linha da tablatura
  (define (tab notas)
    (for-each (lambda (corda)
                (print (formata-corda corda notas)))
              '(0 1 2 3)))
  (let loop ((bloco notas))
    (cond ((> (length bloco) notas/corda)
           (tab (take bloco notas/corda))
           (loop (drop bloco notas/corda)))
          (else
           (print "")
           (tab (append ;; preenche ate' o final da linha
                 bloco
                 (make-list (- notas/corda (length bloco))
                            '(- - - -) )))))))

Para gerar uma tablatura, o usuário especifica as notas através de funções, e as passa como argumento para a função tablatura. As funções para representação de notas usam como argumentos a corda em que devem ser tocadas (de 0 a 3) e, opcionalmente, se uma oitava acima. Um exemplo com a escala pentatônica é mostrado abaixo:

(tablatura (G 0) (A# 0) (C 1) (D 1) (F 2))


G |--------------------------------------------------|
D |----------------------3---------------------------|
A |------------3----5--------------------------------|
E |--3----6------------------------------------------|

O programa quebra a linha da tablatura depois de um determinado número de notas (no código este parâmetro está com o valor 10) e completa a linha caso o número de notas seja menor que 10.

Uma tablatura com mais de 10 notas:

(tablatura
    (G 0) (A# 0) (C 1) (D 1) (F 2)
    (G 0) (A# 0) (C 1) (D 1) (F 2)
    (G 0) (A# 0) (C 1) (D 1) (F 2))

G |--------------------------------------------------|
D |----------------------3------------------------3--|
A |------------3----5-------------------3----5-------|
E |--3----6-------------------3----6-----------------|

G |--------------------------------------------------|
D |----------------------3---------------------------|
A |------------3----5--------------------------------|
E |--3----6------------------------------------------|

Programação para Web com Chicken e Ajax

2008-05-13T15:06:00.000-07:00

Chicken possui uma extensão interessante para desenvolvimento para a Web: o egg ajax. Essa extensão é, na realidade, um wrapper para a biblioteca prototype.

O uso do egg ajax é bem fácil depois que se entende como ele funciona. Confesso que quebrei um pouco a cabeça para começar a usá-lo, e a dificuldade foi agravada pelo fato de eu não conhecer muito bem a biblioteca prototype na época.

Para facilitar o entendimento do egg ajax, vale a pena mencionar um recurso interessante do egg http: a possibilidade de definição de recursos (resources). Com isso, é possível associar uma URL a um procedimento que será executado no servidor. Esta colocação, embora pareça "solta" agora, é necessária para entender como o egg ajax funciona (espero que ela venha a fazer sentido até o final deste texto...).

Uma das funções mais práticas do egg ajax é a remote-link. Com ela, é possível realizar várias operações no cliente com base no resultado do procedimento executado no servidor. A seguir está um exemplo de aplicação básica de remote-link:

(remote-link
 "Clique aqui"
 (lambda ()
   (print "Oi"))
 update: "resultado")

remote-link recebe três argumentos:

O texto do link

Uma função sem argumentos a ser executada no servidor

O tipo de ação a ser executada no cliente e em qual elemento da página aplicar o resultado da função executada no servidor. O tipo de ação a ser executada é determinado pelo parâmetro de palavra-chave escolhido (update no exemplo) e o elemento a aplicar o resultado é a string associada ao parâmetro de palavra-chave (resultado no exemplo).

O exemplo com remote-link, então, gera os códigos HTML e Javascript necessários para atualizar o elemento de identificador resultado com o texto Oi quando o usuário clicar no link Clique aqui. O código gerado é mostrado abaixo:

<a href='#' onclick="new Ajax.Updater('resultado', '/9fa328569dc39078f13e29086bbf3b93', { });">Clique aqui</a>

O código Javascript gerado corresponde a criação de um objeto Updater da bilioteca prototype, cujos argumentos são o identificador do elemento a ser atualizado no cliente depois da execução do procedimento associado à URL usada como segundo argumento (/9fa328569dc39078f13e29086bbf3b93). Essa URL é gerada pelo egg ajax, usando a funcionalidade de recursos do egg http, mencionada no início deste texto. A URL fica associada à função usada como argumento para remote-link.

Vamos ver um exemplo prático com o servidor web Spiffy. São necessários os seguintes eggs:

spiffy

web-scheme

ajax

spiffy-utils

Os eggs podem ser instalados da seguinte forma:

$ chicken-setup spiffy web-scheme ajax spiffy-utils

Todas as dependências serão instaladas automaticamente.

O programa para execução do servidor web está abaixo (web-server.scm):

(use spiffy web-scheme web-scheme-handler ajax spiffy-utils)

(spiffy-file-ext-handlers `(("ws" . ,web-scheme-handler)))
(spiffy-tcp-port 8080)
(spiffy-root-path ".")
(spiffy-debug-mode #t)
(start-server)

Para usar o egg ajax, é necessária a biblioteca prototype, que acompanha a extensão (o arquivo encontra-se em CHICKEN_PREFIX/lib/chicken/3/prototype.js, onde CHICKEN_PREFIX é o diretório onde o sistema Chicken foi instalado). Copie o arquivo prototype.js para o mesmo diretório onde foi criado o arquivo web-server.scm.

O arquivo para gerar a página HTML (index.ws) é mostrado abaixo:

(ws:page
 (string-append
  (div 'id "resultado")
  (remote-link
   "Clique aqui"
   (lambda ()
     (print "Oi"))
   update: "resultado"))
 additional-headers: (ajax))

Para ver o resultado, basta executar o servidor web:

$ csi -s web-server.scm

e acessar http://localhost:8080 no seu navegador preferido (algum que tenha suporte a Javascript).

A função ajax usada no exemplo gera o código HTML necessário para referenciar a biblioteca prototype na página.

Obviamente, é possível fazer algo de mais útil com isso. A seguir é mostrado um exemplo mais elaborado (tamanho.ws): uma aplicação que mostra em uma caixa do tipo select os arquivos no diretório raíz do servidor e exibe o tamanho quando são selecionados.

(use posix)

(ws:page
 (string-append
  (ws:select
   'id "file-box"
   'onchange (remote-action
              (lambda ()
                (let ((file (post-var "file")))
                  (print "Tamanho de " file " = "
                         (file-size file) " bytes")))
              update: "resultado"
              arguments: "'file=' + $F('file-box')")
   (string-intersperse
    (map (lambda (opt)
           (option 'value opt opt))
         (glob (make-pathname
                (spiffy-root-path) "*")))
    ""))
  (div 'id "resultado"))
 additional-headers: (ajax))

O código acima monta uma caixa de opções (select de HTML) com os arquivos no diretório raíz do servidor (parâmetro (spiffy-root-path)) e usa remote-action para registrar a função que é executada no lado do servidor e executá-la quando um arquivo for selecionado na caixa de seleção.

O parâmetro de palavra-chave arguments especifica as variáveis a serem passadas através dos métodos GET e POST do HTTP. Se nenhum método for especificado, POST é usado (o parâmetro de palavra-chave method permite especificar o método a ser usado). A função $F em Javascript, da biblioteca prototype, retorna o conteúdo do widget cujo identificador é passado como argumento.

Para ver a aplicação em funcionamento, acesse http://localhost:8080/tamanho.ws no seu navegador

Mais detalhes sobre o funcionamento do egg ajax podem ser obtidos na documentação da extensão, em http://www.call-with-current-continuation.org/eggs/3/ajax.html.

Objetos em Scheme

2008-05-12T07:04:00.000-07:00

Há uns dias o tópico "objetos" surgiu nas discussões no canal #lisp-br. A especificação de Scheme não oferece nenhum sistema de objetos para ser prontamente usado, mas a linguagem possui características que permitem a implementação de sistemas de objetos (tanto que há vários).

A seguir está um exemplo de implementação bem simplificada de um criador de objetos em Scheme (Chicken Scheme).

Considerações:

Objetos são representados por closures que aceitam mensagens para acesso a atributos internos.

Em Scheme, funções (procedures) são objetos de primeira classe, ou seja, podem ser manipuladas como qualquer outro tipo de valor (e.g., números, strings). Assim, uma "chamada de método" nesse sistema de objetos exemplo corresponde ao acesso a um atributo cujo valor é uma função.

(use (srfi 1))

(define (cria-ponto)
  (letrec
      ((atributos
        `((pos-x . 0)
          (pos-y . 0)
          (posicao . ,(lambda ()
                        (cons (this 'pos-x)
                              (this 'pos-y)
                              )))))
       (this (lambda (var)
               (alist-ref var atributos))))
    (lambda args
      (if (null? args)
          (error "Nenhuma mensagem.")
          (let ((acao (car args)))
            (case acao
              ((set!) (let ((atributo (cadr args))
                            (valor (caddr args)))
                        (alist-update! atributo valor
                                       atributos)
                        (void)))
              ((get) (let ((atributo (this (cadr args))))
                       (or atributo
                           (error "Atributo inexistente."))))
              (else (error "Mensagem nao conhecida."))
              ))))))

A função cria-ponto retorna um objeto ponto, o qual é representado por uma função que aceita um número arbitrário de argumentos, que correspondem a mensagens. Os atributos do objeto são declarados na alist atributos, com um valor inicial. Um dos atributos (posicao) é uma função, que retorna um par representando as coordenadas do ponto.

A criação de um objeto ponto é feita com a avaliação da expressão (cria-ponto):

(define ponto (cria-ponto))

ponto, então, passa a representar um objeto ponto, o qual aceita mensagens. Alguns exemplos:

csi> (define ponto (cria-ponto))
csi> (ponto 'get 'pos-x)
0
csi> (ponto 'get 'pos-y)
0
csi> (ponto 'set! 'pos-y 10)
csi> (ponto 'get 'pos-y)
10
csi> (ponto 'get 'posicao)
#<procedure (?)>
csi> ((ponto 'get 'posicao))
(0 . 10)

Algumas mensagens causam alteração nos objetos (i.e., set!). Como a representação de pontos é feita com closures, a alteração do estado interno de um objeto não deve alterar o dos outros:

csi> (define outro-ponto (cria-ponto))
csi> (outro-ponto 'get 'pos-x)
0
csi> (outro-ponto 'set! 'pos-x 15)
csi> ((outro-ponto 'get 'posicao))
(15 . 0)
csi> ((ponto 'get 'posicao))
(0 . 10)

A implementação de introspecção pode ser feita com a implementação tratadores para duas novas mensagens: tipo e atributos, ou seja, fazemos com que objetos ponto respondam a mensagens tipo e atributos:

(use (srfi 1))

(define (cria-ponto)
  (letrec
      ((tipo 'ponto)
       (atributos
        `((pos-x . 0)
          (pos-y . 0)
          (posicao . ,(lambda ()
                        (cons (this 'pos-x)
                              (this 'pos-y)
                              )))))
       (this (lambda (var)
               (alist-ref var atributos))))
    (lambda args
      (if (null? args)
          (error "Nenhuma mensagem.")
          (let ((acao (car args)))
            (case acao
              ((set!) (let ((atributo (cadr args))
                            (valor (caddr args)))
                        (alist-update! atributo valor
                                       atributos)
                        (void)))
              ((get) (let ((atributo (this (cadr args))))
                       (or atributo
                           (error "Atributo inexistente."))))
              ((tipo) tipo)
              ((atributos) atributos)
              (else (error "Mensagem nao conhecida."))
              ))))))

Para obter as informações de tipo e atributos do objeto ponto, então:

csi> (define ponto (cria-ponto))
csi> (ponto 'tipo)
ponto
csi> (ponto 'atributos)
((pos-x . 0) (pos-y . 0) (posicao . #<procedure (?)>))

Para a implementação de um simples mecanismo de herança, fazemos com que a função criadora de objetos passe a aceitar uma lista de ancestrais, e incorpore a lista de atributos dos ancestrais aos atributos do objeto sendo criado. O exemplo a seguir mostra a criação de um objeto representando um ponto em três dimensões, aproveitando características de um ponto em duas dimensões (pos-x e pos-y):

(use (srfi 1))

(define (cria-ponto-3D . pais)
  (letrec
      ((tipo 'ponto-3D)
       (tipos (cons tipo
                    (map (lambda (pai)
                           (pai 'tipo))
                         pais)))
       (supers (apply append
                      (map (lambda (pai)
                             (pai 'atributos))
                           pais)))
       (atributos
        `((pos-z . 0)
          (posicao . ,(lambda ()
                        (list (this 'pos-x)
                              (this 'pos-y)
                              (this 'pos-z)
                              )))))
       (this (lambda (var)
               (or (alist-ref var atributos)
                   (alist-ref var supers)))))
    (lambda args
      (if (null? args)
          (error "Nenhuma mensagem.")
          (let ((acao (car args)))
            (case acao
              ((set!) (let ((atrib (cadr args))
                            (valor (caddr args)))
                        (if (alist-ref atrib atributos)
                            (alist-update! atrib valor
                                           atributos)
                            (alist-update! atrib valor
                                           supers))
                        (void)))
              ((get) (let ((atributo (this (cadr args))))
                       (or atributo
                           (error "Atributo inexistente."))))
              ((tipo) tipo)
              ((atributos) (append supers atributos))
              ((is-a?) (lambda (t)
                         (not (not (memq t tipos)))))
              (else (error "Mensagem nao conhecida."))
              ))))))

O objeto ponto 3D incorpora as características de seus ancestrais e adiciona uma nova: pos-z, além de responder mensagens novas, como is-a?.

csi> (define ponto-3D (cria-ponto-3D ponto))
csi>  (ponto-3D 'tipo)
ponto-3D
csi> ((ponto-3D 'is-a?) 'ponto)
#t
csi> ((ponto-3D 'is-a?) 'ponto-3D)
#t
csi> ((ponto-3D 'is-a?) 'ponto-4D)
#f

É possível generalizar a função criadora de objetos para que ela receba como argumentos o tipo, os atributos e os ancestrais dos objetos a serem criados:

(use (srfi 1))

(define-macro (cria tipo atributos pais)
  `(letrec
       ((tipo ,tipo)
        (tipos (cons ,tipo
                     (map (lambda (pai)
                            (pai 'tipo))
                          ,pais)))
        (supers (apply append
                       (map (lambda (pai)
                              (alist-copy (pai 'atributos)))
                            ,pais)))
        (atributos ,atributos)
        (this (lambda (var)
                (or (alist-ref var atributos)
                    (alist-ref var supers)))))
     (lambda args
       (if (null? args)
           (error "Nenhuma mensagem.")
           (let ((acao (car args)))
             (case acao
               ((set!) (let ((atrib (cadr args))
                             (valor (caddr args)))
                         (if (alist-ref atrib atributos)
                             (alist-update! atrib valor
                                            atributos)
                             (alist-update! atrib valor
                                            supers))
                         (void)))
               ((get) (let ((atributo (this (cadr args))))
                        (or atributo
                            (error "Atributo inexistente."))))
               ((tipo) tipo)
               ((atributos) (append supers atributos))
               ((is-a?) (lambda (t)
                          (not (not (memq t tipos)))))
               (else (error "Mensagem nao conhecida."))
               ))))))

csi> (define obj (cria 'ponto
--->                   `((pos-x . 0)
--->                     (pos-y . 0)
--->                     (posicao . ,(lambda ()
--->                                   (cons (this 'pos-x)
--->                                         (this 'pos-y)))))
--->                   '()))
csi>
csi> (obj 'get 'pos-x)
0
csi> (obj 'set! 'pos-x 30)
csi> (obj 'get 'pos-x)
30
csi> (obj 'tipo)
ponto
csi> ((obj 'is-a?) 'ponto)
#t
csi> ((obj 'is-a?) 'ponto00)
#f
csi>
csi> (define obj2 (cria 'ponto-3D
--->                    `((pos-z . 0)
--->                      (posicao . ,(lambda ()
--->                                    (list (this 'pos-x)
--->                                          (this 'pos-y)
--->                                          (this 'pos-z)))))
--->                    (list obj)))
csi>
csi> ((obj2 'is-a?) 'ponto)
#t
csi> (obj2 'get 'pos-x)
30
csi> (obj2 'set! 'pos-x 90)
csi> (obj 'get 'pos-x)
30
csi> (obj2 'get 'pos-x)
90
csi> ((obj2 'get 'posicao))
(90 0 0)

O sistema de objetos mostrado aqui não utiliza classes para a representação de características de objetos. As características de objetos são representadas em uma função geradora de objetos. A herança utiliza objetos para a representação de ancestrais, não classes, havendo a clonagem dos objetos usados como ancestrais. A ordem para resolução de atributos é a ordem de passagem de ancestrais na criação de objetos, ou seja, se dois ancestrais possuem um atributo comum, o atributo do primeiro antecestral será o usado pelo objeto filho.

Clip no REPL

2008-05-08T07:06:00.000-07:00

A procrastinação leva o cara a fazer coisas como essa:

(use utils)

(define (stupid-clip text)
  (string-append
        " --
/  \\
|  |
@  @
|| ||
|| ||
|\\_/|
\\___/\n

What do you want to mess up with today?

"
text
))

(toplevel-command
 'annoy
 (lambda ()
   (print
    (stupid-clip (with-output-to-string
                   (lambda ()
                     (apropos (read))))))))

Usando isso no REPL:

$ csi -n

CHICKEN
(c)2008 The Chicken Team
(c)2000-2007 Felix L. Winkelmann
Version 3.2.0 - linux-unix-gnu-x86 [ manyargs dload ptables applyhook ]
SVN rev. 10664  compiled 2008-05-07 on ze-dureza (Linux)

#;1> (load "annoy.scm")
; loading annoy.scm ...
; loading library utils ...
#;2> ,annoy close
 --
/  \
|  |
@  @
|| ||
|| ||
|\_/|
\___/


What do you want to mess up with today?

close-input-port  : (procedure port948)
close-input-file  : variable
close-output-file : variable
close-output-port : (procedure port949)

Atualização

Na realidade, o código pode ser um pouco mais simples:


(use utils)

(toplevel-command
 'annoy
 (lambda ()
   (print " --
/  \\
|  |
@  @
|| ||
|| ||
|\\_/|
\\___/\n

What do you want to mess up with today?

")
   (apropos (read))))

Apresentações em Scheme

2008-05-08T04:36:00.000-07:00

Não sou um especialista em apresentações, mas de vez em quando surgem algumas para eu fazer. Não tenho o hábito de usar softwares para edição de apresentações como o Impress do Openoffice.org (é uma questão de preferência pessoal como usuário -- nada contra o Openoffice.org). Sobretudo, faço as apresentações com o visual mais simples possível, normalmente fundo branco com letras pretas, como uma página de livro tradicional.

Durante um bom tempo fui usuário de LaTeX (cheguei a fazer uma classe para apresentações -- Pauerpoint), mas algumas coisas são desnecessariamente difíceis de se fazer em LaTeX.

Então me ocorreu a idéia de implementar algo em Scheme para fazer apresentações. Com o uso de algumas coisas prontas em CSS e Javascript, a implementação em Scheme é surpreendentemente simples:

(use web-scheme)

(define (slide title-text . contents)
  (div 'class "slide"
       (h1 title-text)
       (string-intersperse contents)))

(define (cover title-text . contents)
  (div 'class "slide cover"
       (h1 title-text)
       (string-intersperse contents)))

(define (presentation . slides)
  (ws:page
   (string-intersperse slides)
   additional-headers: (string-append
                        (link 'rel "stylesheet"
                              'type "text/css"
                              'media "screen, projection"
                              'href "show.css")
                        (script 'src "slidy.js"
                                'type "text/javascript"))))

O código acima, em Chicken Scheme, mostra as três funções para a montagem de uma apresentação. As partes de CSS e Javascript são do HTML Slidy.

Para criar uma apresentação, basta fazer algo como:

(presentation
    (cover "Minha capa")
    (slide "Introdução")
    (slide "Fim"))

Para gerar o código HTML, que pode ser visualizado em qualquer browser, executo:

$ web-scheme2html minha-apresentacao.scm > minha-apresentacao.html

web-scheme2html é um script que acompanha a extensão web-scheme de Chicken.

Em http://g3pd.ucpel.tche.br/~mario/misc/upgrade-v2 está um exemplo de apresentação que fiz sobre programação para a Web com Scheme (boa parte da apresentação é sobre o básico da linguagem). O código fonte da apresentação está em http://g3pd.ucpel.tche.br/~mario/misc/upgrade-v2/index.ws.

Compilador ingênuo de Scheme para Javascript

2008-05-06T15:48:00.000-07:00

Por curiosidade, há algum tempo tentei ver como seria fazer um compilador simples de Scheme para Javascript. Obviamente, um compilador "de verdade" não é uma tarefa fácil, embora haja esforços nesta direção.

De qualquer forma, é impressionante o que dá para fazer com algumas poucas linhas de código. :-)

Várias formas básicas de Scheme não estão implementadas: cond, begin, call/cc e muitas outras.

#!/usr/bin/csi -script

(use (srfi 1))

(define (infix-op op args)
  (string-intersperse
   (map ->string (map scm->js args)) (->string op)))

(define (mapconcat elts #!optional sep)
  (string-intersperse (map ->string elts) (or sep "")))

(define (scm-body->js body)
  (let ((body-butlast (butlast body))
        (last-expr (last body)))
    (conc (mapconcat (map scm->js body-butlast) ";") ";"
          "return " (scm->js last-expr) ";")))
  
(define (scm->js expr)
  (if (atom? expr)
      (cond ((string? expr)
             (conc "'" expr "'"))
            ((boolean? expr)
             (if (eq? expr '#t) "true" "false"))
            (else expr))
      (case (car expr)
        ((if) (let ((condition (cadr expr))
                    (branch1 (caddr expr))
                    (branch2 (and (= 4 (length expr))
                                  (cadddr expr))))
                (conc "(function(){if(" (scm->js condition)
                      "){return(" (scm->js branch1) ");}"
                      (if branch2
                          (conc "else{return("
                                (scm->js branch2) ");}")
                          "")
                      "})();")))
        ((return) (conc "return(" (scm->js (cadr expr))
                        ");"))
        ((lambda)
         (conc "function"
               (if (null? (cadr expr))
                   "()"
                   (conc "(" (mapconcat (cadr expr) ",")
                         ")")) "{"
                         (scm-body->js (cddr expr)) "}"))
        ((define) (conc ";var " (cadr expr) "="
                        (scm->js (caddr expr)) ";"))
        ((+ - * / < >)  (infix-op (car expr) (cdr expr)))
        ((=)  (infix-op '== (cdr expr)))
        ((or) (infix-op "||" (cdr expr)))
        ((and) (infix-op "&&" (cdr expr)))
        ((let) (conc "(function(){"
                     (string-intersperse
                      (map (lambda (binding)
                             (conc "var " (car binding) "="
                                   (scm->js (cadr binding))
                                   ";"))
                           (cadr expr)))
                     (scm-body->js (cddr expr))
                     "})()"))
        ((let*) (scm->js (macroexpand expr)))
        (else (conc (car expr) "("
                    (string-intersperse
                     (map ->string
                          (map scm->js (cdr expr)))
                     ",") ")")))))

(define (js exprs)
  (string-intersperse (map scm->js exprs) ""))

(print (js (read-file (car (command-line-arguments)))))

Alguns exemplos "práticos" estão a seguir. scm2js.scm é o compilador, implementado em Chicken Scheme; js é um interpretador de Javascript que pode ser executado na linha de comando.

Obs.: o código Javascript gerado é bastante indigesto:

$ ./scm2js.scm ex1.scm

;var fatorial=function(n){;return (function(){if(n<1){return(1);}else{return(n*fatorial(n-1));}})();;};print(fatorial(4))

$ cat ex1.scm

(define fatorial
  (lambda (n)
    (if (< n 1)
        1
        (* n (fatorial (- n 1))))))

(print (fatorial 4))

$ ./scm2js.scm ex1.scm | js
24

$ cat ex2.scm

(define a (lambda (n)
            (print "aqui")
            n))
(print (a 6))

$ ./scm2js.scm ex2.scm | js
aqui
6

$ cat ex3.scm

(define x (if #t "ok" "false"))
(print x)

 $ ./scm2js.scm ex3.scm | js
ok

$ cat ex4.scm

(define func
  (lambda (a b c d)
    (let* ((a (+ b c d))
           (dif (- a b c d)))
      (+ a dif))))

(print (func 1 2 3 4))

$ ./scm2js.scm ex4.scm | js
9

Código formatado no Blogger

2008-05-06T06:24:00.000-07:00

A minha primeira tentiva de escrita de código no Blogger foi frustrante: sem destaque de sintaxe (syntax highlight) e um editor com poucos recursos.

Vi que a marcação do texto era feita com HTML (surpresa!) e decidi fazer um script para gerar texto formatado para o Blogger. Faço a marcação do texto com web-scheme e o programa se encarrega de gerar o HTML. Depois só copio e colo o código HTML na caixa de edição do Blogger.

O programa para geração de HTML está a seguir (em Chicken Scheme). O "embelezamento" do código é feito com o programa Enscript.

(use posix utils web-scheme (srfi 1))

(define (run . cmd)
  (let* ((p (open-input-pipe (sprintf "~A 2>&1" (apply conc cmd)))))
    (read-all p)))

(define (run-enscript code lang #!optional pretty)
  (let ((tmp (create-temporary-file)))
    (with-output-to-file tmp (lambda ()
                               (if pretty
                                   (pp code)
                                   (print code))))
    (let ((out (run "enscript -q --color --highlight="
                    lang " -o - -whtml " tmp)))
      (delete-file tmp)
      out)))

(define (htmlize code lang #!optional no-pre)
  (let* ((out (run-enscript code lang (not (string? code))))
         (lines (with-input-from-string out read-lines)))
    (string-append
     ((if no-pre ;; pre nao quebra linhas
          tt
          pre)
      (string-intersperse
       ;; retira cabecalho e rodape colocados pelo enscript
       (drop-right (take-right lines (- (length lines) 11)) 5)
       "\n"))
     (if no-pre "\n" ""))))

(define ->
  (let ((bookmarks
         '((Chicken . "http://www.call-with-current-continuation.org")
           (web-scheme . "http://chicken.wiki.br/web-scheme")
           (eggs . "http://chicken.wiki.br/eggs"))))
    (lambda (url #!optional text)
      (let ((bookmarked (alist-ref url bookmarks)))
        (if (and (symbol? url) bookmarked)
            (a 'href bookmarked (symbol->string url))
            (a 'href url (or text url)))))))

(define (p . text) ;; paragrafo do blogger
  (string-append (apply conc text) "\n\n"))

(define (usage #!optional exit-code)
  (print (program-name) " <input-file>")
  (when exit-code (exit exit-code)))

(let ((args (command-line-arguments)))
  (if (null? args)
      (usage 1)
      (print
       (string-intersperse
        (map eval (with-input-from-file (car args) read-file))))))

A função -> é especialmente interessante: admite como argumentos uma URL e um texto, somente uma URL, ou uma palavra-chave para acesso aos bookmarks.

O código fonte deste artigo inteiro é:

(p "A minha primeira tentiva de escrita de código no Blogger foi frustrante: sem destaque de sintaxe (" (i "syntax highlight") ") e um editor com poucos recursos.") (p "Vi que a marcação do texto era feita com HTML (surpresa!) e decidi fazer um script para gerar texto formatado para o Blogger. Faço a marcação do texto com " (-> 'web-scheme) " e o programa se encarrega de gerar o HTML. Depois só copio e colo o código HTML na caixa de edição do Blogger.") (p "O programa para geração de HTML está a seguir (em " (-> 'Chicken) " Scheme). O \"embelezamento\" do código é feito com o programa " (-> "http://www.gnu.org/software/enscript/" "Enscript") ".") (htmlize (read-all "./bin/blog.scm") 'scheme) (p "A função " (code "->") " é especialmente interessante: admite como argumentos uma URL e um texto, somente uma URL, ou uma palavra-chave para acesso aos " (i "bookmarks") ".") (p "O código fonte " (b "deste artigo inteiro") " é:") (htmlize (read-all "./call-hc/codigo-formatado-no-blogger.scm") 'scheme 'no-pre)