#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
BEGIN { $| = 1; }

use DB_File;
use DBM_Filter;
use Encode;

use Lingua::Identify;

my $lexDir;
my $etcDir;
my ($binDir, $sep) = $0 =~ /^(.*)(\\|\/).*/;
$ENV{DANGRAM_BIN} = "$binDir";
$ENV{DANGRAM_ETC} = $etcDir = "$binDir/../etc";
$ENV{DANGRAM_LEX} = $lexDir = "$binDir/../lex";

my $Tfreq = tie my %freq, "DB_File", "$lexDir/da_stat_basepos.db", O_RDONLY;
$Tfreq->Filter_Push('utf8');
my $Tfullform = tie my %fullform, "DB_File", "$lexDir/fuldformer_freq.db", O_RDONLY;
$Tfullform->Filter_Push('utf8');
my $Tlex =     tie my %lex, "DB_File", "$lexDir/dan.lex3.db", O_RDONLY;
$Tlex->Filter_Push('utf8');

use Getopt::Long;
my $raw = 0;
my $mark = 0;
my $fuse = 0;
my $rop = GetOptions(
   "raw|r" => \$raw,
   "mark|m" => \$mark,
   "fuse|f" => \$fuse
   );
if ($mark || $fuse) {$raw =1;} # raw=1 means that non-Danish will be marked or fused, but kept, raw=0 means that it will be filtered away
#print "--raw=$raw\n";

my $Tenfreq;
my %enfreq;
if (-s "$lexDir/en_stat_basepos.db") {
	$Tenfreq = tie %enfreq, "DB_File", "$lexDir/en_stat_basepos.db", O_RDONLY;
}
elsif (-s "$lexDir/../../eng/lex/en_stat_basepos.db") {
	$Tenfreq = tie %enfreq, "DB_File", "$lexDir/../../eng/lex/en_stat_basepos.db", O_RDONLY;
}
elsif (-s "/usr/local/visl/lex/en_stat_basepos.db") {
	$Tenfreq = tie %enfreq, "DB_File", "/usr/local/visl/lex/en_stat_basepos.db", O_RDONLY;
}
else {
	die("$0 error: cannot find en_stat_basepos.db!\n");
}
$Tenfreq->Filter_Push('utf8');

my $f_eng_vs_dan = int(100 * $enfreq{"and"}/$freq{"og"})/100 ;
#print "--english/danish frequency normalization: $f_eng_vs_dan\n";
my $f_stavfuld_vs_statfuld = int(100 * $fullform{"og"}/$freq{"og"})/100 ;
#print "--stavfuld/statfuld frequency normalization: $f_stavfuld_vs_statfuld\n";

my $text = '';
my $endtag = '';
my $starttag = '';
my $eng = 0;
my $dan = 0;
my $nor = 0;
my $sve = 0;
my $text_orig = '';
my $text_orig_danlang = '';
my $hits = 0;
my $nondan = 0;

