#!/usr/bin/perl
#
# Written by Jon Dehdari 2004-2005
# Perl 5.8
# Stemmer and Morphological Parser for Persian
# The license for this stemmer only is the LGPLv2.1 (www.fsf.org)
#
# The format of the resolve.txt file is as follows:
# 1. Mokassar: 		'ktb	ktAb'    OR    'ktb	ktAb_+PL'
# 2. Preparsed (speed):	'krdn	kr_+dn'
# 3. Don't stem:	'bArAn	bArAn'
# 4. Stop word:		'u	'

use strict;
use Getopt::Long;
#use diagnostics;

my $version        = "0.4.5";
my $date           = "2005/06/05";
my $copyright      = "(c) 2004-2005  Jon Dehdari - GPL v2.";
my $title          = "Persian stemmer $version, $date - $copyright";
my $resolve_file   = "resolve.txt";
my $recall         = 0;
my $show_links     = 0;
my $show_only_root = 0;
my $tokenize       = 0;
my $unvowel        = 0;
my @line;
my %resolve;
my @resolve;
my $resolve;
my $ar_chars    = "EqHSTDZLVU";
#my $longvowel    = "Aui]";

my $usage       = <<"END_OF_USAGE";
${title}

Syntax:   perl $0 [options] < input > output

Function: Stemmer and morphological analyzer for the Persian language.
          Inflexional morphemes are separated from their roots.

Options:
  -h, --help              Print usage
  -l, --links             Show morphological links
  -r, --root              Return only word roots
  -R, --recall            Increase recall by parsing ambiguous affixes
  -s, --stoplist <file>   Use stopword list <file>  (default: ./resolve.txt)
  -t, --tokenize          Tokenize punctuation
  -u, --unvowel           Remove short vowels
  -v, --version           Print version

END_OF_USAGE

GetOptions(
    'h|help|?'      => sub { print $usage; exit; },
    'l|links'       => \$show_links,
    'r|root'	    => \$show_only_root,
    'R|recall'	    => \$recall,
    's|stoplist:s'  => \$resolve_file,
    't|tokenize'    => \$tokenize,
    'u|unvowel'     => \$unvowel,
    'v|version'     => sub { print "$version\n"; exit; },
) or die $usage;


#open RESOLVE, "$resolve_file";
#while ($resolve = <RESOLVE>) {
#    chomp $resolve;
#    @resolve = split /\t/, $resolve;
#    %resolve = ( %resolve, "$resolve[0]" => "$resolve[1]" , );
#}
 
while ($_ = <>) {
chomp $_;

if ( $unvowel ) {
    $_ =~ s/\b([aeo])/|/g; # Inserts alef before words that begin with short vowel
    $_ =~ s/\bA/]/g;       # Changes long 'aa' at beginning of word to alef madda
    $_ =~ s/[aeo~]//g;     # Finally, removes all other short vowels and tashdids
}

#Inserts ZWNJ's where they should have been originally, but weren't
    $_ =~ s/(?<![a-zA-Z|])mi /mi-/g;    # 'mi-'
    $_ =~ s/(?<![a-zA-Z|])nmi /nmi-/g;  # 'mi-'
    $_ =~ s/ hA(?![a-zA-Z|])/-hA/g;     # '-hA'
    $_ =~ s/ hAi(?![a-zA-Z|])/-hAi/g;   # '-hA'
    $_ =~ s/h \|i(?![a-zA-Z|])/h-\|i/g; # '+h-|i'

#$_ =~ s/\b(?<!\])`exists($resolve[0])`\b/Eureka/g;
#print "Resolve-line: $resolve{??}\n";
#$_ =~ s/\b(?<!\])(??{exists($resolve{$_})})\b/eureka/g;
##@line = split /\b(?<!\])/, $_;
##print "LINE: @line\n";

#if ( exists($resolve{$_})) { print "$resolve{$_}\n";}
#else 
#{

## If these regular expressions are readable to you, you need to check in to a psychiatric ward!


##### Verb Section #####
# todo: 3Spast

