Split full discipline powers for Hero Lab

#!/usr/bin/perl

use common::sense;
use IO::File;
use XML::Parser;
use XML::Writer;
use File::HomeDir;
use File::Spec;
use Data::Dumper;
use Clone qw(clone);
use Readonly;

#### Prototypes
sub order_to_rank;
sub build_word_maps;
sub tag_to_word;
sub tag_to_name;
sub remember_element;
my %thing_read;
my %thing_write;
sub StartThing;
sub StartNested;
sub StartPassthrough;
sub StartTag;
sub EndTag;
sub Char;
sub Text;
sub ConvertFDPower;
sub WriteThing;
sub WriteElements;

#### Variables
Readonly my $default_directory => File::Spec->catdir( File::HomeDir->my_data, q{Hero Lab}, q{Data}, q{4e} );

my @element_path;

my $thing_element;
my $active_element;
my @active_element;

my %tag_name;
my %tag_abbrev;

my $active_text;
my $next_pad;

my $xml_writer;

my %attribute_order = (
    document => [ qw( signature ) ],
    thing => [ qw( id compset name description summary isunique holdable maxlimit panellink stacking lotsize replaces buytemplate xactspecial isprivate ) ],
    fieldval => [ qw( field value ) ],
    arrayval => [ qw( field index column value ) ],
    usesource => [ qw( source name parent ) ],
    tag => [ qw( group tag name abbrev ) ],
    bootstrap => [ qw( thing index ) ],
    containerreq => [ qw( phase priority name ) ],
    link => [ qw( linkage thing ) ],
    eval => [ qw( phase priority index runlimit iseach sortas name isprimary ) ],
    evalrule => [ qw( phase priority message summary index severity runlimit iseach reportlimit issilent sortas name isprimary ) ],
    pickreq => [ qw( thing iserror ispreclude onlyonce issilent ) ],
    exprreq => [ qw( message iserror onlyonce issilent ) ],
    prereq => [ qw( message iserror onlyonce issilent ) ],
    child => [ qw( entity ) ],
    minion => [ qw( id ownmode isinherit ) ],

    before => [ qw( name ) ],
    after => [ qw( name ) ],
    autotag => [ qw( group tag ) ],
    assignval => [ qw( field value behavior ) ],
);

my %attribute_rank;
order_to_rank( \%attribute_order, \%attribute_rank );

my %has_text = (
    containerreq => 1,
    holdlimit => 1,
    gear => 1,
    eval => 1,
    evalrule => 1,
    exprreq => 1,
    match => 1,
    test => 1,
    validate => 1,
);

my %element_order = (
    document => [ qw( procedure thing portal template layout panel form sheet dossier hidden editthing faq ) ],
    thing => [ qw( fieldval arrayval usesource tag bootstrap containerreq holdlimit gear link eval evalrule pickreq exprreq prereq child minion ) ],
    bootstrap => [ qw( match containerreq autotag assignval ) ],
    containerreq => [ qw( match before after ) ],
    eval => [ qw( match before after ) ],
    evalrule => [ qw( match before after ) ],
    prereq => [ qw( match test validate ) ],
    child => [ qw( tag bootstrap ) ],
    minion => [ qw( tag bootstrap ) ],
);

# We do not really need to worry about these elements:
# procedure portal template layout panel form sheet dossier hidden editthing faq

my %element_rank;
order_to_rank( \%element_order, \%element_rank );

my %full_discipline_tags = (
    PowerType => 1,
    ReqLevel => 1,
    PowerClass => 1,
    PowerDest => 1,
    PowerPath => 1,
    RecomClass => 1,
    ReqSkill => 1,
    User => {
        NeedChosen => 1,
        PwrAsClass => 1,
    },
# FeatureChk NeedChosen PwrAsClass
# AttrMental AttrPhys RangeDex
);

my %attack_technique_supress_tags = (
    PowerClass => 1,
    PowerDest => 1,
    PowerPath => 1,
    ReqSkill => 1,
    User => {
        NeedChosen => 1,
        PwrAsClass => 1
    },
);

my %type_keywords = map { $_ => 1 } qw( PowerType PowerSrc PowerAcc DamageType EffectType );
my %action_range = map { $_ => 1 } qw( ActionType AttackType );
my %prefer_words = (
    q{Move Action} => 1,
    q{Free Action} => 1,
    q{No Action} => 1,
    q{Standard Action} => 1,
    q{Minor Action} => 1,
    q{Teleport} => 1,
    q{At-Will} => 1,
    q{Daily} => 1,
    q{Encounter} => 1,
);

