diale.org

Blog e página pessoal de Tiago Charters de Azevedo (Blog and personal webpage of Tiago Charters de Azevedo)

Sobre a originalidade e o método da bissecção em Lisp

2012/03/30-13:31:09

Quando comecei a aprender Lisp também li o Structure and Interpretation of Computer Programs

Structure and Interpretation of Computer Programs

Este livro é muito inspirador não śo para quem programa em Scheme, um dialecto de Lisp, mas também para qualquer outra linguagem de programação. E claro, de tão bom que é fácil aparecerem obras derivadas de qualidade inferior.

Um dos exemplos do livro Programação em scheme introdução à programação utilizando múltiplos paradigmas (PSIPUMP) de J. P. Martins e M. Cravo é o método da bissecção. Aí, pg. 128 1ª ed, é chamado de metodo-intervalo. Ora na sua forma mais simples pode ser implementado na forma

(defun bisection-1 (f a b &optional tol)
 (when (null tol)
   (setq tol 0.00001))
 (let*
     ((m (+ a (/ (- b a) 2.0))) ;; passar para função externa
      (fm (funcall f m))
      (fa (funcall f a)))
   (cond ((< (- b a) tol) m)   ;; passar para função externa
         (t 
         (cond ((> (* fa fm) 0.0)
                (bisection-1 f m b tol))
               (t (bisection-1 f a m tol)))))))

Como se verá esta versão é a mais eficiente das quatro que vou construir. Como é fácil de ver o método depende da construção de sucessivos pontos médios do intervalo e de, em cada aproximação, de verificar se a aproximação obtida está já dentro da precisão que se quer. O ponto médio é calculado através de

(m (+
a (/ (- b a) 2.0)))

e a condição através de (< (- b a) tol). Qualquer uma destas operações pode ser definida à custa de duas funções externas tornando a implementação do método da bissecção mais modular. A saber, respectivamente,

(defun mean (a b)
  (+ a (/ (- b a) 2.0)))  

(defun good-enough (a b eps)
  (cond ((< (abs (- b a)) eps)
         t)
        (t
         nil)))

O cálculo do ponto médio é feito de modo a evitar problemas de overflow, coisa que não acontece em PSIPUMP. Assim podemos escrever o método da bissecção na forma (versão 2)

(defun good-enough (a b eps)
  (cond ((< (abs (- b a)) eps)
         t)
        (t
         nil)))

(defun mean (a b)
  (+ a (/ (- b a) 2.0)))  

(defun bisection-2 (f a b tol)
  (let* ((m (mean a b))
         (fm (funcall f m))
         (fa (funcall f a)))
    (cond ((good-enough a b tol)
           m)
          (t 
           (cond ((> (* fa fm) 0.0)
                  (bisection-2 f m b tol))
                 (t (bisection-2 f a m tol)))))))

Outras das versões possíveis de construir é a de definir os procedimentos good-enough e mean como procedimentos locais dentro de bisection, o que dá:

(defun bisection-3 (f a b tol)
  (labels ((good-enough (a b eps)
             (cond ((< (abs (- b a)) eps)
                    t)
                   (t
                    nil)))
           (mean (a b)
             (+ a (/ (- b a) 2.0))))
    (let* ((m (mean a b))
           (fm (funcall f m))
           (fa (funcall f a)))
      (cond ((good-enough a b tol)
             m)
            (t 
             (cond ((> (* fa fm) 0.0)
                    (bisection-3 f m b tol))
                   (t (bisection-3 f a m tol))))))))

mas perde-se parte da modularidade.

Outra ainda, evitar-se a azelhice (versão 4) confirmando em cada passo que a função tem valores de sinais contrários em cada extremo do intervalo.

(defun bisection-4 (f a b tol)
  (labels ((good-enough (a b eps)
             (cond ((< (abs (- b a)) eps)
                    t)
                   (t
                    nil)))
           (mean (a b)
             (+ a (/ (- b a) 2.0))))
    (let* ((m (mean a b))
           (fm (funcall f m))
           (fa (funcall f a))
           (fb (funcall f b))) ;; confirmação extra
      (when (< (* fa fb) 0.0)  ;; dos sinais de f em a e b
        (cond ((good-enough a b tol)
               m)
              (t 
               (cond ((> (* fa fm) 0.0)
                      (bisection-4 f m b tol))
                     (t (bisection-4 f a m tol)))))))))

A pergunta que podemos fazer a seguir é a seguinte: qual das quatro variações é a mais eficiente, mais rápida, que consome menos recursos? Ora isto pode ser investigado usando o slime-profile¹ e a função

(defun profile-bis (nmax)
  (dotimes (n nmax)
    (dolist 
        (bisection '(bisection-1 bisection-2 
                     bisection-3 bisection-4 bisection-5))
      (funcall bisection (lambda (x) (- 2 (* x x))) 1 2 
               (expt 10 -6))))
  "Done...")

Os resultados são estes que falam por si (por ordem crescente de eficiencia):

                                                               Cons  
                             %      %                          Per     Total     Total
