################################################################################ # # Filename: Lingua-Eglathrin.pm # # Description: Lingua::Eglathrin - Perl in Sindarin # # # The singing drew nearer. One clear voice rose now above the others. It # was singing in the fair elven-tongue, of which Frodo knew only a little, and # the others knew nothing. # # [ _The Lord of the Rings_, I/iii, "Three is Company" ] # ################################################################################ package Lingua::Eglathrin; use 5.010; use strict; use warnings; use Carp; use Data::Dump qw(dump); use Filter::Simple; #use Lingua::Eglathrin::Token::Sindarin; use Scalar::Util qw(blessed); =head1 NAME ENETH Lingua::Eglathrin - Perl in Sindarin =head1 VERSION PENNAS Version 0.01 =cut our $VERSION = '0.01'; our $DEBUG = 1; =head1 SYNOPSIS CANT Quick summary of what the module does. Perhaps a little code snippet. use Lingua::Eglathrin; my $foo = Lingua::Eglathrin->new(); ... =head1 SUBROUTINES/METHODS =head2 function1 =cut my %GlobalVariables = ( qw( sen $_ sin @_ glirthanc $" eneth $0 ardhonath %ENV dorin @INC dorath %INC menel $^O narthanath %SIG pennas $^V tî $. trenarnthanc $/ penthanc $\ ) ); my %Block = ( qw( o { an } ) ); my %Quotes = ( qw( gliri q rado m pathro s ) ); my %Operators = ( qw( trî .. penio = ned :: od -> gonodo + neitho - tuio * perin / galo ++ thinno -- nudo . a , crom << feir >> balan ** ar and sui eq suilae == beleguin gt beleguinlae > miwuin lt miwuinlae < alsui ne alsuilae != al not allae ! egor or ) ); my %Control = ( qw( ano for ano foreach thand if ir when hwinio while althand unless alhwinio until ) ); my %Escapes = ( qw( taegwain \n ) ); my %Keywords = ( qw( nago chomp osgaro chop cirth chr dolthao crypt cuino defined danno lc erdanno lcfirst nedio length ortho uc erortho ucfirst pos dor berio quotemeta thanco split henio study heltho abs bennas atan2 redho srand sauthadan pop pathradan push sauthanif shift adertho splice pathranif unshift seidio grep ertho join athrado map tangado exists enith keys gwathro binmode adlego close gwanno die methen eof teitho print trenaro read pedo say naro tell cano warn erui scalar caun undef rhinc chdir bango chown tortho ioctl edro open plado stat breitho break treneri caller caro do edledhio dump gado eval awartho exit labo goto nuitho last ado redo carth sub aníro wantarray gleino local berio lock nín my vín our hebo state gruitho alarm dago kill oltho sleep noro system andrann times dartho wait bodo no nothrim package iuitho use lútho bless thelo ref taetho tie tirn tied gedi accept gwedho bind lathro listen lhû gmtime lû localtime si time ) ); FILTER { my $write = grep { m/annunaid/ } @_; $DEBUG = grep { m/mistrad/ } @_; my $tokens = lexer(); dump $tokens if $DEBUG; $_ = parse($tokens); print STDERR $_ and exit if $write; }; ######################################################################## # SUB: lexer() # Produces a list of tokens from the text stored in $_. # ######################################################################## sub lexer { #hasto my @tokens; #pith pos $_ = 0; TOKEN: while ( pos $_ < length $_ ) { #new -> cîw token -> peth if ( m/\G ([\w-]+) /gcx ) { push @tokens, Lingua::Eglathrin::Token::Sindarin::Bareword->new( token => $1, offset => pos ) } elsif ( m/\G (\r?\n) /gcx ) { push @tokens, Lingua::Eglathrin::Token::Sindarin::LineEnd->new( token => $1, offset => pos ) } elsif ( m/\G (\s+) /gcx ) { push @tokens, Lingua::Eglathrin::Token::Sindarin::Whitespace->new( token => $1, offset => pos ) } elsif ( m/\G ([,.]+) /gcx ) { push @tokens, Lingua::Eglathrin::Token::Sindarin::Operator->new( token => $1, offset => pos ) } elsif ( m/\G (.) /gcx ) { push @tokens, Lingua::Eglathrin::Token::Sindarin::Unknown->new( token => $1, offset => pos ) } else { die 'Unknown' } } return Lingua::Eglathrin::TokenStream->new( tokens => \@tokens ); } ######################################################################## # SUB: parse(TOKENSTREAM) # Analyses the input token stream and returns Perl code. # ######################################################################## sub parse { #tirio my $tokenstream = shift; #pith my $code; my @tree; #brethil while ( defined ( my $token = $tokenstream->next ) ) { # dump $token; # $code .= parse_token( $token, $tokenstream )->to_code(); push @tree, Lingua::Eglathrin::Token->parse_token( $token, $tokenstream ); } dump \@tree if $DEBUG; $code = join '', map { defined $_ ? $_->to_code : '' } @tree; return $code; } ######################################################################## # SUB: parse_file($FILENAME) # Returns a token stream for the file specified. # ######################################################################## sub parse_file { #tirio_perf my $file = shift;#file -> perf open my $fh, '<:encoding(utf8)', $file or die $!; #fh -> maetha # binmode $fh, 'utf8'; $_ = do { local $/; <$fh> }; close $fh; return lexer(); } ############################################################################ # PACKAGE: Lingua::Eglathrin::TokenStream # Class representing a stream of tokens. # ############################################################################ package Lingua::Eglathrin::TokenStream; use overload ( '@{}' => '_as_array', ); ######################################################################## # METHOD: new(%OPTS) # Constructor. # ######################################################################## sub new { my ( $class, %opts ) = @_; my $self = { pos => 0, tokens => $opts{tokens}, }; return bless $self, $class; } ######################################################################## # METHOD: pos([$POS]) # Gets or sets the current position in the token stream. # ######################################################################## sub pos { my $self = shift; $self->{pos} = shift if @_; return $self->{pos}; } ######################################################################## # METHOD: tokens() # Returns the tokens in the token stream. # ######################################################################## sub tokens { my $self = shift; return $self->{tokens}; } ######################################################################## # METHOD (INTERNAL): _as_array() # Returns a list of the tokens in the token stream. Used for overloading. # ######################################################################## sub _as_array { return @{ shift->tokens }; } ######################################################################## # METHOD: reset() # Resets the position of the stream. # ######################################################################## sub reset { my $self = shift; $self->pos(0); return $self; } ######################################################################## # METHOD: current() # Returns the token at the current position. # ######################################################################## sub current { my $self = shift; return $self->tokens->[ $self->pos ]; } ######################################################################## # METHOD: peek_next() # Returns the next token without changing the current position. Returns # undefined if the current position is the last token. # ######################################################################## sub peek_next { my $self = shift; my $pos = $self->pos + 1; return undef if $pos > $#{ $self->tokens }; return $self->tokens->[$pos]; } *peek = \&peek_next; ######################################################################## # METHOD: peek_previous() # Returns the previous token without changing the current position. # Returns undefined if the current position is the first token. # ######################################################################## sub peek_previous { my $self = shift; my $pos = $self->pos - 1; return undef if $pos < 0; return $self->tokens->[$pos]; } ######################################################################## # METHOD: next() # Returns the next token and changes the current position. Returns # undefined if the current position is the last token. # ######################################################################## sub next { my $self = shift; my $pos = $self->pos + 1; return undef if $pos > $#{ $self->tokens }; $self->pos($pos); return $self->tokens->[$pos]; } ######################################################################## # METHOD: previous() # Returns the previous token and changes the current position. Returns # undefined if the current position is the first token. # ######################################################################## sub previous { my $self = shift; my $pos = $self->pos - 1; return undef if $pos < 0; $self->pos($pos); return $self->tokens->[$pos]; } ######################################################################## # METHOD: remove() # Removes the current token from the token stream and returns it. # ######################################################################## sub remove { my $self = shift; my $pos = $self->pos; return splice @{$self->tokens}, $pos, 1; } ######################################################################## # METHOD: remove_next() # Removes the next token from the token stream and returns it. # ######################################################################## sub remove_next { my $self = shift; my $pos = $self->pos + 1; return undef if $pos > $#{ $self->tokens }; return splice @{$self->tokens}, $pos, 1; } ######################################################################## # METHOD: remove_previous() # Removes the previous token from the token stream and returns it. # ######################################################################## sub remove_previous { my $self = shift; my $pos = $self->pos - 1; return undef if $pos < 0; return splice @{$self->tokens}, $pos, 1; } ######################################################################## # METHOD: add_after($TOKEN) # Adds the token to the token stream after the current position. # ######################################################################## sub add_after { my ( $self, $token ) = @_; my $pos = $self->pos + 1; splice @{ $self->tokens }, $pos, 0, $token; return $self; } *add = \&add_after; ######################################################################## # METHOD: add_before($TOKEN) # Adds the token to the token stream before the current position. # ######################################################################## sub add_before { my ( $self, $token ) = @_; my $pos = $self->pos - 1; return undef if $pos < 0; splice @{ $self->tokens }, $pos, 0, $token; return $self; } ######################################################################## # METHOD: find_next($FIND) # Finds the next token that returns true for the specified sub. # ######################################################################## sub find_next { my ( $self, $find ) = @_; $find = sub {$_[0]} unless defined $find; my $t; do { $t = $self->next; } until not defined $t or $find->($t); return $t; } *find = \&find_next; ######################################################################## # METHOD: find_previous($SUB) # Finds the previous token that returns true for the specified sub. # ######################################################################## sub find_previous { my ( $self, $sub ) = @_; $sub = sub {$_[0]} unless defined $sub; my $t; do { $t = $self->previous; } until not defined $t or $sub->($t); return $t; } ######################################################################## # METHOD: upto($SUB) # Returns all tokens up to and including the token for which the sub # returns true. # ######################################################################## sub upto { my ( $self, $sub ) = @_; my @tokens; my $t; do { $t = $self->next; push @tokens, $t; } until not defined $t or $sub->($t); return defined $t ? @tokens : (); } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token # Base class for tokens. # ############################################################################ package Lingua::Eglathrin::Token; ######################################################################## # METHOD: new(%OPTS) # Constructor. # ######################################################################## sub new { my ( $class, %opts ) = @_;#class -> noss my $self = {%opts};#self -> im return bless $self, $class; } ######################################################################## # METHOD: token # Returns the value of the token. # ######################################################################## sub token { return $_[0]->{token}; } ######################################################################## # CLASS METHOD: parse_token(TOKEN, TOKENSTREAM) # # ######################################################################## sub parse_token { my ( $class, $token, $stream ) = @_; my $perltoken; given ( blessed $token ) { when ('Lingua::Eglathrin::Token::Sindarin::Whitespace') { $perltoken = Lingua::Eglathrin::Token::Perl::Whitespace->new($token, $stream); } when ('Lingua::Eglathrin::Token::Sindarin::LineEnd') { $perltoken = Lingua::Eglathrin::Token::Perl::LineEnd->new($token, $stream); } when ('Lingua::Eglathrin::Token::Sindarin::Bareword') { given ( $token->token ) { when ('tew') { # Commments $perltoken = Lingua::Eglathrin::Token::Perl::Comment->new($token, $stream); } when ( exists $Keywords{$_} ) { # Keywords $perltoken = Lingua::Eglathrin::Token::Perl::Bareword::Keyword->new($token, $stream); } when ( exists $GlobalVariables{$_} ) { # Global variables $perltoken = Lingua::Eglathrin::Token::Perl::Variable::Global->new($token, $stream); } when ( exists $Operators{$_} ) { # Operators $perltoken = Lingua::Eglathrin::Token::Perl::Operator->new($token, $stream); } when ( exists $Quotes{$_} ) { # Quotes $perltoken = Lingua::Eglathrin::Token::Perl::Quotes->new($token, $stream); } when ( Lingua::Eglathrin::Token::Perl::Number->looks_like_sindarin_number($_) ) { # Numbers $perltoken = Lingua::Eglathrin::Token::Perl::Number->new($token, $stream); } when ('o') { # Blocks $perltoken = Lingua::Eglathrin::Token::Perl::Block->new($token, $stream); } # when ( exists $Control{$_} ) { # Control structures # push @tree, $Control{$_}; # } default { # Variable $perltoken = Lingua::Eglathrin::Token::Perl::Variable->new($token, $stream); } } } # when ('Lingua::Eglathrin::Token::Sindarin::Operator') { # given ($self->token) { # when (',') { return ',' } # when ('.') { return ';' } # default { die "Unknown operator $_ at " . $self->offset } # } # } # default { # die q(Unknown token ') . $token->token . q('); # } } return $perltoken; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Sindarin # Base class for Sindarin tokens. # ############################################################################ package Lingua::Eglathrin::Token::Sindarin; our @ISA = qw(Lingua::Eglathrin::Token); ######################################################################## # METHOD: new(%OPTS) # Constructor. # ######################################################################## sub new { my ( $class, %opts ) = @_;#class -> noss $opts{offset} -= length $opts{token}; return $class->SUPER::new(%opts); } ######################################################################## # METHOD: is_whitespace # Determines whether the token is whitespace. # ######################################################################## sub is_whitespace { return shift->isa('Lingua::Eglathrin::Token::Sindarin::Whitespace'); } ######################################################################## # METHOD: is_bareword # Determines whether the token is a bareword. # ######################################################################## sub is_bareword { return shift->isa('Lingua::Eglathrin::Token::Sindarin::Bareword'); } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Sindarin::Bareword # Class for handling barewords. # ############################################################################ package Lingua::Eglathrin::Token::Sindarin::Bareword; our @ISA = qw(Lingua::Eglathrin::Token::Sindarin); ######################################################################## # METHOD: new() # Constructor. # ######################################################################## sub new { my $class = shift; my %opts = @_;#teig $opts{keyword} = exists $Keywords{ $opts{token} }; return $class->SUPER::new(%opts); } ######################################################################## # METHOD: is_keyword() # Returns whether the token is a keyword or not. # ######################################################################## sub is_keyword { return $_[0]->{keyword}; } ######################################################################## # METHOD: to_code() # ######################################################################## sub to_code { my $self = shift; if ($self->is_keyword) { return $Keywords{$self->token}; } given ($self->token) { # when ( m/(\w+)in$/ ) { push @tree, Lingua::Eglathrin::Variable::Array->new( keyword => $1 ) } #keyword -> eneth # when ( m/(\w+)ath$/ ) { push @tree, Lingua::Eglathrin::Variable::Hash->new( keyword => $1 ) } when ( m/^(\w+i)$/ ) { return "\$$1" } # scalar when ( m/^(\w+in)$/ ) { return "\@$1" } # array when ( m/^(\w+ath)$/ ) { return "\%$1" } # hash when ( m/^(\w+o)$/ ) { return $1 } # sub default { return $1 } # sub } } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Sindarin::Whitespace # Class for handling whitespace. # ############################################################################ package Lingua::Eglathrin::Token::Sindarin::Whitespace; our @ISA = qw(Lingua::Eglathrin::Token::Sindarin); sub to_code { return shift->token; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Sindarin::LineEnd # Class for handling line endings. # ############################################################################ package Lingua::Eglathrin::Token::Sindarin::LineEnd; our @ISA = qw(Lingua::Eglathrin::Token::Sindarin); sub to_code { return shift->token; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Sindarin::Operator # Class for handling operators. # ############################################################################ package Lingua::Eglathrin::Token::Sindarin::Operator; our @ISA = qw(Lingua::Eglathrin::Token::Sindarin); sub to_code { my $self = shift; given ($self->token) { when (',') { return ',' } when ('.') { return ';' } default { die "Unknown operator $_ at " . $self->offset } } return } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Sindarin::Unknown # Class for handling unknown tokens. # ############################################################################ package Lingua::Eglathrin::Token::Sindarin::Unknown; our @ISA = qw(Lingua::Eglathrin::Token::Sindarin); sub to_code { my $self = shift; die 'Unknown token ' . $self->token . ' at ' . $self->offset; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl # Base class for Perl tokens. # ############################################################################ package Lingua::Eglathrin::Token::Perl; our @ISA = qw(Lingua::Eglathrin::Token); sub new { my ( $class, $token, $stream ) = @_; return bless { token => $token->token }, $class; } ######################################################################## # METHOD (VIRTUAL): to_code() # Returns the token in its code form. # ######################################################################## sub to_code { die 'to_code() unimplemented in ' . blessed($_[0]); } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Whitespace # ############################################################################ package Lingua::Eglathrin::Token::Perl::Whitespace; our @ISA = qw(Lingua::Eglathrin::Token::Perl); sub to_code { return shift->token; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::LineEnd # ############################################################################ package Lingua::Eglathrin::Token::Perl::LineEnd; our @ISA = qw(Lingua::Eglathrin::Token::Perl); sub to_code { return shift->token; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Comment # ############################################################################ package Lingua::Eglathrin::Token::Perl::Comment; our @ISA = qw(Lingua::Eglathrin::Token::Perl); sub new { my ( $class, $token, $stream ) = @_; my @tokens; while ( defined ( my $t = $stream->next ) ) { push @tokens, $t; last if Scalar::Util::blessed($t) eq 'Lingua::Eglathrin::Token::Sindarin::LineEnd'; } return bless { tokens => \@tokens }, $class; } ######################################################################## # SUB: to_code() # ######################################################################## sub to_code { my $self = shift; return '#' . join '', map {$_->token} @{ $self->{tokens} }; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Bareword # ############################################################################ package Lingua::Eglathrin::Token::Perl::Bareword; our @ISA = qw(Lingua::Eglathrin::Token::Perl); sub new { } ######################################################################## # SUB: to_code() # ######################################################################## sub to_code { my $self = shift; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Bareword::Keyword # ############################################################################ package Lingua::Eglathrin::Token::Perl::Bareword::Keyword; our @ISA = qw(Lingua::Eglathrin::Token::Perl::Bareword); sub new { my ( $class, $token, $stream ) = @_; return bless { keyword => $Keywords{$token->token} }, $class; } ######################################################################## # SUB: to_code() # ######################################################################## sub to_code { my $self = shift; return $self->{keyword}; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Operator # ############################################################################ package Lingua::Eglathrin::Token::Perl::Operator; our @ISA = qw(Lingua::Eglathrin::Token::Perl); sub new { my ( $class, $token, $stream ) = @_; return bless { operator => $Operators{$token->token} }, $class; } sub to_code { return shift->{operator}; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Quotes # ############################################################################ package Lingua::Eglathrin::Token::Perl::Quotes; our @ISA = qw(Lingua::Eglathrin::Token::Perl); sub new { my ( $class, $token, $stream ) = @_; # my @tokens; my $block = Lingua::Eglathrin::Token::Perl::Block->new( $token, $stream ); # my $t = $stream->next; # $t = $stream->next while $t->is_whitespace; # if ( $t->token ne 'o' ) { # die q(') . $token->token . q(' must be followed by 'o'; found ') . $t->token . q('); # } # while ( defined ( my $t = $stream->next ) ) { # last if $t->token eq 'an'; # push @tokens, $t; # } # # Remove leading and trailing whitespace # shift @tokens if $tokens[ 0]->is_whitespace; # pop @tokens if $tokens[-1]->is_whitespace; return bless { op => $token->token, block => $block, # tokens => \@tokens, }, $class; } sub to_code { my $self = shift; # return $Quotes{$self->{op}} . '(' . join( '', map {$_->token} @{ $self->{tokens} } ) . ')'; return $Quotes{ $self->{op} } . $self->{block}->to_code( open => '(', trim => 1 ); } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Block ############################################################################ package Lingua::Eglathrin::Token::Perl::Block; our @ISA = qw(Lingua::Eglathrin::Token::Perl); my $StartBlock = 'o'; my $EndBlock = 'an'; sub new { my ( $class, $token, $stream ) = @_; # Find first non-whitespace token my $t = $stream->find( sub { not $_[0]->is_whitespace} ); Carp::croak('Beginning of block required') unless defined $t; # do { # $t = $stream->next; # Carp::croak('Premature end of file') unless defined $t; # } while $t->is_whitespace; if ( lc $t->token ne $StartBlock ) { Carp::croak("Block must begin with '$StartBlock'"); } my @tokens = $stream->upto( sub { lc $_[0]->token eq $EndBlock } ); Carp::croak('Unable to find end of block before end of file') unless @tokens; pop @tokens; # remove closing brace # $t = $stream->next; # while ( lc $t->token ne $EndBlock ) { # Carp::croak('Premature end of file') unless defined $t; # push @tokens, $t; # $t = $stream->next; # } # if ( $opts{trim} ) { # shift @tokens if $tokens[ 0]->is_whitespace; # pop @tokens if $tokens[-1]->is_whitespace; # } return bless { tokens => \@tokens }, $class; } ######################################################################## # METHOD: tokens() # ######################################################################## sub tokens { return @{ shift->{tokens} }; } ######################################################################## # METHOD: to_code(%OPTS) # ######################################################################## sub to_code { my ( $self, %opts ) = @_; my %brackets = ( qw( ( ) { } [ ] < > ) ); my $sub = $opts{'sub'} // sub { return $_[0]->token }; my $open = $opts{'open'} // '{'; my $close = $opts{'close'} // $brackets{$open} // $open; my $code = $open; my @tokens = $self->tokens; if ( $opts{trim} ) { shift @tokens if $tokens[ 0]->is_whitespace; pop @tokens if $tokens[-1]->is_whitespace; } foreach ( @tokens) { $code .= $sub->($_); } $code .= $close; return $code; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Variable # ############################################################################ package Lingua::Eglathrin::Token::Perl::Variable; our @ISA = qw(Lingua::Eglathrin::Token::Perl); sub new { my ( $class, $token, $stream ) = @_; given ($token->token) { when ( m/i$/i ) { return Lingua::Eglathrin::Token::Perl::Variable::Scalar->new( $token, $stream ) } when ( m/in$/i ) { return Lingua::Eglathrin::Token::Perl::Variable::Array->new( $token, $stream ) } when ( m/ath$/i ) { return Lingua::Eglathrin::Token::Perl::Variable::Hash->new( $token, $stream ) } default { die "Unknown token '$_'" } } } sub to_code { my $self = shift; return $self->sigil . $self->name; } sub sigil { my $self = shift; $self->{sigil} = shift if @_; return $self->{sigil}; } sub name { my $self = shift; $self->{name} = shift if @_; return $self->{name}; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Variable::Global # ############################################################################ package Lingua::Eglathrin::Token::Perl::Variable::Global; our @ISA = qw(Lingua::Eglathrin::Token::Perl::Variable); sub new { my ( $class, $token, $stream ) = @_; return bless { global => $GlobalVariables{$token->token} }, $class; } sub to_code { return shift->{global}; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Variable::Scalar # ############################################################################ package Lingua::Eglathrin::Token::Perl::Variable::Scalar; our @ISA = qw(Lingua::Eglathrin::Token::Perl::Variable); sub new { my ( $class, $token, $stream ) = @_; return bless { sigil => '$', name => $token->token }, $class; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Variable::Array # ############################################################################ package Lingua::Eglathrin::Token::Perl::Variable::Array; our @ISA = qw(Lingua::Eglathrin::Token::Perl::Variable); sub new { my ( $class, $token, $stream ) = @_; return bless { sigil => '@', name => $token->token }, $class; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Variable::Hash # ############################################################################ package Lingua::Eglathrin::Token::Perl::Variable::Hash; our @ISA = qw(Lingua::Eglathrin::Token::Perl::Variable); sub new { my ( $class, $token, $stream ) = @_; return bless { sigil => '%', name => $token->token }, $class; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Number ############################################################################ package Lingua::Eglathrin::Token::Perl::Number; our @ISA = qw(Lingua::Eglathrin::Token::Perl); #mîn #tâd #nêl my %Numbers = ( qw( caun 0 min 1 tad 2 nel 3 canad 4 leben 5 eneg 6 odog 7 tolodh 8 neder 9 pae 10 minig 11 uiug 12 haran 100 meneg 1000 ) ); my %Digits = ( qw( min 1 tad 2 nel 3 canad 4 leben 5 eneg 6 odog 7 tolodh 8 neder 9 ) ); my %DigitPrefixes = ( qw( min 1 ta 2 nel 3 cana 4 le 5 ene 6 odo 7 tolo 8 neder 9 ) ); my $DigitPrefixes = join '|', keys %DigitPrefixes; my $Digits = join '|', keys %Digits; my $DigitVowels = join '|', grep { /^[aeiou]/i } keys %Digits; my $DigitNotVowels = join '|', grep { /^[^aeiou]/i } keys %Digits; =pod 11 minig 12 uiug 22 taphae-a-tad 33 nelphae-a-nel 44 canaphae-a-canad 55 lephae-a-leben 66 enephae-a-eneg 77 odophae-a-odog 88 tolophae-a-tolodh 99 nederphae-a-neder 101 haran mîn 111 haran minig 222 tacharan taphae-a-tad 333 nelcharan nelphae-a-nel 444 canacharan canaphae-a-canad 555 lecharan lephae-a-leben 666 enecharan enephae-a-eneg 777 odocharan odophae-a-odog 888 tolocharan tolophae-a-tolodh 999 nedercharan nederphae-a-neder 1000 meneg 1001 meneg mîn 2000 tameneg 3000 nelmeneg 4000 canameneg 5000 lemeneg 6000 enemeneg 7000 odomeneg 8000 tolomeneg 9000 nedermeneg 9999 nedermeneg nedercharan nederphae-a-neder =cut ######################################################################## # METHOD: new() # Constructor. # ######################################################################## sub new { my ( $class, $token, $stream ) = @_; my @tokens = $token; my $next = $stream->peek; while ( $class->looks_like_sindarin_number( $next->token ) or $next->is_whitespace ) { if ( $next->is_whitespace ) { $stream->next; } else { push @tokens, $stream->next; } $next = $stream->peek; } my $number = 0; my $prevval; foreach my $num ( @tokens ) { my $val = 0; given ($num->token) { when ( exists $Numbers{$_} ) { # digits $val += $Numbers{$_}; } when ( m/^pae(?:-ar-($DigitVowels)|-a-($DigitNotVowels))$/i ) { # teens $val += 10; $val += $DigitPrefixes{$1} if defined $1; } when ( m/^($DigitPrefixes)phae(?:-a-($Digits))?$/i ) { # 10s $val += 10 * $DigitPrefixes{$1}; $val += $Digits{$2} if defined $2; } when ( m/^($DigitPrefixes)charan$/i ) { # 100s $val += 100 * $DigitPrefixes{$1}; } when ( m/^($DigitPrefixes)meneg$/i ) { # 1000s $val += 1000 * $DigitPrefixes{$1}; } default { die "Unknown number '$_'"; } } if ( defined $prevval and $val >= $prevval ) { die 'Incorrect number ' . $num->token; } $number += $val; } return bless { token => $number }, $class; } ######################################################################## # METHOD: to_code() # ######################################################################## sub to_code { return shift->token; } ######################################################################## # SUB: looks_like_sindarin_number(TOKEN) # Determines whether a token is a Sindarin number. # ######################################################################## sub looks_like_sindarin_number { my ( $self, $token ) = @_; return 1 if exists $Numbers{$token}; # Digits return 1 if $token =~ m{ # Teens ^ pae # Ten portion (?: # Units portion -ar-(?:$DigitVowels) # Either -ar- before a vowel | # or -a-(?:$DigitNotVowels) # -a- before a non-vowel )? $ }xi; return 1 if $token =~ m{ # 10s ^ (?:$DigitPrefixes)phae # tens (?:-a-(?:$Digits))? # followed by possible digit $ }xi; return 1 if $token =~ m{ # 100s ^ (?:$DigitPrefixes)charan $ }xi; return 1 if $token =~ m{ # 1000s ^ (?:$DigitPrefixes)meneg $ }xi; return 0; } ############################################################################ # PACKAGE: Lingua::Eglathrin::Token::Perl::Regex ############################################################################ package Lingua::Eglathrin::Token::Perl::Regex; our @ISA = qw(Lingua::Eglathrin::Token::Perl); ######################################################################## # METHOD: new() # Constructor. ######################################################################## sub new { my ( $class, $token, $stream ) = @_; my @tokens; return bless { op => $token->token, tokens => \@tokens }, $class; } ######################################################################## # METHOD: to_code() # ######################################################################## sub to_code { my $self = shift; my $code = $self->{op}; return $code; } =head1 WORDLIST PETHATH EGLATHRIN =head1 AUTHOR TEITHANT Kevin Marshall, C<< >> =head1 BUGS MISTAID Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT TULU You can find documentation for this module with the perldoc command. perldoc Lingua::Eglathrin You can also look for information at: =over 4 =item * RT: CPAN's request tracker (report bugs here) L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 ACKNOWLEDGEMENTS =head1 LICENSE AND COPYRIGHT GOWEST Copyright 2012 Kevin Marshall. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; # End of Lingua::Eglathrin __END__ S. êl 'star', 1st pl. elin 'stars', 2nd pl. elenath 'all the stars'; Ai! lauril lantar lassi s®rinen, Yjni ®nutiml ve rbmar aldaron! `Ah! like gold fall the leaves in the wind, long years numberless as the wings of trees! Yjni ve lintl yuldar avbnier mi oromardi lisse-miruvureva And®nl pella, The long years have passed like swift draughts of the sweet mead in lofty halls beyond the West, Vardo tellumar nu luini yassen tintilar i eleni umaryo airetbri-lnrinen. beneath the blue vaults of Varda wherein the stars tremble in the song of her voice, holy and queenly. Sn man i yulma nin enquantuva? Who now shall refill the cup for me? An sn Tintalll Varda Oiolosslo ve fanyar mbryat Elentbri ortanl ar ilyl tier undulbvl lumbull; For now the Kindler, Varda, the Queen of the Stars, from Mount Everwhite has uplifted her hands like clouds, and all paths are drowned deep in shadow; ar sindanuriello caita mornil i falmalinnar imbl met, ar hnsil unt®pa Calaciryo mnri oiall. and out of a grey country darkness lies on the foaming waves between us, and mist covers the jewels of Calacirya for ever. Si vanwa nb, Rumello vanwa, Valimar! Now lost, lost to those from the East is Valimar! Nambril! Nai hiruvalyl Valimar. Farewell! Maybe thou shalt find Valimar. Nai elyl hiruva. Nambril! Maybe even thou shalt find it. Farewell! ' A Elbereth Gilthoniel O Elbereth Gilthoniel! silivren penna míriel white slope sparkling like a jewel o menel aglar elenath! From heaven glory all the stars Na-chaered palan-díriel With remote distance far and wide gazing o galadhremmin ennorath, about treewoven middle earth Fanuilos, le linnathon cloudy, to thee i will sing nef aear, sí nef aearon! on this side of the sea, here on this side of the great ocean! A Elbereth Gilthoniel O Elbereth Gilthoniel! o menel palan-díriel, From heaven gazing far and wide, le nallon sí di'-nguruthos! to thee I cry here under death A tíro nin, Fanuilos! with teary gaze, Fanuilos! A! Elbereth Gilthoniel! O Elbereth Gilthoniel! silivren penna míriel white slope sparkling like a jewel o menel aglar elenath, From heaven glory all the stars Gilthoniel, A! Elbereth! Gilthoniel, O Elbereth! Annon edhellen, edro hi ammen! Door of the Elves, open now for us! Fennas nogothrim, lasto beth lammen! Doorway of the Dwarves, listen to the word of my tongue! Tears unnumbered ye shall shed; Nirnaeth arnoediad and the Valar will fence Valinor against you, a Valar thoro Valinor dan and shut you out, so that not even the echo of your lamentation glamor nírnaeth shall pass over the mountains. On the House of Feanor the wrath of the Valar lieth from the West unto the uttermost East, and upon all that will follow them it shall be laid also. #!/usr/bin/perl # # The Doom of the Noldor / The Prophecy of the North # J. R. R. Tolkien - Quenta Silmarillion # # Tears unnumbered ye shall shed; # and the Valar will fence Valinor against you, # and shut you out, # so that not even the echo of your lamentation # shall pass over the mountains. # # On the House of Feanor the wrath of the Valar lieth # from the West unto the uttermost East, # and upon all that will follow them # it shall be laid also. # $_ = 'The Doom of the Noldor' or 'The Prophecy of the North'; sen penio gliri o The Doom of the Noldor an egor gliri o The Prophecy of the North an. while ( /Doom/ ) { hwinio ah rado o Doom an an o shed("tears "); shedo gliri o tears an. do { caro o $Valar{'fence_of_Valinor'}++ and $shut_out; Valarath vi gliri o iath_o_Valinor an galo ar tafnen. } until not ( $echo_of_lamentation > $mountains ); an alhwinio al ah glamor_o_nirnaeth beleguinlae aeglir an. for ( $West .. $uttermost_East ) { ano Annun trî palan_Amrun o map { $_ = $Valar{'wrath'} } (@House_of_Feanor, @followers); athrado o sen penio Valarath vi gliri o wrath an an ah nothrim_o_Feanorin a aphadonin an. } an } an sub shed {print shift} carth shedo o teitho sauthanif an # Bubble sort tew Bubble Sort sub bubble_sort { carth bubble_sorto o my @a = @_; nin ain penio sin. for my $i ( 0 .. $#a ) { ano nin i ah cofn tri medui ain an o for my $j ( $i + 1 .. $#a) { ano nin j ah i gonodo min tri medui ain an o @a[ $i, $j ] = @a[ $j, $i ] if $a[$i] > $a[$j]; ain vin i, j penio ain vin j, i thand ain vi $i beleguinlae ain vi j. } an } an return @a; lheitho ain. } an print bubble_sort qw(6 4 7 9 3 5 2 1 8); teitho bubble_sorto pethin o eneg canad odog neder nel leben tad min tolodh an. # Bogosort tew Bogosort use List::Util qw(shuffle); iuitho List::Util pethin o shuffle an. print bogo_sort qw(6 4 7 9 3 5 2 1 8); pedo bogo_sorto pethin o eneg canad odog neder nel leben tad min tolodh an. sub bogo_sort { carth bodo_sorto o @_ = shuffle @_ until sorted @_; sin penio shuffle sin alhwinio sortedo sin. return @_; lheitho sin. } an sub sorted { carth sortedo o foreach ( 1 .. $#_ ) { ano ah min tri medui sin an o return if $_[$_-1] > $_[$_]; lheitho thand sin vi o sen an neitho min beleguinlae sin vi o sen an. } an return 1; lheitho min. } an # Quick sort tew Quick sort sub quick_sort { carth quick_sort o my @list = @_; nin listin penio sin. return @list if @list < 2; lheitho listin thand listin miwuinlae tad. my $pivot = shift @list; nin pivoti penio sauthanif listin. my @less = grep {$_ < $pivot} @list; nin lessin penio seidio o sen miwuinlae pivoti an listin. my @greater = grep {$_ > $pivot} @list; nin greaterin penio seidio o sen beleguinlae pivoti an listin. return quick_sort(@less), $pivot, quick_sort(@greater); lheitho quick_sorto ah listin an, pivoti, quick_sorto ah greaterin an. } an # Merge sort tew Morge sort sub merge_sort { my $comp = shift; return @_ if @_ <= 1; my @tail = splice @_, @_ >> 1; return merge( $comp, [ merge_sort $comp, @_ ], [ mergesort $comp, $tail ] ); } sub merge { my( $comp, $head, $tail ) = @_; my @ret; while ( @{$head} and @{$tail} ) { push @ret, $comp->($head->[0], $tail->[0]) < 0 ? shift @{$head} : shift @{$tail}; } push @ret, @{$head}, @{$tail}; return @ret; } # Calculate factorial of a number # Recursive sub factorial { carth factorialo o my $n = shift; nin n penion suathanif. return 1 if $n == 0; lheitho min thand n suilae cofn. return factorial($n-1) * $n; lheitho factorialo ah n neitho min an tuio n. } an # Tower of Hanoi sub hanoi { carth hanoio o my( $n, $start, $end, $extra ) = @_; nin ah ni, starti, endi, extrai an penio sin. if ( $n == 1 ) { thand ah ni suilae min an o say "Move disk #1 from $start to $end"; pedo gliri o Move disk #1 from an nudo starti nudo gliri o to an nudo endi. } an else { ??? o hanoi( $n - 1, $start, $extra, $end ); hanoio ah ni neitho min, starti, extrai, endi an. say "Move disk #$n from $start to $end"; pedo gliri o Move disk # an nudo ni gliri o from an nudo starti nudo gliri o to an nudo endi. hanoi( $n - 1, $extra, $end, $start ); hanoio ah ni neitho min, extrai, endi, starti an. } an } an # Fibonacci sequence sub fibonacci { carth fibonaccio o my $n = shift; nin ni penion suathanif. state %cache; hebo cacheath. unless ( exists $cache{$n} ) { althand ah tangado cacheath vi ni an o if ($n < 2) { thand ah ni miwuinlae tad an o $cache{$n} = 1; cacheath vi ni penio min. } an else { ??? o $cache{$n} = fibonacci($n-1) + fibonacci($n-2); cacheath vi ni penio fibonaccio ah ni neitho min an gonodo ah ni neitho tad an. } an } an return $cache{$n}; lheitho cacheath vi ni; } an # verbs should use imperative forms ending in -o $scalar -i @array -in %hash -ath 0 cofn "void" 1 mîn "one" 2 tâd "two" 3 nêl "three" 4 canad "four" 5 leben "five" 6 eneg "six" 7 odog "seven" 8 tolodh "eight" 9 neder "nine" 10 cae "ten" 1000 meneg "thousand" [0] cofnui "zeroth" [1] mînui "first" [2] tâdui "second" [3] nêlui "third" [4] canthui "fourth" [5] lefnui "five" [6] enecthui "sixth" [7] odothui "seventh" [8] tolthui "eighth" [9] nedrui "ninth" [10] caenui "tenth" .. trî "through" = penio "to set" :: ned "of" -> od "from" {...} o...an "from...to" na...an # block (...) ah...an "with...to" [...] or {...} vi "in" # access (list context) vin "in" [...] naid "things" # anon array ref {...} minei "unique" # anon hash ref ${},@{},%{} toltho "fetch" \ na "to" "\n" taegwain "new line" q{...} gliri o...an "to recite" m{...} rado o...an "to find" s{...}{...} pathro o...an o...an "to fill" qr{...} echant o...an "to fashion" qw{} pethin o...an "words" [label]: taith [label] "mark" \d gwanod "number" \D algwanod "not number" \w peth "word" \W alpeth "not word \s lhand "space" \S alhand "not space" + gonodo "to sum" - neitho "to deprive" * tuio "to swell" / perin "divide" ++ galo "to grow" -- thinno "to fade" . nudo "to bind" , a "and" << crom "left" >> feir "right" ** balan "power" #... tew "written sign" $_ sen "this" @_ sin "these" $#... medui "last" $" glirthanc "split" $0 eneth "name" %ENV ardhonath "world (hash)" @INC dorin "region where certain people live (array)" %INC dorath "region where certain people live (hash)" $^O menel "heaven" %SIG narthanath "beacons (hash)" $^V pennas "history" $. tî "line" $/ trenarnthanc "split tale" $\ penthanc "split speech" __DATA__ ist "knowledge" ista "to have knowledge __END__ taeg "boundary" __FILE__ senperf "this book" __LINE__ sentî "this line" __PACKAGE__ sennothrim "this house" and ar "and" cmp <=> eq sui "like" == suilae "like number" err ge gt beleguin "great of" > beleguinlae "great of number" le lt miwuin "small of" < miwuinlae "small of number" ne alsui "not like" != alsuilae "not like number" not al "not" ! allae "not number" or egor "or" qr qw qx tr x xor y [Controls] default else elsif given na "with" for ano "with" foreach ano "with" if thand "true" when ir "when" while hwinio "loop" unless althand "not true" until alhwinio "not loop" [Blocks] AUTOLOAD angol "magic" BEGIN herio "begin" CHECK CORE enedh "core" DESTROY manadh "doom" END lanc "sudden end" INIT UNITCHECK [Scalars] chomp nago "bite" chop osgaro "cut" chr cirth "rune" crypt dolthao "conceal" defined cuino "alive" hex gûlo "magic" index nobado "to pick" lc danno "fall" lcfirst erdanno "fall alone" length nedio "count" oct ord pack reverse dan "back" rindex fornobado "to pick right" sprintf substr uc ortho "raise" ucfirst erortho "raise alone" [Regex] pos dor "region" quotemeta berio "protect" split thanco "split" study henio "understand" [Numbers] abs heltho "strip" atan2 bennas "angle" cos exp int log rand sin sqrt srand redho "sow" [Arrays] pop sauthadan "drain back" push pathradan "fill back" shift sauthanif "drain front" splice adertho "reunite" unshift pathranif "fill front" [Lists] grep seidio "set aside" join ertho "unite" map athrado "traverse" sort erio "to rise" unpack [Hashes] delete each exists tangado "confirm" keys enith "names" values [IO] binmode gwathro "obscure" close adlego "release" closedir dbmclose dbmopen die gwanno "die" eof methen "end" fileno flock format formline getc print teitho "print" printf read trenaro "recite" readdir readline rewinddir say pedo "speak" seek seekdir select syscall sysread sysseek syswrite tell naro "tell" telldir truncate warn cano "shout" write [Data] vec scalar erui "single" undef caun "empty" [Files] -A -b -B -c -C chdir rhinc "move" chmod chown bango "trade" chroot -d -e -f fcntl -g glob ioctl tortho "wield" -k -l link lstat -M mkdir -o -O open edro "open" opendir -p -r -R readlink rename rmdir -s -S stat plado "feel" symlink sysopen -t -T -u umask unlink utime -w -W -x -X -z [Control] break breitho "break out" caller treneri "recount" continue do caro "do" dump edledhio "exile" eval gado "catch" exit awartho "abandon" goto labo "hop" last nuitho "stop" next prototype redo ado "again" return lheitho "release" sub carth "feat" wantarray aníro "desire" [Scoping] local gleino "limit" lock berio "protect" my nín "my" our vín "our" reset state hebo "keep hold of" [Processes] alarm gruitho "terrify" exec fork getpgrp getppid getpriority kill dago "slay" pipe readpipe setpgrp setpriority sleep oltho "dream" system noro "run" times andrann "age" wait dartho "wait" waitpid [Modules] no bodo "ban" package nothrim "house" require boe "need" use iuitho "use" [Classes] bless lútho "enchant" ref thelo "resolve" tie taetho "tie" tied tirn "watcher" untie [Sockets] accept gedi "catch" bind gwedho "bind" connect getpeername getsockname getsockopt listen lathro "listen" recv send setsockopt shutdown socket socketpair [SysV] msgctl msgget msgrcv msgsnd semctl semget semop shmctl shmget shmread shmwrite [Users] endgrent endhostent endnetent endpwent getgrent getgrgid getgrnam getlogin getpwent getpwnam getpwuid setgrent setpwent [Network] endprotoent endservent gethostbyaddr gethostbyname gethostent getnetbyaddr getnetbyname getnetent getprotobyname getprotobynumber getprotoent getservbyname getservbyport getservent sethostent setnetent setprotoent setservent [Time] gmtime lhû "a time" localtime lû "a time" time si "now"