Posted by Patrick Krusenotto on Jul 14, 2009 in
Algorithmen,
Perl Im Zusammenhang mit der Untersuchung des Surf-Verhaltens von Website-Besuchern bin ich auf das Mittel der Clusteranalyse gestossen. Die Clusteranalyse dient dazu, Individuen, denen ein oder mehrere numerische Merkmale zugeordnet werden könnnen, zu Clustern zusammen zu fassen, sodaß ähnliche Individuen im gleichen Cluster landen. Internet-Shops nutzen soche Analysen gerne um Nutzern zum Beispiel Bücher zu empfehlen. Dabei wird untersucht, ob es andere Nutzer mit einem ähnlichen Profil gibt. Die Bücher, die diese außerdem gekauft haben werden dem Shop-Benutzer dann empfohlen.
Bei der hier vorgestellten hierrarchischen Clusteranalyse werden wird der gesamte Datenbestand als Baum zusammengefasst. Die Individuen befinden sich nur in den Blättern
Der Algrithmus geht so vor, daß zunächst alles Individuen als Cluster aufegefasst werden. Sodann werden immer die Cluster, die sich am ähnlichsten sind (-> den geringsten Euklidischen Abstand haben) zu einem Cluster zusammengefasst. Die Berechnung endet, wenn nur noch ein Cluster übrig bleibt
Das Modul unten ist ein erster Prototyp, der eine solche Analyse durchführt.
package Cluster;
use strict;
use warnings;
# hierachische Clusteranalyse
sub new {
# erzeuge neuen endknoten
my ($class,$center) = @_;
return bless {
center => $center,
nodes => 1,
}, $class;
}
sub combine {
# fasse zwei cluster zu einem zusammen
my ($class,$l,$r)= @_;
my $res = bless {
left=>$l,
right=>$r,
nodes=>do {
my $n = 0;
$n += $l->{nodes} if $l;
$n += $r->{nodes} if $r;
$n;
},
}, $class;
my $fact_l = $l->{nodes};
my $fact_r = $r->{nodes};
my $quot = $res->{nodes};
for (0..$#{$l->{center}}) {
$res->{center}->[$_]=
($fact_l*$l->{center}->[$_]
+$fact_r*$r->{center}->[$_])
/ $quot;
}
return $res;
}
sub distance {
# bestimme die Distanz zwischen zwei clustern
my ($self,$other)=@_;
die "Incompatible clusters" unless scalar(@{$self->{center}}) == scalar(@{$other->{center}});
my $N = scalar(@{$self->{center}});
my $h2;
for my $i (0.. $N-1) {
$h2 += ($self->{center}->[$i] - $other->{center}->[$i])**2;
}
return sqrt($h2);
}
use Memoize;
memoize "distance";
sub do_clustering {
# führe hierarchisches clustering durch.
my (@clusters) = @_;
while (scalar(@clusters) > 1) {
my $N=scalar(@clusters);
my ($i_min,$j_min,$d_min) = (-1,-1,1e99);
for my $i (0..$N-1) {
for my $j ($i+1..$N-1) {
my $d = $clusters[$i]->distance($clusters[$j]);
if ($d < $d_min) {
($i_min,$j_min,$d_min)=($i,$j,$d)
}
}
}
# $i_min und $j_min zusammenfassen
# print "cluster($i_min,$j_min)\n";
$clusters[$i_min] = __PACKAGE__->combine($clusters[$i_min],$clusters[$j_min]);
$clusters[$j_min]=$clusters[$#clusters];
pop @clusters;
}
return $clusters[0];
}
1;
Aufruf-Beispiel:
use Cluster;
my @clusters;
for (1..200) {
push @clusters,Cluster->new([int(rand(10)-5),int(rand(10)-5),int(rand(10)-5)]);
}
use Data::Dumper;
print Dumper( Cluster::do_clustering(@clusters));
Posted by Patrick Krusenotto on Feb 22, 2009 in
Algorithmen 
Heute fiel mir das Buch “Python kompakt” beim Aufräumen in die Hände. Da ich eigentlich keine Lust zum Aufrämen hatte, habe ich angefangen, darin zu blättern. Weiter hinten befindet sich zum Thema CGI-Programmierung ein Abschnitt zum Thema Login. Richtiger Weise stellt der Autor dort fest, daß es nicht gut ist, die Passwörter der Nutzer auf dem Server zu speichern. Das ist völlig korrekt und die Möglichkeit, diese Speicherung zu umgehen, die dort beschreiben wird, wird auch von den meisten Frameworks angeboten.
Sie sieht so aus, daß der Server den Benutzernamen und das Passwort miteinander verkettet und aus dieser Verkettung einen Hash-Wert (MD5, SHA1, was auch immer) bestimmt. Dieser Wert wird dann im Benutzerdatensatz abgespeichert. Beim Login wird mit den Eingaben dasselbe gemacht und der entstandene Hashwert verglichen. Schön und gut! Das Passwort kann jetzt der Datenbank nicht mehr entnommen werden und ist vor dem Administrator des Servers sicher.
Leider ist das immer noch unbefriedigend, denn nach wie vor wird das Passwort vom Browser zum Server übertragen und kann von jedem Router, Gateway, Proxy etc der an der Übertragung beteiligt ist, mitgeschrieben werden.
Ok, werden Sie sagen: Kein Problem. Wir führen die Hashwertberechnung auf der Browserseite mittels Javascript durch und übertragen nur den Hashwert an den Server. Dann gucken die bösen Hacker-Admins in die Röhre.
Dem entgegne ich: Die Gucken überhaupt nicht in die Röhre, denn denen ist es egal, ob sie das Passwort kennen oder nicht. Allein der Hashwert reicht schon, um Zugang zum Portal zu bekommen. Dazu müssen sie nur eine lokale Kopie der HTML-Seite der Loginmaske machen, diese leicht verändern, sodaß die Seite den abgehörten Hashwert an den Server schickt und fertig.
Was kann man also machen? Mein Vorschlag ist der folgende:
Wir übernehmen das Verfahren mit dem Hashwert wie oben beschrieben, sorgen aber dafür, daß trotzdem der Hashwert jedesmal anders ist. Die Lösung wie ich sie mir denke, sieht so aus:
Registrierung
- Benutzer gibt Benutzernamen B und Passwort P ein.
Browser berechnet H = h(B+P). Dabei ist h eine Hashfunktion (MD5 oder SHA) und “+” eine Verkettungsoperation.
- Browser überträgt H an Server. Dieser legt H zusammen mit den anderen Benutzerdaten in der Datenbank ab.
Login
- Server erzeugt ein Los L. Das ist ein zufällige Zeichenkette. L wird zusammen mit der Loginmaske an den Browser gesendet.
- Der Browser nimmt die Benutzereingaben B und P entgegen. Er berechnet zunächst wie gehabt HB = h(B+P). Diesen Wert sendet er aber nicht zum Server sondern verquirlt ihn nun mit dem Los L:
JB = h(L+Hb) = h(L+h(B+P)). JB ist der tatsächliche Kontrollwert, der über das unsichere Internet gesendet wird. Dieser Wert ist abhängig von L und deswegen bei jedem Login ein anderer. Er nützt einem Angreifer nichts, da dieser für seinen eigenen Loginversuch von Server ein anderes Los L zugeschickt bekommen würde.
- Der Server hat sich, um die Prüfung durchzuführen, das Los L für den betreffenden Client gemerkt, nimmt JB in Empfang entnimmt der Datenbank mit Hilfe des ebenfalls empfangenen Benutzernamens den gespeicherten Hashwert H. Damit berechnet er JS = h(L+H). Diesen Wert vergleicht er mit JB. Falls beide Werte identisch sind, ist der Login ok und kann zugelassen werden.
Das Verfahren erscheint mir sinnvoll und sicher, denn:
- Es steht kein Passwort in einer Datenbank
- Es wird kein Passwort übertragen
- Es wird keine andere Diskriminiante übertragen, mit der man in das System eindringen kann, denn im Wert JB ist das einmalige Los L verarbeitet, das beim einem Angriff durch einen Abhörer nicht mehr gültig ist.
Nun könnte man einwenden: Was soll der ganze Sermon, denn es gibt doch https, das dieses und eine Reihe anderer Abhör-Probleme sicher und ohne Aufwand erledigt. Wer für seine Projekte jederzeit 100€ für ein Zertifikat zur Verfügung hat: Völlig korrekt.
Posted by Patrick Krusenotto on Okt 10, 2008 in
Algorithmen,
Allgemein,
Perl 
Wenn sie diesen Artikel verstehen möchten, muss Ihnen der Begriff der “Closure” geläufig sein. Einen Artikel dazu werde ich der Vollständigkeit halber später noch verfassen.
Eine anonyme…
Wie in einigen anderen Programmiersprachen können in Perl Funktionen anonym definiert werden. Das bedeutet, sie werden an keinen Namen gebunden, sondern sofort aufgerufen, einer Variablen zugewiesen oder weitergereicht.
print sub{$_[0]*3}->(8);
gibt zum Beispiel 3*8 = 24 auf die Konsole. Die Sub wird “on the fly” definiert. und mit “….->;(8)” direkt aufgerufen. Danach wird sie allerdingds ein Opfer des Garbage Collectors. Es erfolgt keine Bindung an einen Namen, wie das bei
sub mal3 {$_[0]*3}
der Fall wäre.
Will man die Tatsache, daß eine “ordentliche” Funktionsdefinition nur die Bindung einer anonymen Funktion an einen Bezeichner ist, in der Notation expliziter machen, kann man in Perl auch folgendermaßen schreiben:
*mal3 = sub{$_[0]*3};
Das Ergebnis ist völlig identisch.
Um eine Funktion zu definieren, kann man also auf einen Namen verzichten. Namen sind eben Schall und Rauch… Doch halt! Was macht man, wenn man eine Funktion rekursiv definieren möchte? Wie formuliert man den rekursiven Aufruf, wenn das Kind keinen Namen hat? Gibt es da ein eigenes Sprachmittel, etwa so wie den Bezeichner “SUPER” , mit dem man in einer Methode auf die unmittelbare Elternklasse kommt, ohne zu wissen, wie sie heisst?
… und trotzdem rekursive Funktion …
Antwort: Nö. Aber: Es gibt aber eine Lösung. Sie kommt allerdings aus einer ganz anderen Ecke. DIe Lösung trägt den Namen Y-Kombinator. Diesen wollen wir jetzt ausprobieren.
Wir nehmen uns zunächst ein ödes Beispiel einer rekursiven Funktion daher: Die Fakultät. Nach dem oben Gesagten können wir das in Perl wie folgt schreiben:
*fak =
sub {
my $n=shift;
if ($n==0) {
return 1
}
else {
return $n * fak($n -1);
}
};
Was an dieser Definition nun stört, ist das Auftreten des Namens fak in der siebten Zeile. Um ihn loszuwerden, müssen wir die rechte Seite der Zuweisung, “*fak=..”, also die anonyme Funktion nach fak abstrahieren. Wir verpacken sie daher in einen Parameter $psi und geben nun nicht mehr den Wert der Berechnung, sondern eine neue Funktion als Berechnungsergebnis zurück.
Das neue Gebilde ist die nicht-rekursive Funktion pfak (”parameterized fak”):
*pfak =
sub {
my $psi=shift;
return sub {
my $n=shift;
if ($n==0) {
return 1
}
else {
return $n * $psi->($n -1);
}
}
};
Das ist eine Funktion, die als Wert eine (anonyme) Funktion zurückgibt. Eine Funktion, die das tut, heißt in der Mathematik auch “Funktional”.
Wenn wir also an pfak die Funktion fak übergeben, erhalten wir die Funktion fak. Dazu muss man sich nur überlegen, daß dadurch der Parameter $psi mit der Funkion fak belegt wird. Wir könnten also fak nun folgendermaßen umdefineren, ohne die Funktion damit zu verändern:
*fak = pfak(\&fak)
Diese Gleichung besagt: efak bildet die Funktion fak auf sich selbst ab. (Kein Wunder, denn dafür haben wir sie ja auch gebaut!). Soetwas heißt in der Mathematik “Fixpunktgleichung”. Der Fixpunkt ist die Funktion fak. Das ist nichts anderes als eine Feststellung wie 1² = 1. Die Zahl 1 ist ein Fixpunkt der Quadratfunktion.
Tun wir jetzt einmal so, als wüssten wir über fak garnichts. Darum nenne ich fak jetzt hurz.
hurz === pfak(\&hurz)
(Der Operator “===” soll die Gleichheit zweier Funkionen andeuten)
Alles, was wir über hurz wissen, ist, daß die Funktion ein/der Fixpunkt von pfak ist. Falls es möglich ist, hurz aus pfak zu bestimmen, dann gäbe es ein Funktion Y, sodaß gilt:
hurz === Y(\&pfak)
… dank des Y-Kombinators!
Ja, also was soll man sagen? Eine solche Funktion gibt es! Es ist der Y-Kombinator von Haskell Curry, den dieser in den 40er Jahren gefunden hat. In Perl hat er folgende Gestalt:
sub Y {
my $e=shift;
sub {
my $x=shift;
sub {
my $u=shift;
($e->($x->($x)))->($u)
}
}->(sub {
my $x=shift;
sub {
my $u=shift;
($e->($x->($x)))->($u)
}
}
)
}
Wir stellen zunächst fest, daß der Y-Kombinator nicht rekursiv ist. Es findet kein Aufruf von Y innerhalb von Y statt. Daß Y die Funktion fak als Fixpunkt von pfak “findet”, können Sie ganz leicht feststellen, indem Sie jetzt Ihren Perl-Interpreter anwerfen und die Funktionen pfak und Y hineinwerfen. Danach können Sie sich zum Beispiel mit
print Y(\&pfak)->(10)
die Fakultät der Zahl 10 berechnen lassen.
Daß das Ganze funktioniert, kann man ausprobieren, aber es ist alles Andere als einleuchtend. Darum müssen wir den Y-Kombinator etwas genauer unter die Lupe nehmen. Es bleibt nämlich die unbewiesene Behauptung, daß gilt:
fak == Y(\&pfak)
beziehungsweise, fak oder eben auch Y(\&pfak) Fixpunkt von pfak ist. Zu diesem Zweck kann man sich einfach mal anschauen, was passiert, wenn Y mit dem Parameter &pfak aufgerufen wird, indem jedes Vorkommen von $e-> durch efak ersetzt wird:
Y(\&efak) ===
sub {
my $x=shift;
sub {
my $u=shift;
(pfak($x->($x)))->($u)
}
}->(sub {
my $x=shift;
sub {
my $u=shift;
(pfak($x->($x)))->($u)
}
}
)
Was hier entstanden ist, besteht offenbar aus zwei gleichen Teilen: Es ist eine sub, die sich selbst übergeben wird. Es ist also ein Ausdruck der Form $A->($A), wenn man annimmt, daß
$A = sub {
my $x=shift;
sub {
my $u=shift;
(pfak($x->($x)))->($u)
}
};
gilt.
Rechnet man weiter, was das bedeutet, indem $A in $A->() eingesetzt wird, ergibt sich
$A->($A)===sub {
my $u=shift;
(pfak($A->($A)))->($u)
}
Man kann bereits erkennen, wo die Reise hingeht. Rufen wir zurück, daß $A->($A) genau Y(\&pfak) ist,
Lesen wir
Y(\&pfak) === sub {
$u=shift;
(pfak(Y(\&pfak))->($u)
}
Und damit gilt für Zahlen $N:
Y(\&pfak)->($N) === pfak(Y(\&pfak))->($N)
Was nichts anderes besagt, als daß Y(\&pfak) Fixpunkt von von pfak ist, also die Lösung unserer ursprünglichen Fixpunktgleichung.
Das ist eben Perl ! 
Zugegeben: Die Materie ist nicht ganz einfach. Aber es lohnt sich, über den Y-Kombinator nachzudenken und damit zu spielen. Er zeigt auch eindrucksvoll, wie korrekt und vollständig das Design des Perl-Laufzeitsystems ist. Java zum Beispiel kann den Y-Kombinator nicht darstellen, denn dort sind Funktionen (leider auch Klassen) keine First-Class-Objects. Weiterhin kennt Java keine Closures, die hier aber dringend erforderlich sind.
Posted by Patrick Krusenotto on Okt 3, 2008 in
Algorithmen,
Allgemein,
Perl
Scanner
Mit Perl einen Scanner zu schreiben, ist eine einfache Sache, denn Perl hat eine sehr potente Implementierung für reguläre Ausdrücke. Allerdings muss man wissen, welche Modifier erforderlich sind, damit der Lexer auch immer an der Stelle weitermacht, wo er aufgehört hat. Dazu benutzt man den Pattern Matcher mit dem Modifier /g und startet jedes Matching mit dem Anker \G. Durch /g wird erreicht, daß Perl sich die aktuelle Scanposition merkt und mit \G verlangen wir, das bei der nächsten Mustererkennung genau an dieser Stelle weitergemacht werden soll.
Zusätzlich muss der Modifier /c angegeben werden, damit Perl die Position auch dann behält, wenn ein matching-Versuch scheitert und deswegen ein anderes Pattern versucht werden soll (was der häufigste Fall sein wird). Die weiteren Modifier, die verwendet werden sind /s , damit der Scanner mit einem Text umgeht, als wäre es eine einzelne Zeile und manchmal /i, damit “case-insensitiv” gescannt wird.
Von einem Lexer erwarten wir, daß er einen String in Tokens zerlegt und bei jedem Aufruf das nächste erkannte Token zurückgibt. Außerdem brauchen wir von jedem Token das gescannte Lexem. Bei jedem Aufruf bekommen wir also zwei Werte. Wird zum beispiel des Schlüsselwort “select” erkannt, bekommen wir das Wertepaar ['KEYW' , 'select'] geliefert.
Hier also die Implemetierung eines Fragmentes eines SQL-Scanners Das Lexen übernimmt die sub lex. Darunter eine Schleife, die die Ergebnisse ausgibt.
use strict;
$_ = <<EOT;
select name,alter
FROM person
where name like \'Kaz%mir\' and alter>20;
EOT
sub lex {
/\G(\s+)/gcs; # spaces wegfuttern.
return [$1,'OP'] if /\G"([\*\+\-\/]*)"/gcs;
return [uc($1),'KEYW'] if /\G(from|like|select|where)/gcsi;
return [$1,'COMM'] if /\G(\,)/gcs;
return [$1,'SEMI'] if /\G(\;)/gcs;
return [$1,'COMP'] if /\G(>|<|>=|<=|=)/gcs;
return [$1,'STRI'] if /\G'([^']*)'/gcs;
return [$1,'IDEN'] if /\G([a-zA-Z_]+)/gcs;
return [$1,'INTE'] if /\G(\d+)/gcs;
return undef if /\G$/;
die "lexer error at '",substr(substr($_,pos($_)),0,60),"'";
}
while (my $t = lex) {
print "$t->[1] '$t->[0]' ",pos(),"\n";
}
Das hier vorgestellte Vorgehen ist einfach zu überblicken und der Scanner arbeitet schnell. Wie man einen einfachen Recursive-Descent-Parser dazu baut, werde ich eventuell ebenfalls einmal hier notieren.
Tags: Flex, Lexer, Perl, Scanner
Posted by Patrick Krusenotto on Okt 1, 2008 in
Algorithmen,
Allgemein,
Perl Datenbanken kennen Aggregatfunktionen. Ein Aggregat ist - Ja? - leider daneben! Ein Aggregat ist eine Anhäufung. Im Grunde ist die ehrfurchtsgebietende Miene, mit der ein Heizungsfachman ein elektronisches Kästchen aus einer Packung holt, während er dieses als Aggregat bezeichnet um es darauf in die kaputte Heizung einzubauen, eher lachhaft. Würde er sagen, er baue jetzt einen elektronischen Haufen in die Heizung ein, würden wir eher grinsen als ehrfürchtig Abstand haltend sein fachmännisches Tun zu würdigen.
Mit Aggregat ist also gemeint, dass wir etwas unübersichtiches zu einem Haufen zusammenwerfen, um den Überblick zu behalten. Etwas vornehmer nennt man diesen Vorgang manchmal auch Faltung.
Beispiele bei Datenbanken sind zum Beispiel COUNT(*) für die Anzahl der Elemente, AVG(*) für deren Durchschnitt und SUM(*) die Summe aller Elemente.
Was mich immer schon geärgert hat ist, ist, das zumindest bei Datenbankten kein offensichtlicher Weg existiert, solche “Aggregatfunktionen” selber zu definieren. Mag sein, daß einzelne dieser Datenbanken solche Möglichkeiten haben. In der SQL’92 Spezifikation sind Aggregatfunktionen vorgegbene schwarze Kisten, die man benutzen kann. Sonst nichts.
Das Wesen einer Aggregatfunktion oder Faltung ist, eine Liste “zusammenzufalten”, sodaß man Ende der Operation ein einzelnes etwas (etwa eine Summe) anstatt einer unhandlichen Liste hat.
Wie kommt man zu einer Aggregatfunkion? Aus der Operation z(a,b)=a+b gelang man zu der Aggregatfunktion SUM(*) aus der Operation z(n,a)=n+1 gelangt man zu Aggregatfunktion COUNT(*) und anderes mehr. Jeder Programmieranfänger hat schonmal eine Aggregation programmiert, ohne sich darüber Gedanken gemacht zu haben. Dazu ist der Vorgang auch insgesamt zu banal. Zumeist wird man wohl eine FOR-Schleife verwendet haben. Das ist sehr schön. aber nicht unser Thema. gesucht ist eine Generalisierung dieses Vorgangs. Das bedeutet, daß wir die gesamte Faltung von dem konkreten Faltungsoperator abstrahieren müssen.
Angenommen, wir haben eine Liste L=(x1,x2,..xn) sowie eine zweistellige Faltungsoperation z. Dann ist die Faltung f eine Funktion höherer Ordnung mit dem Faltungsoperator z und der Liste L als Argumenten:
f(z,L) = z( L[0] , L[1] ) falls die Liste zweielementig ist und
z( L[0] , f(z, L[1..n]) sonst
Beispiel:
z(a,b)=a+b und L=[4,3,2,6]
Dann ist
f(z,L)=
4+f(z,[3,2,6])=
4+3+f(z,[2,6])=
4+3+2+6=15.
Schönheitsfehler ist noch, daß unsere Konstruktion nur mit mindestens zweielementigen Listen arbeitet. Dem kann man mit einem zusätzlichen Startparameter s begegnen, mit dem das erste Listenelement verknüpft wird.
Dann kommt man zu folgender Version:
f(s,z,L) = s falls die Liste leer ist,
z( L[0] , f(s,z, L[1..n]) sonst.
In Perl kann das so aussehen:
sub foldleft ($&@) {
my ($s,$z,@l)=@_;
return $s unless @l;
my $a = shift @l;
return $z->($a,foldleft($s,$z,@l));
}
Schöner und schneller ist aber diese iterative Version:
sub foldl ($&@) {
my ($s,$z,@l) = @_;
$s = $z->($s,$_) for (@l);
return $s
}
Wozu das gut ist? Ganz einfach: Durch Konstruktionen wie diese spart man innere Schleifen. Um nun die Summe aller Elemente einer Liste zu bilden, kann man
$summe = foldl 0, sub {$_[0]+$_[1]}, @LISTE
schreiben.
Um alle Zeilen einer Datei zusammenzufassen und dabei zwischen je zwei Zeilen eine Leerzeile einzubauen:
$text = foldl 0, sub {$_[0] . "\n". $_[1]}, <FILE>;
Anstatt hier fehleranfällig mit Schleifen und Variablen zu arbeiten, kann man eine einzige Funktion aufrufen. Funktionale Programmiersprachen wie Haskell und andere haben eine solche Faltungsfunktion direkt mit eingebaut. Interessant ist auch, daß große Teile der Programmentwicklung sich gerade mit Aggregationen befassen, auch wenn uns das nicht immer bewusst ist. Wer als Programmierer ein bisschen darüber nachdenkt, was er gerade tut, stößt täglich selbst auf Beispiele. Jeder Erstellung einer HTML-Seite aus einer Datenbankabfrage ist ein solches Beispiel.
Tags: Aggregation, Faltung, Fold, Perl
Posted by Patrick Krusenotto on Jun 5, 2008 in
Algorithmen,
Allgemein 
Für ein aktuelles Projekt benötge ich einen Parsebaum aus XML-Dokumenten, der aus Objekten besteht. Ich bin sicher, daß schon mal so oder ähnlich jemand gemacht hat. Leider ist CPAN mittlerweile recht groß…
Meine Vorstellung ist, daß der Tagname der Klassenname des Objektes wird. Zu diesem Zweck muss der etwas gewöhnungsbedürftige Output von XML::Parser transformiert werden. Die Objekte sollen Hashes sein mit den Einträgen “attr” und “data”. “attr” soll seinerseits ein hash der Attributwerte sein und data ein array mit den Sub-Objekten.
Los gehts:
package main;
use XML::Parser;
use Data::Dumper;
my $p = new XML::Parser(Style => 'Tree');
my $t= $p->parse('<html htmlattr1="xx">
<head headattr1="a" headattr2="b"><title>test</title></head>
<body>
<div style="color:red">murx</div>
</body>
</html>');
print Dumper($t);
sub transform {
my ($tag,$content) = @_;
return $content unless $tag;
my @content = @$content; #kopie!
my $attr = shift @content;
my %attr = %$attr; #kopie!
# an dieser stelle haben wir mit $tag, %attr und @content eine
# repräsentation des aktuellen tags
my @tags;
while (@content) {
my $t = shift @content;
my $c = shift @content;
push @tags, transform($t,$c);
}
my $obj={
attr => \%attr,
data => \@tags,
};
return bless $obj,$tag;
}
my $objtree = transform(@$t->[0], $t->[1]);
print Dumper($objtree);
Tags: parsing, Perl, XML
Posted by Patrick Krusenotto on Nov 24, 2007 in
Algorithmen,
Allgemein,
Perl Spielen Sie 4gewinnt gegen Ihren Perl-Interpreter!
- - - - - - -
- - - - - - -
- - - - - - -
- - - X - - -
- - O X - - -
- - X O O - -
1 2 3 4 5 6 7
In folgendem Skript habe ich den Neg(a)max-Algorithmus verbaut. Als Bewertungsfunktion kommt eine einfache Punktvergabefunktion zum Einsatz. Das Skript spielt überaschend gut und man muss schon einiges an Übung haben, um zu gewinnen.
#!/usr/bin/perl
#4gewinnt,p.krusenotto 2005
@f=(0)x42;$M=9999;@S[1,2,3,5,10,15]=(1,9,99,-1,-9,-99);sub p{for$y(0..5){print{
1=>'O',5=>'X',0=>'-'}->{$f[$y*7+$_]},' 'for(0..6);print"\n";}print
"1 2 3 4 5 6 7\n";}sub d{($p,$c)=@_;$c+=7while($c<42&&!$f[$c]);next if$c<7;$f
[$c-7]=$p;$c-7;}sub e{($o,$d)=@_;$S=0;for(0..3,7..10,14..17,21..24,
28..31,35..38){$Z=$f[$_+3]+$f[$_+2]+$f[$_+1]+$f[$_];return-$M-$d if$Z==4*$o;$S
+=$S[$Z];}for(0..20){$Z=$f[$_]+$f[$_+7]+$f[$_+14]+$f[$_+21];return-$M-$d if$Z==
4*$o;$S+=$S[$Z];}for(0..3,7..10,14..17){$Z=$f[$_]+$f[$_+8]+$f[$_+16]+$f[$_+24];
return-$M-$d if$Z==4*$o;$S+=$S[$Z];}for(3..6,10..13,17..20){$Z=$f[$_]+$f[$_+6]+
$f[$_+12]+$f[$_+18];return-$M-$d if$Z==4*$o;$S+=$S[$Z];}$o!=1?$S:-$S;}sub a{my(
$c,$a,$b,$D)=@_;my$S=e(6-$c,$D);return$S if!$D||abs($S)>999;my$B;for(0..6){next
if$f[$_];my$j=d $c,$_;my($s)=a(6-$c,-$b,-$a,$D-1);$s=-$s;$f[$j]=0;if($s>$a){$a
=$s;$B=$_;}last if$a>=$b;}($a,$B);}while(1){p;last if abs(e 5)>$M/9;$m=<>;d 1
,$m-1;last if abs(e 1)>$M/9;($v,$m)=a 5,-$M,$M,6;d 5,$m;}
Tags: Alpha-Beta, Negmax, Perl, Perl-Golf
Posted by Patrick Krusenotto on Okt 23, 2007 in
Algorithmen,
Allgemein,
Perl Für ein aktuelles Projekt benötigte ich einen sicheren Mechanismus um Serien in einer Symbolkette zu finden.
Nach einigen fruchtlosen überlegungen mit Schleppzeigern beim Parsen und dergleichen und verschiedenen anderen Versuchen, dem Problem beizukommen, fand sich folgende Lösung:
- Suche die häufigste zweielementige Symbol-Teilfolge
- Ende der Berechnung, falls diese nicht mindestens zweimal vorkommt
- Fasse diese Symbolfolge zu einem einzelnen Symbol zusammen
- Weiter bei 1
Der Folgende Perl-Code implementiert das exemplarisch:
my @list=split //,"schalallalallalallaperl";
print $#list,"\n";
ROUND:
while (1) {
my %n=(); # %n zaehlt die Anzahl der Vorkommen aller
# zweielementigen Teilfolgen
my %position=(); # $position enthält zu jeder dieser
# zweielementigen Teilfolgen die
# Indexposition des zweiten Gliedes
# Zählen aller zweieelementigen Teilfolgen
for my $i (1..$#list) {
if ($list[$i-1] ne $list[$i]) { # Zähle nicht diejeigen
# Teilfolgen, die aus zwei
# identischen Symbolen bestehen!
my $folge=$list[$i-1].$list[$i];
$n{$folge}++;
push @{$position{$folge}} , $i;
}
}
# Finde die Teilfolge, die am häufigsten vorkommt. Am Ende der
# Berechnung steht die Teilfolge in $xmax und ihre Häufigkeit in
# $max
my ($xmax,$max)=("",0);
for (keys %n) {
if ($n{$_} > $max){
$xmax =$_;
$max =$n{$_};
}
}
last ROUND if $max<2; # Die Berechnung ist zuende, wenn keine
# Teilfolge mehr als einmal vorkommt
# Fasse nun die Teilfolgen zu einem Symbol zusammen. Beginne dabei
# von hinten, damit sich die Indices der Positionen nicht
# verschieben
my $pos = $position{$xmax};
for my $p (reverse @$pos) {
$list[$p-1] = $list[$p-1].$list[$p];
splice @list,$p,1;
}
}
# Fertig!
print "@list\n";
Tags: Periodensuche, Perl
Posted by Patrick Krusenotto on Okt 6, 2007 in
Algorithmen,
Allgemein,
Perl Manche Sachen sind banal, schon hundert mal da gewesen und doch oft erforderlich. Dann kann man erstmal googeln… Die Berechnung der Monatslänge unter Berücksichtigung von Schaltjahren gehört dazu. Die erste Version eines Ausdrucks ohne Schleifen und Abfragen ist mir 1983 in einem Programmierbuch für den Taschenrechner TI-59 begegnet. Das Problem ist natürlich so alt wie der gregorianische Kalender selbst… Kein Wunder also!
Entsprechend dem gregorianischen Kalender kann man die Berechnung folgendermaßen durchführen.
# Monat 1 <= $m < 12 und Jahr $y > 1530
$laenge = $m-2?30+($m*3%7<4):28+!($y%4||$y%400*!($y%100))
gefunden bei http://www.arcknowledge.com/gmane.comp.lang.perl.fun/2003-05/msg00077.html
Tags: Monatslänge, Perl