my %word_to_tag_by_group = (
    q{} => {
        q{Aura}                  => q{Aura},
        q{Elemental}             => q{Elemental}
    },
    q{ActionType} => {
        q{Free}                  => q{Free},
        q{Free Action}           => q{Free},
        q{Free Action (Special)} => q{Free},
        q{Immediate Interrupt}   => q{ImmedInt},
        q{Immediate Reaction}    => q{ImmedReact},
        q{Minor}                 => q{Minor},
        q{Minor Action}          => q{Minor},
        q{Move}                  => q{Move},
        q{Move Action}           => q{Move},
        q{No Action}             => q{None},
        q{None}                  => q{None},
        q{Opportunity Action}    => q{Opportun},
        q{Standard}              => q{Standard},
        q{Standard Action}       => q{Standard}
    },
    q{AttackType} => {
        q{Area Burst}            => q{AreaBurst},
        q{Area Wall}             => q{AreaWall},
        q{Area}                  => q{Area},
        q{Close Blast}           => q{CloseBlast},
        q{Close Burst}           => q{CloseBurst},
        q{Close}                 => q{Close},
        q{Melee Touch}           => q{MeleeTouch},
        q{Melee Weapon}          => q{MeleeWep},
        q{Melee}                 => q{Melee},
        q{Personal}              => q{Personal},
        q{Ranged Sight}          => q{RangeSight},
        q{Ranged Weapon}         => q{RangeWep},
        q{Ranged}                => q{Range}
    },
    q{DamageType} => {
        q{Acid}                  => q{Acid},
        q{Cold}                  => q{Cold},
        q{Fire}                  => q{Fire},
        q{Force}                 => q{Force},
        q{Lightning}             => q{Lightning},
        q{Necrotic}              => q{Necrotic},
        q{Psychic}               => q{Psychic},
        q{Radiant}               => q{Radiant},
        q{Thunder}               => q{Thunder}
    },
    q{EffectType} => {
        q{Artifice}              => q{Artifice},
        q{Augmentable}           => q{Augment},
        q{Beast}                 => q{Beast},
        q{Beast Form}            => q{BeastForm},
        q{Charm}                 => q{Charm},
        q{Conjuration}           => q{Conjur},
        q{Fear}                  => q{Fear},
        q{Full Discipline}       => q{FullDisc},
        q{Healing}               => q{Healing},
        q{Illusion}              => q{Illusion},
        q{Invigorating}          => q{Invigorat},
        q{Paralysis}             => q{Paralysis},
        q{Poison}                => q{Poison},
        q{Polymorph}             => q{Polymorph},
        q{Psionic}               => q{Psionic},
        q{Rage}                  => q{Rage},
        q{Rattling}              => q{Rattling},
        q{Reliable}              => q{Reliable},
        q{Shadow}                => q{Shadow},
        q{Sleep}                 => q{Sleep},
        q{Special}               => q{Special},
        q{Stance}                => q{Stance},
        q{Summoning}             => q{Summoning},
        q{Teleport}              => q{Teleport},
        q{Teleportation}         => q{Teleport},
        q{Zone}                  => q{Zone}
    },
    q{PowerAcc} => {
        q{Implement}             => q{Implement},
        q{Weapon}                => q{Weapon}
    },
    q{PowerSrc} => {
        q{Arcane}                => q{Arcane},
        q{Divine}                => q{Divine},
        q{Martial}               => q{Martial},
        q{Primal}                => q{Primal}
    },
    q{PowerType} => {
        q{At-Will (Special)}     => q{AtWill},
        q{At-Will}               => q{AtWill},
        q{Daily (Special)}       => q{Daily},
        q{Daily}                 => q{Daily},
        q{Encounter (Special)}   => q{Encounter},
        q{Encounter}             => q{Encounter}
    }
);

my %word_to_group;
my %tag_to_word;
build_word_maps;

# Functions

sub order_to_rank {
    my ( $order_var, $rank_var ) = @_;
    foreach my $key ( keys %{ $order_var } ) {
        my $rank = 0;
        $rank_var->{ $key } = { map { $_ => ++$rank } @{ $order_var->{ $key } } };
    }
}

sub build_word_maps {
    while ( my ( $group, $records ) = each %word_to_tag_by_group ) {
        while ( my ( $word, $tag ) = each %{ $records } ) {
            $word_to_group{ $word } = $group;
            my $old_word = $tag_to_word{ $tag };
            if ( $prefer_words{ $word } || !defined $old_word ) {
                $tag_to_word{ $tag } = $word;
            }
            elsif ( ! $prefer_words{ $old_word } ) {
                warn qq{$old_word vs $word};
            }
        }
    }
    $tag_to_word{ defAC } = q{AC};
    $tag_to_word{ defFort } = q{Fort};
    $tag_to_word{ defRef } = q{Ref};
    $tag_to_word{ defWill } = q{Will};
    $tag_to_word{ attrStr } = q{Strength};
    $tag_to_word{ attrCon } = q{Constitution};
    $tag_to_word{ attrDex } = q{Dexterity};
    $tag_to_word{ attrInt } = q{Intelligence};
    $tag_to_word{ attrWis } = q{Wisdom};
    $tag_to_word{ attrCha } = q{Charisma};
}