######## Verb Prefixes ########
    $_ =~ s/\b(?<!\])n(\S{2,}?(?:im|id|nd|m|(?!A|u)i|d|(?:r|u|i|A|n|m|z)dn|(?:f|C|x|s)tn)(?:mAn|tAn|CAn|C)?)\b/n+_$1/g; # neg. verb prefix 'n+'
    $_ =~ s/(\bn\+_|\b)mi-(.{2,}?(?:im|id|nd|m|(?!hA)i|d)(?:mAn|tAn|CAn|C)?)\b/$1mi-+_$2/g;    # Durative verb prefix 'mi+'
    $_ =~ s/(\bn\+_|\b)mi(?!-)(.{2,}?(?:im|id|nd|m|(?!hA)i|d)(?:mAn|tAn|CAn|C)?)\b/$1mi+_$2/g; # Durative verb prefix 'mi+'
    $_ =~ s/\bb(?!ud)([^ ]{2,}?(?:im|id|nd|m|(?!hA)i|d)(?:mAn|tAn|CAn|C)?)\b/b+_$1/g;          # Subjunctive verb prefix 'be+'

######## Verb Suffixes ########
    $_ =~ s/(.*?(?:..d|..(?:s|f|C|x)t|\bn\+_.{2,}?|mi\+_.{2,}?|b\+_.{2,}?)(?:im|id|nd|m|(?!A|u)i|d))(mAn|tAn|CAn|C)\b/$1_+$2/g;   # Verbal Object verb suffix
    $_ =~ s/\b(n\+_.{2,}?|\S?mi\+_.{2,}?|b\+_\S{2,}?)([uAi])([iI])(im|id|i)(_\+.*)?\b/$1$2_+0$4$5/g;    # Removes epenthesized 'i/I' before Verbal Person suffixes 'im/id/i'
    $_ =~ s/\b(n\+_.{2,}?|.?mi\+_.{2,}?|b\+_\S{2,}?)([uA])i(nd|d|m)(_\+.*?)?\b/$1$2_+0$3$4/g;    # Removes epenthesized 'i' before Verbal Person suffixes 'm/d/nd'
    $_ =~ s/(.*?(?:\S{2}d|\S(?:s|f|C|x)t|\bn\+_\S{2,}?|mi-?\+_\S{2,}?|\bb\+_\S{2,}?))(nd|id|im|d|(?!A|u)i|m)(_\+.*?)?\b/$1_+$2$3/g;    # Verbal Person verb suffix
    $_ =~ s/(\S{2,}?)d_\+(nd|id|im|d|i|m)(_\+.*?)?\b/$1_+d_+$2$3/g;	# Verbal tense suffix 'd'
    $_ =~ s/(\S+?)(s|f|C|x)t_\+(nd|id|im|d|i|m)(_\+.*?)?\b/$1$2_+t_+$3$4/g;	# Verbal tense suffix 't'

    $_ =~ s/\b(\S{2,}?)(r|u|i|A|n|m)dn\b/$1$2_+dn/g;               # Verbal Infinitive '+dan'
    $_ =~ s/\b(\S{2,}?)(f|C|x|s)tn\b/$1$2_+tn/g;                   # Verbal Infinitive '+tan'
    $_ =~ s/\b(\S{2,}?)(i|n|A|u|z|r|b|h|s|k|C|f)ndh\b/$1$2_+ndh/g; # Verbal present participle '+andeh'
    $_ =~ s/\b(\S{2,}?)(C|r|n|A|u|i|m|z)dh\b/$1$2_+d_+h/g;         # Verbal past participle '+deh'
    $_ =~ s/\b(\S{2,}?)(C|f|s|x)th\b/$1$2_+th/g;                   # Verbal past participle '+teh'

    $_ =~ s/\b(C|z|kr|bu|dA|\]ur|di|br|\]m|mr|kn|ci)(dn|dh)\b/$1_+$2/g;  # 'shodan/zadan' Infinitive or Verbal past participle
    $_ =~ s/\b(C|z|kr|bu|dA|\]ur|di|br|\]m|mr|kn|ci)d(nd|i|id|m|im)?\b/$1_+d_+$2/g;  # 'shodan/zadan...' simple past - temp. until resolve file works
    $_ =~ s/\b(xuAh|dAr)(d|nd|i|id|m|im)\b/$1_+$2/g;  # future/have - temp. until resolve file works
    $_ =~ s/_\+d_\+\B/_+d/g;                          # temp. until resolve file works