while (<>) {
  if (/^<STREAMCMD:FLUSH>/) {
    if ($endtag) {print $endtag . "\n";}
    if ($text) {&check;}
    $text = $endtag = $starttag = '';
#    print "--text=$text\n";
    print;
  }
  elsif (/^<\// && ! /<(\/STYLE|NONTEXT)/) {
    $endtag =$_;
#    print "--found endtag=$endtag text=$text ...\n";
    if ($text) {&check;}
  }
  elsif (/^</ && ! /<(\/?STYLE|NONTEXT)/) {
#    print "--found starttag=$_ text=$text ...\n";
    if ($endtag) {print $endtag . "\n";}
    $starttag =$_;
    print "$starttag";
    if ($text) {
      &check;
    }
    $endtag = "";
  }
  elsif ($starttag && /./) {
    if (/^ *\".*\" *$/ || /^ *\'.*\' *$/) {&check;}
    $text .= $_;
#        print "--checking  text=$text\n";
    if ($raw) {
      $_ = $text; $text =""; &splitlines; # (alternative to just &check, which would treat <s> ... </s> chunks differently from running lines)
    }
    else {
      &check;
    }
  }
  elsif (/./) { # If there are no containing tags, print the raw line. -Tino ... remodelled, Eckhard, to chunk all lines together in one <>...</> block, rather than always printing everything after the first (potentially short) Danish line in the chunk was found
    &splitlines;
  }
  else {
#    print "--remaining: $_>>>\n";
#    if ($starttag) {print $starttag; $starttag = "";}
    if (! $endtag) {
      print;
    }
  } # without this print, empty newlines get lost, and sentence separation gets more difficult ... however, it should not print the nl from in between </s> and the following <a> into an unclosed text block (i.e. when still waiting for $endtag to be printed
}

  sub splitlines {
    if ($starttag) {
#      print $starttag; $starttag=""; # now startag is printed when set
    }
#    print "--$_\n";
    s/: /:¤ /g;
    s/ - /¤ - ¤/g; # rather than -¤ ... the '-' at line start prevents @upper tagging in dancg.spelling
    s/(["«][\pL ]{30,}["»])(,? [\pL\(\-])/$1¤$2/g;
    s/( \pL+[\.\?\!]["»])(,? [\pL\(\-])/$1¤$2/g;
    s/( \pL+[\.\?\!])(,? [\(\-])/$1¤$2/g;
    my @lines = split /¤/;
    foreach (@lines) {
      if ($raw && (/\pL\)? +\pL{5,} \(?+\pL/ || / (\pL\p{Ll}+)/ && $enfreq{"\l$1"}) || ! /[æøå]/ || $eng && (! $dan || $eng > $dan)) { # 'managing owner', "Dancer in the Dark", 'Scandinavian Star' ... could just use $nondan
#	print "--$1, dan=$dan, eng=$eng, raw1=$_\n";
	$text = $_;
	&check;
      }
      else {
#      print "--raw=$raw, raw2= dan=$dan, eng=$eng, $_***\n";
	print;
      }
    }
    if ($endtag) {print $endtag . "\n";}
    $endtag =""; $starttag ="";
}


####################
if ($text) {
    &check;
}

#####################

sub check {
  $text_orig = $text;
  $text =~ s/<\/?(STYLE|NONTEXT).*?>//g;
  $text =~ s/\n//;
  if ($text =~ /^((\p{Lu}\pL*)(\pL))/) {
    if (! $lex{$1} && ! $lex{"\u\L$2\l$3"} && ($3 ne "s" || ! $lex{$2})) { # cave: Anders Rye Skjold Jensen
      $text =~ s/^(.)/\l$1/;
    }
  }
#  print "--$text_orig, $text\n";
  $eng = $dan = $nor = $sve = 0;
  if ($text =~ /[a-zæøå]/) {&danlang;  $text = $text_orig_danlang;}
#  print "***danlang: dan=$dan eng=$eng sve=$sve nor=$nor *** $text\n";
  #	if ($dan >= $eng) {
  my $n_words = 1;
  if (($eng >= $dan || $text =~ / .*? .*? .*? / || / \p{Ll}/) && $text !~ /^Restaurant \p{Lu}\pL+$/ && $sve * 10 <= $dan && $nor *10 <= $dan && ! /[äö]/) {
    $dan = $dan/4; $eng=$eng/4; # weaken the absolute weights, so the relative, word-counting weight will matter more
    ### fine-grained word counting
    my @words = split /[ ,;:\?\!\(\)\[\]\t¶\'\"-]+/, $text; # not . / \ or @ as splitters (email etc.), not " and . - quotes and abbreviations are to stay separate from words so as to make them "non-counting"
    $n_words = @words;
    foreach (@words) {
#      print "--word=$_¤¤¤ fullform: $fullform{\"\l$_\"}, enfreq:$enfreq{\"\l$_\"}\n";
      if (/^(comeback|feeds?|interview|point|time|.*[0-9].*)$/) {
      }
      elsif (/^[a-zæøåéA-ZÆØÅ]+$/ && $fullform{"\l$_"} && (! $enfreq{"\l$_"} || $freq{"\l$_"} && $enfreq{"\l$_"} < $freq{"\l$_"} * 0.2 * $f_eng_vs_dan || $enfreq{"\l$_"} < $fullform{"\l$_"} * 0.2 * $f_eng_vs_dan / $f_stavfuld_vs_statfuld || /^(for)$/)) {
	$dan += 20;
#	print "-----found $_ in danlex, dan=$dan, eng=$eng\n";
      }
      elsif (/^[a-zA-Z]+$/ && ! /^(folk|her|man|to)$/ && $enfreq{"\l$_"} && (! $freq{"\l$_"} || $freq{"\l$_"} < $enfreq{"\l$_"} * 0.2 / $f_eng_vs_dan) && (! $fullform{"\l$_"} || $fullform{"\l$_"} < $enfreq{"\l$_"} * 0.2 / $f_eng_vs_dan * $f_stavfuld_vs_statfuld)) { # English words may appear in Danish list
	$eng += 20;
#	print "-----found $_ in englex da=" . $freq{"\l$_"} . " en=" . $enfreq{"\l$_"} . "\n";
      }
      elsif ($text_orig =~ /^\u\Q$_\E \p{Lu}/) {} # bail out if lc 1. word was uc originally
      elsif (/^\p{Ll}{2,7}$/ && /[aeiouáéíóúâêîôûàèìòù]/ && ! /^(.)\1+$/ && ! $fullform{"\l$_"} && $n_words >=4) { # Youtube: Munazra kr mere bhai fir agar jeet jaye to marzi pdhe jo kriyo
	$eng +=40; # small words weighted heavily, because they should have been in the Danish list
#	print "----$_: eng increased by 40: $eng, $n_words\n";
      }
      elsif (/^\p{Ll}+$/ && $n_words >=4) { # Youtube: Munazra kr mere bhai fir agar jeet jaye to marzi pdhe jo kriyo
	$eng +=15;
#	print "--$_ eng=$eng, n_words=$n_words\n";
      }
      if ($freq{"\l$_" . "_V_PR_AKT"} || $freq{"\l$_" . "_V_IMPF_AKT"} || $freq{"\l$_" . "_V_PR_PAS"}) {
	$dan += 20; # extra points for finite verbs, because heuristics/loanwords tend to produce nouns, and Danish verbs can provide a Danish skeleton between English noun loan-words, while not being so short as to be confused with English function words : Make-up forvirrer
      }
#      print "--dan=$dan, eng=$eng\n";
#      print "--" . $freq{"forvirrer_V_PR_AKT"} . "\n";
    }
  }
#  print "***check: dan=$dan eng=$eng sve=$sve nor=$nor ***\n";
#  print "***check: dan=$dan eng=$eng sve=$sve nor=$nor *** $text\n";
#  print "--dan=$dan, eng=$eng, sve=$sve, nor=$nor\n";
  $text = $text_orig;
  if ($nor >= 2 && $sve/$n_words > 1/6) {$eng = $dan + $nor;} # if 2 or more Norwegian words
  if ($sve >= 2 && $sve/$n_words > 1/6) {$eng = $dan + $sve;} # if 2 or more Norwegian words
  if ($text =~ /^([^ ]+-|\p{Lu}+ [0-9]+-)?([^ ]+?)$/ && $lex{$2} && $lex{$2} !~ /X$/) {$eng =0; $dan++;}
  if ($dan >= $eng && $dan >= 0 || $text =~ /STYLE:/) { # also print non-text lines with neither dan nor eng
#    if ($starttag) {print $starttag; $starttag="";}
    print "$text";
#    if ($endtag) {print $endtag;}
  }
#  if ($text =~ /^([^ ]+?)$/ && $lex{$1} && $lex{$1} !~ /X$/) {$eng =0;}
#  print "--dan=$dan, eng=$eng, $raw, --- $text*** \n";
  if ($raw && $dan < $eng) {
#    if ($starttag) {print $starttag; $starttag="";}
#    $text =~ s/\n?$/\n/; print "<foreign>\n$text\n<\/foreign>\n"; # vertical (keep this line)
    if ($mark && $text !~ /^['"«»].+['"«»]$/) { # if the entire line is quoted, it could be a film title, institution name or the like - in this case, don't mark, but fuse it (dvs. else condition below ...)
      $text =~ s/\n/¶/g;
      $text =~ s/\*xdot/./g;
      print "...\n<foreign>$text<\/foreign>\n"; # horizontal (keep this line) ... tripledot added to add a CG-visible marker for the removed material and prevent spelling rules seeing e.g. colon backwards across the hidden foreign text
    }
    else { # with the raw condition, "else" is equivalent to $fuse=1
      if (! /[0-9,\.] / && ! /\.$/ && ! /([\t\(\)]|\.\.\.)/ || /^ *\".*\" *$/ || /^ *\'.*\' *$/ || /^ *[«»].*[«»] *$/) {
	$text =~ s/ /=/g;
	$text =~ s/=#/ #/g;
	$text =~ s/^=/ /; # otherwise space after ':' becomes leading '='
	if (! /(www|http|\/[^ ]*\/)/) {
	  $text =~ s/([^=])\/([^=])/$1 \/ $2/g;
	}
	$text =~ s/=([\(])/ $1/g; # box=(boks)=catamaran
	$text =~ s/([\)])=/$1 /g;
	$text =~ s/=([^\pL]+)$/ $1/g;
	print "$text"; # fuse
      }
      else {
	print "$text"; # unaltered, possibly foreign text
      }
    }
#    if ($endtag) {print $endtag;}
  }
  $text ="";
#  $endtag =""; $starttag ="";
}


sub danlang {
  $text_orig_danlang = $text;
    $text =~ s/^(.)/ \l$1/; # initial space and lowercasing
    $text =~ s/$/ /; # final space
    $text =~ s/ /  /g;
    if ($hits = () = $text =~ m/[ \-=]([A-ZÄÖÜa-zäöü]*(\p{L}\p{L}[^hsS]ed |ck|[Ss]ch|sz|[Tt]h[aeiouyäöü]|[Ww][aeiouyäöü]|[aeiouyäöü][Ww]|[Xx][aeiouyäöü]|[aeiouyäöü][Xx]|[Qq]u)|\p{Ll}+(oe|øy))/g) {
#	$hits = (grep -c '[ \-=][a-z]*([^sS]ed |th|w|[^cghjsuCGHJSU]x|y|q)', $text);
#      print "--English: $hits *10\n"; # --- $text ***\n";
	$eng =$eng + 10 * $hits; # English
    }
    if ($hits = () = $text =~ m/[ \(\t](agama|\pL*allahu|allha|bakalan|befar|beri|bohot|byan|cakep|dea|hanallah|humein|joss|kb\pL+|kiya|khub|kom|koru|maaf|math|merdu|nouman|nyc|osam|pagal|pak|patel|pohela|pukimak|supoh|zara)[^a-z]/g) {
      $eng =$eng + 10 * $hits; # arabisk etc.
#      print "--Arabic etc.: $hits *10\n";
    }
    if ($text =~ /[ \(\-=][a-z]*([äöüÄÖÜ]|ch[^aeiou]|cje |ck|sch|sz|tsk|tz |y )/) {
      $eng =$eng + 11; # German, Polish ... [a-z]ig fjernet
    }
    if ($text =~ /[ \(\-=][a-z]*([áâàãêèíîìïóôòõúûùýðþœ]|oi)/) {$eng =$eng + 12;} # Romance and other
    if ($text =~ /[ \(](a|am|and|are|better|by|can have|from|has|have|I have|I'M|I'm|in|is|news|on|or|pm|[pP]raise|the|that|this|these|to|was|with|word|you|Monday|Tuesday|Wednesday|Thursday|Friday|Saturday|Sunday)[^a-z]/) {
      $eng =$eng + 20;
    }
    if ($text =~ /[ \(](che|[Ll][ao]s|que)[^a-z]/) {$eng =$eng + 20;} # Romance, 'y' already in letter list
    if ($text =~ /[ \(](auf|bist|das|die|[kms]?eine?r?|es|haben|hat|ist|Mann|nicht|oder|[Ss]ie|sind|und|Uhr|war|zu[mr])[^a-z]/) {$eng =$eng + 20;} # German and Danish
    if ($hits = () = $text =~ m/[ \(](av|bekrefter?|bekreftelse|bruker?|båe|bildene|deg|dessuten|ditt|drept|dyna|enn|etter|farget|hadde|gjen\p{Ll}|gutt|heisan|hverandre|igjen|jevnlig|jælla|kring|kvifor|kvinne|lenge|lite[nt]|litt|mann|mannen|meg|menn|mitt|mye|natta|noe|oss|prater?|seg|setter?|sier|sitt|sittet|tok|trenger?|vet|vite)[^a-z]/g) {
      $eng =$eng + 20 * $hits; # Norwegian
      $nor = $nor + $hits;
#      print "--Norwegian ($1), eng=$eng, hits=$hits\n";
    }
    if ($hits = () = $text =~ m/[ \(](alla|anna[nt]|annenstans|[a-zäöå]+arnas?|att|av|avbrytar?|behöv.*?|bli|blir|blivit|bra|bästa?|deras|dessa|där.*?|då|egna|finns|i?från|följa|för.*?|ge|genom|gick|gör|grattis|gång|gånger|heter|hur|här|höj|höra.*?|inom|inga|inte|jag|jätte.*?|jävla|jobbar?|kanske|köp.*?|lika|liknande|låt|mej|mot|munn.*?|måste|när.*?|någo[tn]|nå[nt]|också|och|oss|oxå|prick|rätt.*?|sanningen|sina|själv.*?|sjung.*?|skrikar?|snygg[at]?|snälla|sägar?|säja|sätt.*?|tar|till|tillsammans|tilløta?r?|tänk|träf.*?|trött|[tT]vå|ut|vad|vanlig[at]?|vara|varför|varit|vart|verkligen|vet|väl.*?|våld.*?|vår.*?|älskar?|än|ända|ännu|är|även|över.*?|åka|åkt|åter.*?)[^a-z]/g) {
      $eng =$eng + 20 * $hits; # Swedish
      $sve = $sve + $hits;
#      print "--Swedish ($1), eng=$eng, hits=$hits\n";
    }
    if ($text_orig =~ /([Aa]uthor|Copyright|Date|[Ll]anguage|[Mm]essage|[Nn]ews|Re|[Rr]eferences|[Ss]earch|[Ss]ubject|Source|[Tt]itle):/) {
      $eng =$eng + 250; # html-speak, NOT: [Pp]age, [Mm]ail, they do appear in E-texts !
#      print "--eng=$eng\n";
    }

    if ($text =~ /^ (E-Mail|e-mail|http|[<>\/\|]|\[ )/) {$eng =$eng + 20;} # snask

    if ($text =~ /[^\w](og|til|det|af|på|der|med|den|har|som|ikke|et|om|var|fra|Det|så|sig|han|jeg|vi|skal|vil|men|ved|også|være|år|blev|hvor|eller|havde|Men|siger|ud|efter|meget|op|kunne|hun|da|nu|sin|Og|selv|Den|få|bliver|mere|De|Jeg|have|noget|når|mange|alle|deres|været|Han|andre|mod|hvis|godt|går|dem|kun|mig|ind|nye|Der|skulle|danske|må|dag|store|hvad|blive|får|helt|flere|ville|Danmark)[^\w]/ && ! /[äöüÄÖÜ]/) { # de, en, er, kan removed -- too likely to appear in other languages
      $dan =$dan + 100; # Danish
      #      print "--dan=$dan\n";
    }
#    if ($text =~ /[^\w](og|er|en|til|det|af|på|der|med|de|den|har|som|ikke|et|om|var|kan|fra|Det|så|sig|han|jeg|vi|skal|vil|men|ved|også|være|år|blev|hvor|eller|havde|Men|siger|ud|efter|meget|op|kunne|hun|da|nu|sin|Og|selv|Den|få|bliver|mere|De|Jeg|have|noget|når|mange|alle|deres|været|Han|andre|mod|hvis|godt|går|dem|kun|mig|ind|nye|Der|skulle|danske|må|dag|store|hvad|blive|får|helt|flere|ville|Danmark)[^\w]/ && ! /[äöüÄÖÜ]/) {
#      $dan =$dan + 100; # Danish
#    }
    if ($text =~ /([^\w][a-z]*[æøå])/) {$dan =$dan + 50;} # in-word dan-sounds, but not e.g. Danish uppercase town nouns

    if ($text =~ /[ \(\-=][a-zæøå]*(isere)(t|ede)? /) {$dan =$dan + 10;} # E-affixes
    $text =~ s/^ //; # initial space
    $text =~ s/ $//; # final space

    if ($dan ==0 && $text =~ /(http|www|\@)/) {$eng =$eng + 20;} # internet addresses without E-text

    if ($eng > $dan) {$nondan =1;} # remember nondan for next line
    elsif ($dan > $eng) {$nondan =0;} # cancel nondan text streak
    elsif ($nondan) {$eng =5;}
#    print "--- dan $dan, eng $eng --- $text";

    if ($eng < $dan && $eng >=20) {
#    print "--- dan $dan, eng $eng --- $text";
    }
}
if ($endtag) {print $endtag;}
