#!/usr/bin/perl
# weave.pl -- Implementation of Corel Paint's Weaving Language.
use strict;
use warnings;
use diagnostics;
use Text::DelimMatch;

my $operand_pattern  = qr/[0-9{}]/;
my %precedence_table = (
    DOWNTO     => 6,
    UPTO       => 6,
    CONCAT     => 6,
    DASH       => 6,
    UPDOWN     => 5,
    DOWNUP     => 5,
    TEMPLATE   => 4,
    REPEAT     => 4,
    EXTEND     => 4,
    INTERLEAVE => 4,
    PERMUTE    => 3,
    PBOX       => 3,
    PALINDROME => 2,
    BLOCK      => 1,
    REVERSE    => 1,
    ROTATE     => 1,
    TICKMARK   => 1,
    DEROTATE   => 1,
    START      => 0,
    END        => 0
);
my %parse = (
    CONCAT   => [ qr/\s*(\d+)\s+CONCAT\s+(\d+)\s*/, '$1 . $2' ],
    DASH     => [ qr/(\d)\s*DASH(\'*)\s*(\d)/,      'range($1,$3,$2)' 
+],
    UPTO     => [ qr/(\d)\s*UPTO(\'*)\s*(\d)/,      'upto($1,$3,$2)' ]
+,
    DOWNTO   => [ qr/(\d)\s*DOWNTO(\'*)\s*(\d)/,    'downto($1,$3,$2)'
+ ],
    BLOCK    => [ qr/(\d+)\s*BLOCK\s*([0-9{}]+)/,   'block($1,$2)' ],
    REPEAT   => [ qr/(\d+)\s*REPEAT\s*(\d)/,        '$1 x $2' ],
    DEROTATE => [ qr/(\d+)\s*DEROTATE\s*(\d+)/,     'rotate($1,-$2)' ]
+,
    ROTATE   => [ qr/(\d+)\s*ROTATE\s*(-*\d+)/,     'rotate($1,$2)' ],
    REVERSE  => [ qr/(\d+)\s*REVERSE/,              'reverse($1)' ],
    EXTEND   => [ qr/(\d+)\s*EXTEND\s*(\d+)/,       'extend($1,$2)' ],
    PALINDROME => [ qr/(\d+)\s*PALINDROME/,         'palindrome($1)' ]
+,
    INTERLEAVE => [ qr/(\d+)\s*INTERLEAVE\s*(\d+)/, 'interleave($1,$2)
+' ],
    PERMUTE    => [ qr/(\d+)\s*PERMUTE\s*(\d+)/,    'permute($1,$2)' ]
+,
    UPDOWN   => [ qr/(\d+)\s*UPDOWN(\'*)\s*(\d+)/, 'updown($1,$3,$2)' 
+],
    DOWNUP   => [ qr/(\d+)\s*DOWNUP(\'*)\s*(\d+)/, 'downup($1,$3,$2)' 
+],
    TEMPLATE => [ qr/(\d+)\s*TEMPLATE\s*(\d+)/,    'template($1,$2)' ]
+,
    PBOX     => [ qr/(\d+)\s*PBOX\s*(\d+)/,        'pbox($1,$2)' ],
);
my @lex = (
    [ qr/->/,           sub { ' EXTEND '; } ],
    [ qr/\*/,           sub { ' REPEAT '; } ],
    [ qr/,/,            sub { ' CONCAT '; } ],
    [ qr/\s*-(\'*)\s*/, sub { ' DASH' . $1 . ' '; } ],
    [ qr/`/,            sub { ' REVERSE '; } ],
    [ qr/\s*\#-\s*/,    sub { ' DEROTATE '; } ],
    [ qr/<>(\'*)/,      sub { ' UPDOWN' . $1 . ' '; } ],
    [ qr/updown(\'*)/,  sub { 'UPDOWN' . $1; } ],
    [ qr/><(\'*)/,      sub { ' DOWNUP' . $1 . ' '; } ],
    [ qr/downup(\'*)/,  sub { 'DOWNUP' . $1; } ],
    [ qr/\|/,           sub { ' PALINDROME '; } ],
    [ qr/pal/,          sub { 'PALINDROME'; } ],
    [ qr/palindrome/,   sub { 'PALINDROME'; } ],
    [ qr/perm/,         sub { 'PERMUTE'; } ],
    [ qr/permute/,      sub { 'PERMUTE'; } ],
    [ qr/\#/,           sub { ' ROTATE '; } ],
    [ qr/rotate/,       sub { 'ROTATE'; } ],
    [ qr/pbox/,         sub { 'PBOX'; } ],
    [ qr/:/,            sub { ' TEMPLATE '; } ],
    [ qr/temp/,         sub { 'TEMPLATE'; } ],
    [ qr/template/,     sub { 'TEMPLATE'; } ],
    [ qr/\[\]/,         sub { ' BLOCK '; } ],
    [ qr/block/,        sub { 'BLOCK'; } ],
    [ qr/rep/,          sub { 'REPEAT'; } ],
    [ qr/repeat/,       sub { 'REPEATE'; } ],
    [ qr/~/,            sub { ' INTERLEAVE '; } ],
    [ qr/int/,          sub { 'INTERLEAVE'; } ],
    [ qr/interleave/,   sub { 'INTERLEAVE'; } ],
    [ qr/ext/,          sub { 'EXTEND'; } ],
    [ qr/extend/,       sub { 'EXTEND'; } ],
    [ qr/concat/,       sub { 'CONCAT'; } ],
    [ qr/upto(\'*)/,    sub { 'UPTO' . $1; } ],
    [ qr/downto(\'*)/,  sub { 'DOWNTO' . $1; } ],
    [ qr/rev/,          sub { 'REVERSE'; } ],
    [ qr/reverse/,      sub { 'REVERSE'; } ],
    [ qr/<(\'*)/,       sub { ' UPTO' . $1 . ' '; } ],
    [ qr/>(\'*)/,       sub { ' DOWNTO' . $1 . ' '; } ],
);

while (<DATA>) {
    chomp;
    print $_, "\n";
    $_ = list2expression( parenthesize( expression2list( lex( $_ ) ) )
+ );
    while (/\(/) {
        my $inner      = innermost($_);
        my $safe_inner = quotemeta($inner);
        s/\($safe_inner\)/parse($inner)/e;
    }
    print $_, "\n";
}

sub lex {
    local $_ = shift;
    for my $ref (@lex) {
        s/$ref->[0]/&{$ref->[1]}/eg;
    }
    "($_)";
}

sub expression2list {
    my @s                = split ( //, shift );
    my $n                = 0;
    my $i                = 0;
    my $op               = '';
    my @expression_list;
    my $operand = '';
    my $addop   = sub {

        if ( $op ne '' ) {
            push ( @expression_list, { OP => $op } );
            $op = '';
        }
    };
    my $addoperand = sub {
        if ( $operand ne '' ) {
            push ( @expression_list, { OPERAND => $operand } );
            $operand = '';
        }
    };
    push ( @expression_list, { OP => 'START' } );
    for (@s) {
        if (/$operand_pattern/) {
            $operand .= $_;
            &$addop();
        }
        elsif (/\(/) {
            &$addop();
            &$addoperand();
            push ( @expression_list, { LITERAL => '(' } );
        }
        elsif (/\)/) {
            &$addop();
            &$addoperand();
            push ( @expression_list, { LITERAL => ')' } );
        }
        elsif (/ /) {
            &$addop();
            &$addoperand();
        }
        else {
            $op .= $_;
            &$addoperand();
        }
    }
    push ( @expression_list, { OP => 'END' } );
    $i = $n = 0;
    for (@expression_list) {
        for my $key ( keys %$_ ) {
            my $value = $$_{$key};
            if ( $key eq 'OP' ) {
                $value =~ s/\'//g;
                if ( exists( $precedence_table{$value} ) ) {
                    $expression_list[$i] = [
                        { $key => $$_{$key} },
                        ( $n + $precedence_table{$value} )
                    ];
                }
            }
            elsif ( $key eq 'LITERAL' ) {
                $n += ( $value eq '(' ? 10 : -10 );
            }
            $i++;
        }
    }
    @expression_list;
}

sub parenthesize {
    my @exp      = @_;
    my $n        = 0;
    my @nodelist = getnodelist(@exp);
    while ( @nodelist > 2 ) {
        my ( $node0, $node1 );
        while ( ( $n + 1 ) < @nodelist ) {
            $node0 = $nodelist[$n];
            $node1 = $nodelist[ $n + 1 ];
            last if $exp[$node0][1] >= $exp[$node1][1];
            $n++;
        }
        splice @exp, $node1, 1, { LITERAL => ')' }, $exp[$node1];
        while ($n) {
            $node0 = $nodelist[ $n - 1 ];
            $node1 = $nodelist[$n];
            last if $exp[$node0][1] <= $exp[$node1][1];
            $n--;
        }
        splice @exp, $node0, 1, $exp[$node0], { LITERAL => '(' };
        splice @exp, $node1 + 1, 1, $exp[ $node1 + 1 ][0];
        @nodelist = getnodelist(@exp);
        $n--;
    }
    @exp;
}

sub getnodelist {
    my @exp = @_;
    my @nodelist;
    my $i = 0;
    for (@exp) {
        if ( ref($_) eq 'ARRAY' ) {
            push ( @nodelist, $i );
        }
        $i++;
    }
    @nodelist;
}

sub list2expression {
    my @exp = @_;
    my $expression;
    for (@exp) {
        next if ( ref($_) eq 'ARRAY' );
        for my $key ( keys %$_ ) {
            my $value = $_->{$key};
            if ( $key eq 'OP' ) {
                $expression .= " $value ";
            }
            else {
                $expression .= $value;
            }
        }
    }
    substr( $expression, 1, -1 );
}

sub innermost {
    my $mp = new Text::DelimMatch( "\\(", "\\)" );
    my ( $p, $m, $r, $result );
    $r = shift;
    while ($r) {
        ( $p, $m, $r ) = $mp->match($r);
        $r = $mp->strip_delim($m);
        $result = $r if $r;
    }
    $result;
}

sub parse {
    local $_ = shift;
    while ( my ( $key, $ref ) = each(%parse) ) {
        s/$ref->[0]/$ref->[1]/ee if /$key/;
    }
    $_;
}

#
# Operator routines
#

sub block {
    my ( @p1, @p2 );
    my $result = '';
    samelength( \@p1, \@p2, shift, shift );
    $result .= $p1[$_] x $p2[$_] for ( 0 .. $#p2 );
    $result;
}

sub pbox {
    my ( $p1, $p2 ) = @_;
    if ( length($p2) != length($p1) ) {
        if ( length($p2) < length($p1) ) {
            my $copy = $p2;
            $p2 .= $copy while ( length($p2) < length($p1) );
        }
        $p2 = substr( $p2, 0, length($p1) );
    }
    permute( $p2, $p1 );
}

sub downto {
    my ( $m, $n, $tickmark ) = @_;
    my $result = '';
    if ( $m < $n ) {
        while ($m) {
            $result .= "$m";
            $m--;
        }
        $m = 8;
    }
    if ($tickmark) {
        my $t = ( length($tickmark) - 1 );
        while ($m) {
            $result .= "$m";
            $m--;
        }
        while ($t) {
            $result .= '87654321';
            $t--;
        }
        $m = 8;
    }
    while ( $m > $n ) {
        $result .= "$m";
        $m--;
    }
    "$result$n";
}

sub upto {
    my ( $m, $n, $tickmark ) = @_;
    my $result = '';
    if ( $m > $n ) {
        $result .= $_ for ( $m .. 8 );
        $m = 1;
    }
    if ($tickmark) {
        my $t = ( length($tickmark) - 1 );
        $result .= $_ for ( $m .. 8 );
        while ($t) {
            $result .= '12345678';
            $t--;
        }
        $m = 1;
    }
    while ( $m < $n ) {
        $result .= "$m";
        $m++;
    }
    "$result$n";
}

sub template {
    my $result = '';
    my @p1     = split ( //, shift );
    my @p2     = tpat(shift);
    for (@p1) {
        for my $offset (@p2) {
            $result .= ( ( ( $_ + $offset - 1 ) ) % 8 ) + 1;
        }
    }
    $result;
}

sub tpat {
    my @p = split ( //, shift );
    map { $_ - $p[0] } @p;
}

sub updown {
    my ( @p1, @p2 );
    my $result = '';
    samelength( \@p1, \@p2, shift, shift );
    my $tickmark = shift;
    for ( 0 .. $#p1 ) {
        substr( $result, -1 ) = upto( $p1[$_], $p2[$_], $tickmark );
        last if $_ == $#p1;
        substr( $result, -1 ) = downto( $p2[$_], $p1[ $_ + 1 ], $tickm
+ark );
    }
    $result;
}

sub downup {
    my ( @p1, @p2 );
    my $result = '';
    samelength( \@p1, \@p2, shift, shift );
    my $tickmark = shift;
    for ( 0 .. $#p1 ) {
        substr( $result, -1 ) = downto( $p1[$_], $p2[$_], $tickmark );
        last if $_ == $#p1;
        substr( $result, -1 ) = upto( $p2[$_], $p1[ $_ + 1 ], $tickmar
+k );
    }
    $result;
}

sub permute {
    my ( $p1, $p2 ) = @_;
    my $result = '';
    my $offset = 0;
    if ( length($p1) != length($p2) ) {
        my $copy = $p1;
        $p1 .= $copy while ( length($p1) % length($p2) );
    }
    while ( length($result) != length($p1) ) {
        $result .=
          substr( $p1, ( substr( $p2, $_, 1 ) - 1 ) + $offset, 1 )
          for ( 0 .. length($p2) - 1 );
        $offset += length($p2);
    }
    $result;
}

sub interleave {
    my ( @p1, @p2 );
    my $result = '';
    samelength( \@p1, \@p2, shift, shift );
    $result .= $p1[$_] . $p2[$_] for ( 0 .. $#p1 );
    $result;
}

sub palindrome {
    my $pat = shift;
    "$pat" . substr( ( reverse $pat ), 1, length($pat) - 2 );
}

sub extend {
    my ( $pat, $n ) = @_;
    my $result = '';
    $result .= $pat while ( length($result) < $n );
    $result = substr( $result, 0, $n ) if ( length($result) > $n );
    $result;
}

sub rotate {
    my ( $pat, $n ) = @_;
    if ( $n > 0 ) {
        while ($n) {
            $pat = substr( $pat, 1 ) . substr( $pat, 0, 1 );
            $n--;
        }
    }
    else {
        while ( $n < 0 ) {
            $pat =
              ( substr( $pat, -1, 1 ) . substr( $pat, 0, length($pat) 
+- 1 ) );
            $n++;
        }
    }
    $pat;
}

sub range {
    my ( $m, $n, $template ) = @_;
    if ( $m < $n ) {
        upto( $m, $n, $template );
    }
    else {
        downto( $m, $n, $template );
    }
}

sub samelength {
    my ( $r1, $r2 ) = ( shift, shift );
    @$r1 = split ( //, shift );
    @$r2 = grep { $_ } split ( /{(\d+)}|(\d)/, shift );
    if ( @$r1 < @$r2 ) {
        push ( @$r1, @$r1 ) while ( @$r1 < @$r2 );
        @$r1 = @$r1[ 0 .. $#{@$r2} ];
    }
    elsif ( @$r2 < @$r1 ) {
        push ( @$r2, @$r2 ) while ( @$r2 < @$r1 );
        @$r2 = @$r2[ 0 .. $#{@$r1} ];
    }
}


=head2 Operators

 BLOCK <pattern> block <count> : []
 REPEAT <pattern> repeat <count> : rep,*
 EXTEND <pattern> extend <count> : ext,->
 CONCAT <pattern> concat <pattern> : ,
 INTERLEAVE <pattern> interleave <pattern> : int,~
 UPTO <pattern> upto <pattern> : <,-
 DOWNTO <pattern> downto <pattern> : >,-
 TEMPLATE <pattern> template <pattern> : temp,:
 PALINDROME <pattern> palindrome : pal,|
 PERMUTE <pattern> permute <permutation> : perm
 PBOX <pattern> pbox <permutation>
 UPDOWN <pattern> updown <pattern> : <>
 DOWNUP <pattern> downup <pattern> : ><
 ROTATE <pattern> rotate <number> : #
 REVERSE <pattern> reverse : `

=head2 Other symbols

 () grouping
 {} number grouping
 ' tick mark operator

=head2 Precedence

 upto, downto, concat
 downup, updown
 repeat, extend, template interleave
 permute, pbox
 palindrome
 block, rotate reverse [No precedence assigned in orignal doc]

=head2 Bibliography

 1. The Painter Weaving Language, Ralph Griswold.
    http://www.cs.arizona.edu/patterns/weaving/webdocs/gre_pwl.pdf

 2. Advanced Weaving, Corel Inc.
    http://newgraphics.corel.com/products/weaving.pdf

=cut

__DATA__
(1 upto 5),4-1
(12345,4321)[](1-4-1)
123[]1{12}3
(1-4-1)*5
(((1-5),)4-1)
1-4-1*5
(1<4>1)*5
1<4>1
16243 # 2
16243#-2
12365238`
(16243#2),432
1346->16
1346->15
1234567812345678->10
1346|
1234~5678
1346<3
(12365238`)-4
1346 perm 4123
13465 perm 4123
1234<>5678
5678><1234
12345678:121
1-8:12121
12345:212
1<''5
13<''5812
13>''5812
5>''1
5-''1
1-''5
12<>'567
12><'567
4-18-5
1-'8
123456787654321 pbox 21436587
1-'8 pbox 4-18-5
1 UNKNOWN 8
[download]