Function                    Time   Cons    Calls  Sec/Call     Call    Time      Cons
-----------------------------------------------------------------------------------------
PROFILE-BIS::BISECTION-4:  32.64   50.00  1050000  0.000020    1128    20.593  1184400000
PROFILE-BIS::BISECTION-3:  30.22   50.00  1050000  0.000018    1128    19.069  1184400000
PROFILE-BIS::BISECTION-5:  14.32    0.00  1050000  0.000009       0     9.033           0
PROFILE-BIS::BISECTION-2:  12.40    0.00  1050000  0.000007       0     7.820           0
PROFILE-BIS::BISECTION-1:  10.42    0.00  1050000  0.000006       0     6.576           0
-----------------------------------------------------------------------------------------
TOTAL:                    100.00  100.00  5250000                      63.092  2368800000
Estimated monitoring overhead:  0.00 seconds
Estimated total monitoring overhead:  0.00 seconds

Já me esquecia a função bisection-5 é a função bisection-2 com a correcção da azelhice.

(defun bisection-5 (f a b tol)
  (let* ((m (mean a b))
         (fm (funcall f m))
         (fa (funcall f a))
         (fb (funcall f b)))
    (when (< (* fa fb) 0.0)
      (cond ((good-enough a b tol)
             m)
            (t 
             (cond ((> (* fa fm) 0.0)
                    (bisection-5 f m b tol))
                   (t (bisection-5 f a m tol))))))))

Pacote com todas as funções

