* Add scottish filter by Adam Borowski. Closes: #436168

[filters.git] / scottish

diff --git a/scottish b/scottish
new file mode 100755 (executable)
index 0000000..aff89a0
--- /dev/null
+++ b/scottish
@@ -0,0 +1,51 @@
+#!/usr/bin/perl -w
+# Fake scottish (dwarven) accent filter, by Adam Borowski, inspired by the
+# character "Durkon" from Order of the Stick by Rich Burlew.  GPL, 2007.
+use strict;
+
+my @repl=qw(
+  ^yes$:aye            there:thar              eir$:ar
+  about:aboot          ^he$:'e                 them:'em
+  ^him:'im             out_of$:outta           of_course:'course
+  ^of$:o'              ^and$:an'               to$:ta
+  tog:tag              that:tha                the:tha
+  wouldn't:wouldn'ta   cannot:cannae           can't:cannae
+  don't:dinnae         're$:r                  for$:fer
+  ver$:'er             ber$:b'r                every$:ev'ry
+  en$:'n               ^if$:if'n               enl:'nl
+  eng:'ng              ing:in'                 ment:mn't
+  ^es:'s               ^ex:'s                  ^not$:na
+  ^no$:nay             n't_have:n'tve          ^is$:be
+  ^are$:be             have:haf                abl:'bl
+  ^you$:ye             ^your:yer               ^you':ye'
+  noth:nuth            ^this$:'tis             ^here:'ere
+  doesn't:don't                at_a$:atta              ith$:it'
+  ered$:'red           into$:inta              ^before:'fore
+  wit'_':wit_'         wit'_t:wit_t            wit'_w:wit_w
+  wit'_y:wit_y         get_a:git_a             ally$:'lly$
+  ^my:me               ^i_think$:methinks      nay_w:na_w
+  ^one$:'un            ^'un_a:one_a            at_ta$:atta
+  ot_ta$:otta          ^isn't$:ain't           ^so_th:s'th
+  ned$:n'd             ^because:'cause
+), my @r;
+
+sub firstu($) {
+       $_[0]=~s/^([^a-z]*)([a-z])/$1\u$2/;
+       return $_[0];
+}
+
+for(@repl) {
+       s/_/ /g;
+       my ($l,$r)=split(/:/,$_);
+       for([$l,$r], [firstu $l, firstu $r], ["\U$l","\U$r"]) {
+               ($l,$r)=@$_;
+               $l=~s/^\^/\\b/;
+               $l=~s/\$$/\\b/;
+               push @r, [qr/$l/, $r];
+       }
+}
+
+while(my $txt=<>) {
+       $txt=~s/$$_[0]/$$_[1]/g for @r;
+       print $txt;
+}