diale.org

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

1W hifi single ended class A amplifier

2013/05/22-22:53:16

I've been planning, for quite some time now, on building an audio amplifier, and after reading Pass's articles on audio amplification decided to desgin one for myself.

I found this topology in "Design of VMOS Ciruits" book from the 80's (the same book that Jack's mentions on his BS170 booster webpage) but Pass's patent for a very similar topology is dated from 1998. Go figure?!?

Quoting Pass on Dick Olsher:

Dick Olsher famously remarked that “The first watt is the most important watt.”

and looking for "the personal amplifier" reviewed by Olsher (made by http://davidberning.com/) I decided that a 1W per channel amp would be a good amp to aim.

Enough talk here is the schematic (one channel)

I call it nez amplifier,

Etiquetas/Tags: hifi, amplifier, nelson pass, zen, nez, 1W

Diode function generator

2013/01/04-11:55:36

Since I've started to play with guitar circuits I wanted to try a non linear resistor diode network device. The circuit is base in an old paper "Design of a diode generator using the diode equation and iteration" by Vincent G. Bello (1971). It uses the following

This is a quite general synthesis procedure. Given a convex monotonically increasing function the resistors can be chosen such that a set of voltage points can be obtained (Vin,Vout). The controls are highly interactive and, as the simulation shows, the breakpoints are hard to set by hand.

Here is the circuit

I've added a sum/difference opamp at the output.

Here are some typical output wave forms (sum on the left, difference on the right)

It needs, in this form, 10 pots. If the control of negative part is include it will need a total of 14 pots!!

My idea is to build something like this variable diode function generator

but I can not find on-line any of these function generator used in analog computers. Any links? Refs? Some other diode/resistors networks?

Are there any stompbox that uses such a function shaper? Is it feasible?

BTW this variable diode function generator is a Comdyna (http://www.comdyna.com/) module.

Etiquetas/Tags: guitar, diy, diode function generator, analog computer

The TRANSFET: latest DIY experience

2012/12/11-22:33:59

Here is my latest experience which I dubbed TRANSFET

It has a good compression and distorts very well under overdrive (I've used a mini-booster to do it).

Here is the transformer for the TRANSFET.

I've also tested Escobedo's Ultra Class A Superdrive Power Amp has a preamp. It sounded good! Very Fender-ish with a lot of gain.

Have fun!

Etiquetas/Tags: jfet, transformer, class a, preamo

Potpourri

2012/11/02-10:37:56

Um dos próximos projectos que vou executar é este pequeno amplificador de 1/2W e corresponde à junção de vários esquemas que se podem encontrar por aí.

É constituído por um pré-amplificador (aliás, um buffer de ganho unitário) com o MPF102, um depletion-mode mosfet, cuja ideia foi retirada do Ruby, já montado anteriormente. De modo a evitar confusões sobre a autoria da utilização deste tipo de topologia, facto que perturba o sono da malta (ver aviso no início da página), a verdade é que a ideia de colocar um mosfet à entrada do amplificador foi usada em 1969 por Linsley Hood num famoso artigo da Wireless World sobre um "Simple Class A Amplifier: A 10-W design giving subjectively better results than class B transistor amplifiers". Uma colectânea de artigos relacionados um este amplificador pode ser consultada em: The JLH Class-A Amplifier.

A segunda parte consiste no amplificador que usa um IRF510, circuito retirado da página do The Radio Amateur Society of Norwich — A Potpourri of Audio Amplifiers. Note-se que este amplificador foi já testado como amplificador para guitarra (http://www.beavisaudio.com), no entanto, e segundo o construtor "Sounds ok, but not great". Veremos!

Nelson Pass, autor da mais expressiva forma de amplificadores de classe A, o Zen amplifier, expressa muito bem a vantagem de se usar uma configuração em classe A para amplificação de áudio.

Simplicity is not the only reason for the use of the single-ended topology. The characteristic of a single-ended gain stage is the most musically natural. Its asymmetry is similar to the compression / rarefaction characteristic of air, where for a given displacement slightly higher pressure is observed on a positive (compression) than on a negative (rarefaction). Air itself is observed to be a single-ended medium, where the pressure can become very high, but never go below 0. The harmonic distortion of such a medium is second harmonic, the least offensive variety.

Ref.: Zen Amplifier, by Nelson Pass

Dito isto aqui ficam mais alguns detalhes técnicos da montagem do amplificador:

é necessário montar o IRF510 num dissipador de calor, assim como a resistência R4 de 10W
o valor da tensão em A deve ser posta em 4.5V através da resistência R3; talvez no futuro se possa usar também um depletion-mode mosfet para o amplificador, por exemplo IXTH20N50, como vem no De-Lite Amplifier de Nelson Pass
provavelmente o valor de C2=47n deve ter de ser aumentado de modo a garantir uma melhor resposta nos graves; aliás o valor de C3 também.

Etiquetas/Tags: amplificador, guitarra, 1/2W

The "triode" emulator revisited

2012/10/31-09:52:31

After reading the excellent page at http://www.runoffgroove.com about the Fetzer Valve circuit and the paper that supports it (Dimitri Danyuk, "Triode Emulator", 116th Audio Engineering Society Convention, May 2004 in Berlin, Germany), I wonder how the results in that paper could be obtained analytically. This page contains my impressions on it. I've found that the exact value of the magic constant is $latex2png equation$ .

The basic circuit of a class A JFET amplifier is given in the following figure.

Plain circuit of a class A JFET amplifier.

Plain circuit of a class A JFET amplifier.

The basic equations that governs the behavior of a JFET, in the saturated regime, are given by $latex2png equation$ Where $latex2png equation$ is the threshold voltage (pin-off voltage) and $latex2png equation$ is the drain current with $latex2png equation$ . Then we can write the drain current as a function of the input voltage as $latex2png equation$ In order to simplify the analysis let us define the variables (normalized current and voltage, respectively) $latex2png equation$ and the constant, which determine the value of the source resistor, $latex2png equation$ We also need the normalized input voltage $latex2png equation$ The relation between the normalized current $latex2png equation$ and voltage $latex2png equation$ can be put into the form $latex2png equation$

We want to obtain a power law relation between normalized current $latex2png equation$ and the normalized input voltage $latex2png equation$ and, in particular, the exponent 3/2 for the triode emulation. So, in order to get that, let us assume that one has $latex2png equation$ that is $latex2png equation$ Taking the logarithm derivative of the last expression and solving it in order of $latex2png equation$ one gets $latex2png equation$ or $latex2png equation$

The next figure shows the value of the exponent $latex2png equation$ as a function of the normalized input voltage $latex2png equation$

The exponent n as a function of the normalized input voltage z.

The exponent n as a function of the normalized input voltage z.

The value of the constant $latex2png equation$ that determines the value of the source resistor is given by $latex2png equation$ For $latex2png equation$ and $latex2png equation$ one gets $latex2png equation$ which is closed to the value obtained by Dimitri, 0.83, but not exactly the same. This is the exact value of the constant that determines the value of the source resistor.

One can also see that the expression $latex2png equation$ permits to obtain for any working voltage $latex2png equation$ and exponent $latex2png equation$ the value of the parameter $latex2png equation$ that emulates a super-triode, a "triode" with a exponent between one and two.

Who says that math doesn't pay off?

Fetzer Valve - A mu-amp variation

You could also make a mu-amp variation

by biasing the upper jfet in a different way!

If you have any comments about this page, please fell free to send me an email:

Etiquetas/Tags: DIY, triode valve, fet, electronics

Triode emulator - from a pentode to a triode

2012/10/29-22:09:28

In 1938 Schade proposed a mechanism to transform a pentode tube into a triode by connecting the plate to the grid using a resistor network. Here is the graphs from is work "Beam Power tubes" by O. H. Schade, March 1938.

So I've simulated a few circuits to try to understand a bit more what is going on. All of you know the triodizer. Here are the simulations. The version described in the text with a battery at the gate:

and the circuit from a MIT lab course

Wonderful graphs don't you think!

I've also simulated the Fetzer valve circuit and as suspected the characteristic curves are not of that type... although it sounds good

This graphs and simulations does put things into perspective. ç

Etiquetas/Tags: tube, diy, triode, pentode

Arsenio Novo - Tube Sound Overdrive

2012/10/24-11:47:09

It is easy to see why?

Here is Arsenios explanation:

The operation of the circuit more closely resembles a vacuum tube than a diode clipper does because of the strong square law characteristic. This is due to the negative feedback around both base-emitter pairs. This feedback accentuates the junction non-linear behaviour manyfold. Thus each transitor drives the other even harder so that the transfer curve ends up more logarithmic than is typical of a single transistor. In other words: the clipping is gradual and not abrupt like it is in the case of a silicon diode. Typically a lot more 2nd harmonic is produced as well. As a bonus the waveform folds over on itself when the circuit is overdriven!

Etiquetas/Tags: guitar, diy, arsenio novo, Tube Sound Overdrive

PUNCH amplifier: 1W guitar amplifier

2012/10/20-15:34:38

I've started this project as an alternative to the infamous ROG's Ruby amp. I built a few Ruby's but I didn't like the frequency response of them. So before anything else here is the schematic.

As you see it shares with the Ruby the same topology: a buffer and a chip amp. It uses a JFET buffer with a MPF102 and the 1W TDA7052 chip. It is a clean amp and it reacts very well with any pedal in front of it. I don't use a lot of distortion so this little amp suits all my needs. It doesn't have a volume and tone control because I wanted a plug-in-and-play amp. If you want an amp with a volume control try the TDA7052A, it has a volume voltage control pin that works perfectly (simple pot), this chip has the advantage that the volume pot is not on the signal path.

Of course the PUNCH also works with batteries, a 9v battery or with six 1.5V batteries in series. For small voltages and currents the sound could become distorted or to muddy, if so decrease the 1u cap to 470n or smaller.

What about the speaker? The guys from ROG say

What speakers do you recommend for use with your mini-amp circuits? While the Ruby, Little Gem, and Little Gem MkII practice amps can be used with any speakers, best results are achieved with full-size speakers intended for use with guitar amps. The amps will work well with an total impedance of 4, 8, or 16 ohms. We've tried hi-fi speakers, clock-radio speakers, and auto speakers - they just can't cut it. For me, using anything other than a speaker designed for the frequencies of an electric guitar produced sounds more like a toy than an actual amp. However, you may want to ask at Aron's Stompbox Forum. Many of the members have built one of the aforementioned amps and may be able to suggest a decent-sounding small speaker.

This is only in part true. One thing they are right is that clock-radio speakers and small radio speakers won't work! But the same is not true for hi-fi speakers and auto speakers. Let me be more precise about it.

I've tested the PUNCH and the Ruby with some 6'' auto speakers and they work great, specially with the PUNCH. This Fonestar UT528 speaker of 5.25''=13.3cm with a frequency response of 50-12.000 Hz and a sensitivity of 90 dB - 1 W/1 m works great.

I've also test it with a smaller one, the Fonestar 3''=7.5cm speaker (20-14.000 Hz, 8 Ω, 89 dB - 1 W/1 m)

and also has a great sound.

Here is the PCB pdf file.

Here is a cabinet for the PUNCH with a 3'' Fonestar speaker and using a IKEA wooden box. The rear photo shows the 9V battery enclosure.

As always comments, questions or suggestions to my email.

Etiquetas/Tags: guitar, amplifier, 1W, DIY

Simple quitar 5 band EQ using the BA3812L chip

2012/10/15-22:13:06

I'm planning on building a simple 5 band EQ using the BA3812L chip but changing the frequencies to more suitable values. The frequencies that I'll be using are the ones from Mesa Boogie DC-5 amp. Here is the schematic:

And here is a copy of the Mesa Boogie DC-5 owner's manual about a similar EQ.

The capacitor values were obtained using a simple GNU/Octave script:

#1;
# Calculations for a simple EQ: BA3812L 
# All resistors in Ohm and capacitors in F

R0=1.2e3;
R1=68e3;
Q=.7;

f=[80 240 750 2200 6600];

C0=1./(2*pi*R0*Q*f);
C=Q./(2*pi*R1*f);

Q=1;
C0=1./(2*pi*R0*Q*f);
C=Q./(2*pi*R1*f);

disp("Q=1")
disp("        Freq      C0 (uF)    C (uF)")
disp([f' floor(C0'*10^12)/10^6 floor(C'*10^12)/10^6])

One can relate the octave bandwidth N to quality factor Q by the expression $latex2png equation$ or inversely $latex2png equation$ This is important because one would like to be able to control the complete frequency range of the guitar signal.

For the EQ frequencies 80, 240, 750, 2200 and 6600, roughly a factor of 3 for consecutive frequencies, and a Q factor of order 1 one gets a 1.5 band width in octaves, so because of the ratio of the EQ frequencies one can, with this Q=1, control the full interval of frequencies between 40Hz to 10kHz.

I think I'm getting it right?!

Here are the capacitors values fitted to the standard values freq real_freq real_Q C*1 C*2

f    f    Q   C*2    C*1
80   83   1.1 1.5u   .030u 
240  257  1.1 .47u   .01u
750  830  1.1 .15u   3n
2200 2137 .9  .068u  1n
6600 6260 1   .022u  .36n

Etiquetas/Tags: EQ, guitar, BA3812L

Tube emulation with solid state devices

2012/06/01-16:03:17

It has been a while since I've started to make simple tube emulators, all of them "sounded" like a tube even when overdriven... but they still miss something, some airiness and detail, they all sound "tubish" but the spirit of tube distortion seems to be absent from these configurations.

All of them show a clear presence of even order harmonics simulating the 3/2 Child's law of a triode, but only one of the configurations takes into account the non-linear response of a triode under overdrive (Russian schematic see below) and of course it sounds the best!.

Here is a small list with the simulations:

Fetzer valve

Fetron type configurations

Jack Orman's Muffer

and my version of Tim Escobedo's bootstrap for gain version of the muffer

Russian schematic

Child's law, as is usually referred, stands on some pretty strong bias but quite acceptable from a physicist point of view. These are (taken from C. D. Child, Phys. Rev. (Series I) 32, 492–511 (1911) Discharge From Hot CaO)

there is not possible to compute just how many positive ions it would take to raise the potential so as to check the current when the cathode is a irregular piece of foil but we may get some idea of what is to be expected by considering the current density between parallel plates of infinite extent, when there are only positive ions present.
The less the ions are stopped by collisions with molecules, the greater will be their velocity and the less the electrostatic effect produced by the movement through the field of a given number. In order to find the maximum current, we may assume that there are no collisions.

One may think that these are very strong bias but the goal is to solve a ordinary differential equation which, without these restriction, would be very hard to solve :D

It is the non-linear response of a triode that gives the good tone but the tone does not come from the 3/2 law. One can improve the emulation by looking at the behavior of the triode amplifier when driven by a sin and mimic the behavior with a couple of BJT (probably the Russian was build like this adjusting the diode-resistor network to mimic the change of input impedance) but the guitar signal is a non-trivial signal and the response of non-linear triode amplifier acts and looks more like a collective entity than a simple response to a periodic signal shows. I would guess that one could get a much more "real" approximation of a triode by simulating the physics behind the triode than the triode itself.

Etiquetas/Tags: vacuum tubes, transistors, fet

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

Palavras chave: página pessoal, blog, vida-exacta

Última actualização/Last updated: 2013-05-22 [22:53]

1999-2012 (c) Tiago Charters de Azevedo

São permitidas cópias textuais parciais/integrais em qualquer meio com/sem alterações desde que se mantenha este aviso.

Verbatim copying and redistribution of this entire page are permitted provided this notice is preserved.