sub tag_to_word {
    my ( $tag ) = @_;
    return $tag_abbrev{ $tag } // ( $tag_to_word{ $tag } //= $tag );
}

sub tag_to_name {
    my ( $tag ) = @_;
    return $tag_name{ $tag } // ( $tag_to_word{ $tag } //= $tag );
}

sub remember_element {
    my ( $rec, $key ) = @_;

    my $array = $rec->{ $key };
    if ( q{ARRAY} ne ref $array ) {
        if ( ref $array ) {
            $array = [ $array ];
        }
        else {
            $array = [];
        }
$rec->{ $key } = $array;
    }
    push @{ $array }, $active_element;
}

$thing_read{ fieldval } = sub {
    my %attrs = @_;
    my $field = $attrs{ field };
    my $value = $attrs{ value };

    $thing_element->{ fieldval }->{ $field } = $value;
};

$thing_read{ arrayval } = sub {
    my %attrs = @_;
    my $field = $attrs{ field };
    my $value = $attrs{ value };

    my $index = $attrs{ index };
    my $column = $attrs{ column };

    if ( defined $column ) {
        $thing_element->{ matrixval }->{ $field }->[ $index ]->[ $column ] = $value;
    }
    else {
        $thing_element->{ arrayval }->{ $field }->[ $index ] = $value;
    }
};

