sexta-feira, 30 de maio de 2008

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

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.

sábado, 24 de maio de 2008

Giannini Thunder Sound Bass II

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

quarta-feira, 14 de maio de 2008

Geração de tablaturas em Scheme

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

terça-feira, 13 de maio de 2008

Programação para Web com Chicken e Ajax

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:


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.

segunda-feira, 12 de maio de 2008

Objetos em Scheme

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.

quinta-feira, 8 de maio de 2008

Clip no REPL

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

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.

terça-feira, 6 de maio de 2008

Compilador ingênuo de Scheme para Javascript

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

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)

segunda-feira, 5 de maio de 2008

web-scheme for dummies

web-scheme é uma extensão do sistema do sistema Chicken que implementa uma linguagem de programação baseada em Scheme para a Web.

web-scheme disponibiliza funções para a geração de código HTML a partir de código Scheme. Exemplo:

(div 'id "caixa" "Texto")

produz a string

<div  id="caixa">Texto</div>

Todas as tags de HTML são representadas como funções em Scheme de mesmo nome, exceto nomes conflitantes, como, por exemplo, map e select (nomeadas ws:map e ws:select, respectivamente).

Além da representação de tags HTML como funções em Scheme, web-scheme também disponibiliza algumas funções que podem facilitar a geração de código HTML.

Um exemplo é a função ws:page, para gerar páginas HTML de forma desburocratizada. Exemplo:

(ws:page "Oi")

gera a seguinte string com código HTML:

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
<html><head><meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<title></title>
</head>
<body>Oi</body>
</html>

É possível alterar o código HTML gerado por ws:page através do uso de parâmetros. Por exemplo, o conjunto de caracteres da página pode ser alterado com o parâmetro charset:

(ws:page "Oi" charset: "utf-8")

produz

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
<html><head><meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<title></title>
</head>
<body>Oi</body>
</html>

Outro exemplo é a função ws:make-table, que usa como argumento uma lista de listas representando uma tabela:

(ws:make-table '((1 2 3) (4 5 6)))

produz

<table><tr><td>1</td>
<td>2</td>
<td>3</td>
</tr>
<tr><td>4</td>
<td>5</td>
<td>6</td>
</tr>
</table>

Além dessas, há várias outras funções, macros e parâmetros com documentação no site da extensão.