######## Contractions ########
    $_ =~ s/\bcist\b/ch |st/g;                       # 'cheh ast'  - semicheap hack
    $_ =~ s/\b([^+ ]+?)([uAi])st(?!\s)\b/$1$2 |st/g; # normal "[uAi] ast", can't be followed by space (eg. mAst vs ...mA |st.)
    $_ =~ s/\bmrA\b/mn rA/g;                         # 'man rA'    - semicheap hack
    $_ =~ s/\btrA\b/tu rA/g;                         # 'man rA'    - semicheap hack


##### Noun Section #####

    $_ =~ s/\b([^+ ]{2,}?)(u|A)i(CAn|C|tAn|mAn)(_\+.*?)?\b/$1$2_+0_+$3$4/g;  # Removes epenthesized 'i' before genitive pronominal enclitics
    $_ =~ s/\b([^+ ]+?)([^uAi+])(CAn|C|tAn|mAn)(_\+.*?)?\b/$1$2_+$3$4/g;     # Genitive pronominal enclitics
#   $_ =~ s/\b([^+ ]{2,}?)(A|u)\b//g;             # Removes epenthesized 'i' before accusative enclitics
    $_ =~ s/\b([^+ ]{2,}?)(?!A)gAn\b/$1h_+An/g;   # Nominal plural suffix from stem ending in 'eh'
    $_ =~ s/\b([^+ ]+?)(A|u)i\b/$1$2_+e/g;        # Ezafe preceded by long vowel
    $_ =~ s/\b([^+ ]{2,}?)(hA|-hA)\b/$1_+$2/g;           # Nominal plural suffix
    $_ =~ s/\b([^+ ]{2,}?)(hA|-hA)(_\+.*?)\b/$1_+$2$3/g; # Nominal plural suffix
    $_ =~ s/\b(\S*?[$ar_chars]\S*?)At\b/$1_+h/g;         # Arabic plural: +At
    $_ =~ s/\b((?:m|\|)\S*?)At\b/$1_+h/g;                # Arabic plural: +At
    $_ =~ s/\b(m[^+ ]{3,}?)t\b/$1_+t/g;                  # Arabic fem: +at
    $_ =~ s/\b([^+ ]*?[$ar_chars][^+ ]*?)t\b/$1_+t/g;    # Arabic fem: +at

##### Adjective Section #####

    $_ =~ s/\b([^+ ]+?)trin\b/$1_+trin/g;  # Adjectival Superlative suffix
    $_ =~ s/\b([^+ ]+?)tr\b/$1_+tr/g;      # Adjectival Comparative suffix
    $_ =~ s/\b([^+ ]+?)(?!A)gi\b/$1h_+i/g; # Adjectival suffix from stem ending in 'eh'
    $_ =~ s/\b([^+ ]+?)(i|I)i\b/$1_+i/g;   # '+i' suffix preceded by 'i' (various meanings)


##### End #####

### Increase recall, but lower precision
if ( $recall ) {
    $_ =~ s/\b([^+ ]{2,}?)(An)\b/$1_+$2/g; # Plural suffix '+An'
    $_ =~ s/\b([^+ ]+?)i\b/$1_+i/g;        # Indef. '+i' suffix
}

### Deletes everything but the root
if ( $show_only_root ) {
    $_ =~ s/\b[^ ]+\+_([^ ]+?)\b/$1/g;  # Removes prefixes
    $_ =~ s/\b([^ ]+?)_\+[^ ]+\b/$1/g;  # Removes suffixes
}

### Deletes word boundaries ' ' from morpheme links '_+'/'+_'
unless ( $show_links ) {
    $_ =~ s/_\+0/ /g;  # Removes epenthesized letters
    $_ =~ s/_\+-/ /g;  # Removes suffix links w/ ZWNJs
    $_ =~ s/_\+/ /g;   # Removes all suffix links
    $_ =~ s/-\+_/ /g;  # Removes prefix links w/ ZWNJs
    $_ =~ s/\+_/ /g;   # Removes all prefix links
}

### Tokenizes punctuation
if ( $tokenize ) {
    $_ =~ s/([ ,.;:!?(){}#1-9\/])/ $1 /g;  # Pads punctuation w/ spaces
    $_ =~ s/(\s){2,}/$1/g;                 # Removes multiple spaces
}

print "$_\n";

#} # ends else
} # ends while (<>)