$thing_read{ usesource } = sub {
    my %attrs = @_;
    my $source = $attrs{ source };

    remember_element( $thing_element->{ usesource } //= {}, $source );
};

$thing_read{ tag } = sub {
    my %attrs = @_;
    my $group = $attrs{ group };
    my $tag = $attrs{ tag };
    my $name = $attrs{ name };
    my $abbrev = $attrs { abbrev };

    if ( defined $name ) {
        $tag_name{ $tag } //= $name;
    }
    if ( defined $abbrev ) {
        $tag_abbrev{ $tag } //= $abbrev;
    }

    $thing_element->{ tag }->{ $group }->{ $tag } = 1;
};

$thing_read{ bootstrap } = sub {
    my %attrs = @_;
    my $thing = $attrs{ thing };

    remember_element( $thing_element->{ bootstrap } //= {}, $thing );
};

sub StartThing {
    my ( $name, $pad, @attrs ) = @_;

    $thing_element = {
        attr         => { @attrs },
        pad          => $pad,
    };

    $active_element = $thing_element;
}

sub StartNested {
    my ( $name, $pad, @attrs ) = @_;

    push @active_element, $active_element;
    my $parent_element = $active_element;
    my $is_thing_top = ( $parent_element == $thing_element );

    $active_element = {
        attr         => { @attrs },
        pad          => $pad,
    };

    my $code;
    if ( $is_thing_top ) {
        $code = $thing_read{ $name };
    }

    if ( $code ) {
        $code->( @attrs );
    }
    else {
        remember_element( $parent_element->{elements} //= {}, $name );
    }
}

sub StartPassthrough {
    my ( $name, $pad, @attrs ) = @_;
}

sub StartTag {
    my ( $e, $name, @attrs ) = @_;

    Text();
    my $pad = $next_pad;
    undef $next_pad;

    push @element_path, $name;

    if ( $thing_element ) {
        StartNested( $name, $pad, @attrs );
    }
    elsif (    2 == scalar @element_path
            && $element_path[ 0 ] eq q{document}
            && $element_path[ 1 ] eq q{thing} ) {
        StartThing( $name, $pad, @attrs );
    }
    else {
        StartPassthrough( $name, $pad, @attrs );
    }
}

sub EndTag {
    pop @element_path;

    Text();
    my $pad = $next_pad;
    undef $next_pad;

    if ( $thing_element ) {
        if ( $thing_element == $active_element ) {
            if (    $thing_element->{ tag }->{ EffectType }->{ FullDisc }
                 && $thing_element->{ attr }->{ compset } eq q{Power} ) {
                ConvertFDPower( $thing_element );
            }
            undef $thing_element;
        }
        $active_element = pop @active_element;
    }
}

sub Char {
    my ( $e, $text ) = @_;

    $active_text .= $text;
}

sub Text {
    if ( $active_text =~ s{ \n ( \h* ) \z }{}xms ) {
        $next_pad = $1;
    }
    else {
        undef $next_pad;
    }

    if ( $active_element  && $active_text ne q{} ) {
        $active_element->{ text } .= $active_text;
    }

    $active_text = q{};
}

sub TagsForGroup {
    my ( $power, @groups ) = @_;
    my @res;

    foreach my $group ( @groups ) {
        my $tags = $power->{ tag }->{ $group };
        next unless $tags;
        push @res, grep { $tags->{ $_ } } keys %{ $tags };
    }
    return @res;
}
sub InfoPower {
    my ( $power, %args ) = @_;

    my $details = q{{align center}{b}} . $power->{ attr }->{ name } . q{{/b}{br}{align left}};

    if ( !$args{ no_flavor } && defined $power->{ fieldval }->{ pwFlavor } ) {
        $details .= q{{i}} . $power->{ fieldval }->{ pwFlavor } . q{{/i}{br}{br}};
    }

    if ( !$args{ no_usage } ) {
        my $any;

        my @use;
        foreach my $group ( qw( PowerUse PowerType ) ) {
            @use = map { tag_to_word( $_ ) } TagsForGroup( $power, $group );
            last if @use;
        }

        my @keywords = map { tag_to_word( $_ ) } TagsForGroup( $power, qw( PowerSrc EffectType PowerAcc DamageType ) );

        if ( @use || @keywords ) {
            $details .= q{{b}} . join( q{{/b} {font Wingdings}w{font revert} {b}}, @use, join( q{, }, @keywords ) ) . q{{/b}{br}};
        }
    }

    my ( $action ) = TagsForGroup( $power, q{ActionType} );
    my ( $attack ) = TagsForGroup( $power, q{AttackType} );
    if ( $action || $attack ) {
        $details .= q{{b}};
        if ( $action ) {
            $details .= tag_to_name( $action );
            if ( $attack ) {
                $details .= q{ - };
            }
        }
        if ( $attack ) {
            $details .= tag_to_name( $attack );
        }
        $details .= q{{/b}};
        if ( $power->{ fieldval }->{ pwRange1 } ) {
            $details .= q{ } . $power->{ fieldval }->{ pwRange1 };
            if ( $power->{ fieldval }->{ pwRange2 } ) {
                $details .= q{ Within } . $power->{ fieldval }->{ pwRange2 } . q{ Square};
                if ( $power->{ fieldval }->{ pwRange2 } != 1 ) {
                    $details .= q{s};
                }
            }
        }
        $details .= q{{br}};
    }

    my ( $link ) = TagsForGroup( $power, q{ PowerLink } );
    if ( $link ) {
        $details .= q{{b}} . tag_to_name( $link ) . q{{/b}};
        if ( $link =~ m{(\d+)$} ) {
            $details .= qq{ ($1 use} . ( $1 != 1 ? q{s} : q{} ) . q{ total)};
        }
        $details .= q{{br}};
    }

    my $special = $power->{ fieldval }->{ pwSpecial };
    if ( $special ) {
        $details .= q{{b}Special:{/b} }. $special . q{{br}};
    }

    my $require = $power->{ fieldval }->{ pwRequire };
    if ( $require ) {
        $details .= q{{b}Requirements:{/b} }. $require . q{{br}};
    }

    my $target = $power->{ fieldval }->{ pwTarget };
    if ( $target ) {
        $details .= q{{b}Target:{/b} } . $target . q{{br}};
    }

    ( $attack ) = TagsForGroup( $power, q{Attack} );
    if ( $attack ) {
        $details .= q{{b}Attack:{/b} };

        if ( $power->{ fieldval }->{ spcNotes } ) {
            $details .= q{{b}} . $power->{ fieldval }->{ spcNotes } . q{{/b} (};
        }

        $details .= tag_to_name( $attack );
        my $atk_mode = 0 + $power->{ fieldval }->{ pwAtkMod };
        if ( $atk_mode ) {
            $details .= q{ } . $atk_mode;
        }
        my ( $vs ) = TagsForGroup( $power, q{AttackVs} );
        if ( $vs ) {
            $details .= q{ vs. } . tag_to_word( $vs );
        }
        my $extra = $power->{ fieldval }->{ pwAtkExtra };
        if ( defined $extra ) {
            $details .= $extra;
        }

        if ( $power->{ fieldval }->{ spcNotes } ) {
            $details .= q{)};
        }

        $details .= q{{br}};
    }

    $details =~ s{ (?: {br} )* \z}{{br}{br}}xms;

    return $details;
}

sub SplitDescription {
    my ( $orig_power, $fd_power, $at_power, $mt_power, $base_name ) = @_;

    my $mt_detail;
    my @at_desc;
    my @mt_desc;

    my $desc = $orig_power->{ attr }->{ description };
    my @desc = split( m[ {br}{br} (?! {br} ) ]xms, $desc );
    while ( @desc ) {
        my $piece = shift @desc;
        if ( $piece =~ s{ \A \Q${base_name}\E\s* \[ \w* \s Technique \] }{}xms ) {
            $mt_detail = $piece;
            @mt_desc = @desc;
            last;
        }
        push @at_desc, $piece;
    }

    # Hot fix Tiger Claw Rake
    if ( $base_name eq q{Tiger Claw Rake} ) {
        if ( !defined  $mt_detail ) {
            $mt_detail = q{{b}Encounter{/b}  {b}{b}Full Discipline{/b}, {b}Psionic{/b}{br}{b}Move Action{/b}{b}Personal{/b} };
            @mt_desc = ( q{{i}This power did not parse correctly. Should be something like:{/i}{br}Move 2+ speed, ignoring difficult terrain and mark ( until end of turn ) and do strength mod damage to any enemy that makes an op attack against you during this move.} );
        }
    }

    if ( !defined $mt_detail ) {
        warn $base_name, q{ does not have information for movement technique};
        return;
    }

    if ( $mt_detail =~ m{ \A {i} (.*) {/i} \z }xms ) {
        $mt_power->{ fieldvar }->{ pwFlavor } = $1;
        $mt_detail = shift @mt_desc;
    }

    my ( $type_keywords, $action_range ) = split( m{ {br} }xms, $mt_detail, 2 );
    state $match_word = qr{ (?<= \{ b \} ) ( (?: [^\{]++ | \{ (?! /b \} ) )*+ ) (?= \{ /b \} ) }xms;

    $type_keywords =~ s[ {b}(?:{b})+ ][{b}]xms;
    foreach my $keyword ( $type_keywords =~ m{ $match_word }xmsgo ) {
        my $word_type = $word_to_group{ $keyword } // q{Unknown group};
        next if ( $word_type eq q{} );
        my $word_tag = $word_to_tag_by_group{ $word_type }->{ $keyword };
        unless ( $type_keywords{ $word_type } && defined $word_tag ) {
            warn q{Unable to process keyword: }, $keyword, q{ / group: }, $word_type, q{ skipping: }, $base_name, q{\n};
            return;
        }
        $mt_power->{ tag }->{ $word_type }->{ $word_tag } = 1;
    }

    $action_range =~ s[ {b}(?:{b})+ ][{b}]xms;
    foreach my $keyword ( $action_range =~ m{ $match_word }xmsgo ) {
        my $word_type = $word_to_group{ $keyword } // q{Unknown group};
        next if ( $word_type eq q{} );
        my $word_tag = $word_to_tag_by_group{ $word_type }->{ $keyword };
        unless ( $action_range{ $word_type } && defined $word_tag ) {
            warn q{Unable to process keyword: }, $keyword, q{ / group: }, $word_type, q{ skipping: }, $base_name, q{\n};
            return;
        }
        $mt_power->{ tag }->{ $word_type }->{ $word_tag } = 1;
    }
    $action_range =~ s{ .* {/b} }{}xms;
    $action_range =~ s{ \A \s* (?: : \s* )? }{}xms;
    $action_range =~ s{ \s* \z }{}xms;

    my ( $attack_type ) = keys %{ $mt_power->{ tag }->{ AttackType } };
    $attack_type //= q{Personal};
    delete $mt_power->{ tag }->{ AttackType };

    if ( $action_range =~ s{ \s* Within \s+ ( \d+ ) \s+ squares? \z}{}xmsi ) {
        $mt_power->{ fieldval }->{ pwRange2 } = $1;
    }
    if ( $action_range =~ s{ \s* ( \d+ ) \z}{}xmsi ) {
        $mt_power->{ fieldval }->{ pwRange1 } = $1;
    }

    given( $action_range ) {
        when ( qr{\A Weapon \z}xmsi ) {
            if ( $attack_type =~ m{ \A (?: Melee | Range ) \z } ) {
                $attack_type .= "Wep";
            }
            else {
                undef $attack_type;
            }
        }
        when ( qr{\A Touch \z}xmsi ) {
            if ( $attack_type eq q{Melee} ) {
                $attack_type = "MeleeTouch";
            }
            else {
                undef $attack_type;
            }
        }
        when ( qr{\A Sight \z}xmsi ) {
            if ( $attack_type eq q{Range} ) {
                $attack_type = "RangeSight";
            }
            else {
                undef $attack_type;
            }
        }
        when ( qr{\A Burst \z}xmsi ) {
            if ( $attack_type =~ m{ \A (?: Close | Area ) \z } ) {
                $attack_type .= q{Burst};
            }
            else {
                undef $attack_type;
            }
        }
        when ( qr{\A Wall \z}xmsi ) {
            if ( $attack_type eq q{Area} ) {
                $attack_type .= q{Burst};
            }
            else {
                undef $attack_type;
            }
        }
        when ( qr{\A Blast \z}xmsi ) {
            if ( $attack_type eq q{Close} ) {
                $attack_type .= q{Burst};
            }
            else {
                undef $attack_type;
            }
        }
        default {
            if ( $attack_type eq q{Close} ) {
                undef $attack_type;
            }
        }
    }

    if ( defined $attack_type ) {
        $mt_power->{ tag }->{ AttackType }->{ $attack_type } = 1;
    }
    else {
        delete $mt_power->{ fieldval }->{ pwRange1 };
        delete $mt_power->{ fieldval }->{ pwRange2 };
    }

    unless ( TagsForGroup( $mt_power, q{PowerType} ) ) {
        my ( $type ) = TagsForGroup( $orig_power, qw{PowerUse PowerType} );
        $mt_power->{ tag }->{ PowerType }->{ $type } = 1;
    }

    my $at_desc = $at_power->{ attr }->{ description } = join( q{{br}{br}}, @at_desc );
    my $mt_desc = $mt_power->{ attr }->{ description } = join( q{{br}{br}}, @mt_desc );
    $fd_power->{ attr }->{ description } = join( q{{br}{br}},
        q{This is a full discipline power which consists of both a attack technique and movement technique.},
        InfoPower( $orig_power, no_flavor => 1 ) . $at_desc,
        InfoPower( $mt_power, no_flavor => 1 ) . $mt_desc,
    );

    return 1;
}

sub ConvertFDPower {
    my ( $orig_power ) = @_;

    if ( $orig_power->{ elements }->{ eval } ) {
        warn q{Can not process: }, $orig_power->{ attr }->{ name }, qq{\n};
        return;
    }

    my $fd_power = {};
    my $at_power = {};
    my $mt_power = {};

    # Attributes
    $fd_power->{ attr } = clone( $orig_power->{ attr } // {} );
    $at_power->{ attr } //= {};
    $mt_power->{ attr } //= {};

    # Attribute( id )
    my $orig_id = $orig_power->{ attr }->{ id };
    my $post_id = $orig_id;
    $post_id =~ s{\A (..) .. }{}xms;
    my $pre_id = $1;
    my $fd_id = $pre_id . q{FD} . $post_id;
    my $at_id = $pre_id . q{AT} . $post_id;
    my $mt_id = $pre_id . q{MT} . $post_id;
    $fd_power->{ attr }->{ id } = $fd_id;
    $fd_power->{ attr }->{ replaces } = $orig_id;
    $at_power->{ attr }->{ id } = $at_id;
    $mt_power->{ attr }->{ id } = $mt_id;

    # Fields
    $at_power->{ fieldval } = clone( $orig_power->{ fieldval } // {} );
    $at_power->{ arrayval } = clone( $orig_power->{ arrayval } // {} );
    $at_power->{ matrixval } = clone( $orig_power->{ matrixval } // {} );
    if ( defined $orig_power->{ fieldval }->{ pwFlavor } ) {
        $mt_power->{ fieldval }->{ pwFlavor } //= $orig_power->{ fieldval }->{ pwFlavor };
    }

    # Attribute( name )
    my $orig_name = $orig_power->{ attr }->{ name };
    ( my $base_name = $orig_name ) =~ s{ \s* \[ \w* \s Technique \] \s* \z}{}xms;
    $fd_power->{ attr }->{ name } = $base_name . q{ [Full Discipline]};
    $at_power->{ attr }->{ name } = $orig_name;
    $mt_power->{ attr }->{ name } = $base_name . q{ [Movement Technique]};

    # Tags
    my $groups = $orig_power->{ tag } // {};
    foreach my $group ( keys %{ $groups } ) {
        my $fd_status = $full_discipline_tags{ $group };
        my $at_status = $attack_technique_supress_tags{ $group };
        my $tags = $groups->{ $group };
        foreach my $tag ( keys %{ $tags } ) {
            if ( $fd_status ) {
                if ( !ref $fd_status || $fd_status->{ $tag } ) {
                    $fd_power->{ tag }->{ $group }->{ $tag } = 1;
                }
            }
            if ( $at_status ) {
                if ( ref $at_status && !$at_status->{ $tag } ) {
                    $at_power->{ tag }->{ $group }->{ $tag } = 1;
                }
            }
            else {
                $at_power->{ tag }->{ $group }->{ $tag } = 1;
            }
        }
    }
    $fd_power->{ tag }->{ Hide }->{ Special } = 1;

    # Tags ( PowerLink )
    # Change the if ( 1 ) to an if ( 0 ) if you do not want the link between the powers
    if ( 1 ) {
        my $link_id = q{fd} . $post_id . q{1};
        $tag_name{ $link_id } = $fd_power->{ attr }->{ name };
        $tag_abbrev{ $link_id } = $base_name;
        $at_power->{ tag }->{ PowerLink }->{ $link_id } = 1;
        $mt_power->{ tag }->{ PowerLink }->{ $link_id } = 1;
    }

    # Attribute ( compset )
    $fd_power->{ attr }->{ compset } = q{Power};
    $at_power->{ attr }->{ compset } = q{Power};
    $mt_power->{ attr }->{ compset } = q{Power};

    # Attribute( description )
    SplitDescription( $orig_power, $fd_power, $at_power, $mt_power, $base_name )
        or return;

    # Attribute( isunique )
    my $val = $orig_power->{ attr }->{ isunique };
    if ( defined $val ) {
        $fd_power->{ attr }->{ isunique } = $val;
        $at_power->{ attr }->{ isunique } = $val;
        $mt_power->{ attr }->{ isunique } = $val;
    }

    # Source
    $fd_power->{ usesource } = $orig_power->{ usesource };
    $at_power->{ usesource } = $orig_power->{ usesource };
    $mt_power->{ usesource } = $orig_power->{ usesource };

    # Bootstraps
    $fd_power->{ bootstrap } = clone( $orig_power->{ bootstrap } // {} );
    $fd_power->{ bootstrap }->{ $at_id } //= 1;
    $fd_power->{ bootstrap }->{ $mt_id } //= 1;

    # Elements
    $fd_power->{ elements } = clone( $orig_power->{ elements } // {} );

    #WriteThing( $orig_power );
    WriteThing( $at_power );
    WriteThing( $mt_power );
    WriteThing( $fd_power );
}

sub WriteThing {
    my ( $thing ) = @_;

    my $pad = qq{\n  };
    my $attrs = $thing->{ attr };
    my @attrs = ();
    my $attr_order = $attribute_order{ thing };
    my $attr_rank = $attribute_rank{ thing };
    foreach my $attr_name ( @{ $attr_order } ) {
        if ( exists $attrs->{ $attr_name } ) {
            push @attrs, $attr_name, $attrs->{ $attr_name };
        }
    }
    foreach my $attr_name ( sort keys %{ $attrs } ) {
        if ( ! $attr_rank->{ $attr_name } ) {
            push @attrs, $attr_name, $attrs->{ $attr_name };
        }
    }

    $xml_writer->characters( $pad );
    $xml_writer->startTag( q{thing}, @attrs );

    my $elements = $thing->{ elements };
    my $elem_order = $element_order{ thing } //= [];
    my $elem_rank = $element_rank{ thing } //= {};
    foreach my $elem_name ( @{ $elem_order } ) {
        my $code = $thing_write{ $elem_name };
        if ( $code ) {
            $code->( $thing );
            next;
        }
        next unless $elements->{ $elem_name };
        WriteElements( 0, $elem_name, @{ $elements->{ $elem_name } } );
    }
    foreach my $elem_name ( sort keys %{ $elements } ) {
        next if $elem_rank->{ $elem_name };
        my $code = $thing_write{ $elem_name };
        if ( $code ) {
            $code->( $thing );
            next;
        }

        WriteElements( 0, $elem_name, @{ $elements->{ $elem_name } } );
    }


    $xml_writer->characters( $pad );
    $xml_writer->endTag( q{thing} );
}

$thing_write{ fieldval } = sub {
    my ( $thing ) = @_;

    my $fields = $thing->{ fieldval };
    return unless $fields;

    my $pad = qq{\n    };

    foreach my $field ( sort keys %{ $fields } ) {
        my $value = $fields->{ $field };
        next unless defined $value;

        $xml_writer->characters( $pad );
        $xml_writer->emptyTag( q{fieldval}, field => $field, value => $value );
    }
};

$thing_write{ arrayval } = sub {
    my ( $thing ) = @_;

    my $pad = qq{\n    };

    my $arrays = $thing->{ arrayval };
    my $matrices = $thing->{ maxtrixval };

    if ( $arrays ) {
        foreach my $field ( sort keys %{ $arrays } ) {
            my $array = $arrays->{ $field };
            my $index_size = scalar @{ $array };
            for ( my $index = 0; $index < $index_size; ++$index ) {
                my $value = $array->[ $index ];
                next unless defined $value;

                $xml_writer->characters( $pad );
                $xml_writer->emptyTag( q{arrayval}, field => $field, index => $index, value => $value );
            }
        }
    }

    if ( $matrices ) {
        foreach my $field ( sort keys %{ $matrices } ) {
            my $matrix = $matrices->{ $field };
            my $index_size = scalar @{ $matrix };
            for ( my $index = 0; $index < $index_size; ++$index ) {
                my $row = $matrix->[ $index ];
                next unless $row;

                my $column_size = scalar @{ $row };
                for ( my $column = 0; $column < $column_size; ++$column ) {
                    my $value = $row->[ $column ];
                    next unless defined $value;

                    $xml_writer->characters( $pad );
                    $xml_writer->emptyTag( q{arrayval}, field => $field, index => $index, column => $column, value => $value );
                }
            }
        }
    }
};

$thing_write{ usesource } = sub {
    my ( $thing ) = @_;

    my $sources = $thing->{ usesource };
    return unless $sources;

    my $pad = qq{\n    };

    foreach my $source ( sort keys %{ $sources } ) {
        $xml_writer->characters( $pad );
        $xml_writer->emptyTag( q{usesource}, source => $source );
    }
};

$thing_write{ tag } = sub {
    my ( $thing ) = @_;

    my $groups = $thing->{ tag };
    return unless $groups;

    my $pad = qq{\n    };

    foreach my $group ( sort keys %{ $groups } ) {
        my $tags = $groups->{ $group };
        next unless $tags;

        foreach my $tag ( sort keys %{ $tags } ) {
            next unless $tags->{ $tag };

            my @extra;
            state %tag_written;
            if ( ! $tag_written{ $tag } ) {
                $tag_written{ $tag } = 1;
                if ( exists $tag_name{ $tag } ) {
                    push @extra, name => $tag_name{ $tag };
                }
                if ( exists $tag_abbrev{ $tag } ) {
                    push @extra, abbrev => $tag_abbrev{ $tag };
                }
            }

            $xml_writer->characters( $pad );
            $xml_writer->emptyTag( q{tag}, group => $group, tag => $tag, @extra );
        }
    }
};

$thing_write{ bootstrap } = sub {
    my ( $thing ) = @_;

    my $bootstraps = $thing->{ bootstrap };
    return unless $bootstraps;

    my $pad = qq{\n    };

    foreach my $bootstrap ( keys %{ $bootstraps } ) {
        my $value = $bootstraps->{ $bootstrap };
        next unless $value;

        if ( ref $value ) {
            if ( @{ $value } ) {
                WriteElements( 0, q{bootstrap}, @{ $value } );
                next;
            }
        }

        $xml_writer->characters( $pad );
        $xml_writer->emptyTag( q{bootstrap}, thing => $bootstrap );
    }
};

sub WriteElements {
    my ( $depth, $name, @records ) = @_;

    my $pad = qq{\n} . ( ' ' x ( 4 + 2 * $depth ) );

    foreach my $record ( @records ) {
        my $attrs = $record->{ attr };
        my @attrs = ();
        my $attr_order = $attribute_order{ $name } //= [];
        my $attr_rank = $attribute_rank{ $name } //= {};
        foreach my $attr_name ( @{ $attr_order } ) {
            next unless exists $attrs->{ $attr_name };
            push @attrs, $attr_name, $attrs->{ $attr_name };
        }
        foreach my $attr_name ( sort keys %{ $attrs } ) {
            next if $attr_rank->{ $attr_name };
            push @attrs, $attr_name, $attrs->{ $attr_name };
        }


        $xml_writer->characters( $pad );
        if ( exists $record->{ elements } || exists $record->{ text } || $has_text{ $name } ) {
            $xml_writer->startTag( $name, @attrs );
            if ( exists $record->{ text } ) {
                $xml_writer->characters( $record->{ text } );
            }
            my $elements = $record->{ elements };
            my $elem_order = $element_order{ $name } //= [];
            my $elem_rank = $element_rank{ $name } //= {};
            foreach my $elem_name ( @{ $elem_order } ) {
                next unless $elements->{ $elem_name };
                WriteElements( $depth+1, $elem_name, @{ $elements->{ $elem_name } } );
            }
            foreach my $elem_name ( sort keys %{ $elements } ) {
                next if $elem_rank->{ $elem_name };
                WriteElements( $depth+1, $elem_name, @{ $elements->{ $elem_name } } );
            }

            $xml_writer->characters( $pad );
            $xml_writer->endTag( $name );
        }
        else {
            $xml_writer->emptyTag( $name, @attrs );
        }
    }
}

Readonly my $powers_filename => shift // q{ddi_powers.dat};
Readonly my $fd_filename => shift // q{fd_powers.user};

Readonly my $powers_in_path => ( -e $powers_filename ? $powers_filename : File::Spec->catfile( $default_directory, $powers_filename ) );
Readonly my $powers_out_path => $fd_filename eq q{-}? $fd_filename : ( -e $powers_filename ? $fd_filename : File::Spec->catfile( $default_directory, $fd_filename ) );

unless ( -e $powers_in_path ) {
    die "Unable to find: $powers_filename\n";
}

my $parser = XML::Parser->new( Handlers => {
    Start => \&StartTag,
    End   => \&EndTag,
    Char  => \&Char
} );

my $output = IO::File->new( q{>} . $powers_out_path )
    or die "Unable to create output file: $powers_out_path: $!\n";
$xml_writer = XML::Writer->new( ENCODING => q{utf-8}, OUTPUT => $output );
$xml_writer->xmlDecl();
$xml_writer->startTag( q{document}, signature => q{Hero Lab Data} );
$parser->parsefile( $powers_in_path );
$xml_writer->characters( qq{\n} );
$xml_writer->endTag( q{document} );
$xml_writer->end();
$output
    or die "Error writing: $powers_out_path: $!\n";

####
1;