(defpackage :profile-bis
  (:use :cl)
  (:export #:profile-bis))

(in-package :profile-bis)

;;1

(defun bisection-1 (f a b tol)
  (let*
      ((m (+ a (/ (- b a) 2.0)))
       (fm (funcall f m))
       (fa (funcall f a)))
    (cond ((< (- b a) tol) m)
          (t 
           (cond ((> (* fa fm) 0.0)
                  (bisection-1 f m b tol))
                 (t (bisection-1 f a m tol)))))))

;;2

(defun good-enough (a b eps)
  (cond ((< (abs (- b a)) eps)
         t)
        (t
         nil)))

(defun mean (a b)
  (+ a (/ (- b a) 2.0)))  

(defun bisection-2 (f a b tol)
  (let* ((m (mean a b))
         (fm (funcall f m))
         (fa (funcall f a)))
    (cond ((good-enough a b tol)
           m)
          (t 
           (cond ((> (* fa fm) 0.0)
                  (bisection-2 f m b tol))
                 (t (bisection-2 f a m tol)))))))

;;3

(defun bisection-3 (f a b tol)
  (labels ((good-enough (a b eps)
             (cond ((< (abs (- b a)) eps)
                    t)
                   (t
                    nil)))
           (mean (a b)
             (+ a (/ (- b a) 2.0))))
    (let* ((m (mean a b))
           (fm (funcall f m))
           (fa (funcall f a)))
      (cond ((good-enough a b tol)
             m)
            (t 
             (cond ((> (* fa fm) 0.0)
                    (bisection-3 f m b tol))
                   (t (bisection-3 f a m tol))))))))

;;4

(defun bisection-4 (f a b tol)
  (labels ((good-enough (a b eps)
             (cond ((< (abs (- b a)) eps)
                    t)
                   (t
                    nil)))
           (mean (a b)
             (+ a (/ (- b a) 2.0))))
    (let* ((m (mean a b))
           (fm (funcall f m))
           (fa (funcall f a))
           (fb (funcall f b)))
      (when (< (* fa fb) 0.0)
        (cond ((good-enough a b tol)
               m)
              (t 
               (cond ((> (* fa fm) 0.0)
                      (bisection-4 f m b tol))
                     (t (bisection-4 f a m tol)))))))))

;;5

(defun bisection-5 (f a b tol)
  (let* ((m (mean a b))
         (fm (funcall f m))
         (fa (funcall f a))
         (fb (funcall f b)))
    (when (< (* fa fb) 0.0)
      (cond ((good-enough a b tol)
             m)
            (t 
             (cond ((> (* fa fm) 0.0)
                    (bisection-5 f m b tol))
                   (t (bisection-5 f a m tol))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun profile-bis (nmax)
  (dotimes (n nmax)
    (dolist 
        (bisection '(bisection-1 bisection-2 
                     bisection-3 bisection-4
                     bisection-5))
      (funcall bisection (lambda (x) (- 2 (* x x))) 1 2 
               (expt 10 -6))))
  "Done...")

(profile-bis 50000)

1. SLIME: The Superior Lisp Interaction Mode for Emacs

Etiquetas/Tags: lisp, scheme, slime, matemática, bissecção,

Trying to learn METAFONT (act.)

2012/03/23-15:41:34

Estava a "tentar" aprender METAFONT, o significado das aspas tornar-se-á claro em poucos instantes, e dei com o seguinte comentário escrito pelo próprio Knuth

Pythagorean addition $latex2png equation$ is implemented by an elegant iterative scheme due to Cleve Moler and Donald Morrison IBM Journal of Research and Development 27 (1983), 577—581. It modifies |a| and |b| in such a way that their Pythagorean sum remains invariant, while the smaller argument decreases.

E, justifica-se as aspas, tive de descobrir o artigo (não encontrei outro sítio para o ler) e implementar o código em Lisp.

(defun pythag (a b &optional tol)
  "Pythagorean addition $\sqrt{a^2+b^2}$ is implemented by an elegant
iterative scheme due to Cleve Moler and Donald Morrison IBM Journal
of Research and Development 27 (1983), 577--581. It modifies |a| and |b|
in such a way that their Pythagorean sum remains invariant, while the
smaller argument decreases."
  (if (>= a b)
      (pythag b a tol)
      (if (<= a (if tol 
                    tol 
                    (expt 10.0 -16)))
          b
          (let* ((r (expt (/ a b) 2))
                 (s (/ r (+ 4 r)))
                 (b (+ b (* 2 s b)))
                 (a (* s a)))
            (pythag a b tol)))))

> (pythag 1.0 2.0 .000001)
2.236068
> (expt  5 .5)
2.236068

e com a operação inversa

(defun pythag (pm a b &optional tol)
  "Pythagorean addition $\sqrt{a^2\pm b^2}$ is implemented by an elegant
iterative scheme due to Cleve Moler and Donald Morrison IBM Journal
of Research and Development 27 (1983), 577--581. It modifies |a| and |b|
in such a way that their Pythagorean sum remains invariant, while the
smaller argument decreases. pm -> +1 gives sqrt(a^2+b^2); pm -> -1 gives sqrt(a^2-b^2);"
  (if (>= a b)
      (pythag pm b a tol)
      (if (<= a (if tol 
                    tol 
                    (expt 10.0 -16)))
          b
          (let* ((r (* pm (expt (/ a b) 2)))
                 (s (/ r (+ 4 r)))
                 (b (+ b (* 2 s b)))
                 (a (* s a)))
            (pythag pm a b tol)))))

Voltando ao METAFONT.

Etiquetas/Tags: Metafont, LaTeX, Pythagorean addition, lisp

Números primos com o Maxima (CAS)

2012/03/21-22:24:04

Uma das principais vantagens do uso de software livre é o partilhar-e-aprender. Resolvi verificar se o software maxima (http://maxima.sourceforge.net) fazia a factorizarão de um número inteiro e que algoritmo usava. E como é software livre aqui está ele:

(defun get-one-factor-pollard (n lim)
  (let* ((x (+ (random (- n 3)) 2))
         (a (+ (random (- n 2)) 1))
         (b (+ (random (- n 5)) 1))
         (y x) (d 1) (r 2) (j 1) (k)
         (terms (ceiling (log (float n)))))
    (setq b (/ b (gcd a b)))
    (loop while (= d 1) do
         (setq y x)
         (incf j r)
         (dotimes (i r)
           (setq x (mod (+ (* a (mod (* x x) n)) b) n)))
         (setq k 0)
         (loop while (and (< k r) (equal d 1)) do
              (dotimes (i (min terms (- r k)))
                (setq x (mod (+ (* a (mod (* x x) n)) b) n))
                (setq d (mod (* d (- x y)) n)))
              (setq d (gcd d n))
              (incf k terms))
         (setq r (* 2 r))
         (when (< 0 lim j)
             (return-from get-one-factor-pollard d)))
    d))

Claro que também usa, se o número for muito grande, uma factorizarão com curvas elípticas. E é suficientemente rápido para calcular a factorizarão dos 8 primeiros números de Fermat:

(%i1) F(n):=2^(2^n)+1;
                                          n
                                         2
(%o1)                           F(n) := 2   + 1
(%i2) for n in [0,1,2,3,4,5,6,7] do ldisp(ifactors(F(n)))$
(%t2)                              [[3, 1]]

(%t3)                              [[5, 1]]

(%t4)                              [[17, 1]]

(%t5)                             [[257, 1]]

(%t6)                            [[65537, 1]]

(%t7)                      [[641, 1], [6700417, 1]]

(%t8)                 [[274177, 1], [67280421310721, 1]]

(%t9)        [[59649589127497217, 1], [5704689200685129054721, 1]]

E ainda

(%i2) F(8);
(%o2) 
 115792089237316195423570985008687907853269984665640564039457584007913129639937
(%i3) ifactors(F(8));
(%o3) [[1238926361552897, 1], 
           [93461639715357977769163558199606896584051237541638188580280321, 1]]
(%i4) ifactors(F(9));

Unrecoverable error: Pages out of range in make_writable.

Process maxima aborted

Etiquetas/Tags: maxima, primos, matemática

Aprender Python

2012/03/19-22:44:13

Tenho andado a aprender a programar em Python e por isso comecei a fazer os 99 problemas ¹. Esta lista é baseada na original em PROLOG.

Python é mais imperativa do que funcional, mas mesmo assim vale a pena.

O problema 35 é de um dos mais estimulantes:

Determine the prime factors of a given positive integer.

A maneira mais simples, e a primeira que fiz, usa o crivo de Eratóstenes

# 35. Determine the prime factors of a given positive integer.
#     Construct a flat list containing the prime factors in ascending order.

import math

def isprime (n):
    q=map(lambda x: float(n)/x,[2]+range(3,math.trunc(math.sqrt(n))+1,2))
    if n<2:
        return False
    elif n==2:
        return True
    else:
        aux=map((lambda x,y:not x==y),q,map(lambda x: math.trunc(x),q))
        return map((lambda x:True),aux)==aux

def isprime_n (n):
    if isprime(n): return n

def genprimes (n):
    p=range(2,n+1)
    p=map(lambda x: isprime_n(x), p)
    return rm_none(p)

def rm_none (lst):
    aux=lst
    retval=[]
    i=0
    for x in aux:
        if not x==None:
            retval.append(x)
            i=i+1
    return retval

def primefactor (n):
    "This works for small n."
    p=genprimes(n)
    pf=[]
    if isprime(n):
        pf.append(n)
        return pf
    else:
        for pi in p:
            while  n % pi == 0:
                pf.append(pi)
                n=n/pi
            if isprime(n):
                pf.append(n)
                return pf
            elif n==1:
                return pf

Por exemplo:

>>> primefactor(3016)
[2, 2, 2, 13, 29]

Não é de facto a mais elegante mas resolve o problema para valores pequenos de n.

Claro que o problema está quando se quer calcular a factorização de 4434353535435160. Para este "tipo" de números o algoritmo rho de Pollard resolve o problema.

>>> list(factor(4434353535435160))
[2, 2, 2, 5L, 5261L, 21881L, 963019L]

def gcd (a,b):
    while not b==0:
        t = b
        b = a % b
        a = t
    return a

def pollard(n,c):
    if n % 2 == 0: return 2
    def f(z,c,n):
        return (pow(z,2)+c) % n
    x,y,d=2,2,1
    while d==1:
        x=f(x,c,n)
        y=f(f(y,c,n),c,n)
        d=gcd(abs(x-y),n)
    return d

def factor(n):
    m=2
    lmax=n**0.5
    while m<=lmax:
        m=pollard(n,1)
        if n % m == 0:
            yield m
            n=n/m
            lmax=n**0.5
    if n > 1:
        yield n

Para o F5 (número de Fermat) o resultado é quase instantâneo:

>>> list(factor(4294967297))
[641L, 6700417L]

para factorizar o F6 é preciso mais tempo

>>> list(factor(18446744073709551617))
[274177L, 67280421310721L]

A ideia era factorizar este 13256278887989457651018865901401704640L num tempo relativamente curto! Mas nem mesmo este algoritmo o faz!

Gosto de muito de métodos de Monte Carlo e o algoritmo rho de Pollard pode ser visto como um. Para breve mais notas sobre Pollard. E claro uma versão em LISP do mesmo.

Refs.:

http://www.christiankissig.de/cms/index.php/en/programming/29-general/39-programming-challenges

Prolog

Há muitos anos que uso o Emacs Muse, comecei por user o emacs wiki mas como deixou de ser actualizado e o emacs Muse pareceu-me o sucessor mais bem sucedido aqui fiquei.

A razão principal por usar o este sistema tem haver com possibilidade de introduzir comandos de LaTeX directamente no texto, por exemplo, através de

$$\int_0^\infty \frac{1}{1+x^2}dx=\frac{\pi}{2}$$

entre

<latex></latex>

obtém-se $latex2png equation$

e claro a inclusão de código em elisp directamente no texto através de

<lisp>(this-is-lisp)</lisp>

Está na hora de fazer ainda outra Yet another Lisp markup language

...every Lisp programmer seems to write at least one during his career ...

O problema está que nomenclaturas usar. Aqui fica uma pequena lista de Lisp markup languages:

Scribble: http://www.cliki.net/scribble
Exscribe: http://www.cliki.net/Exscribe
YstokHTML: http://lisp.ystok.ru/yhtml/index.html

Mais algumas refs.

A Lisp Based HTML Parser: http://www.franz.com/support/documentation/8.0/doc/phtml.htm

O exemplo de um interpretador de HTML merece uma leitura inicial

Practical Common Lisp: http://www.gigamonkeys.com/book/practical-an-html-generation-library-the-interpreter.html
Etiquetas/Tags: emacs muse, emacs, muse, lisp, elisp

Heart

2012/02/27-11:29:59

Etiquetas/Tags: photo, foto

Muse-post

2012/02/26-16:24:08

(defcustom muse-post-register ?R
  "The register in which the window configuration is stored."
  :type 'character
  :group 'muse-post)

(defcustom muse-post-header 
  "#title\n#author tca@diale.org (Tiago Charters de Azevedo)\n#desc\n#keywords\n"
  "")

(defun muse-insert-date ()
  (insert "#date " (format-time-string "%y%m%d\n")))

(defvar muse-post-buffer "*muse post*"
  "The name of the muse post buffer.")


(defun muse-post (&optional initial)
  (interactive
   (list (when current-prefix-arg
           (buffer-substring (point) (mark)))))
  (window-configuration-to-register muse-post-register)
  (get-buffer-create muse-post-buffer)
  (switch-to-buffer-other-window muse-post-buffer)
  (goto-char (point-min))
  (when initial 
    (insert initial))
  (goto-char (point-min))
  (insert muse-post-header)
  (muse-insert-date))

(defun muse-post-buffer-desc ()
  "Using the first line of the current buffer."
    (interactive)
    (let ((post (buffer-substring (point-min)
                                  (save-excursion
                                    (goto-char (point-min))
                                    (end-of-line)
                                    (if (> (- (point) (point-min)) 60)
                                        (goto-char (+ (point-min) 60)))
                                    (point)))))

      (muse-post post)))

(defun muse-post-clipboard ()
  "Post to muse the contents of the current clipboard.
Most useful for posting things from any where."
  (interactive)
  (muse-post (current-kill 0)))

(defun muse-post-destroy ()
  "Destroy the current muse post buffer."
  (interactive)
  (when (equal muse-post-buffer (buffer-name))
    (kill-buffer (current-buffer))
    (jump-to-register muse-post-register)))


(defun muse-short-url (url)
  "Short URL function, uses is.gd."
  (interactive "M")
  (let ((url-request-method "GET"))
    (url-retrieve (concat "http://is.gd/create.php?format=simple&url=" url)
                   (lambda (x)
                     (goto-char (point-min))
                     (search-forward-regexp "http://.*")
                     (setq s-url (match-string-no-properties 0))))
   (insert s-url)))


(provide 'muse-post)

Etiquetas/Tags: muse, emacs, muse

Word list

2012/02/22-11:04:47

Na antiga versão do jogo do monopólio existia uma carta da sorte que começava com a expressão "Levou um tiro de um amigo..." e normalmente o que se seguia consistia no pagamento de uma conta do hospital.

Um amigo não me deu um tiro mas fez-me uma pergunta, e no meu caso a procura da resposta leva a quase uma visita ao hospital. A pergunta era: " Será que existem palavras de 5 letras em português que verifiquem o padrão seguinte?"

Nota: cada número representa uma letra diferente.

Não interessa muito de onde aparece a motivação da pergunta, interessa-me mais a procura da resposta. Há largos meses que tinha começado a ler o volume 4 do TAOCP Combinatorial Algorithms, Part 1 onde, entre outras coisas, é usada a Stanford GraphBase, uma lista de 5757 palavras em inglês com cinco letras, para exposição dos vários algoritmos que aí são descritos.

Propus-me então replicar¹ alguns dos resultados descritos no TAOCP usando palavras em PT. Para isso precisava de um dicionário e uma maneira de começar a extrair a informação. O resultado é este pequeno conjunto de funções em elisp. Muito ainda está por fazer, por exemplo, o aspell usa um sistema de compressão para prefixos e sufixos, cuja sintaxe só descobri hoje, e que aumenta o número de palavras disponíveis para se brincar.

;;; wlist.el --- Emacs tools for manipulating word-files 
;; word-files, meaning a file with words in it, one word per line.

;; Author: Tiago Charters de Azevedo <tca@diale.org>
;; Maintainer: Tiago Charters de Azevedo <tca@diale.org>
;; Created: Fev, 17, 2012
;; Version: .1
;; Keywords: words
;; URL: http://diale.org/wlist.html

;; Copyright (c) 2012 Tiago Charters de Azevedo

;; This file is not part of GNU Emacs.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:
;; None.

;; Code:

(defvar wlist-max-lenght 
  0
  "")

(defvar wlist-regexp-pt
  "[aerisontcdmlupvgbfzáhçqjíxãóéêâúõACMPSBTELGRIFVDkHJONôywUKXZWQÁYÍÉàÓèÂÚ].+"
  "Regular expression for a portuguese word; see aspell.")

(defun wlist-looking-at-size ()
  "Returns the length of a word on the beginning of a line (pt-PT)."
  (interactive)
  (if  (looking-at wlist-regexp-pt)
      (length (match-string-no-properties 0))
    0))

(defun  wlist-looking-at-size-plus-1 ()
  (interactive)
  (forward-line 1)
  (wlist-looking-at-size))

(defun wlist (size)
  "Removes all sized SIZE words from `current-buffer'; asks SIZE."
  (interactive "n") 
  (with-current-buffer (current-buffer)
    (goto-char (point-min))
    (save-excursion  
      (while (< (line-number-at-pos) (line-number-at-pos (point-max)))
        (when (not (= size (wlist-looking-at-size)))
          (delete-region (point) (line-end-position)))
        (forward-line 1))))
  (wlist-delete-blank-lines))

(defun wlist-delete-blank-lines ()
  (interactive)
  (with-current-buffer (current-buffer)
    (goto-char (point-min))
    (save-excursion  
      (while (< (line-number-at-pos) (line-number-at-pos (point-max)))
        (delete-blank-lines)
        (forward-line 1)))))

(defun wlist-insert-header ()
  "Inserts a not so beautiful header."
  (goto-char (point-min))
  (insert (format "File name: %s\n" (file-name-nondirectory (buffer-file-name)))
          (format "Number of %s sized words: %s\n" size (line-number-at-pos (point-max)))))

(defun wlist-hamming-dist-list (lst1 lst2)
   "For equal length lists is the number of positions at which the 
corresponding lists are different."
  (if  (and lst1 lst2
            (= (length lst1) (length lst2)))
      (if (equal (car lst1) (car lst2))
          (wlist-hamming-dist-list (cdr lst1) (cdr lst2))
        (+ 1 (wlist-hamming-dist-list (cdr lst1) (cdr lst2))))
    0))

(defun wlist-hamming-dist (str1 str2)
  "For equal length strings is the number of positions at which the 
corresponding strings are different."
  (wlist-hamming-dist-list (string-to-list str1) 
                              (string-to-list str2)))

(defun wlist-remove-bslash ()
  "Remove /* properties form word-file. No plurals or m/f, etc,... 
Needs to be changed correctly for portuguese."
  (interactive)
  (with-current-buffer (current-buffer)
    (goto-char (point-min))
    (save-excursion  
      (while (search-forward-regexp "\\(.+\\)\\(/.+\\)" nil t)
        (let ((word-s (match-string-no-properties 1)))
          (replace-match word-s))))))

(defun wlist-max-size ()
  "Gets the maximum size of all words in a word-file."
  (interactive)
  (with-current-buffer (current-buffer) 
    (goto-char (point-min))
    (save-excursion  
      (while (< (line-number-at-pos) (line-number-at-pos (point-max)))
        (setq wlist-max-lenght (max (wlist-looking-at-size) (wlist-looking-at-size-plus-1) wlist-max-lenght))))))

(defun wlist-file-size (size)
  "Determines and creates a file of all the words with size SIZE."
  (interactive "n")
  (let ((dic-words (buffer-string)))
    (with-temp-buffer
      (insert dic-words)
      (wlist size)
      (append-to-file (point-min) (point-max) 
                      (concat default-directory (format "%s.wl" size))))))

(defun wlist-all-files-sizes ()
  "Determines all the words from size 2 to `wlist-max-size' 
and save them to separate files *.wl; it takes a few minutes to finish."
  (interactive)
  (if (= wlist-max-lenght 0)
      (wlist-max-size))
  (let ((size 2))
    (while (<= size wlist-max-lenght )
      (wlist-file-size size)
      (incf size))))
  
(defun wlist-same-pos (n)
  (interactive "x")
  (with-current-buffer (current-buffer) 
    (goto-char (point-min))
    (save-excursion  
      (while (< (line-number-at-pos) (line-number-at-pos (point-max)))
        (looking-at wlist-regexp-pt)
        (if (not (equal (nth (- (car n) 1 )
                        (string-to-list (match-string-no-properties 0)))
                   (nth (- (cadr n) 1)
                        (string-to-list (match-string-no-properties 0)))))
;;          (message (match-string-no-properties 0)))
            (delete-region (point) (line-end-position)))
        (forward-line 1)))
    (wlist-delete-blank-lines)))

(defun wlist-file-same-pos (n)
  (interactive "x")
  (let ((i (car n))
        (j (cadr n))
        (words (buffer-string)))
    (with-temp-buffer
      (insert words)
      (wlist-same-pos (list i j))
      (append-to-file (point-min) (point-max) 
                      (concat default-directory (format "%s_%s.wl" i j))))))


(defun wlist-find-all-hamming-dist-word (word dist)
  (with-current-buffer (current-buffer) 
    (goto-char (point-min))
    (save-excursion  
      (while (< (line-number-at-pos) (line-number-at-pos (point-max)))
        (looking-at wlist-regexp-pt)
        (if (not (= dist (wlist-hamming-dist word (match-string-no-properties 0))))
            (delete-region (point) (line-end-position)))
        (forward-line 1)))
    (wlist-delete-blank-lines)))

(defvar wlist-buffer-content-list nil
  "")

(defun wlist-buffer-length ()
  (count-lines (point-min) (point-max)))
  
(defun wlist-buffer-alist ()
  (interactive)
  (with-current-buffer (current-buffer) 
    (goto-char (point-min))
    (let ((wl-buffer-list nil))
      (save-excursion  
        (while (< (line-number-at-pos) (line-number-at-pos (point-max)))
          (looking-at wlist-regexp-pt)
          ;;    (push 'new-item accumulator)
        (push (match-string-no-properties 0) wl-buffer-list)
        (forward-line 1)))
      (reverse wl-buffer-list))))

(defvar wlist-word-link nil
  "")

(defun wlist-hamming-dist-word-insert (word dist)
  "Looks for the hamming DIST of word WORD, inserts all the words found after WORD."
  (setq wlist-word-link nil)
  (with-current-buffer (current-buffer) 
    (goto-char (point-min))
    (save-excursion
      (while (< (line-number-at-pos) (line-number-at-pos (point-max)))
        (looking-at wlist-regexp-pt)
        ;; Looks for word in file and save point, for inserting.
        (if (equal word (match-string-no-properties 0))
            (setq w-point (list (point) (line-end-position))))
        (forward-line 1)))
    (save-excursion  
      (while (< (line-number-at-pos) (line-number-at-pos (point-max)))
        (looking-at wlist-regexp-pt)
        (if (= dist (wlist-hamming-dist word (match-string-no-properties 0)))
            (push (match-string-no-properties 0) wlist-word-link))
        (forward-line 1)))
    (goto-char (cadr w-point))
    (insert (format " %s" (mapconcat 'concat word-link " ")))))

(defun wlist-hamming-dist-insert-buffer (dist)
  "Builds the world link with DIST and inserts the result after every word in buffer."
  (let ((wlist-list (wlist-buffer-alist)  ))
    (dolist (word wlist-list)
      (wlist-hamming-dist-word-insert word dist))))

(defun wlist-insert-after-word (word in-word)
  "Insert IN-WORD in `curren-buffer' after WORD."
  (with-current-buffer (current-buffer) 
    (goto-char (point-min))
    (save-excursion
      (while (< (line-number-at-pos) (line-number-at-pos (point-max)))
        (looking-at wlist-regexp-pt)
        (if (equal word (match-string-no-properties 0))
            (replace-match (format "%s %s" word in-word)))
        (forward-line 1)))))

(defun wlist-hamming-dist-word-list (word dist)
  "Looks for the words with hamming DIST of word WORD; returns all of the in a list."
  (setq wlist-word-link nil)
  (with-current-buffer (current-buffer) 
    (goto-char (point-min))
    (save-excursion  
      (while (< (line-number-at-pos) (line-number-at-pos (point-max)))
        (looking-at wlist-regexp-pt)
        (if (= dist (wlist-hamming-dist word (match-string-no-properties 0)))
            (push (match-string-no-properties 0) wlist-word-link))
        (forward-line 1))))
  (reverse wlist-word-link))

(defun wlist-word-link-next (word dist)
  "Returns the next link of word-link with hamming DIST of word WORD."
  (car (wlist-hamming-dist-word-list word dist)))

(defun wlist-one-word-link (word dist n)
  "Returns a word-link from WORD whit hamming distance DIST."
  (let ((word-link word)
        (new-word (wlist-word-link-next word dist)))
    (while (and new-word (<= 0 n))
      (push new-word word-link)
      (wlist-one-word-link new-word dist (- n 1)))))
            
(provide 'wlist)

1. Existe tamanho palavrão em português?.

Etiquetas/Tags: aspell, emacs, elisp

Shorten URLs in Emacs Lisp

2012/01/29-14:50:41

O código é este:

(defun short-url (url)
  (interactive "M")
  (let ((url-request-method "GET"))
    (url-retrieve (concat "http://is.gd/create.php?format=simple&url=" url)
                   (lambda (x)
                     (goto-char (point-min))
                     (search-forward-regexp "http://.*")
                     (setq s-url (match-string-no-properties 0))))
   (insert s-url)))

Etiquetas/Tags: is.gd, short urls, Emacs Lisp

diaspora(dot)el -- Simple Emacs-based client for diaspora*

2012/01/18-15:04:19

I've started a simple set of functions for posting to diaspora using Emacs.

Some of the ideas should be credit to Christian and his auth-get. I'm still trying incorporate Christian's ideas in one package. I've used the authenticity token function and not, yet, the streaming...

I don't have many experience in sharing code that is still incomplete, it is not mature enough; and so have a question. What is the thumb rule, in terms of completeness, for sharing code? It can go from a simple idea to a far complete code, right :)

Usage

copy the code to a buffer and safe it
eval it
open a file which content you like to post to diaspora; write something
type (diaspora)
authenticate

smile

The code

;;; diaspora.el --- Simple Emacs-based client for diaspora*
;; Copyright 2011 Tiago Charters Azevedo
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301, USA.

;;; Commentary:

;; A diaspora* client for emacs


;;; Code:


(require 'url)
(require 'url-http)

(defvar diaspora-username nil)
(defvar diaspora-password nil)


(defconst diaspora-url-sign-in
  "https://joindiaspora.com/users/sign_in"
  "URL used to signing in.")

(defconst diaspora-url-status-messages
  "https://joindiaspora.com/status_messages"
  "URL used to update diaspora status messages.")

(defun diaspora-ask ()
  (list
   (read-from-minibuffer "username: "
                         (car diaspora-username)
                         nil nil
                         'diaspora-username)
   (read-from-minibuffer "password: "
                         (car diaspora-password)
                         nil nil
                         'diaspora-password)))

(defun diaspora-authenticity-token (url)
  (let ((url-request-method "POST")
        (url-request-extra-headers
         '(("Content-Type" . "application/x-www-form-urlencoded")))
        (url-request-data
         (mapconcat (lambda (arg)
                      (concat (url-hexify-string (car arg)) "=" (url-hexify-string (cdr arg))))
                    (list (cons "user[username]" (car diaspora-username))
                          (cons "user[password]" (car diaspora-password)))
                    "&")))
    (url-retrieve url 'diaspora-find-auth-token)))

(defun diaspora-find-auth-token (status)
;  (switch-to-buffer (current-buffer))
  (save-excursion
    (goto-char (point-min))
    (search-forward-regexp "<meta name=\"csrf-token\" content=\"\\(.*\\)\"/>")
    (setq auth-token (match-string-no-properties 1)))
  auth-token)

(defun diaspora-post (post &optional id)
  (let ((url-request-method "POST")
        (url-request-extra-headers
         '(("Content-Type" . "application/x-www-form-urlencoded")))
        (url-request-data
         (mapconcat (lambda (arg)
                      (concat (url-hexify-string (car arg)) "=" (url-hexify-string (cdr arg))))
                    (list (cons "user[username]" (car diaspora-username))
                          (cons "user[password]" (car diaspora-password))
                          (cons "status_message[text]" post)
                          (cons "user[remember_me]" "1")
                          (cons "authenticity_token" auth-token)
                          (cons "commit" "Sign in")
                          (cons "aspect_ids[]" "public"))
                    "&")))
    (url-retrieve diaspora-url-status-messages
                  (lambda (arg) 
                    (kill-buffer (current-buffer))))))

(defun diaspora ()
  (interactive)
  (diaspora-ask)
  (diaspora-authenticity-token diaspora-url-sign-in)
  (diaspora-post (buffer-string)))

(global-set-key (kbd "C-c d") 'diaspora)


(provide 'diaspora)

Etiquetas/Tags: diaspora, emacs, client, diaspora.el

My way into LISP

2012/01/07-17:10:36

There are a lot of ways of learning a programing language, the tips that follows describe my way into LISP. This my work for you, or, maybe not.

Work out the Introduction to Programming in Emacs Lisp; it is not THE lisp that we are aiming, but we will run Lisp with SLIME, and it is a good thing to learn: emacs lisp; learn the difference between Dynamic Binding and Lexical Binding
Run Steel Bank Common Lisp in Emacs with SLIME
Move on to some fundamentals on lisp an read "The roots of LISP" by Paul Graham; try to reproduce the results in another programing language, e.g., in my case GNU/Octave :)
Read the original McCarthy's paper on Recursive Functions of Symbolic Expressions and their Computation by Machine (Part I)
Find a copy of the 2nd ed. of the "The little lisper": read it
Start reading On Lisp, by Paul Graham
Find out about Scheme and run it on a GNU/Linux system
Read some of The Original 'Lambda Papers' by Guy Steele and Gerald Sussman
Start reading Structure and Interpretation of Computer Programs, by Abelson, Sussman, and Sussman
Start reading Paradigms of Artificial Intelligence Programming: Case Studies in Common Lisp, by PeterNorvig
Have a look at the lispmachine.net
do what ever you like...

(To be continued...)

Etiquetas/Tags: lisp

Street view

2012/01/02-12:01:44

Made with Hugin - Panorama photo stitcher.

Etiquetas/Tags: photo,panorama, hugin

Foyer - Salão Nobre: Escola de Música do Conservatório Nacional

2011/12/20-08:48:00

Etiquetas/Tags: emcn, foto, salão nobre, foto, foyer

Salão Nobre: Escola de Música do Conservatório Nacional

2011/12/18-15:44:22

Etiquetas/Tags: emcn, foto, salão nobre, foto

Foto Bairro Alto

2011/12/18-14:29:03

Etiquetas/Tags: Foto, Bairro Alto, Lisboa, Portugal

Write off the debt, bankrupt the banks, nationalize the financial system, and start all over again: Entrevista a Steve Keen

2011/12/11-22:59:57

Keen's entry in Wikipedia

Gostei especialmente do convite à invasão aos departamentos de economia das universidades, e a referência final ao Max Planck! É uma "chatice" estar sempre do contra!!!!

Etiquetas/Tags: economia, entrevista, Keen, BBC

Algoritmo

2011/11/08-09:34:34

Sobre uma muito antiga revelação revelada de Miguel Sousa Tavares:

"Não conhecemos, em todo o mundo árabe, o nome de um cientista, músico, arquitecto, cineasta, explorador, atleta, enfim, alguém que faça sonhar ou avançar a humanidade."

Cópia de um selo emitido pela antiga URSS em 1983.

Aqui está o contra exemplo, uma cópia de um selo emitido pela antiga URSS em 1983 comemorando o 1200º aniversário de Muhammad al-Khowarizmi, do qual o vocábulo algoritmo deriva.

Ref.: http://www-cs-faculty.stanford.edu/~uno/

Mais detalhes aqui.

Etiquetas/Tags: algoritmo, Muhammad al-Khowarizmi